| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package HTML::FillInForm::Lite; | 
| 2 | 17 |  |  | 17 |  | 794029 | use 5.008_001; # 5.8.1 | 
|  | 17 |  |  |  |  | 71 |  | 
|  | 17 |  |  |  |  | 1948 |  | 
| 3 |  |  |  |  |  |  |  | 
| 4 | 17 |  |  | 17 |  | 284 | use strict; | 
|  | 17 |  |  |  |  | 35 |  | 
|  | 17 |  |  |  |  | 791 |  | 
| 5 | 17 |  |  | 17 |  | 116 | use warnings; | 
|  | 17 |  |  |  |  | 50 |  | 
|  | 17 |  |  |  |  | 875 |  | 
| 6 |  |  |  |  |  |  |  | 
| 7 |  |  |  |  |  |  | our $VERSION  = '1.13'; | 
| 8 |  |  |  |  |  |  |  | 
| 9 | 17 |  |  | 17 |  | 84 | use Exporter (); | 
|  | 17 |  |  |  |  | 48 |  | 
|  | 17 |  |  |  |  | 992 |  | 
| 10 |  |  |  |  |  |  | our @ISA       = qw(Exporter); | 
| 11 |  |  |  |  |  |  | our @EXPORT_OK = qw(fillinform); | 
| 12 |  |  |  |  |  |  |  | 
| 13 |  |  |  |  |  |  | #use Smart::Comments '####'; | 
| 14 | 17 |  |  | 17 |  | 94 | use Carp (); | 
|  | 17 |  |  |  |  | 30 |  | 
|  | 17 |  |  |  |  | 345 |  | 
| 15 | 17 |  |  | 17 |  | 88 | use Scalar::Util (); | 
|  | 17 |  |  |  |  | 29 |  | 
|  | 17 |  |  |  |  | 72590 |  | 
| 16 |  |  |  |  |  |  |  | 
| 17 |  |  |  |  |  |  | # Regexp for HTML tags | 
| 18 |  |  |  |  |  |  |  | 
| 19 |  |  |  |  |  |  | my $form     = q{[fF][oO][rR][mM]}; | 
| 20 |  |  |  |  |  |  | my $input    = q{[iI][nN][pP][uU][tT]}; | 
| 21 |  |  |  |  |  |  | my $select   = q{[sS][eE][lL][eE][cC][tT] }; | 
| 22 |  |  |  |  |  |  | my $option   = q{[oO][pP][tT][iI][oO][nN] }; | 
| 23 |  |  |  |  |  |  | my $textarea = q{[tT][eE][xX][tT][aA][rR][eE][aA]}; | 
| 24 |  |  |  |  |  |  |  | 
| 25 |  |  |  |  |  |  | my $checked  = q{[cC][hH][eE][cC][kK][eE][dD]}; | 
| 26 |  |  |  |  |  |  | my $selected = q{[sS][eE][lL][eE][cC][tT][eE][dD]}; | 
| 27 |  |  |  |  |  |  | my $multiple = q{[mM][uU][lL][tT][iI][pP][lL][eE]}; | 
| 28 |  |  |  |  |  |  |  | 
| 29 |  |  |  |  |  |  | my $id       = q{[iI][dD]}; | 
| 30 |  |  |  |  |  |  | my $type     = q{[tT][yY][pP][eE]}; | 
| 31 |  |  |  |  |  |  | my $name     = q{[nN][aA][mM][eE]}; | 
| 32 |  |  |  |  |  |  | my $value    = q{[vV][aA][lL][uU][eE]}; | 
| 33 |  |  |  |  |  |  |  | 
| 34 |  |  |  |  |  |  | my $SPACE        =  q{\s}; | 
| 35 |  |  |  |  |  |  | my $ATTR_NAME    =  q{[\w\-]+}; | 
| 36 |  |  |  |  |  |  | my $ATTR_VALUE   =  q{(?:" [^"]* " | ' [^']* ' | [^'"/>\s]+ | [\w\-]+ )}; | 
| 37 |  |  |  |  |  |  | my $ATTR         = qq{(?: $SPACE+ (?: $ATTR_NAME (?: = $ATTR_VALUE )? ) )}; | 
| 38 |  |  |  |  |  |  |  | 
| 39 |  |  |  |  |  |  | my $FORM         = qq{(?: <$form     $ATTR+ $SPACE*  > )}; # | 
| 40 |  |  |  |  |  |  | my $INPUT        = qq{(?: <$input    $ATTR+ $SPACE*/?> )}; # | 
| 41 |  |  |  |  |  |  | my $SELECT       = qq{(?: <$select   $ATTR+ $SPACE*  > )}; # | 
| 42 |  |  |  |  |  |  | my $OPTION       = qq{(?: <$option   $ATTR* $SPACE*  > )}; # | 
| 43 |  |  |  |  |  |  | my $TEXTAREA     = qq{(?: <$textarea $ATTR+ $SPACE*  > )}; # | 
| 44 |  |  |  |  |  |  |  | 
| 45 |  |  |  |  |  |  | my $END_FORM     = qq{(?: $form>     )}; | 
| 46 |  |  |  |  |  |  | my $END_SELECT   = qq{(?: $select>   )}; | 
| 47 |  |  |  |  |  |  | my $END_OPTION   = qq{(?: $option>   )}; | 
| 48 |  |  |  |  |  |  | my $END_TEXTAREA = qq{(?: $textarea> )}; | 
| 49 |  |  |  |  |  |  |  | 
| 50 |  |  |  |  |  |  | my $CHECKED      = qq{(?: | 
| 51 |  |  |  |  |  |  | $checked  (?: = (?: "$checked " | '$checked'  | $checked  ) )? | 
| 52 |  |  |  |  |  |  | )}; | 
| 53 |  |  |  |  |  |  | my $SELECTED     = qq{(?: | 
| 54 |  |  |  |  |  |  | $selected (?: = (?: "$selected" | '$selected' | $selected ) )? | 
| 55 |  |  |  |  |  |  | )}; | 
| 56 |  |  |  |  |  |  | my $MULTIPLE     = qq{(?: | 
| 57 |  |  |  |  |  |  | $multiple (?: = (?: "$multiple" | '$multiple' | $multiple ) )? | 
| 58 |  |  |  |  |  |  | )}; | 
| 59 |  |  |  |  |  |  |  | 
| 60 |  |  |  |  |  |  | #my $DISABLED = q{(?: disabled = (?: "disabled" | 'disabled' | disabled ) )}; | 
| 61 |  |  |  |  |  |  |  | 
| 62 |  |  |  |  |  |  | #sub _extract{ # for debugging only | 
| 63 |  |  |  |  |  |  | #    my $s = shift; | 
| 64 |  |  |  |  |  |  | #    my %f = (input => [], select => [], textarea => []); | 
| 65 |  |  |  |  |  |  | #    @{$f{input}}    = $s =~ m{($INPUT)}gxmsi; | 
| 66 |  |  |  |  |  |  | #    @{$f{select}}   = $s =~ m{($SELECT.*?$END_SELECT)}gxmsi; | 
| 67 |  |  |  |  |  |  | #    @{$f{textarea}} = $s =~ m{($TEXTAREA.*?$END_TEXTAREA)}gxmsi; | 
| 68 |  |  |  |  |  |  | # | 
| 69 |  |  |  |  |  |  | #    return \%f; | 
| 70 |  |  |  |  |  |  | #} | 
| 71 |  |  |  |  |  |  |  | 
| 72 |  |  |  |  |  |  |  | 
| 73 |  |  |  |  |  |  | sub fillinform { # function interface to fill() | 
| 74 | 4 | 100 |  | 4 | 1 | 29 | if(@_ == 1) { | 
| 75 | 1 |  |  |  |  | 2 | my($data) = @_; | 
| 76 | 1 |  |  |  |  | 5 | my $fif = __PACKAGE__->new(); | 
| 77 |  |  |  |  |  |  | return sub { | 
| 78 | 2 |  |  | 2 |  | 498 | my($form) = @_; | 
| 79 | 2 |  |  |  |  | 6 | return $fif->fill(\$form, $data); | 
| 80 |  |  |  |  |  |  | } | 
| 81 | 1 |  |  |  |  | 7 | } | 
| 82 |  |  |  |  |  |  | else { | 
| 83 | 3 |  |  |  |  | 8 | my($form, $data) = @_; | 
| 84 | 3 |  |  |  |  | 25 | return __PACKAGE__->fill(\$form, $data); | 
| 85 |  |  |  |  |  |  | } | 
| 86 |  |  |  |  |  |  | } | 
| 87 |  |  |  |  |  |  |  | 
| 88 |  |  |  |  |  |  | # utilities for getting HTML attributes | 
| 89 |  |  |  |  |  |  | sub _unquote{ | 
| 90 | 418 | 100 |  | 418 |  | 2887 | $_[0] =~ /(['"]) (.*) \1/xms ? $2 : $_[0]; # ' for poor editors | 
| 91 |  |  |  |  |  |  | } | 
| 92 |  |  |  |  |  |  | sub _get_id{ | 
| 93 | 22 | 100 |  | 22 |  | 212 | $_[0] =~ /$id    = ($ATTR_VALUE)/xms ? _unquote($1) : undef; | 
| 94 |  |  |  |  |  |  | } | 
| 95 |  |  |  |  |  |  | sub _get_type{ | 
| 96 | 183 | 100 |  | 183 |  | 2123 | $_[0] =~ /$type  = ($ATTR_VALUE)/xms ? _unquote($1) : undef; | 
| 97 |  |  |  |  |  |  | } | 
| 98 |  |  |  |  |  |  | sub _get_name{ | 
| 99 | 236 | 100 |  | 236 |  | 2614 | $_[0] =~ /$name  = ($ATTR_VALUE)/xms ? _unquote($1) : undef; | 
| 100 |  |  |  |  |  |  | } | 
| 101 |  |  |  |  |  |  | sub _get_value{ | 
| 102 | 118 | 100 |  | 118 |  | 1498 | $_[0] =~ /$value = ($ATTR_VALUE)/xms ? _unquote($1) : undef; | 
| 103 |  |  |  |  |  |  | } | 
| 104 |  |  |  |  |  |  |  | 
| 105 |  |  |  |  |  |  | #use macro | 
| 106 |  |  |  |  |  |  | #    _unquote   => \&_unquote, | 
| 107 |  |  |  |  |  |  | #    _get_id    => \&_get_id, | 
| 108 |  |  |  |  |  |  | #    _get_type  => \&_get_type, | 
| 109 |  |  |  |  |  |  | #    _get_name  => \&_get_name, | 
| 110 |  |  |  |  |  |  | #    _get_value => \&_get_value, | 
| 111 |  |  |  |  |  |  | #; | 
| 112 |  |  |  |  |  |  |  | 
| 113 |  |  |  |  |  |  | sub new :method{ | 
| 114 | 34 |  |  | 34 | 1 | 15319 | my $class = shift; | 
| 115 | 34 |  |  |  |  | 148 | return $class->_parse_option(@_); | 
| 116 |  |  |  |  |  |  | } | 
| 117 |  |  |  |  |  |  |  | 
| 118 |  |  |  |  |  |  | sub _parse_option{ | 
| 119 | 247 |  |  | 247 |  | 360 | my $self = shift; | 
| 120 |  |  |  |  |  |  |  | 
| 121 | 247 | 100 | 100 |  |  | 1263 | if(ref $self and not @_){ # as instance method with no option | 
| 122 | 141 |  |  |  |  | 290 | return $self; | 
| 123 |  |  |  |  |  |  | } | 
| 124 |  |  |  |  |  |  |  | 
| 125 | 106 |  |  |  |  | 1035 | my %context = ( | 
| 126 |  |  |  |  |  |  | ignore_types => { | 
| 127 |  |  |  |  |  |  | button   => 1, | 
| 128 |  |  |  |  |  |  | submit   => 1, | 
| 129 |  |  |  |  |  |  | reset    => 1, | 
| 130 |  |  |  |  |  |  | password => 1, | 
| 131 |  |  |  |  |  |  | image    => 1, | 
| 132 |  |  |  |  |  |  | file     => 1, | 
| 133 |  |  |  |  |  |  | }, | 
| 134 |  |  |  |  |  |  |  | 
| 135 |  |  |  |  |  |  | escape        => \&_escape_html, | 
| 136 |  |  |  |  |  |  | decode_entity => \&_noop, | 
| 137 |  |  |  |  |  |  | layer         => '', | 
| 138 |  |  |  |  |  |  | ); | 
| 139 |  |  |  |  |  |  |  | 
| 140 |  |  |  |  |  |  | # merge if needed | 
| 141 | 106 | 100 |  |  |  | 570 | if(ref $self){ | 
| 142 | 49 |  |  |  |  | 80 | while(my($key, $val) = each %{$self}){ | 
|  | 276 |  |  |  |  | 955 |  | 
| 143 | 227 | 100 |  |  |  | 676 | $context{$key} = ref($val) eq 'HASH' ? { %{$val} } : $val; | 
|  | 71 |  |  |  |  | 397 |  | 
| 144 |  |  |  |  |  |  | } | 
| 145 |  |  |  |  |  |  | } | 
| 146 |  |  |  |  |  |  |  | 
| 147 |  |  |  |  |  |  | # parse options | 
| 148 | 106 |  |  |  |  | 484 | while(my($opt, $val) = splice @_, 0, 2){ | 
| 149 | 95 | 100 |  |  |  | 238 | next unless defined $val; | 
| 150 |  |  |  |  |  |  |  | 
| 151 | 94 | 100 | 100 |  |  | 669 | if(       $opt eq 'ignore_fields' | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
| 152 |  |  |  |  |  |  | or $opt eq 'disable_fields' ){ | 
| 153 | 8 |  | 100 |  |  | 60 | @{ $context{$opt} ||= {} }{ @{$val} } | 
|  | 8 |  |  |  |  | 11 |  | 
|  | 8 |  |  |  |  | 13 |  | 
| 154 | 8 |  |  |  |  | 11 | = (1) x @{$val}; | 
| 155 |  |  |  |  |  |  | } | 
| 156 |  |  |  |  |  |  | elsif($opt eq 'fill_password'){ | 
| 157 | 27 |  |  |  |  | 130 | $context{ignore_types}{password} = !$val; | 
| 158 |  |  |  |  |  |  | } | 
| 159 |  |  |  |  |  |  | elsif($opt eq 'target'){ | 
| 160 | 21 |  |  |  |  | 80 | $context{target} = $val; | 
| 161 |  |  |  |  |  |  | } | 
| 162 |  |  |  |  |  |  | elsif($opt eq 'escape'){ | 
| 163 | 3 | 100 |  |  |  | 6 | if($val){ | 
| 164 | 2 | 100 |  |  |  | 10 | $context{escape} = ref($val) eq 'CODE' | 
| 165 |  |  |  |  |  |  | ? $val | 
| 166 |  |  |  |  |  |  | : \&_escape_html; | 
| 167 |  |  |  |  |  |  | } | 
| 168 |  |  |  |  |  |  | else{ | 
| 169 | 1 |  |  |  |  | 5 | $context{escape} = \&_noop; | 
| 170 |  |  |  |  |  |  | } | 
| 171 |  |  |  |  |  |  | } | 
| 172 |  |  |  |  |  |  | elsif($opt eq 'layer'){ | 
| 173 | 3 |  |  |  |  | 12 | $context{layer} = $val; | 
| 174 |  |  |  |  |  |  | } | 
| 175 |  |  |  |  |  |  | elsif($opt eq 'decode_entity'){ | 
| 176 | 30 | 100 |  |  |  | 403 | if($val){ | 
| 177 | 28 | 100 |  |  |  | 165 | $context{decode_entity} = ref($val) eq 'CODE' | 
| 178 |  |  |  |  |  |  | ? $val | 
| 179 |  |  |  |  |  |  | : \&_decode_entity; | 
| 180 |  |  |  |  |  |  | } | 
| 181 |  |  |  |  |  |  | else{ | 
| 182 | 2 |  |  |  |  | 19 | $context{decode_entity} = \&_noop; | 
| 183 |  |  |  |  |  |  | } | 
| 184 |  |  |  |  |  |  | } | 
| 185 |  |  |  |  |  |  | else{ | 
| 186 | 2 |  |  |  |  | 535 | Carp::croak("Unknown option '$opt' supplied"); | 
| 187 |  |  |  |  |  |  | } | 
| 188 |  |  |  |  |  |  | } | 
| 189 |  |  |  |  |  |  |  | 
| 190 | 104 |  | 66 |  |  | 727 | return bless \%context => ref($self) || $self; | 
| 191 |  |  |  |  |  |  | } | 
| 192 |  |  |  |  |  |  |  | 
| 193 |  |  |  |  |  |  | sub fill :method{ | 
| 194 | 218 |  |  | 218 | 1 | 33458 | my($self, $src, $q, @opt) = @_; | 
| 195 |  |  |  |  |  |  |  | 
| 196 | 218 | 100 |  |  |  | 1449 | defined $src or Carp::croak('No source supplied'); | 
| 197 | 215 | 100 |  |  |  | 901 | defined $q   or Carp::croak('No data supplied'); | 
| 198 |  |  |  |  |  |  |  | 
| 199 | 213 |  |  |  |  | 620 | my $context = $self->_parse_option(@opt); | 
| 200 |  |  |  |  |  |  |  | 
| 201 |  |  |  |  |  |  | ### $context | 
| 202 |  |  |  |  |  |  |  | 
| 203 |  |  |  |  |  |  | # HTML source to a scalar | 
| 204 | 212 |  |  |  |  | 317 | my $content; | 
| 205 | 212 | 100 |  |  |  | 664 | if(ref($src) eq 'SCALAR'){ | 
|  |  | 100 |  |  |  |  |  | 
| 206 | 189 |  |  |  |  | 195 | $content = ${$src}; # copy | 
|  | 189 |  |  |  |  | 373 |  | 
| 207 |  |  |  |  |  |  | } | 
| 208 |  |  |  |  |  |  | elsif(ref($src) eq 'ARRAY'){ | 
| 209 | 7 |  |  |  |  | 11 | $content = join q{}, @{$src}; | 
|  | 7 |  |  |  |  | 23 |  | 
| 210 |  |  |  |  |  |  | } | 
| 211 |  |  |  |  |  |  | else{ | 
| 212 | 16 |  |  |  |  | 59 | my $is_fh = Scalar::Util::openhandle($src); | 
| 213 |  |  |  |  |  |  |  | 
| 214 | 16 | 100 | 100 |  |  | 756 | if($is_fh or !ref($src)) { | 
| 215 | 14 | 100 |  |  |  | 48 | if(!$is_fh){ | 
| 216 | 9 | 100 |  |  |  | 914 | open my($in), '<'.$context->{layer}, $src | 
| 217 |  |  |  |  |  |  | or Carp::croak("Cannot open '$src': $!"); | 
| 218 | 8 |  |  |  |  | 161 | $src = $in; | 
| 219 |  |  |  |  |  |  | } | 
| 220 | 13 |  |  |  |  | 65 | local $/; | 
| 221 | 13 |  |  |  |  | 78376 | $content = readline($src); # slurp | 
| 222 |  |  |  |  |  |  | } | 
| 223 |  |  |  |  |  |  | else { | 
| 224 | 2 |  |  |  |  | 177 | $content = ${$src}; | 
|  | 2 |  |  |  |  | 16 |  | 
| 225 |  |  |  |  |  |  | } | 
| 226 |  |  |  |  |  |  | } | 
| 227 |  |  |  |  |  |  |  | 
| 228 |  |  |  |  |  |  | # if $content is utf8-flagged, params should be utf8-encoded | 
| 229 | 210 |  |  |  |  | 1006 | local $context->{utf8} = utf8::is_utf8($content); | 
| 230 |  |  |  |  |  |  |  | 
| 231 |  |  |  |  |  |  | # param object converted from data or object | 
| 232 | 210 |  |  |  |  | 475 | local $context->{data} =  _to_form_object($q); | 
| 233 |  |  |  |  |  |  |  | 
| 234 |  |  |  |  |  |  | # param storage for multi-text fields | 
| 235 | 205 |  |  |  |  | 527 | local $context->{params} = {}; | 
| 236 |  |  |  |  |  |  |  | 
| 237 |  |  |  |  |  |  | # Fill in contents | 
| 238 | 205 | 100 |  |  |  | 486 | if(defined $context->{target}){ | 
| 239 |  |  |  |  |  |  |  | 
| 240 | 21 |  |  |  |  | 580 | $content =~ s{ ($FORM) (.*?) ($END_FORM) } | 
| 241 |  |  |  |  |  |  | { | 
| 242 | 22 |  |  |  |  | 102 | my($beg, $content, $end) = ($1, $2, $3); | 
| 243 |  |  |  |  |  |  |  | 
| 244 | 22 |  |  |  |  | 42 | my $id = _get_id($beg); | 
| 245 | 22 | 100 | 100 |  |  | 187 | (defined($id) and $context->{target} eq $id) | 
| 246 |  |  |  |  |  |  | ? $beg . _fill($context, $content) . $end | 
| 247 |  |  |  |  |  |  | : $beg .                 $content  . $end | 
| 248 |  |  |  |  |  |  | }gexms; | 
| 249 |  |  |  |  |  |  |  | 
| 250 | 21 |  |  |  |  | 287 | return $content; | 
| 251 |  |  |  |  |  |  | } | 
| 252 |  |  |  |  |  |  | else{ | 
| 253 | 184 |  |  |  |  | 945 | return _fill($context, $content); | 
| 254 |  |  |  |  |  |  | } | 
| 255 |  |  |  |  |  |  |  | 
| 256 |  |  |  |  |  |  | } | 
| 257 |  |  |  |  |  |  |  | 
| 258 |  |  |  |  |  |  | sub _fill{ | 
| 259 | 195 |  |  | 195 |  | 299 | my($context, $content) = @_; | 
| 260 | 195 |  |  |  |  | 4345 | $content =~ s{($INPUT)} | 
| 261 | 183 |  |  |  |  | 433 | { _fill_input($context, $1)                  }gexms; | 
| 262 |  |  |  |  |  |  |  | 
| 263 | 195 |  |  |  |  | 2848 | $content =~ s{($SELECT) (.*?) ($END_SELECT) } | 
| 264 | 43 |  |  |  |  | 116 | { $1 . _fill_select($context, $1, $2) . $3   }gexms; | 
| 265 |  |  |  |  |  |  |  | 
| 266 | 195 |  |  |  |  | 2947 | $content =~ s{($TEXTAREA) (.*?) ($END_TEXTAREA) } | 
| 267 | 19 |  |  |  |  | 54 | { $1 . _fill_textarea($context, $1, $2) . $3 }gexms; | 
| 268 |  |  |  |  |  |  |  | 
| 269 | 195 |  |  |  |  | 2663 | return $content; | 
| 270 |  |  |  |  |  |  | } | 
| 271 |  |  |  |  |  |  |  | 
| 272 |  |  |  |  |  |  |  | 
| 273 |  |  |  |  |  |  | sub _fill_input{ | 
| 274 | 183 |  |  | 183 |  | 449 | my($context, $tag) = @_; | 
| 275 |  |  |  |  |  |  |  | 
| 276 |  |  |  |  |  |  | ### $tag | 
| 277 |  |  |  |  |  |  |  | 
| 278 | 183 |  | 100 |  |  | 365 | my $type = _get_type($tag) || 'text'; | 
| 279 | 183 | 100 |  |  |  | 659 | if($context->{ignore_types}{ $type }){ | 
| 280 | 9 |  |  |  |  | 36 | return $tag; | 
| 281 |  |  |  |  |  |  | } | 
| 282 |  |  |  |  |  |  |  | 
| 283 | 174 | 100 |  |  |  | 329 | my $values_ref = $context->_get_param( _get_name($tag) ) | 
| 284 |  |  |  |  |  |  | or return $tag; | 
| 285 |  |  |  |  |  |  |  | 
| 286 | 150 | 100 | 100 |  |  | 757 | if($type eq 'checkbox' or $type eq 'radio'){ | 
| 287 | 44 |  |  |  |  | 80 | my $value = _get_value($tag); | 
| 288 |  |  |  |  |  |  |  | 
| 289 | 44 | 100 |  |  |  | 93 | if(not defined $value){ | 
| 290 | 7 |  |  |  |  | 12 | $value = 'on'; | 
| 291 |  |  |  |  |  |  | } | 
| 292 |  |  |  |  |  |  | else{ | 
| 293 | 37 |  |  |  |  | 87 | $value = $context->{decode_entity}->($value); | 
| 294 |  |  |  |  |  |  | } | 
| 295 |  |  |  |  |  |  |  | 
| 296 | 44 | 100 |  |  |  | 53 | if(grep { $value eq $_ } @{$values_ref}){ | 
|  | 63 |  |  |  |  | 164 |  | 
|  | 44 |  |  |  |  | 104 |  | 
| 297 | 24 | 100 |  |  |  | 550 | $tag =~ /$CHECKED/xms | 
| 298 |  |  |  |  |  |  | or $tag =~ s{$SPACE* (/?) > \z} | 
| 299 |  |  |  |  |  |  | { checked="checked" $1>}xms; | 
| 300 |  |  |  |  |  |  | } | 
| 301 |  |  |  |  |  |  | else{ | 
| 302 | 20 |  |  |  |  | 277 | $tag =~ s/$SPACE+$CHECKED//gxms; | 
| 303 |  |  |  |  |  |  | } | 
| 304 |  |  |  |  |  |  | } | 
| 305 |  |  |  |  |  |  | else{ | 
| 306 | 106 |  |  |  |  | 128 | my $new_value = $context->{escape}->(shift @{$values_ref}); | 
|  | 106 |  |  |  |  | 287 |  | 
| 307 |  |  |  |  |  |  |  | 
| 308 | 106 | 100 |  |  |  | 2063 | $tag =~ s{$value = $ATTR_VALUE}{value="$new_value"}xms | 
| 309 |  |  |  |  |  |  | or $tag =~ s{$SPACE* (/?) > \z} | 
| 310 |  |  |  |  |  |  | { value="$new_value" $1>}xms; | 
| 311 |  |  |  |  |  |  | } | 
| 312 | 150 |  |  |  |  | 794 | return $tag; | 
| 313 |  |  |  |  |  |  | } | 
| 314 |  |  |  |  |  |  | sub _fill_select{ | 
| 315 | 43 |  |  | 43 |  | 131 | my($context, $tag, $content) = @_; | 
| 316 |  |  |  |  |  |  |  | 
| 317 | 43 | 100 |  |  |  | 177 | my $values_ref = $context->_get_param( _get_name($tag) ) | 
| 318 |  |  |  |  |  |  | or return $content; | 
| 319 |  |  |  |  |  |  |  | 
| 320 | 37 | 100 |  |  |  | 687 | if($tag !~ /$MULTIPLE/oxms){ | 
| 321 | 24 |  |  |  |  | 40 | $values_ref = [ shift @{ $values_ref } ]; # in select-one | 
|  | 24 |  |  |  |  | 67 |  | 
| 322 |  |  |  |  |  |  | } | 
| 323 |  |  |  |  |  |  |  | 
| 324 | 37 |  |  |  |  | 1006 | $content =~ s{($OPTION) (.*?) ($END_OPTION)} | 
| 325 | 74 |  |  |  |  | 162 | { _fill_option($context, $values_ref, $1, $2) . $2 . $3 }gexms; | 
| 326 | 37 |  |  |  |  | 291 | return $content; | 
| 327 |  |  |  |  |  |  | } | 
| 328 |  |  |  |  |  |  | sub _fill_option{ | 
| 329 | 74 |  |  | 74 |  | 202 | my($context, $values_ref, $tag, $content) = @_; | 
| 330 |  |  |  |  |  |  |  | 
| 331 | 74 |  |  |  |  | 129 | my $value = _get_value($tag); | 
| 332 | 74 | 100 |  |  |  | 180 | unless( defined $value ){ | 
| 333 | 36 |  |  |  |  | 52 | $value = $content; | 
| 334 | 36 |  |  |  |  | 162 | $value =~ s{\A $SPACE+   } {}xms; | 
| 335 | 36 |  |  |  |  | 117 | $value =~ s{   $SPACE{2,}}{ }xms; | 
| 336 | 36 |  |  |  |  | 128 | $value =~ s{   $SPACE+ \z} {}xms; | 
| 337 |  |  |  |  |  |  | } | 
| 338 |  |  |  |  |  |  |  | 
| 339 | 74 |  |  |  |  | 238 | $value = $context->{decode_entity}->($value); | 
| 340 |  |  |  |  |  |  |  | 
| 341 |  |  |  |  |  |  | ### @_ | 
| 342 | 74 | 100 |  |  |  | 105 | if(grep{ $value eq $_ }  @{$values_ref}){ | 
|  | 97 |  |  |  |  | 272 |  | 
|  | 74 |  |  |  |  | 393 |  | 
| 343 | 40 | 100 |  |  |  | 785 | $tag =~ /$SELECTED/oxms | 
| 344 |  |  |  |  |  |  | or $tag =~ s{ $SPACE* > \z} | 
| 345 |  |  |  |  |  |  | { selected="selected">}xms; | 
| 346 |  |  |  |  |  |  | } | 
| 347 |  |  |  |  |  |  | else{ | 
| 348 | 34 |  |  |  |  | 670 | $tag =~ s/$SPACE+$SELECTED//gxms; | 
| 349 |  |  |  |  |  |  | } | 
| 350 | 74 |  |  |  |  | 554 | return $tag; | 
| 351 |  |  |  |  |  |  | } | 
| 352 |  |  |  |  |  |  |  | 
| 353 |  |  |  |  |  |  | sub _fill_textarea{ | 
| 354 | 19 |  |  | 19 |  | 55 | my($context, $tag, $content) = @_; | 
| 355 |  |  |  |  |  |  |  | 
| 356 | 19 | 100 |  |  |  | 45 | my $values_ref = $context->_get_param( _get_name($tag) ) | 
| 357 |  |  |  |  |  |  | or return $content; | 
| 358 |  |  |  |  |  |  |  | 
| 359 | 16 |  |  |  |  | 27 | return $context->{escape}->(shift @{$values_ref}); | 
|  | 16 |  |  |  |  | 63 |  | 
| 360 |  |  |  |  |  |  | } | 
| 361 |  |  |  |  |  |  |  | 
| 362 |  |  |  |  |  |  | # utilities | 
| 363 |  |  |  |  |  |  |  | 
| 364 |  |  |  |  |  |  | sub _get_param{ | 
| 365 | 236 |  |  | 236 |  | 904 | my($context, $name) = @_; | 
| 366 |  |  |  |  |  |  |  | 
| 367 | 236 | 100 | 100 |  |  | 1541 | return if not defined $name or $context->{ignore_fields}{$name}; | 
| 368 |  |  |  |  |  |  |  | 
| 369 | 228 |  |  |  |  | 400 | my $ref = $context->{params}{$name}; | 
| 370 |  |  |  |  |  |  |  | 
| 371 | 228 | 100 |  |  |  | 483 | if(not defined $ref){ | 
| 372 | 205 |  |  |  |  | 711 | $ref = $context->{params}{$name} | 
| 373 |  |  |  |  |  |  | = [ $context->{data}->param($name) ]; | 
| 374 |  |  |  |  |  |  |  | 
| 375 | 205 | 100 |  |  |  | 2375 | if($context->{utf8}){ | 
| 376 | 13 |  |  |  |  | 17 | for my $datum( @{$ref} ){ | 
|  | 13 |  |  |  |  | 26 |  | 
| 377 | 10 | 100 |  |  |  | 55 | utf8::decode($datum) unless utf8::is_utf8($datum); | 
| 378 |  |  |  |  |  |  | } | 
| 379 |  |  |  |  |  |  | } | 
| 380 |  |  |  |  |  |  | } | 
| 381 |  |  |  |  |  |  |  | 
| 382 | 228 | 100 |  |  |  | 294 | return @{$ref} ? $ref : undef; | 
|  | 228 |  |  |  |  | 1049 |  | 
| 383 |  |  |  |  |  |  | } | 
| 384 |  |  |  |  |  |  |  | 
| 385 |  |  |  |  |  |  | sub _noop{ | 
| 386 | 64 |  |  | 64 |  | 117 | return $_[0]; | 
| 387 |  |  |  |  |  |  | } | 
| 388 |  |  |  |  |  |  | sub _escape_html{ | 
| 389 | 120 |  |  | 120 |  | 168 | my $s = shift; | 
| 390 |  |  |  |  |  |  | #    return '' unless defined $s; | 
| 391 |  |  |  |  |  |  |  | 
| 392 | 120 |  |  |  |  | 232 | $s =~ s/&/&/g; | 
| 393 | 120 |  |  |  |  | 175 | $s =~ s/</g; | 
| 394 | 120 |  |  |  |  | 161 | $s =~ s/>/>/g; | 
| 395 | 120 |  |  |  |  | 183 | $s =~ s/"/"/g; # " for poor editors | 
| 396 | 120 |  |  |  |  | 338 | return $s; | 
| 397 |  |  |  |  |  |  | } | 
| 398 |  |  |  |  |  |  |  | 
| 399 |  |  |  |  |  |  |  | 
| 400 |  |  |  |  |  |  | sub _decode_entity{ | 
| 401 | 47 |  |  | 47 |  | 71 | my $s = shift; | 
| 402 |  |  |  |  |  |  |  | 
| 403 | 47 |  |  |  |  | 68 | our %entity2char; | 
| 404 | 47 | 100 |  |  |  | 197 | unless(%entity2char){ | 
| 405 |  |  |  |  |  |  | # load the HTML entity data | 
| 406 | 2 |  |  |  |  | 10 | local $/ = "__END__\n"; | 
| 407 | 2 |  |  |  |  | 10 | local($@, $!); | 
| 408 | 2 | 50 |  |  |  | 159 | open my $data_in, '<', __FILE__ or die $!; # should be success | 
| 409 | 2 |  |  |  |  | 169 | readline $data_in; # discard the first segment | 
| 410 | 2 | 50 |  |  |  | 2412 | eval scalar readline($data_in) or die $@; | 
| 411 |  |  |  |  |  |  | } | 
| 412 |  |  |  |  |  |  |  | 
| 413 | 47 | 100 |  |  |  | 122 | $s =~ s{&(\w+);}{ $entity2char{$1} || "&$1;" }egxms; | 
|  | 11 |  |  |  |  | 62 |  | 
| 414 |  |  |  |  |  |  |  | 
| 415 | 47 |  |  |  |  | 88 | $s =~ s{&\#(\d+)          ;}{ chr     $1 }egxms; | 
|  | 10 |  |  |  |  | 45 |  | 
| 416 | 47 |  |  |  |  | 66 | $s =~ s{&\#x([0-9a-fA-F]+);}{ chr hex $1 }egxms; | 
|  | 2 |  |  |  |  | 9 |  | 
| 417 | 47 |  |  |  |  | 119 | return $s; | 
| 418 |  |  |  |  |  |  | } | 
| 419 |  |  |  |  |  |  |  | 
| 420 |  |  |  |  |  |  | #sub _disable{ | 
| 421 |  |  |  |  |  |  | #    my $context = shift; | 
| 422 |  |  |  |  |  |  | #    my $name   = shift; | 
| 423 |  |  |  |  |  |  | # | 
| 424 |  |  |  |  |  |  | #    if($context->{disable_fields}{$name}){ | 
| 425 |  |  |  |  |  |  | #        $_[0] =~ /$DISABLED/xmsi | 
| 426 |  |  |  |  |  |  | #            or $_[0] =~ s{$SPACE* /? > \z} | 
| 427 |  |  |  |  |  |  | #                    { disabled="disabled" />}xmsi; | 
| 428 |  |  |  |  |  |  | #    } | 
| 429 |  |  |  |  |  |  | #    return; | 
| 430 |  |  |  |  |  |  | #} | 
| 431 |  |  |  |  |  |  |  | 
| 432 |  |  |  |  |  |  | sub _to_form_object{ | 
| 433 | 218 |  |  | 218 |  | 951 | my($ref) = @_; | 
| 434 |  |  |  |  |  |  |  | 
| 435 | 218 |  |  |  |  | 258 | my $wrapper; | 
| 436 |  |  |  |  |  |  | my $type; | 
| 437 |  |  |  |  |  |  |  | 
| 438 | 218 | 100 |  |  |  | 1391 | if(!Scalar::Util::blessed($ref)){ | 
|  |  | 100 |  |  |  |  |  | 
| 439 | 132 |  |  |  |  | 238 | $type = ref $ref; | 
| 440 | 132 | 100 |  |  |  | 1222 | if($type eq 'HASH'){ | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
| 441 | 120 |  |  |  |  | 836 | $wrapper = {}; | 
| 442 | 120 | 100 |  |  |  | 332 | @{$wrapper}{ keys %{$ref} } | 
|  | 120 | 100 |  |  |  | 241 |  | 
|  | 155 |  |  |  |  | 1206 |  | 
| 443 |  |  |  |  |  |  | = map{ | 
| 444 | 120 |  |  |  |  | 392 | ref($_) eq 'ARRAY' ?  $_ | 
| 445 |  |  |  |  |  |  | : defined($_)        ? [$_] | 
| 446 |  |  |  |  |  |  | :                      [  ]; | 
| 447 | 120 |  |  |  |  | 177 | } values %{$ref}; | 
| 448 |  |  |  |  |  |  | } | 
| 449 |  |  |  |  |  |  | elsif($type eq 'ARRAY'){ | 
| 450 | 5 |  |  |  |  | 12 | $wrapper = []; | 
| 451 | 5 |  |  |  |  | 10 | @{$wrapper} = map{ _to_form_object($_) } @{$ref}; | 
|  | 5 |  |  |  |  | 13 |  | 
|  | 8 |  |  |  |  | 28 |  | 
|  | 5 |  |  |  |  | 15 |  | 
| 452 |  |  |  |  |  |  | } | 
| 453 |  |  |  |  |  |  | elsif($type eq 'CODE'){ | 
| 454 | 2 |  |  |  |  | 3 | $wrapper = \$ref; | 
| 455 |  |  |  |  |  |  | } | 
| 456 |  |  |  |  |  |  | else{ | 
| 457 | 5 |  |  |  |  | 1163 | Carp::croak("Cannot use '$ref' as form data"); | 
| 458 |  |  |  |  |  |  | } | 
| 459 |  |  |  |  |  |  | } | 
| 460 |  |  |  |  |  |  | elsif($ref->can('param')){ # a request object like CGI.pm | 
| 461 | 83 |  |  |  |  | 793 | return $ref; | 
| 462 |  |  |  |  |  |  | } | 
| 463 |  |  |  |  |  |  | else{ | 
| 464 |  |  |  |  |  |  | # any object is ok | 
| 465 | 3 |  |  |  |  | 7 | $wrapper = \$ref; | 
| 466 | 3 |  |  |  |  | 5 | $type    = 'Object'; | 
| 467 |  |  |  |  |  |  | } | 
| 468 |  |  |  |  |  |  |  | 
| 469 | 130 |  |  |  |  | 1193 | return bless $wrapper => __PACKAGE__ . q{::} . $type; | 
| 470 |  |  |  |  |  |  | } | 
| 471 |  |  |  |  |  |  | sub HTML::FillInForm::Lite::HASH::param{ | 
| 472 | 122 |  |  | 122 |  | 204 | my($hash_ref, $key) = @_; | 
| 473 |  |  |  |  |  |  |  | 
| 474 | 122 | 100 |  |  |  | 436 | my $value = $hash_ref->{$key} or return; | 
| 475 |  |  |  |  |  |  |  | 
| 476 | 113 |  |  |  |  | 134 | return @{ $value }; | 
|  | 113 |  |  |  |  | 929 |  | 
| 477 |  |  |  |  |  |  | } | 
| 478 |  |  |  |  |  |  |  | 
| 479 |  |  |  |  |  |  | sub HTML::FillInForm::Lite::ARRAY::param{ | 
| 480 | 5 |  |  | 5 |  | 14 | my($ary_ref, $key) = @_; | 
| 481 |  |  |  |  |  |  |  | 
| 482 | 5 |  |  |  |  | 39 | return map{ $_->param($key) } @{$ary_ref}; | 
|  | 8 |  |  |  |  | 24 |  | 
|  | 5 |  |  |  |  | 35 |  | 
| 483 |  |  |  |  |  |  | } | 
| 484 |  |  |  |  |  |  |  | 
| 485 |  |  |  |  |  |  | sub HTML::FillInForm::Lite::CODE::param{ | 
| 486 | 2 |  |  | 2 |  | 5 | my($ref_to_code_ref, $key) = @_; | 
| 487 |  |  |  |  |  |  |  | 
| 488 | 2 |  |  |  |  | 3 | return ${$ref_to_code_ref}->($key); | 
|  | 2 |  |  |  |  | 15 |  | 
| 489 |  |  |  |  |  |  | } | 
| 490 |  |  |  |  |  |  | sub HTML::FillInForm::Lite::Object::param{ | 
| 491 | 15 |  |  | 15 |  | 18 | my($ref_to_object, $key) = @_; | 
| 492 | 15 | 100 |  |  |  | 14 | my $method = ${$ref_to_object}->can($key)  or return; | 
|  | 15 |  |  |  |  | 71 |  | 
| 493 | 13 |  |  |  |  | 19 | my(@values) = ${$ref_to_object}->$method(); | 
|  | 13 |  |  |  |  | 247 |  | 
| 494 |  |  |  |  |  |  |  | 
| 495 | 13 | 100 | 100 |  |  | 156 | return @values == 1 && !defined($values[0]) ? () : @values; | 
| 496 |  |  |  |  |  |  | } | 
| 497 |  |  |  |  |  |  |  | 
| 498 |  |  |  |  |  |  | 1; | 
| 499 |  |  |  |  |  |  |  | 
| 500 |  |  |  |  |  |  | __END__ |