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

   1 package CGI::Ex::Fill;
   2
   3 =head1 NAME
   4
   5 CGI::Ex::Fill - Fast but compliant regex based form filler
   6
   7 =cut
   8
   9 ###----------------------------------------------------------------###
  10 #  Copyright 2007 - Paul Seamons                                     #
  11 #  Distributed under the Perl Artistic License without warranty      #
  12 ###----------------------------------------------------------------###
  13
  14 use strict;
  15 use vars qw($VERSION
  16             @EXPORT @EXPORT_OK
  17             $REMOVE_SCRIPT
  18             $REMOVE_COMMENT
  19             $MARKER_SCRIPT
  20             $MARKER_COMMENT
  21             $OBJECT_METHOD
  22             $_TEMP_TARGET
  23             );
  24 use base qw(Exporter);
  25
  26 BEGIN {
  27     $VERSION   = '2.07';
  28     @EXPORT    = qw(form_fill);
  29     @EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key);
  30 };
  31
  32 ### These directives are used to determine whether or not to
  33 ### remove html comments and script sections while filling in
  34 ### a form.  Default is on.  This may give some trouble if you
  35 ### have a javascript section with form elements that you would
  36 ### like filled in.
  37 BEGIN {
  38     $REMOVE_SCRIPT  = 1;
  39     $REMOVE_COMMENT = 1;
  40     $MARKER_SCRIPT  = "\0SCRIPT\0";
  41     $MARKER_COMMENT = "\0COMMENT\0";
  42     $OBJECT_METHOD  = "param";
  43 };
  44
  45 ###----------------------------------------------------------------###
  46
  47 ### Regex based filler - as opposed to HTML::Parser based HTML::FillInForm
  48 ### arguments are positional
  49 ### pos1 - text or textref - if textref it is modified in place
  50 ### pos2 - hash or cgi obj ref, or array ref of hash and cgi obj refs
  51 ### pos3 - target - to be used for choosing a specific form - default undef
  52 ### pos4 - boolean fill in password fields - default is true
  53 ### pos5 - hashref or arrayref of fields to ignore
  54 sub form_fill {
  55     my $text          = shift;
  56     my $ref           = ref($text) ? $text : \$text;
  57     my $form          = shift;
  58     my $target        = shift;
  59     my $fill_password = shift;
  60     my $ignore        = shift || {};
  61
  62     fill({
  63         text          => $ref,
  64         form          => $form,
  65         target        => $target,
  66         fill_password => $fill_password,
  67         ignore_fields => $ignore,
  68     });
  69
  70     return ref($text) ? 1 : $$ref;
  71 }
  72
  73 sub fill {
  74     my $args          = shift;
  75     my $ref           = $args->{'text'};
  76     my $form          = $args->{'form'};
  77     my $target        = $args->{'target'};
  78     my $ignore        = $args->{'ignore_fields'};
  79     my $fill_password = $args->{'fill_password'};
  80
  81     my $forms = UNIVERSAL::isa($form, 'ARRAY') ? $form : [$form];
  82     $ignore = {map {$_ => 1} @$ignore} if UNIVERSAL::isa($ignore, 'ARRAY');
  83     $fill_password = 1 if ! defined $fill_password;
  84
  85
  86     ### allow for optionally removing comments and script
  87     my @comment;
  88     my @script;
  89     if (defined($args->{'remove_script'}) ? $args->{'remove_script'} : $REMOVE_SCRIPT) {
  90         $$ref =~ s|(<script\b.+?</script>)|push(@script, $1);$MARKER_SCRIPT|egi;
  91     }
  92     if (defined($args->{'remove_comment'}) ? $args->{'remove_comment'} : $REMOVE_COMMENT) {
  93         $$ref =~ s|(<!--.*?-->)|push(@comment, $1);$MARKER_COMMENT|eg;
  94     }
  95
  96     ### if there is a target - focus in on it
  97     ### possible bug here - name won't be found if
  98     ### there is nested html inside the form tag that comes before
  99     ### the name field - if no close form tag - don't swap in anything
 100     if ($target) {
 101         local $_TEMP_TARGET = $target;
 102         $$ref =~ s{(<form            # open form
 103                     [^>]+            # some space
 104                     \bname=([\"\']?) # the name tag
 105                     $target          # with the correct name (allows for regex)
 106                     \2               # closing quote
 107                     .+?              # as much as there is
 108                     (?=</form>))     # then end
 109                    }{
 110                        my $str = $1;
 111                        local $args->{'text'} = \$str;
 112                        local $args->{'remove_script'}  = 0;
 113                        local $args->{'remove_comment'} = 0;
 114                        local $args->{'target'}         = undef;
 115                        fill($args);
 116                        $str; # return of the s///;
 117                    }sigex;
 118
 119         ### put scripts and comments back and return
 120         $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1;
 121         $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script  != -1;
 122         return 1;
 123     }
 124
 125     ### build a sub to get a value from the passed forms on a request basis
 126     my %indexes = (); # store indexes for multivalued elements
 127     my $get_form_value = sub {
 128         my $key = shift;
 129         my $all = $_[0] && $_[0] eq 'all';
 130         if (! defined $key || ! length $key) {
 131             return $all ? [] : undef;
 132         }
 133
 134         my $val;
 135         my $meth;
 136         foreach my $form (@$forms) {
 137             next if ! ref $form;
 138             if (UNIVERSAL::isa($form, 'HASH') && defined $form->{$key}) {
 139                 $val = $form->{$key};
 140                 last;
 141             } elsif ($meth = UNIVERSAL::can($form, $args->{'object_method'} || $OBJECT_METHOD)) {
 142                 $val = $form->$meth($key);
 143                 last if defined $val;
 144             } elsif (UNIVERSAL::isa($form, 'CODE')) {
 145                 $val = $form->($key, $_TEMP_TARGET);
 146                 last if defined $val;
 147             }
 148         }
 149         if (! defined $val) {
 150             return $all ? [] : undef;
 151         }
 152
 153         ### fix up the value some
 154         if (UNIVERSAL::isa($val, 'CODE')) {
 155             $val = $val->($key, $_TEMP_TARGET);
 156         }
 157         if (UNIVERSAL::isa($val, 'ARRAY')) {
 158             $val = [@$val]; # copy the values
 159         } elsif (ref $val) {
 160             # die "Value for $key is not an array or a scalar";
 161             $val = "$val";  # stringify anything else
 162         }
 163
 164         ### html escape them all
 165         html_escape(\$_) foreach (ref($val) ? @$val : $val);
 166
 167         ### allow for returning all elements
 168         ### or one at a time
 169         if ($all) {
 170             return ref($val) ? $val : [$val];
 171         } elsif (ref($val)) {
 172             $indexes{$key} ||= 0;
 173             my $ret = $val->[$indexes{$key}];
 174             $ret = '' if ! defined $ret;
 175             $indexes{$key} ++; # don't wrap - if we run out of values - we're done
 176             return $ret;
 177         } else {
 178             return $val;
 179         }
 180     };
 181
 182
 183     ###--------------------------------------------------------------###
 184
 185     ### First pass
 186     ### swap <input > form elements if they have a name
 187     $$ref =~ s{
 188         (<input \s (?: ([\"\'])(?:|.*?[^\\])\2 | [^>] )+ >) # nested html ok
 189         }{
 190             ### get the type and name - intentionally exlude names with nested "'
 191             my $tag   = $1;
 192             my $type  = uc(get_tagval_by_key(\$tag, 'type') || '');
 193             my $name  = get_tagval_by_key(\$tag, 'name');
 194
 195             if ($name && ! $ignore->{$name}) {
 196                 if (! $type
 197                     || $type eq 'HIDDEN'
 198                     || $type eq 'TEXT'
 199                     || $type eq 'FILE'
 200                     || ($type eq 'PASSWORD' && $fill_password)) {
 201
 202                     my $value = $get_form_value->($name, 'next');
 203                     if (defined $value) {
 204                         swap_tagval_by_key(\$tag, 'value', $value);
 205                     } elsif (! defined get_tagval_by_key(\$tag, 'value')) {
 206                         swap_tagval_by_key(\$tag, 'value', '');
 207                     }
 208
 209                 } elsif ($type eq 'CHECKBOX'
 210                          || $type eq 'RADIO') {
 211                     my $values = $get_form_value->($name, 'all');
 212                     if (@$values) {
 213                         $tag =~ s{\s+\bCHECKED\b(?:=([\"\']?)checked\1)?(?=\s|>|/>)}{}ig;
 214
 215                         my $fvalue = get_tagval_by_key(\$tag, 'value');
 216                         $fvalue = 'on' if ! defined $fvalue;
 217                         if (defined $fvalue) {
 218                             foreach (@$values) {
 219                                 next if $_ ne $fvalue;
 220                                 $tag =~ s|(\s*/?>\s*)$| checked="checked"$1|;
 221                                 last;
 222                             }
 223                         }
 224                     }
 225                 }
 226
 227             }
 228             $tag; # return of swap
 229         }sigex;
 230
 231
 232     ### Second pass
 233     ### swap select boxes (must be done in such a way as to allow no closing tag)
 234     my @start = ();
 235     my @close = ();
 236     push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*select\b)|ig;
 237     push @close, pos($$ref) - length($1) while $$ref =~ m|(</\s*select\b)|ig;
 238     for (my $i = 0; $i <= $#start; $i ++) {
 239         while (defined($close[$i]) && $close[$i] < $start[$i]) {
 240             splice (@close,$i,1,());
 241         }
 242         if ($i == $#start) {
 243             $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
 244         } elsif (! defined($close[$i]) || $close[$i] > $start[$i + 1]) {
 245             $close[$i] = $start[$i + 1]; # set to start of next select if no closing or > next select
 246         }
 247     }
 248     for (my $i = $#start; $i >= 0; $i --) {
 249         my $opts = substr($$ref, $start[$i], $close[$i] - $start[$i]);
 250         $opts =~ s{
 251             (<select \s                                 # opening
 252              (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )+ # nested html ok
 253              >)                                         # end of tag
 254             }{}sxi || next;
 255         next if ! $opts;
 256         my $tag    = $1;
 257         my $name   = get_tagval_by_key(\$tag, 'name');
 258         my $values = $ignore->{$name} ? [] : $get_form_value->($name, 'all');
 259         if ($#$values != -1) {
 260             my $n = $opts =~ s{
 261                 (<option[^>]*>)           # opening tag - no embedded > allowed
 262                     (.*?)                   # the text value
 263                     (?=<option|$|</option>) # the next tag
 264                 }{
 265                     my ($tag2, $opt) = ($1, $2);
 266                     $tag2 =~ s%\s+\bSELECTED\b(?:=([\"\']?)selected\1)?(?=\s|>|/>)%%ig;
 267
 268                     my $fvalues = get_tagval_by_key(\$tag2, 'value', 'all');
 269                     my $fvalue  = @$fvalues ? $fvalues->[0]
 270                         : $opt =~ /^\s*(.*?)\s*$/ ? $1 : "";
 271                     foreach (@$values) {
 272                         next if $_ ne $fvalue;
 273                         $tag2 =~ s|(\s*/?>\s*)$| selected="selected"$1|;
 274                         last;
 275                     }
 276                     "$tag2$opt"; # return of the swap
 277                 }sigex;
 278             if ($n) {
 279                 substr($$ref, $start[$i], $close[$i] - $start[$i], "$tag$opts");
 280             }
 281         }
 282     }
 283
 284
 285     ### Third pass
 286     ### swap textareas (must be done in such a way as to allow no closing tag)
 287     @start = ();
 288     @close = ();
 289     push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*textarea\b)|ig;
 290     push @close, pos($$ref) - length($1) while $$ref =~ m|(</\s*textarea\b)|ig;
 291     for (my $i = 0; $i <= $#start; $i ++) {
 292         while (defined($close[$i]) && $close[$i] < $start[$i]) {
 293             splice (@close,$i,1,()); # get rid of extra closes
 294         }
 295         if ($i == $#start) {
 296             $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
 297         } elsif (! defined($close[$i]) || $close[$i] > $start[$i + 1]) {
 298             splice(@close, $i, 0, $start[$i + 1]); # set to start of next select if no closing or > next select
 299         }
 300     }
 301     my $offset = 0;
 302     for (my $i = 0; $i <= $#start; $i ++) {
 303         my $oldval = substr($$ref, $start[$i] + $offset, $close[$i] - $start[$i]);
 304         $oldval =~ s{
 305             (<textarea \s                               # opening
 306              (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )+ # nested html ok
 307              >)                                         # end of tag
 308             }{}sxi || next;
 309         my $tag  = $1;
 310         my $name = get_tagval_by_key(\$tag, 'name');
 311         if ($name && ! $ignore->{$name}) {
 312             my $value = $get_form_value->($name, 'next');
 313             next if ! defined $value;
 314             substr($$ref, $start[$i] + $offset, $close[$i] - $start[$i], "$tag$value");
 315             $offset += length($value) - length($oldval);
 316         }
 317     }
 318
 319     ### put scripts and comments back and return
 320     $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1;
 321     $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script  != -1;
 322     return 1;
 323 }
 324
 325
 326 ### yet another html escaper
 327 ### allow pass by value or by reference (reference is modified inplace)
 328 sub html_escape {
 329     my $str = shift;
 330     return $str if ! $str;
 331     my $ref = ref($str) ? $str : \$str;
 332
 333     $$ref =~ s/&/&amp;/g;
 334     $$ref =~ s/</&lt;/g;
 335     $$ref =~ s/>/&gt;/g;
 336     $$ref =~ s/\"/&quot;/g;
 337
 338     return ref($str) ? 1 : $$ref;
 339 }
 340
 341 ### get a named value for key="value" pairs
 342 ### usage: my $val     = get_tagval_by_key(\$tag, $key);
 343 ### usage: my $valsref = get_tagval_by_key(\$tag, $key, 'all');
 344 sub get_tagval_by_key {
 345     my $tag = shift;
 346     my $ref = ref($tag) ? $tag : \$tag;
 347     my $key = lc(shift);
 348     my $all = $_[0] && $_[0] eq 'all';
 349     my @all = ();
 350     pos($$ref) = 0; # fix for regex below not resetting and forcing order on key value pairs
 351
 352     ### loop looking for tag pairs
 353     while ($$ref =~ m{
 354         (?<![\w\.\-])                  # 0 - not proceded by letter or .
 355             ([\w\.\-]+)                  # 1 - the key
 356             \s*=                         # equals
 357             (?: \s*([\"\'])(|.*?[^\\])\2 # 2 - a quote, 3 - the quoted
 358              |  ([^\s/]*? (?=\s|>|/>))   # 4 - a non-quoted string
 359              )
 360         }sigx) {
 361         next if lc($1) ne $key;
 362         my ($val,$quot) = ($2) ? ($3,$2) : ($4,undef);
 363         $val =~ s/\\$quot/$quot/ if $quot;
 364         return $val if ! $all;
 365         push @all, $val;
 366     }
 367     return undef if ! $all;
 368     return \@all;
 369 }
 370
 371 ### swap out values for key="value" pairs
 372 ### usage: my $count  = &swap_tagval_by_key(\$tag, $key, $val);
 373 ### usage: my $newtag = &swap_tagval_by_key($tag, $key, $val);
 374 sub swap_tagval_by_key {
 375     my $tag = shift;
 376     my $ref = ref($tag) ? $tag : \$tag;
 377     my $key = lc(shift);
 378     my $val = shift;
 379     my $n   = 0;
 380
 381     ### swap a key/val pair at time
 382     $$ref =~ s{(^\s*<\s*\w+\s+ | \G\s+)         # 1 - open tag or previous position
 383                    ( ([\w\-\.]+)                  # 2 - group, 3 - the key
 384                      (\s*=)                       # 4 - equals
 385                      (?: \s* ([\"\']) (?:|.*?[^\\]) \5 # 5 - the quote mark, the quoted
 386                       |  [^\s/]*? (?=\s|>|/>)    # a non-quoted string (may be zero length)
 387                       )
 388                      | ([^\s/]+?) (?=\s|>|/>)      # 6 - a non keyvalue chunk (CHECKED)
 389                      )
 390                }{
 391                    if (defined($3) && lc($3) eq $key) { # has matching key value pair
 392                        if (! $n ++) {  # only put value back on first match
 393                            "$1$3$4\"$val\""; # always double quote
 394                        } else {
 395                            $1; # second match
 396                        }
 397                    } elsif (defined($6) && lc($6) eq $key) { # has matching key
 398                        if (! $n ++) {  # only put value back on first match
 399                            "$1$6=\"$val\"";
 400                        } else {
 401                            $1; # second match
 402                        }
 403                    } else {
 404                        "$1$2"; # non-keyval
 405                    }
 406                }sigex;
 407
 408     ### append value on if none were swapped
 409     if (! $n) {
 410         $$ref =~ s|(\s*/?>\s*)$| value="$val"$1|;
 411         $n = -1;
 412     }
 413
 414     return ref($tag) ? $n : $$ref;
 415 }
 416
 417 1;
 418
 419 __END__
 420
 421 ###----------------------------------------------------------------###
 422
 423 =head1 SYNOPSIS
 424
 425     use CGI::Ex::Fill qw(form_fill fill);
 426
 427     my $text = my_own_template_from_somewhere();
 428
 429     my $form = CGI->new;
 430     # OR
 431     # my $form = {key => 'value'}
 432     # OR
 433     # my $form = [CGI->new, CGI->new, {key1 => 'val1'}, CGI->new];
 434
 435
 436     form_fill(\$text, $form); # modifies $text
 437
 438     # OR
 439     # my $copy = form_fill($text, $form); # copies $text
 440
 441     # OR
 442     fill({
 443         text => \$text,
 444         form => $form,
 445     });
 446
 447
 448     # ALSO
 449
 450     my $formname = 'formname';     # form to parse (undef = anytable)
 451     my $fp = 0;                    # fill_passwords ? default is true
 452     my $ignore = ['key1', 'key2']; # OR {key1 => 1, key2 => 1};
 453
 454     form_fill(\$text, $form, $formname, $fp, $ignore);
 455
 456     # OR
 457     fill({
 458         text          => \$text,
 459         form          => $form,
 460         target        => 'my_formname',
 461         fill_password => $fp,
 462         ignore_fields => $ignore,
 463     });
 464
 465     # ALSO
 466
 467     ### delay getting the value until we find an element that needs it
 468     my $form = {key => sub {my $key = shift; # get and return value}};
 469
 470
 471 =head1 DESCRIPTION
 472
 473 form_fill is directly comparable to HTML::FillInForm.  It will pass
 474 the same suite of tests (actually - it is a little bit kinder on the
 475 parse as it won't change case, reorder your attributes, or alter
 476 miscellaneous spaces and it won't require the HTML to be well formed).
 477
 478 HTML::FillInForm is based upon HTML::Parser while CGI::Ex::Fill is
 479 purely regex driven.  The performance of CGI::Ex::Fill will be better
 480 on HTML with many markup tags because HTML::Parser will parse each tag
 481 while CGI::Ex::Fill will search only for those tags it knows how to
 482 handle.  And CGI::Ex::Fill generally won't break on malformed html.
 483
 484 On tiny forms (< 1 k) form_fill was ~ 13% slower than FillInForm.  If
 485 the html document incorporated very many entities at all, the
 486 performance of FillInForm goes down (adding 360 <br> tags pushed
 487 form_fill to ~ 350% faster).  However, if you are only filling in one
 488 form every so often, then it shouldn't matter which you use - but
 489 form_fill will be nicer on the tags and won't balk at ugly html and
 490 will decrease performance only at a slow rate as the size of the html
 491 increases.  See the benchmarks in the t/samples/bench_cgix_hfif.pl
 492 file for more information (ALL BENCHMARKS SHOULD BE TAKEN WITH A GRAIN
 493 OF SALT).
 494
 495 There are two functions, fill and form_fill.  The function fill takes
 496 a hashref of named arguments.  The function form_fill takes a list
 497 of positional parameters.
 498
 499 =head1 ARGUMENTS TO form_fill
 500
 501 The following are the arguments to the main function C<fill>.
 502
 503 =over 4
 504
 505 =item text
 506
 507 A reference to an html string that includes one or more forms.
 508
 509 =item form
 510
 511 A form hash, CGI object, or an array of hashrefs and objects.
 512
 513 =item target
 514
 515 The name of the form to swap.  Default is undef which means
 516 to swap all form entities in all forms.
 517
 518 =item fill_password
 519
 520 Default true.  If set to false, fields of type password will
 521 not be refilled.
 522
 523 =item ignore_fields
 524
 525 Hashref of fields to be ignored from swapping.
 526
 527 =item remove_script
 528
 529 Defaults to the package global $REMOVE_SCRIPT which defaults to true.
 530 Removes anything in <script></script> tags which often cause problems for
 531 parsers.
 532
 533 =item remove_comment
 534
 535 Defaults to the package global $REMOVE_COMMENT which defaults to true.
 536 Removes anything in <!-- --> tags which can sometimes cause problems for
 537 parsers.
 538
 539 =item object_method
 540
 541 The method to call on objects passed to the form argument.  Default value
 542 is the package global $OBJECT_METHOD which defaults to 'param'.  If a
 543 CGI object is passed, it would call param on that object passing
 544 the desired keyname as an argument.
 545
 546 =back
 547
 548 =head1 ARGUMENTS TO form_fill
 549
 550 The following are the arguments to the legacy function C<form_fill>.
 551
 552 =over 4
 553
 554 =item C<\$html>
 555
 556 A reference to an html string that includes one or more forms or form
 557 entities.
 558
 559 =item C<\%FORM>
 560
 561 A form hash, or CGI query object, or an arrayref of multiple hash refs
 562 and/or CGI query objects that will supply values for the form.
 563
 564 =item C<$form_name>
 565
 566 The name of the form to fill in values for.  The default is undef
 567 which indicates that all forms are to be filled in.
 568
 569 =item C<$swap_pass>
 570
 571 Default true.  Indicates that C<<lt>input type="password"<gt>> fields
 572 are to be swapped as well.  Set to false to disable this behavior.
 573
 574 =item C<\%IGNORE_FIELDS> OR C<\@IGNORE_FIELDS>
 575
 576 A hash ref of key names or an array ref of key names that will be
 577 ignored during the fill in of the form.
 578
 579 =back
 580
 581 =head1 BEHAVIOR
 582
 583 fill and form_fill will attempt to DWYM when filling in values.  The following behaviors
 584 are used on the following types of form elements.
 585
 586 =over 4
 587
 588 =item C<E<lt>input type="text"E<gt>>
 589
 590 The following rules are used when matching this type:
 591
 592    1) Get the value from the form that matches the input's "name".
 593    2) If the value is defined - it adds or replaces the existing value.
 594    3) If the value is not defined and the existing value is not defined,
 595       a value of "" is added.
 596
 597 For example:
 598
 599    my $form = {foo => "FOO", bar => "BAR", baz => "BAZ"};
 600
 601    my $html = '
 602        <input type=text name=foo>
 603        <input type=text name=foo>
 604        <input type=text name=bar value="">
 605        <input type=text name=baz value="Something else">
 606        <input type=text name=hem value="Another thing">
 607        <input type=text name=haw>
 608    ';
 609
 610    form_fill(\$html, $form);
 611
 612    $html eq   '
 613        <input type=text name=foo value="FOO">
 614        <input type=text name=foo value="FOO">
 615        <input type=text name=bar value="BAR">
 616        <input type=text name=baz value="BAZ">
 617        <input type=text name=hem value="Another thing">
 618        <input type=text name=haw value="">
 619    ';
 620
 621
 622 If the value returned from the form is an array ref, the values of the array ref
 623 will be sequentially used for each input found by that name until the values
 624 run out.  If the value is not an array ref - it will be used to fill in any values
 625 by that name.  For example:
 626
 627    $form = {foo => ['aaaa', 'bbbb', 'cccc']};
 628
 629    $html = '
 630        <input type=text name=foo>
 631        <input type=text name=foo>
 632        <input type=text name=foo>
 633        <input type=text name=foo>
 634        <input type=text name=foo>
 635    ';
 636
 637    form_fill(\$html, $form);
 638
 639    $html eq  '
 640        <input type=text name=foo value="aaaa">
 641        <input type=text name=foo value="bbbb">
 642        <input type=text name=foo value="cccc">
 643        <input type=text name=foo value="">
 644        <input type=text name=foo value="">
 645    ';
 646
 647 =item C<E<lt>input type="hidden"E<gt>>
 648
 649 Same as C<E<lt>input type="text"E<gt>>.
 650
 651 =item C<E<lt>input type="password"E<gt>>
 652
 653 Same as C<E<lt>input type="text"E<gt>>.
 654
 655 =item C<E<lt>input type="file"E<gt>>
 656
 657 Same as C<E<lt>input type="text"E<gt>>.  (Note - this is subject
 658 to browser support for pre-population)
 659
 660 =item C<E<lt>input type="checkbox"E<gt>>
 661
 662 As each checkbox is found the following rules are applied:
 663
 664     1) Get the values from the form (do nothing if no values found)
 665     2) Remove any existing "checked=checked" or "checked" markup from the tag.
 666     3) Compare the "value" field to the values and mark with checked="checked"
 667     if there is a match.
 668
 669 If no "value" field is found in the html, a default value of "on" will be used (which is
 670 what most browsers will send as the default value for checked boxes without
 671 "value" fields).
 672
 673    $form = {foo => 'FOO', bar => ['aaaa', 'bbbb', 'cccc'], baz => 'on'};
 674
 675    $html = '
 676        <input type=checkbox name=foo value="123">
 677        <input type=checkbox name=foo value="FOO">
 678        <input type=checkbox name=bar value="aaaa">
 679        <input type=checkbox name=bar value="cccc">
 680        <input type=checkbox name=bar value="dddd" checked="checked">
 681        <input type=checkbox name=baz>
 682    ';
 683
 684    form_fill(\$html, $form);
 685
 686    $html eq  '
 687        <input type=checkbox name=foo value="123">
 688        <input type=checkbox name=foo value="FOO" checked="checked">
 689        <input type=checkbox name=bar value="aaaa" checked="checked">
 690        <input type=checkbox name=bar value="cccc" checked="checked">
 691        <input type=checkbox name=bar value="dddd">
 692        <input type=checkbox name=baz checked="checked">
 693    ';
 694
 695
 696 =item C<E<lt>input type="radio"E<gt>>
 697
 698 Same as C<E<lt>input type="checkbox"E<gt>>.
 699
 700 =item C<E<lt>selectE<gt>>
 701
 702 As each select box is found the following rules are applied (these rules are
 703 applied regardless of if the box is a select-one or a select-multi - if multiple
 704 values are selected on a select-one it is up to the browser to choose which one
 705 to highlight):
 706
 707     1) Get the values from the form (do nothing if no values found)
 708     2) Remove any existing "selected=selected" or "selected" markup from the tag.
 709     3) Compare the "value" field to the values and mark with selected="selected"
 710     if there is a match.
 711     4) If there is no "value" field - use the text in between the "option" tags.
 712
 713     (Note: There does not need to be a closing "select" tag or closing "option" tag)
 714
 715
 716    $form = {foo => 'FOO', bar => ['aaaa', 'bbbb', 'cccc']};
 717
 718    $html = '
 719        <select name=foo><option>FOO<option>123<br>
 720
 721        <select name=bar>
 722          <option>aaaa</option>
 723          <option value="cccc">cccc</option>
 724          <option value="dddd" selected="selected">dddd</option>
 725        </select>
 726    ';
 727
 728    form_fill(\$html, $form);
 729
 730    ok(
 731    $html eq  '
 732        <select name=foo><option selected="selected">FOO<option>123<br>
 733
 734        <select name=bar>
 735          <option selected="selected">aaaa</option>
 736          <option value="cccc" selected="selected">cccc</option>
 737          <option value="dddd">dddd</option>
 738        </select>
 739    ', "Perldoc example 4 passed");
 740
 741
 742 =item C<E<lt>textareaE<gt>>
 743
 744 The rules for swapping textarea are as follows:
 745
 746    1) Get the value from the form that matches the textarea's "name".
 747    2) If the value is defined - it adds or replaces the existing value.
 748    3) If the value is not defined, the text area is left alone.
 749
 750    (Note - there does not need to be a closing textarea tag.  In the case of
 751     a missing close textarea tag, the contents of the text area will be
 752     assumed to be the start of the next textarea of the end of the document -
 753     which ever comes sooner)
 754
 755 If the form returned an array ref of values, then these values will be
 756 used sequentially each time a textarea by that name is found.  If a single value
 757 (not array ref) is found, that value will be used for each textarea by that name.
 758
 759 For example.
 760
 761    $form = {foo => 'FOO', bar => ['aaaa', 'bbbb']};
 762
 763    $html = '
 764        <textarea name=foo></textarea>
 765        <textarea name=foo></textarea>
 766
 767        <textarea name=bar>
 768        <textarea name=bar></textarea><br>
 769        <textarea name=bar>dddd</textarea><br>
 770        <textarea name=bar><br><br>
 771    ';
 772
 773    form_fill(\$html, $form);
 774
 775    $html eq  '
 776        <textarea name=foo>FOO</textarea>
 777        <textarea name=foo>FOO</textarea>
 778
 779        <textarea name=bar>aaaa<textarea name=bar>bbbb</textarea><br>
 780        <textarea name=bar></textarea><br>
 781        <textarea name=bar>';
 782
 783 =item C<E<lt>input type="submit"E<gt>>
 784
 785 Does nothing.  The value for submit should typically be set by the
 786 templating system or application system.
 787
 788 =item C<E<lt>input type="button"E<gt>>
 789
 790 Same as submit.
 791
 792 =back
 793
 794 =head1 HTML COMMENT / JAVASCRIPT
 795
 796 Because there are too many problems that could occur with html
 797 comments and javascript, form_fill temporarily removes them during the
 798 fill.  You may disable this behavior by setting $REMOVE_COMMENT and
 799 $REMOVE_SCRIPT to 0 before calling form_fill.  The main reason for
 800 doing this would be if you wanted to have form elements inside the
 801 javascript and comments get filled.  Disabling the removal only
 802 results in a speed increase of 5%. The function uses \0COMMENT\0 and
 803 \0SCRIPT\0 as placeholders so it would be good to avoid these in your
 804 text (Actually they may be reset to whatever you'd like via
 805 $MARKER_COMMENT and $MARKER_SCRIPT).
 806
 807 =head1 UTILITY FUNCTIONS
 808
 809 =over 4
 810
 811 =item C<html_escape>
 812
 813 Very minimal entity escaper for filled in values.
 814
 815     my $escaped = html_escape($unescaped);
 816
 817     html_escape(\$text_to_escape);
 818
 819 =item C<get_tagval_by_key>
 820
 821 Get a named value for from an html tag (key="value" pairs).
 822
 823     my $val     = get_tagval_by_key(\$tag, $key);
 824     my $valsref = get_tagval_by_key(\$tag, $key, 'all'); # get all values
 825
 826 =item C<swap_tagval_by_key>
 827
 828 Swap out values in an html tag (key="value" pairs).
 829
 830     my $count  = swap_tagval_by_key(\$tag, $key, $val); # modify ref
 831     my $newtag = swap_tagval_by_key($tag, $key, $val);  # copies tag
 832
 833 =back
 834
 835 =head1 LICENSE
 836
 837 This module may distributed under the same terms as Perl itself.
 838
 839 =head1 AUTHOR
 840
 841 Paul Seamons
 842
 843 =cut