Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/Fill.pm

   1 package CGI::Ex::Fill;
   2
   3 ### CGI Extended Form Filler
   4
   5 ###----------------------------------------------------------------###
   6 #  Copyright 2003 - Paul Seamons                                     #
   7 #  Distributed under the Perl Artistic License without warranty      #
   8 ###----------------------------------------------------------------###
   9
  10 ### See perldoc at bottom
  11
  12 use strict;
  13 use vars qw($VERSION
  14             @ISA @EXPORT @EXPORT_OK
  15             $REMOVE_SCRIPT
  16             $REMOVE_COMMENT
  17             $MARKER_SCRIPT
  18             $MARKER_COMMENT
  19             $OBJECT_METHOD
  20             $TEMP_TARGET
  21             );
  22 use Exporter;
  23
  24 $VERSION   = '1.3';
  25 @ISA       = qw(Exporter);
  26 @EXPORT    = qw(form_fill);
  27 @EXPORT_OK = qw(form_fill html_escape get_tagval_by_key swap_tagval_by_key);
  28
  29 ### These directives are used to determine whether or not to
  30 ### remove html comments and script sections while filling in
  31 ### a form.  Default is on.  This may give some trouble if you
  32 ### have a javascript section with form elements that you would
  33 ### like filled in.
  34 $REMOVE_SCRIPT  = 1;
  35 $REMOVE_COMMENT = 1;
  36 $MARKER_SCRIPT  = "\0SCRIPT\0";
  37 $MARKER_COMMENT = "\0COMMENT\0";
  38 $OBJECT_METHOD  = "param";
  39
  40 ###----------------------------------------------------------------###
  41
  42 ### Regex based filler - as opposed to HTML::Parser based HTML::FillInForm
  43 ### arguments are positional
  44 ### pos1 - text or textref - if textref it is modified in place
  45 ### pos2 - hash or cgi obj ref, or array ref of hash and cgi obj refs
  46 ### pos3 - target - to be used for choosing a specific form - default undef
  47 ### pos4 - boolean fill in password fields - default is true
  48 ### pos5 - hashref or arrayref of fields to ignore
  49 sub form_fill {
  50   my $text          = shift;
  51   my $ref           = ref($text) ? $text : \$text;
  52   my $form          = shift;
  53   my $forms         = UNIVERSAL::isa($form, 'ARRAY') ? $form : [$form];
  54   my $target        = shift;
  55   my $fill_password = shift;
  56   my $ignore        = shift || {};
  57   $ignore = {map {$_ => 1} @$ignore} if UNIVERSAL::isa($ignore, 'ARRAY');
  58   $fill_password = 1 if ! defined $fill_password;
  59
  60
  61   ### allow for optionally removing comments and script
  62   my @comment;
  63   my @script;
  64   if ($REMOVE_SCRIPT) {
  65     $$ref =~ s|(<script\b.+?</script>)|push(@script, $1);$MARKER_SCRIPT|egi;
  66   }
  67   if ($REMOVE_COMMENT) {
  68     $$ref =~ s|(<!--.*?-->)|push(@comment, $1);$MARKER_COMMENT|eg;
  69   }
  70
  71   ### if there is a target - focus in on it
  72   ### possible bug here - name won't be found if
  73   ### there is nested html inside the form tag that comes before
  74   ### the name field - if no close form tag - don't swap in anything
  75   if ($target) {
  76     local $TEMP_TARGET = $target;
  77     $$ref =~ s{(<form            # open form
  78                 [^>]+            # some space
  79                 \bname=([\"\']?) # the name tag
  80                 $target          # with the correct name (allows for regex)
  81                 \2               # closing quote
  82                 .+?              # as much as there is
  83                 (?=</form>))     # then end
  84               }{
  85                 local $REMOVE_SCRIPT  = undef;
  86                 local $REMOVE_COMMENT = undef;
  87                 &form_fill($1, $form, undef, $fill_password, $ignore);
  88               }sigex;
  89
  90     ### put scripts and comments back and return
  91     $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1;
  92     $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script  != -1;
  93     return ref($text) ? 1 : $$ref;
  94   }
  95
  96   ### build a sub to get a value
  97   my %indexes = (); # store indexes for multivalued elements
  98   my $get_form_value = sub {
  99     my $key = shift;
 100     my $all = $_[0] && $_[0] eq 'all';
 101     if (! defined $key || ! length $key) {
 102       return $all ? [] : undef;
 103     }
 104
 105     my $val;
 106     my $meth;
 107     foreach my $form (@$forms) {
 108       next if ! ref $form;
 109       if (UNIVERSAL::isa($form, 'HASH') && defined $form->{$key}) {
 110         $val = $form->{$key};
 111         last;
 112       } elsif ($meth = UNIVERSAL::can($form, $OBJECT_METHOD)) {
 113         $val = $form->$meth($key);
 114         last if defined $val;
 115       } elsif (UNIVERSAL::isa($form, 'CODE')) {
 116         $val = &{ $form }($key, $TEMP_TARGET);
 117         last if defined $val;
 118       }
 119     }
 120     if (! defined $val) {
 121       return $all ? [] : undef;
 122     }
 123
 124     ### fix up the value some
 125     if (UNIVERSAL::isa($val, 'CODE')) {
 126       $val = &{ $val }($key, $TEMP_TARGET);
 127     }
 128     if (UNIVERSAL::isa($val, 'ARRAY')) {
 129       $val = [@$val]; # copy the values
 130     } elsif (ref $val) {
 131       # die "Value for $key is not an array or a scalar";
 132       $val = "$val";  # stringify anything else
 133     }
 134
 135     ### html escape them all
 136     &html_escape(\$_) foreach (ref($val) ? @$val : $val);
 137
 138     ### allow for returning all elements
 139     ### or one at a time
 140     if ($all) {
 141       return ref($val) ? $val : [$val];
 142     } elsif (ref($val)) {
 143       $indexes{$key} ||= 0;
 144       my $ret = $val->[$indexes{$key}] || '';
 145       $indexes{$key} ++; # don't wrap - if we run out of values - we're done
 146       return $ret;
 147     } else {
 148       return $val;
 149     }
 150   };
 151
 152
 153   ###--------------------------------------------------------------###
 154
 155   ### First pass
 156   ### swap <input > form elements if they have a name
 157   $$ref =~ s{
 158     (<input \s (?: ([\"\'])(?:|.*?[^\\])\2 | [^>] )* >) # nested html ok
 159     }{
 160       ### get the type and name - intentionally exlude names with nested "'
 161       my $tag   = $1;
 162       my $type  = uc(&get_tagval_by_key(\$tag, 'type') || '');
 163       my $name  = &get_tagval_by_key(\$tag, 'name');
 164
 165       if ($name && ! $ignore->{$name}) {
 166         if (! $type
 167             || $type eq 'HIDDEN'
 168             || $type eq 'TEXT'
 169             || $type eq 'FILE'
 170             || ($type eq 'PASSWORD' && $fill_password)) {
 171
 172           my $value = &$get_form_value($name, 'next');
 173           if (defined $value) {
 174             &swap_tagval_by_key(\$tag, 'value', $value);
 175           } elsif (! defined &get_tagval_by_key(\$tag, 'value')) {
 176             &swap_tagval_by_key(\$tag, 'value', '');
 177           }
 178
 179         } elsif ($type eq 'CHECKBOX'
 180                  || $type eq 'RADIO') {
 181           my $values = &$get_form_value($name, 'all');
 182           if (@$values) {
 183             $tag =~ s{\s+\bCHECKED\b(?:=([\"\']?)checked\1)?(?=\s|>|/>)}{}ig;
 184
 185             if ($type eq 'CHECKBOX' && @$values == 1 && $values->[0] eq 'on') {
 186               $tag =~ s|(/?>\s*)$| checked="checked"$1|;
 187             } else {
 188               my $fvalue = &get_tagval_by_key(\$tag, 'value');
 189               if (defined $fvalue) {
 190                 foreach (@$values) {
 191                   next if $_ ne $fvalue;
 192                   $tag =~ s|(\s*/?>\s*)$| checked="checked"$1|;
 193                   last;
 194                 }
 195               }
 196             }
 197           }
 198         }
 199       }
 200       $tag; # return of swap
 201     }sigex;
 202
 203
 204   ### Second pass
 205   ### swap select boxes (must be done in such a way as to allow no closing tag)
 206   my @start = ();
 207   my @close = ();
 208   push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*select\b)|ig;
 209   push @close, pos($$ref) - length($1) while $$ref =~ m|(</\s*select\b)|ig;
 210   for (my $i = 0; $i <= $#start; $i ++) {
 211     while (defined($close[$i]) && $close[$i] < $start[$i]) {
 212       splice (@close,$i,1,());
 213     }
 214     if ($i == $#start) {
 215       $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
 216     } elsif (! defined($close[$i]) || $close[$i] > $start[$i + 1]) {
 217       $close[$i] = $start[$i + 1]; # set to start of next select if no closing or > next select
 218     }
 219   }
 220   for (my $i = $#start; $i >= 0; $i --) {
 221     my $opts = substr($$ref, $start[$i], $close[$i] - $start[$i]);
 222     $opts =~ s{
 223       (<select \s                                 # opening
 224        (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )* # nested html ok
 225        >)                                         # end of tag
 226       }{}sxi || next;
 227     next if ! $opts;
 228     my $tag    = $1;
 229     my $name   = &get_tagval_by_key(\$tag, 'name');
 230     my $values = $ignore->{$name} ? [] : &$get_form_value($name, 'all');
 231     if ($#$values != -1) {
 232       my $n = $opts =~ s{
 233         (<option[^>]*>)           # opening tag - no embedded > allowed
 234           (.*?)                   # the text value
 235           (?=<option|$|</option>) # the next tag
 236         }{
 237           my ($tag2, $opt) = ($1, $2);
 238           $tag2 =~ s%\s+\bSELECTED\b(?:=([\"\']?)selected\1)?(?=\s|>|/>)%%ig;
 239
 240           my $fvalues = &get_tagval_by_key(\$tag2, 'value', 'all');
 241           my $fvalue  = @$fvalues ? $fvalues->[0]
 242             : $opt =~ /^\s*(.*?)\s*$/ ? $1 : "";
 243           foreach (@$values) {
 244             next if $_ ne $fvalue;
 245             $tag2 =~ s|(\s*/?>\s*)$| selected="selected"$1|;
 246             last;
 247           }
 248           "$tag2$opt"; # return of the swap
 249         }sigex;
 250       if ($n) {
 251         substr($$ref, $start[$i], $close[$i] - $start[$i], "$tag$opts");
 252       }
 253     }
 254   }
 255
 256
 257   ### Third pass
 258   ### swap textareas (must be done in such a way as to allow no closing tag)
 259   @start = ();
 260   @close = ();
 261   push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*textarea\b)|ig;
 262   push @close, pos($$ref) - length($1) while $$ref =~ m|(</\s*textarea\b)|ig;
 263   for (my $i = 0; $i <= $#start; $i ++) {
 264     while (defined($close[$i]) && $close[$i] < $start[$i]) {
 265       splice (@close,$i,1,());
 266     }
 267     if ($i == $#start) {
 268       $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
 269     } elsif (! defined($close[$i]) || $close[$i] > $start[$i + 1]) {
 270       $close[$i] = $start[$i + 1]; # set to start of next select if no closing or > next select
 271     }
 272   }
 273   for (my $i = $#start; $i >= 0; $i --) {
 274     my $oldval = substr($$ref, $start[$i], $close[$i] - $start[$i]);
 275     $oldval =~ s{
 276       (<textarea \s                               # opening
 277        (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )* # nested html ok
 278        >)                                         # end of tag
 279       }{}sxi || next;
 280     my $tag   = $1;
 281     my $name  = &get_tagval_by_key(\$tag, 'name');
 282     my $value = $ignore->{$name} ? [] : &$get_form_value($name, 'next');
 283     next if ! defined $value;
 284     substr($$ref, $start[$i], $close[$i] - $start[$i], "$tag$value");
 285   }
 286
 287   ### put scripts and comments back and return
 288   $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1;
 289   $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script  != -1;
 290   return ref($text) ? 1 : $$ref;
 291 }
 292
 293
 294 ### yet another html escaper
 295 ### allow pass by value or by reference (reference is modified inplace)
 296 sub html_escape {
 297   my $str = shift;
 298   return $str if ! $str;
 299   my $ref = ref($str) ? $str : \$str;
 300
 301   $$ref =~ s/&/&amp;/g;
 302   $$ref =~ s/</&lt;/g;
 303   $$ref =~ s/>/&gt;/g;
 304   $$ref =~ s/\"/&quot;/g;
 305
 306   return ref($str) ? 1 : $$ref;
 307 }
 308
 309 ### get a named value for key="value" pairs
 310 ### usage: my $val     = &get_tagval_by_key(\$tag, $key);
 311 ### usage: my $valsref = &get_tagval_by_key(\$tag, $key, 'all');
 312 sub get_tagval_by_key {
 313   my $tag = shift;
 314   my $ref = ref($tag) ? $tag : \$tag;
 315   my $key = lc(shift);
 316   my $all = $_[0] && $_[0] eq 'all';
 317   my @all = ();
 318   pos($$ref) = 0; # fix for regex below not resetting and forcing order on key value pairs
 319
 320   ### loop looking for tag pairs
 321   while ($$ref =~ m{
 322     (?<![\w\.\-])                  # 0 - not proceded by letter or .
 323       ([\w\.\-]+)                  # 1 - the key
 324       \s*=                         # equals
 325       (?: \s*([\"\'])(|.*?[^\\])\2 # 2 - a quote, 3 - the quoted
 326        |  ([^\s/]*? (?=\s|>|/>))   # 4 - a non-quoted string
 327        )
 328     }sigx) {
 329     next if lc($1) ne $key;
 330     my ($val,$quot) = ($2) ? ($3,$2) : ($4,undef);
 331     $val =~ s/\\$quot/$quot/ if $quot;
 332     return $val if ! $all;
 333     push @all, $val;
 334   }
 335   return undef if ! $all;
 336   return \@all;
 337 }
 338
 339 ### swap out values for key="value" pairs
 340 ### usage: my $count  = &swap_tagval_by_key(\$tag, $key, $val);
 341 ### usage: my $newtag = &swap_tagval_by_key($tag, $key, $val);
 342 sub swap_tagval_by_key {
 343   my $tag = shift;
 344   my $ref = ref($tag) ? $tag : \$tag;
 345   my $key = lc(shift);
 346   my $val = shift;
 347   my $n   = 0;
 348
 349   ### swap a key/val pair at time
 350   $$ref =~ s{(^\s*<\s*\w+\s+ | \G\s+)         # 1 - open tag or previous position
 351                ( ([\w\-\.]+)                  # 2 - group, 3 - the key
 352                  (\s*=)                       # 4 - equals
 353                   (?: \s* ([\"\']) (?:|.*?[^\\]) \5 # 5 - the quote mark, the quoted
 354                    |  [^\s/]*? (?=\s|>|/>)    # a non-quoted string (may be zero length)
 355                   )
 356                 | ([^\s/]+?) (?=\s|>|/>)      # 6 - a non keyvalue chunk (CHECKED)
 357                )
 358              }{
 359                if (defined($3) && lc($3) eq $key) { # has matching key value pair
 360                  if (! $n ++) {  # only put value back on first match
 361                    "$1$3$4\"$val\""; # always double quote
 362                  } else {
 363                    $1; # second match
 364                  }
 365                } elsif (defined($6) && lc($6) eq $key) { # has matching key
 366                  if (! $n ++) {  # only put value back on first match
 367                    "$1$6=\"$val\"";
 368                  } else {
 369                    $1; # second match
 370                  }
 371                } else {
 372                  "$1$2"; # non-keyval
 373                }
 374              }sigex;
 375
 376   ### append value on if none were swapped
 377   if (! $n) {
 378     $$ref =~ s|(\s*/?>\s*)$| value="$val"$1|;
 379     $n = -1;
 380   }
 381
 382   return ref($tag) ? $n : $$ref;
 383 }
 384
 385 1;
 386
 387 __END__
 388
 389 ###----------------------------------------------------------------###
 390
 391 =head1 NAME
 392
 393 CGI::Ex::Fill - Yet another form filler
 394
 395 =head1 SYNOPSIS
 396
 397   use CGI::Ex::Fill qw(form_fill);
 398
 399   my $text = my_own_template_from_somewhere();
 400
 401   my $form = CGI->new;
 402   # OR
 403   # my $form = {key => 'value'}
 404   # OR
 405   # my $form = [CGI->new, CGI->new, {key1 => 'val1'}, CGI->new];
 406
 407
 408   form_fill(\$text, $form); # modifies $text
 409   # OR
 410   # my $copy = form_fill($text, $form); # copies $text
 411
 412
 413   ALSO
 414
 415   my $formname = 'formname';     # table to parse (undef = anytable)
 416   my $fp = 0;                    # fill_passwords ? default is true
 417   my $ignore = ['key1', 'key2']; # OR {key1 => 1, key2 => 1};
 418
 419   form_fill(\$text, $form, $formname, $fp, $ignore);
 420
 421   ALSO
 422
 423   ### delay getting the value until we find an element that needs it
 424   my $form = {key => sub {my $key = shift; # get and return value}};
 425
 426
 427 =head1 DESCRIPTION
 428
 429 form_fill is directly comparable to HTML::FillInForm.  It will pass the
 430 same suite of tests (actually - it is a little bit kinder on the parse as
 431 it won't change case, reorder your attributes, or miscellaneous spaces).
 432
 433 HTML::FillInForm both benefits and suffers from being based on
 434 HTML::Parser. It is good for standards and poor for performance.  Testing
 435 the form_fill module against HTML::FillInForm gave some surprising
 436 results.  On tiny forms (< 1 k) form_fill was ~ 17% faster than FillInForm.
 437 If the html document incorporated very many entities at all, the
 438 performace of FillInForm goes down (and down).  However, if you are only
 439 filling in one form every so often, then it shouldn't matter - but form_fill
 440 will be nicer on the tags and won't balk at ugly html.
 441 See the benchmarks in the t/samples directory for more information (ALL
 442 BENCHMARKS SHOULD BE TAKEN WITH A GRAIN OF SALT).
 443
 444 =head1 HTML COMMENT / JAVASCRIPT
 445
 446 Because there are too many problems that could occur with html
 447 comments and javascript, form_fill temporarily removes them during the
 448 fill.  You may disable this behavior by setting $REMOVE_COMMENT and
 449 $REMOVE_SCRIPT to 0 before calling form_fill.  The main reason for
 450 doing this would be if you wanted to have form elments inside the
 451 javascript and comments get filled.  Disabling the removal only
 452 results in a speed increase of 5%. The function uses \0COMMENT\0 and
 453 \0SCRIPT\0 as placeholders so i'd avoid these in your text (Actually
 454 they may be reset to whatever you'd like via $MARKER_COMMENT and
 455 $MARKER_SCRIPT).
 456
 457 =head1 AUTHOR
 458
 459 Paul Seamons
 460
 461 =head1 LICENSE
 462
 463 This module may distributed under the same terms as Perl itself.
 464
 465 =cut