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 2006 - 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.00';
+ @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";
+};
###----------------------------------------------------------------###
### 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|(<script\b.+?</script>)|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{(<form # open form
- [^>]+ # some space
- \bname=([\"\']?) # the name tag
- $target # with the correct name (allows for regex)
- \2 # closing quote
- .+? # as much as there is
- (?=</form>)) # 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|(<script\b.+?</script>)|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{(<form # open form
+ [^>]+ # some space
+ \bname=([\"\']?) # the name tag
+ $target # with the correct name (allows for regex)
+ \2 # closing quote
+ .+? # as much as there is
+ (?=</form>)) # 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 <input > form elements if they have a name
- $$ref =~ s{
- (<input \s (?: ([\"\'])(?:|.*?[^\\])\2 | [^>] )* >) # 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|(</\s*select\b)|ig;
- for (my $i = 0; $i <= $#start; $i ++) {
- while (defined($close[$i]) && $close[$i] < $start[$i]) {
- splice (@close,$i,1,());
- }
- if ($i == $#start) {
- $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
- } elsif (! defined($close[$i]) || $close[$i] > $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{
- (<select \s # opening
- (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )* # nested html ok
- >) # end of tag
- }{}sxi || next;
- next if ! $opts;
- my $tag = $1;
- my $name = &get_tagval_by_key(\$tag, 'name');
- my $values = $ignore->{$name} ? [] : &$get_form_value($name, 'all');
- if ($#$values != -1) {
- my $n = $opts =~ s{
- (<option[^>]*>) # opening tag - no embedded > allowed
- (.*?) # the text value
- (?=<option|$|</option>) # the next tag
+ if (! defined $val) {
+ return $all ? [] : undef;
+ }
+
+ ### fix up the value some
+ if (UNIVERSAL::isa($val, 'CODE')) {
+ $val = $val->($key, $_TEMP_TARGET);
+ }
+ 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
+ }
+
+ ### 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}];
+ $ret = '' if ! defined $ret;
+ $indexes{$key} ++; # don't wrap - if we run out of values - we're done
+ return $ret;
+ } else {
+ return $val;
+ }
+ };
+
+
+ ###--------------------------------------------------------------###
+
+ ### First pass
+ ### swap <input > form elements if they have a name
+ $$ref =~ s{
+ (<input \s (?: ([\"\'])(?:|.*?[^\\])\2 | [^>] )* >) # 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|(</\s*select\b)|ig;
+ for (my $i = 0; $i <= $#start; $i ++) {
+ while (defined($close[$i]) && $close[$i] < $start[$i]) {
+ splice (@close,$i,1,());
+ }
+ if ($i == $#start) {
+ $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
+ } elsif (! defined($close[$i]) || $close[$i] > $start[$i + 1]) {
+ $close[$i] = $start[$i + 1]; # set to start of next select if no closing or > next select
+ }
}
- }
-
-
- ### Third pass
- ### swap textareas (must be done in such a way as to allow no closing tag)
- @start = ();
- @close = ();
- push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*textarea\b)|ig;
- push @close, pos($$ref) - length($1) while $$ref =~ m|(</\s*textarea\b)|ig;
- for (my $i = 0; $i <= $#start; $i ++) {
- while (defined($close[$i]) && $close[$i] < $start[$i]) {
- splice (@close,$i,1,());
+ for (my $i = $#start; $i >= 0; $i --) {
+ my $opts = substr($$ref, $start[$i], $close[$i] - $start[$i]);
+ $opts =~ s{
+ (<select \s # opening
+ (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )* # nested html ok
+ >) # end of tag
+ }{}sxi || next;
+ next if ! $opts;
+ my $tag = $1;
+ my $name = get_tagval_by_key(\$tag, 'name');
+ my $values = $ignore->{$name} ? [] : $get_form_value->($name, 'all');
+ if ($#$values != -1) {
+ my $n = $opts =~ s{
+ (<option[^>]*>) # opening tag - no embedded > allowed
+ (.*?) # the text value
+ (?=<option|$|</option>) # the next tag
+ }{
+ 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
+ }sigex;
+ if ($n) {
+ substr($$ref, $start[$i], $close[$i] - $start[$i], "$tag$opts");
+ }
+ }
}
- if ($i == $#start) {
- $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
- } elsif (! defined($close[$i]) || $close[$i] > $start[$i + 1]) {
- $close[$i] = $start[$i + 1]; # set to start of next select if no closing or > next select
+
+
+ ### Third pass
+ ### swap textareas (must be done in such a way as to allow no closing tag)
+ @start = ();
+ @close = ();
+ push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*textarea\b)|ig;
+ push @close, pos($$ref) - length($1) while $$ref =~ m|(</\s*textarea\b)|ig;
+ for (my $i = 0; $i <= $#start; $i ++) {
+ while (defined($close[$i]) && $close[$i] < $start[$i]) {
+ splice (@close,$i,1,()); # get rid of extra closes
+ }
+ if ($i == $#start) {
+ $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
+ } elsif (! defined($close[$i]) || $close[$i] > $start[$i + 1]) {
+ splice(@close, $i, 0, $start[$i + 1]); # set to start of next select if no closing or > next select
+ }
+ }
+ my $offset = 0;
+ for (my $i = 0; $i <= $#start; $i ++) {
+ my $oldval = substr($$ref, $start[$i] + $offset, $close[$i] - $start[$i]);
+ $oldval =~ s{
+ (<textarea \s # opening
+ (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )* # nested html ok
+ >) # end of tag
+ }{}sxi || next;
+ my $tag = $1;
+ my $name = get_tagval_by_key(\$tag, 'name');
+ if ($name && ! $ignore->{$name}) {
+ my $value = $get_form_value->($name, 'next');
+ next if ! defined $value;
+ substr($$ref, $start[$i] + $offset, $close[$i] - $start[$i], "$tag$value");
+ $offset += length($value) - length($oldval);
+ }
}
- }
- for (my $i = $#start; $i >= 0; $i --) {
- my $oldval = substr($$ref, $start[$i], $close[$i] - $start[$i]);
- $oldval =~ s{
- (<textarea \s # opening
- (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )* # nested html ok
- >) # end of tag
- }{}sxi || next;
- my $tag = $1;
- my $name = &get_tagval_by_key(\$tag, 'name');
- my $value = $ignore->{$name} ? [] : &$get_form_value($name, 'next');
- next if ! defined $value;
- substr($$ref, $start[$i], $close[$i] - $start[$i], "$tag$value");
- }
-
- ### 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;
+
+ ### 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;
}
### yet another html escaper
### allow pass by value or by reference (reference is modified inplace)
sub html_escape {
- my $str = shift;
- return $str if ! $str;
- my $ref = ref($str) ? $str : \$str;
+ my $str = shift;
+ return $str if ! $str;
+ my $ref = ref($str) ? $str : \$str;
- $$ref =~ s/&/&/g;
- $$ref =~ s/</</g;
- $$ref =~ s/>/>/g;
- $$ref =~ s/\"/"/g;
+ $$ref =~ s/&/&/g;
+ $$ref =~ s/</</g;
+ $$ref =~ s/>/>/g;
+ $$ref =~ s/\"/"/g;
- return ref($str) ? 1 : $$ref;
+ return ref($str) ? 1 : $$ref;
}
### get a named value for key="value" pairs
-### usage: my $val = &get_tagval_by_key(\$tag, $key);
-### usage: my $valsref = &get_tagval_by_key(\$tag, $key, 'all');
+### usage: my $val = get_tagval_by_key(\$tag, $key);
+### usage: my $valsref = get_tagval_by_key(\$tag, $key, 'all');
sub get_tagval_by_key {
- my $tag = shift;
- my $ref = ref($tag) ? $tag : \$tag;
- my $key = lc(shift);
- my $all = $_[0] && $_[0] eq 'all';
- my @all = ();
- pos($$ref) = 0; # fix for regex below not resetting and forcing order on key value pairs
-
- ### loop looking for tag pairs
- while ($$ref =~ m{
- (?<![\w\.\-]) # 0 - not proceded by letter or .
- ([\w\.\-]+) # 1 - the key
- \s*= # equals
- (?: \s*([\"\'])(|.*?[^\\])\2 # 2 - a quote, 3 - the quoted
- | ([^\s/]*? (?=\s|>|/>)) # 4 - a non-quoted string
- )
- }sigx) {
- next if lc($1) ne $key;
- my ($val,$quot) = ($2) ? ($3,$2) : ($4,undef);
- $val =~ s/\\$quot/$quot/ if $quot;
- return $val if ! $all;
- push @all, $val;
- }
- return undef if ! $all;
- return \@all;
+ my $tag = shift;
+ my $ref = ref($tag) ? $tag : \$tag;
+ my $key = lc(shift);
+ my $all = $_[0] && $_[0] eq 'all';
+ my @all = ();
+ pos($$ref) = 0; # fix for regex below not resetting and forcing order on key value pairs
+
+ ### loop looking for tag pairs
+ while ($$ref =~ m{
+ (?<![\w\.\-]) # 0 - not proceded by letter or .
+ ([\w\.\-]+) # 1 - the key
+ \s*= # equals
+ (?: \s*([\"\'])(|.*?[^\\])\2 # 2 - a quote, 3 - the quoted
+ | ([^\s/]*? (?=\s|>|/>)) # 4 - a non-quoted string
+ )
+ }sigx) {
+ next if lc($1) ne $key;
+ my ($val,$quot) = ($2) ? ($3,$2) : ($4,undef);
+ $val =~ s/\\$quot/$quot/ if $quot;
+ return $val if ! $all;
+ push @all, $val;
+ }
+ return undef if ! $all;
+ return \@all;
}
### swap out values for key="value" pairs
### usage: my $count = &swap_tagval_by_key(\$tag, $key, $val);
### usage: my $newtag = &swap_tagval_by_key($tag, $key, $val);
sub swap_tagval_by_key {
- my $tag = shift;
- my $ref = ref($tag) ? $tag : \$tag;
- my $key = lc(shift);
- my $val = shift;
- my $n = 0;
-
- ### swap a key/val pair at time
- $$ref =~ s{(^\s*<\s*\w+\s+ | \G\s+) # 1 - open tag or previous position
- ( ([\w\-\.]+) # 2 - group, 3 - the key
- (\s*=) # 4 - equals
- (?: \s* ([\"\']) (?:|.*?[^\\]) \5 # 5 - the quote mark, the quoted
- | [^\s/]*? (?=\s|>|/>) # a non-quoted string (may be zero length)
- )
- | ([^\s/]+?) (?=\s|>|/>) # 6 - a non keyvalue chunk (CHECKED)
- )
- }{
- if (defined($3) && lc($3) eq $key) { # has matching key value pair
- if (! $n ++) { # only put value back on first match
- "$1$3$4\"$val\""; # always double quote
- } else {
- $1; # second match
- }
- } elsif (defined($6) && lc($6) eq $key) { # has matching key
- if (! $n ++) { # only put value back on first match
- "$1$6=\"$val\"";
- } else {
- $1; # second match
- }
- } else {
- "$1$2"; # non-keyval
- }
- }sigex;
-
- ### append value on if none were swapped
- if (! $n) {
- $$ref =~ s|(\s*/?>\s*)$| value="$val"$1|;
- $n = -1;
- }
-
- return ref($tag) ? $n : $$ref;
+ my $tag = shift;
+ my $ref = ref($tag) ? $tag : \$tag;
+ my $key = lc(shift);
+ my $val = shift;
+ my $n = 0;
+
+ ### swap a key/val pair at time
+ $$ref =~ s{(^\s*<\s*\w+\s+ | \G\s+) # 1 - open tag or previous position
+ ( ([\w\-\.]+) # 2 - group, 3 - the key
+ (\s*=) # 4 - equals
+ (?: \s* ([\"\']) (?:|.*?[^\\]) \5 # 5 - the quote mark, the quoted
+ | [^\s/]*? (?=\s|>|/>) # a non-quoted string (may be zero length)
+ )
+ | ([^\s/]+?) (?=\s|>|/>) # 6 - a non keyvalue chunk (CHECKED)
+ )
+ }{
+ if (defined($3) && lc($3) eq $key) { # has matching key value pair
+ if (! $n ++) { # only put value back on first match
+ "$1$3$4\"$val\""; # always double quote
+ } else {
+ $1; # second match
+ }
+ } elsif (defined($6) && lc($6) eq $key) { # has matching key
+ if (! $n ++) { # only put value back on first match
+ "$1$6=\"$val\"";
+ } else {
+ $1; # second match
+ }
+ } else {
+ "$1$2"; # non-keyval
+ }
+ }sigex;
+
+ ### append value on if none were swapped
+ if (! $n) {
+ $$ref =~ s|(\s*/?>\s*)$| value="$val"$1|;
+ $n = -1;
+ }
+
+ return ref($tag) ? $n : $$ref;
}
1;
###----------------------------------------------------------------###
-=head1 NAME
+=head1 SYNOPSIS
-CGI::Ex::Fill - Yet another form filler
+ use CGI::Ex::Fill qw(form_fill fill);
-=head1 SYNOPSIS
+ my $text = my_own_template_from_somewhere();
- use CGI::Ex::Fill qw(form_fill);
+ my $form = CGI->new;
+ # OR
+ # my $form = {key => 'value'}
+ # OR
+ # my $form = [CGI->new, CGI->new, {key1 => 'val1'}, CGI->new];
- my $text = my_own_template_from_somewhere();
- my $form = CGI->new;
- # OR
- # my $form = {key => 'value'}
- # OR
- # my $form = [CGI->new, CGI->new, {key1 => 'val1'}, CGI->new];
+ form_fill(\$text, $form); # modifies $text
+ # OR
+ # my $copy = form_fill($text, $form); # copies $text
- form_fill(\$text, $form); # modifies $text
- # OR
- # my $copy = form_fill($text, $form); # copies $text
+ # OR
+ fill({
+ text => \$text,
+ form => $form,
+ });
- ALSO
+ # ALSO
- my $formname = 'formname'; # table to parse (undef = anytable)
- my $fp = 0; # fill_passwords ? default is true
- my $ignore = ['key1', 'key2']; # OR {key1 => 1, key2 => 1};
+ my $formname = 'formname'; # form to parse (undef = anytable)
+ my $fp = 0; # fill_passwords ? default is true
+ my $ignore = ['key1', 'key2']; # OR {key1 => 1, key2 => 1};
- form_fill(\$text, $form, $formname, $fp, $ignore);
+ form_fill(\$text, $form, $formname, $fp, $ignore);
- ALSO
+ # OR
+ fill({
+ text => \$text,
+ form => $form,
+ target => 'my_formname',
+ fill_password => $fp,
+ ignore_fields => $ignore,
+ });
- ### delay getting the value until we find an element that needs it
- my $form = {key => sub {my $key = shift; # get and return value}};
+ # ALSO
+
+ ### delay getting the value until we find an element that needs it
+ my $form = {key => sub {my $key = shift; # get and return value}};
=head1 DESCRIPTION
-form_fill is directly comparable to HTML::FillInForm. It will pass the
-same suite of tests (actually - it is a little bit kinder on the parse as
-it won't change case, reorder your attributes, or miscellaneous spaces).
-
-HTML::FillInForm both benefits and suffers from being based on
-HTML::Parser. It is good for standards and poor for performance. Testing
-the form_fill module against HTML::FillInForm gave some surprising
-results. On tiny forms (< 1 k) form_fill was ~ 17% faster than FillInForm.
-If the html document incorporated very many entities at all, the
-performace of FillInForm goes down (and down). However, if you are only
-filling in one form every so often, then it shouldn't matter - but form_fill
-will be nicer on the tags and won't balk at ugly html.
-See the benchmarks in the t/samples directory for more information (ALL
-BENCHMARKS SHOULD BE TAKEN WITH A GRAIN OF SALT).
+form_fill is directly comparable to HTML::FillInForm. It will pass
+the same suite of tests (actually - it is a little bit kinder on the
+parse as it won't change case, reorder your attributes, or alter
+miscellaneous spaces and it won't require the HTML to be well formed).
+
+HTML::FillInForm is based upon HTML::Parser while CGI::Ex::Fill is
+purely regex driven. The performance of CGI::Ex::Fill will be better
+on HTML with many markup tags because HTML::Parser will parse each tag
+while CGI::Ex::Fill will search only for those tags it knows how to
+handle. And CGI::Ex::Fill generally won't break on malformed html.
+
+On tiny forms (< 1 k) form_fill was ~ 13% slower than FillInForm. If
+the html document incorporated very many entities at all, the
+performance of FillInForm goes down (adding 360 <br> tags pushed
+form_fill to ~ 350% faster). However, if you are only filling in one
+form every so often, then it shouldn't matter which you use - but
+form_fill will be nicer on the tags and won't balk at ugly html and
+will decrease performance only at a slow rate as the size of the html
+increases. See the benchmarks in the t/samples/bench_cgix_hfif.pl
+file for more information (ALL BENCHMARKS SHOULD BE TAKEN WITH A GRAIN
+OF SALT).
+
+There are two functions, fill and form_fill. The function fill takes
+a hashref of named arguments. The function form_fill takes a list
+of positional parameters.
+
+=head1 ARGUMENTS TO form_fill
+
+The following are the arguments to the main function C<fill>.
+
+=over 4
+
+=item text
+
+A reference to an html string that includes one or more forms.
+
+=item form
+
+A form hash, CGI object, or an array of hashrefs and objects.
+
+=item target
+
+The name of the form to swap. Default is undef which means
+to swap all form entities in all forms.
+
+=item fill_password
+
+Default true. If set to false, fields of type password will
+not be refilled.
+
+=item ignore_fields
+
+Hashref of fields to be ignored from swapping.
+
+=item remove_script
+
+Defaults to the package global $REMOVE_SCRIPT which defaults to true.
+Removes anything in <script></script> tags which often cause problems for
+parsers.
+
+=item remove_comment
+
+Defaults to the package global $REMOVE_COMMENT which defaults to true.
+Removes anything in <!-- --> tags which can sometimes cause problems for
+parsers.
+
+=item object_method
+
+The method to call on objects passed to the form argument. Default value
+is the package global $OBJECT_METHOD which defaults to 'param'. If a
+CGI object is passed, it would call param on that object passing
+the desired keyname as an argument.
+
+=back
+
+=head1 ARGUMENTS TO form_fill
+
+The following are the arguments to the legacy function C<form_fill>.
+
+=over 4
+
+=item C<\$html>
+
+A reference to an html string that includes one or more forms or form
+entities.
+
+=item C<\%FORM>
+
+A form hash, or CGI query object, or an arrayref of multiple hash refs
+and/or CGI query objects that will supply values for the form.
+
+=item C<$form_name>
+
+The name of the form to fill in values for. The default is undef
+which indicates that all forms are to be filled in.
+
+=item C<$swap_pass>
+
+Default true. Indicates that C<<lt>input type="password"<gt>> fields
+are to be swapped as well. Set to false to disable this behavior.
+
+=item C<\%IGNORE_FIELDS> OR C<\@IGNORE_FIELDS>
+
+A hash ref of key names or an array ref of key names that will be
+ignored during the fill in of the form.
+
+=back
+
+=head1 BEHAVIOR
+
+fill and form_fill will attempt to DWYM when filling in values. The following behaviors
+are used on the following types of form elements.
+
+=over 4
+
+=item C<E<lt>input type="text"E<gt>>
+
+The following rules are used when matching this type:
+
+ 1) Get the value from the form that matches the input's "name".
+ 2) If the value is defined - it adds or replaces the existing value.
+ 3) If the value is not defined and the existing value is not defined,
+ a value of "" is added.
+
+For example:
+
+ my $form = {foo => "FOO", bar => "BAR", baz => "BAZ"};
+
+ my $html = '
+ <input type=text name=foo>
+ <input type=text name=foo>
+ <input type=text name=bar value="">
+ <input type=text name=baz value="Something else">
+ <input type=text name=hem value="Another thing">
+ <input type=text name=haw>
+ ';
+
+ form_fill(\$html, $form);
+
+ $html eq '
+ <input type=text name=foo value="FOO">
+ <input type=text name=foo value="FOO">
+ <input type=text name=bar value="BAR">
+ <input type=text name=baz value="BAZ">
+ <input type=text name=hem value="Another thing">
+ <input type=text name=haw value="">
+ ';
+
+
+If the value returned from the form is an array ref, the values of the array ref
+will be sequentially used for each input found by that name until the values
+run out. If the value is not an array ref - it will be used to fill in any values
+by that name. For example:
+
+ $form = {foo => ['aaaa', 'bbbb', 'cccc']};
+
+ $html = '
+ <input type=text name=foo>
+ <input type=text name=foo>
+ <input type=text name=foo>
+ <input type=text name=foo>
+ <input type=text name=foo>
+ ';
+
+ form_fill(\$html, $form);
+
+ $html eq '
+ <input type=text name=foo value="aaaa">
+ <input type=text name=foo value="bbbb">
+ <input type=text name=foo value="cccc">
+ <input type=text name=foo value="">
+ <input type=text name=foo value="">
+ ';
+
+=item C<E<lt>input type="hidden"E<gt>>
+
+Same as C<E<lt>input type="text"E<gt>>.
+
+=item C<E<lt>input type="password"E<gt>>
+
+Same as C<E<lt>input type="text"E<gt>>.
+
+=item C<E<lt>input type="file"E<gt>>
+
+Same as C<E<lt>input type="text"E<gt>>. (Note - this is subject
+to browser support for pre-population)
+
+=item C<E<lt>input type="checkbox"E<gt>>
+
+As each checkbox is found the following rules are applied:
+
+ 1) Get the values from the form (do nothing if no values found)
+ 2) Remove any existing "checked=checked" or "checked" markup from the tag.
+ 3) Compare the "value" field to the values and mark with checked="checked"
+ if there is a match.
+
+If no "value" field is found in the html, a default value of "on" will be used (which is
+what most browsers will send as the default value for checked boxes without
+"value" fields).
+
+ $form = {foo => 'FOO', bar => ['aaaa', 'bbbb', 'cccc'], baz => 'on'};
+
+ $html = '
+ <input type=checkbox name=foo value="123">
+ <input type=checkbox name=foo value="FOO">
+ <input type=checkbox name=bar value="aaaa">
+ <input type=checkbox name=bar value="cccc">
+ <input type=checkbox name=bar value="dddd" checked="checked">
+ <input type=checkbox name=baz>
+ ';
+
+ form_fill(\$html, $form);
+
+ $html eq '
+ <input type=checkbox name=foo value="123">
+ <input type=checkbox name=foo value="FOO" checked="checked">
+ <input type=checkbox name=bar value="aaaa" checked="checked">
+ <input type=checkbox name=bar value="cccc" checked="checked">
+ <input type=checkbox name=bar value="dddd">
+ <input type=checkbox name=baz checked="checked">
+ ';
+
+
+=item C<E<lt>input type="radio"E<gt>>
+
+Same as C<E<lt>input type="checkbox"E<gt>>.
+
+=item C<E<lt>selectE<gt>>
+
+As each select box is found the following rules are applied (these rules are
+applied regardless of if the box is a select-one or a select-multi - if multiple
+values are selected on a select-one it is up to the browser to choose which one
+to highlight):
+
+ 1) Get the values from the form (do nothing if no values found)
+ 2) Remove any existing "selected=selected" or "selected" markup from the tag.
+ 3) Compare the "value" field to the values and mark with selected="selected"
+ if there is a match.
+ 4) If there is no "value" field - use the text in between the "option" tags.
+
+ (Note: There does not need to be a closing "select" tag or closing "option" tag)
+
+
+ $form = {foo => 'FOO', bar => ['aaaa', 'bbbb', 'cccc']};
+
+ $html = '
+ <select name=foo><option>FOO<option>123<br>
+
+ <select name=bar>
+ <option>aaaa</option>
+ <option value="cccc">cccc</option>
+ <option value="dddd" selected="selected">dddd</option>
+ </select>
+ ';
+
+ form_fill(\$html, $form);
+
+ ok(
+ $html eq '
+ <select name=foo><option selected="selected">FOO<option>123<br>
+
+ <select name=bar>
+ <option selected="selected">aaaa</option>
+ <option value="cccc" selected="selected">cccc</option>
+ <option value="dddd">dddd</option>
+ </select>
+ ', "Perldoc example 4 passed");
+
+
+=item C<E<lt>textareaE<gt>>
+
+The rules for swapping textarea are as follows:
+
+ 1) Get the value from the form that matches the textarea's "name".
+ 2) If the value is defined - it adds or replaces the existing value.
+ 3) If the value is not defined, the text area is left alone.
+
+ (Note - there does not need to be a closing textarea tag. In the case of
+ a missing close textarea tag, the contents of the text area will be
+ assumed to be the start of the next textarea of the end of the document -
+ which ever comes sooner)
+
+If the form returned an array ref of values, then these values will be
+used sequentially each time a textarea by that name is found. If a single value
+(not array ref) is found, that value will be used for each textarea by that name.
+
+For example.
+
+ $form = {foo => 'FOO', bar => ['aaaa', 'bbbb']};
+
+ $html = '
+ <textarea name=foo></textarea>
+ <textarea name=foo></textarea>
+
+ <textarea name=bar>
+ <textarea name=bar></textarea><br>
+ <textarea name=bar>dddd</textarea><br>
+ <textarea name=bar><br><br>
+ ';
+
+ form_fill(\$html, $form);
+
+ $html eq '
+ <textarea name=foo>FOO</textarea>
+ <textarea name=foo>FOO</textarea>
+
+ <textarea name=bar>aaaa<textarea name=bar>bbbb</textarea><br>
+ <textarea name=bar></textarea><br>
+ <textarea name=bar>';
+
+=item C<E<lt>input type="submit"E<gt>>
+
+Does nothing. The value for submit should typically be set by the
+templating system or application system.
+
+=item C<E<lt>input type="button"E<gt>>
+
+Same as submit.
+
+=back
=head1 HTML COMMENT / JAVASCRIPT
comments and javascript, form_fill temporarily removes them during the
fill. You may disable this behavior by setting $REMOVE_COMMENT and
$REMOVE_SCRIPT to 0 before calling form_fill. The main reason for
-doing this would be if you wanted to have form elments inside the
+doing this would be if you wanted to have form elements inside the
javascript and comments get filled. Disabling the removal only
results in a speed increase of 5%. The function uses \0COMMENT\0 and
-\0SCRIPT\0 as placeholders so i'd avoid these in your text (Actually
-they may be reset to whatever you'd like via $MARKER_COMMENT and
-$MARKER_SCRIPT).
+\0SCRIPT\0 as placeholders so it would be good to avoid these in your
+text (Actually they may be reset to whatever you'd like via
+$MARKER_COMMENT and $MARKER_SCRIPT).
-=head1 AUTHOR
+=head1 UTILITY FUNCTIONS
-Paul Seamons
+=over 4
+
+=item C<html_escape>
+
+Very minimal entity escaper for filled in values.
+
+ my $escaped = html_escape($unescaped);
+
+ html_escape(\$text_to_escape);
+
+=item C<get_tagval_by_key>
+
+Get a named value for from an html tag (key="value" pairs).
+
+ my $val = get_tagval_by_key(\$tag, $key);
+ my $valsref = get_tagval_by_key(\$tag, $key, 'all'); # get all values
+
+=item C<swap_tagval_by_key>
+
+Swap out values in an html tag (key="value" pairs).
+
+ my $count = swap_tagval_by_key(\$tag, $key, $val); # modify ref
+ my $newtag = swap_tagval_by_key($tag, $key, $val); # copies tag
+
+=back
=head1 LICENSE
This module may distributed under the same terms as Perl itself.
+=head1 AUTHOR
+
+Paul Seamons
+
=cut
projects / chaz / p5-CGI-Ex / blobdiff