X-Git-Url: https://git.dogcows.com/gitweb?p=chaz%2Fp5-CGI-Ex;a=blobdiff_plain;f=lib%2FCGI%2FEx%2FFill.pm;h=1bc90f31d5b55a0a08c7b514c71e24162c39d0d2;hp=e1094ef929918320c053831a5d614f230dd8ddfc;hb=490b94ab4051adf93abf16a4ed34efb923d6e8fc;hpb=85070b46d0a93ddbeef07341421adb8389a55418 diff --git a/lib/CGI/Ex/Fill.pm b/lib/CGI/Ex/Fill.pm index e1094ef..1bc90f3 100644 --- a/lib/CGI/Ex/Fill.pm +++ b/lib/CGI/Ex/Fill.pm @@ -1,41 +1,46 @@ package CGI::Ex::Fill; -### CGI Extended Form Filler +=head1 NAME + +CGI::Ex::Fill - Fast but compliant regex based form filler + +=cut ###----------------------------------------------------------------### -# Copyright 2003 - Paul Seamons # +# Copyright 2007 - Paul Seamons # # Distributed under the Perl Artistic License without warranty # ###----------------------------------------------------------------### -### See perldoc at bottom - use strict; use vars qw($VERSION - @ISA @EXPORT @EXPORT_OK + @EXPORT @EXPORT_OK $REMOVE_SCRIPT $REMOVE_COMMENT $MARKER_SCRIPT $MARKER_COMMENT $OBJECT_METHOD - $TEMP_TARGET + $_TEMP_TARGET ); -use Exporter; +use base qw(Exporter); -$VERSION = '1.3'; -@ISA = qw(Exporter); -@EXPORT = qw(form_fill); -@EXPORT_OK = qw(form_fill html_escape get_tagval_by_key swap_tagval_by_key); +BEGIN { + $VERSION = '2.22'; + @EXPORT = qw(form_fill); + @EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key); +}; ### These directives are used to determine whether or not to ### remove html comments and script sections while filling in ### a form. Default is on. This may give some trouble if you ### have a javascript section with form elements that you would ### like filled in. -$REMOVE_SCRIPT = 1; -$REMOVE_COMMENT = 1; -$MARKER_SCRIPT = "\0SCRIPT\0"; -$MARKER_COMMENT = "\0COMMENT\0"; -$OBJECT_METHOD = "param"; +BEGIN { + $REMOVE_SCRIPT = 1; + $REMOVE_COMMENT = 1; + $MARKER_SCRIPT = "\0SCRIPT\0"; + $MARKER_COMMENT = "\0COMMENT\0"; + $OBJECT_METHOD = "param"; +}; ###----------------------------------------------------------------### @@ -47,339 +52,366 @@ $OBJECT_METHOD = "param"; ### pos4 - boolean fill in password fields - default is true ### pos5 - hashref or arrayref of fields to ignore sub form_fill { - my $text = shift; - my $ref = ref($text) ? $text : \$text; - my $form = shift; - my $forms = UNIVERSAL::isa($form, 'ARRAY') ? $form : [$form]; - my $target = shift; - my $fill_password = shift; - my $ignore = shift || {}; - $ignore = {map {$_ => 1} @$ignore} if UNIVERSAL::isa($ignore, 'ARRAY'); - $fill_password = 1 if ! defined $fill_password; - - - ### allow for optionally removing comments and script - my @comment; - my @script; - if ($REMOVE_SCRIPT) { - $$ref =~ s|()|push(@script, $1);$MARKER_SCRIPT|egi; - } - if ($REMOVE_COMMENT) { - $$ref =~ s|()|push(@comment, $1);$MARKER_COMMENT|eg; - } - - ### if there is a target - focus in on it - ### possible bug here - name won't be found if - ### there is nested html inside the form tag that comes before - ### the name field - if no close form tag - don't swap in anything - if ($target) { - local $TEMP_TARGET = $target; - $$ref =~ s{(
]+ # some space - \bname=([\"\']?) # the name tag - $target # with the correct name (allows for regex) - \2 # closing quote - .+? # as much as there is - (?=
)) # then end - }{ - local $REMOVE_SCRIPT = undef; - local $REMOVE_COMMENT = undef; - &form_fill($1, $form, undef, $fill_password, $ignore); - }sigex; + my $text = shift; + my $ref = ref($text) ? $text : \$text; + my $form = shift; + my $target = shift; + my $fill_password = shift; + my $ignore = shift || {}; + + fill({ + text => $ref, + form => $form, + target => $target, + fill_password => $fill_password, + ignore_fields => $ignore, + }); - ### put scripts and comments back and return - $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1; - $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script != -1; return ref($text) ? 1 : $$ref; - } +} - ### build a sub to get a value - my %indexes = (); # store indexes for multivalued elements - my $get_form_value = sub { - my $key = shift; - my $all = $_[0] && $_[0] eq 'all'; - if (! defined $key || ! length $key) { - return $all ? [] : undef; - } +sub fill { + my $args = shift; + my $ref = $args->{'text'}; + my $form = $args->{'form'}; + my $target = $args->{'target'}; + my $ignore = $args->{'ignore_fields'}; + my $fill_password = $args->{'fill_password'}; + + my $forms = UNIVERSAL::isa($form, 'ARRAY') ? $form : [$form]; + $ignore = {map {$_ => 1} @$ignore} if UNIVERSAL::isa($ignore, 'ARRAY'); + $fill_password = 1 if ! defined $fill_password; - my $val; - my $meth; - foreach my $form (@$forms) { - next if ! ref $form; - if (UNIVERSAL::isa($form, 'HASH') && defined $form->{$key}) { - $val = $form->{$key}; - last; - } elsif ($meth = UNIVERSAL::can($form, $OBJECT_METHOD)) { - $val = $form->$meth($key); - last if defined $val; - } elsif (UNIVERSAL::isa($form, 'CODE')) { - $val = &{ $form }($key, $TEMP_TARGET); - last if defined $val; - } - } - if (! defined $val) { - return $all ? [] : undef; - } - ### fix up the value some - if (UNIVERSAL::isa($val, 'CODE')) { - $val = &{ $val }($key, $TEMP_TARGET); + ### allow for optionally removing comments and script + my @comment; + my @script; + if (defined($args->{'remove_script'}) ? $args->{'remove_script'} : $REMOVE_SCRIPT) { + $$ref =~ s|()|push(@script, $1);$MARKER_SCRIPT|egi; } - if (UNIVERSAL::isa($val, 'ARRAY')) { - $val = [@$val]; # copy the values - } elsif (ref $val) { - # die "Value for $key is not an array or a scalar"; - $val = "$val"; # stringify anything else + if (defined($args->{'remove_comment'}) ? $args->{'remove_comment'} : $REMOVE_COMMENT) { + $$ref =~ s|()|push(@comment, $1);$MARKER_COMMENT|eg; } - ### html escape them all - &html_escape(\$_) foreach (ref($val) ? @$val : $val); - - ### allow for returning all elements - ### or one at a time - if ($all) { - return ref($val) ? $val : [$val]; - } elsif (ref($val)) { - $indexes{$key} ||= 0; - my $ret = $val->[$indexes{$key}] || ''; - $indexes{$key} ++; # don't wrap - if we run out of values - we're done - return $ret; - } else { - return $val; + ### if there is a target - focus in on it + ### possible bug here - name won't be found if + ### there is nested html inside the form tag that comes before + ### the name field - if no close form tag - don't swap in anything + if ($target) { + local $_TEMP_TARGET = $target; + $$ref =~ s{(
]+ # some space + \bname=([\"\']?) # the name tag + $target # with the correct name (allows for regex) + \2 # closing quote + .+? # as much as there is + (?=
)) # then end + }{ + my $str = $1; + local $args->{'text'} = \$str; + local $args->{'remove_script'} = 0; + local $args->{'remove_comment'} = 0; + local $args->{'target'} = undef; + fill($args); + $str; # return of the s///; + }sigex; + + ### put scripts and comments back and return + $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1; + $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script != -1; + return 1; } - }; - - - ###--------------------------------------------------------------### - - ### First pass - ### swap form elements if they have a name - $$ref =~ s{ - (] )* >) # nested html ok - }{ - ### get the type and name - intentionally exlude names with nested "' - my $tag = $1; - my $type = uc(&get_tagval_by_key(\$tag, 'type') || ''); - my $name = &get_tagval_by_key(\$tag, 'name'); - - if ($name && ! $ignore->{$name}) { - if (! $type - || $type eq 'HIDDEN' - || $type eq 'TEXT' - || $type eq 'FILE' - || ($type eq 'PASSWORD' && $fill_password)) { - - my $value = &$get_form_value($name, 'next'); - if (defined $value) { - &swap_tagval_by_key(\$tag, 'value', $value); - } elsif (! defined &get_tagval_by_key(\$tag, 'value')) { - &swap_tagval_by_key(\$tag, 'value', ''); - } - - } elsif ($type eq 'CHECKBOX' - || $type eq 'RADIO') { - my $values = &$get_form_value($name, 'all'); - if (@$values) { - $tag =~ s{\s+\bCHECKED\b(?:=([\"\']?)checked\1)?(?=\s|>|/>)}{}ig; - - if ($type eq 'CHECKBOX' && @$values == 1 && $values->[0] eq 'on') { - $tag =~ s|(/?>\s*)$| checked="checked"$1|; - } else { - my $fvalue = &get_tagval_by_key(\$tag, 'value'); - if (defined $fvalue) { - foreach (@$values) { - next if $_ ne $fvalue; - $tag =~ s|(\s*/?>\s*)$| checked="checked"$1|; - last; - } - } + + ### build a sub to get a value from the passed forms on a request basis + my %indexes = (); # store indexes for multivalued elements + my $get_form_value = sub { + my $key = shift; + my $all = $_[0] && $_[0] eq 'all'; + if (! defined $key || ! length $key) { + return $all ? [] : undef; + } + + my $val; + my $meth; + foreach my $form (@$forms) { + next if ! ref $form; + if (UNIVERSAL::isa($form, 'HASH') && defined $form->{$key}) { + $val = $form->{$key}; + last; + } elsif ($meth = UNIVERSAL::can($form, $args->{'object_method'} || $OBJECT_METHOD)) { + $val = $form->$meth($key); + last if defined $val; + } elsif (UNIVERSAL::isa($form, 'CODE')) { + $val = $form->($key, $_TEMP_TARGET); + last if defined $val; } - } } - } - $tag; # return of swap - }sigex; - - - ### Second pass - ### swap select boxes (must be done in such a way as to allow no closing tag) - my @start = (); - my @close = (); - push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*select\b)|ig; - push @close, pos($$ref) - length($1) while $$ref =~ m|( $start[$i + 1]) { - $close[$i] = $start[$i + 1]; # set to start of next select if no closing or > next select - } - } - for (my $i = $#start; $i >= 0; $i --) { - my $opts = substr($$ref, $start[$i], $close[$i] - $start[$i]); - $opts =~ s{ - ( form elements if they have a name + $$ref =~ s{ + (] )+ >) # nested html ok }{ - my ($tag2, $opt) = ($1, $2); - $tag2 =~ s%\s+\bSELECTED\b(?:=([\"\']?)selected\1)?(?=\s|>|/>)%%ig; - - my $fvalues = &get_tagval_by_key(\$tag2, 'value', 'all'); - my $fvalue = @$fvalues ? $fvalues->[0] - : $opt =~ /^\s*(.*?)\s*$/ ? $1 : ""; - foreach (@$values) { - next if $_ ne $fvalue; - $tag2 =~ s|(\s*/?>\s*)$| selected="selected"$1|; - last; - } - "$tag2$opt"; # return of the swap + ### get the type and name - intentionally exlude names with nested "' + my $tag = $1; + my $type = uc(get_tagval_by_key(\$tag, 'type') || ''); + my $name = get_tagval_by_key(\$tag, 'name'); + + if ($name && ! $ignore->{$name}) { + if (! $type + || $type eq 'HIDDEN' + || $type eq 'TEXT' + || $type eq 'FILE' + || ($type eq 'PASSWORD' && $fill_password)) { + + my $value = $get_form_value->($name, 'next'); + if (defined $value) { + swap_tagval_by_key(\$tag, 'value', $value); + } elsif (! defined get_tagval_by_key(\$tag, 'value')) { + swap_tagval_by_key(\$tag, 'value', ''); + } + + } elsif ($type eq 'CHECKBOX' + || $type eq 'RADIO') { + my $values = $get_form_value->($name, 'all'); + if (@$values) { + $tag =~ s{\s+\bCHECKED\b(?:=([\"\']?)checked\1)?(?=\s|>|/>)}{}ig; + + my $fvalue = get_tagval_by_key(\$tag, 'value'); + $fvalue = 'on' if ! defined $fvalue; + if (defined $fvalue) { + foreach (@$values) { + next if $_ ne $fvalue; + $tag =~ s|(\s*/?>\s*)$| checked="checked"$1|; + last; + } + } + } + } + + } + $tag; # return of swap }sigex; - if ($n) { - substr($$ref, $start[$i], $close[$i] - $start[$i], "$tag$opts"); - } + + + ### Second pass + ### swap select boxes (must be done in such a way as to allow no closing tag) + my @start = (); + my @close = (); + push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*select\b)|ig; + push @close, pos($$ref) - length($1) while $$ref =~ m|( $start[$i + 1]) { + $close[$i] = $start[$i + 1]; # set to start of next select if no closing or > next select + } + } + for (my $i = $#start; $i >= 0; $i --) { + my $opts = substr($$ref, $start[$i], $close[$i] - $start[$i]); + $opts =~ s{ + ( + + +
+
+ + + +
+
+