File Coverage

blib/lib/CGI/Ex/Fill.pm
Criterion Covered Total %
statement 192 201 95.5
branch 128 150 85.3
condition 53 66 80.3
subroutine 9 9 100.0
pod 3 5 60.0
total 385 431 89.3


line stmt bran cond sub pod time code
1             package CGI::Ex::Fill;
2              
3             =head1 NAME
4              
5             CGI::Ex::Fill - Fast but compliant regex based form filler
6              
7             =head1 VERSION
8              
9             version 2.55
10              
11             =cut
12              
13             ###----------------------------------------------------------------###
14             # Copyright - Paul Seamons #
15             # Distributed under the Perl Artistic License without warranty #
16             ###----------------------------------------------------------------###
17              
18 23     23   6941166 use strict;
  23         55  
  23         1048  
19 23     23   125 use warnings;
  23         47  
  23         1908  
20 23     23   163 use Exporter qw(import);
  23         48  
  23         113644  
21              
22             our $VERSION = '2.55'; # VERSION
23             our @EXPORT = qw(form_fill);
24             our @EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key);
25              
26             ### These directives are used to determine whether or not to
27             ### remove html comments and script sections while filling in
28             ### a form. Default is on. This may give some trouble if you
29             ### have a javascript section with form elements that you would
30             ### like filled in.
31             our $REMOVE_SCRIPT = 1;
32             our $REMOVE_COMMENT = 1;
33             our $MARKER_SCRIPT = "\0SCRIPT\0";
34             our $MARKER_COMMENT = "\0COMMENT\0";
35             our $OBJECT_METHOD = "param";
36             our $_TEMP_TARGET;
37              
38             ###----------------------------------------------------------------###
39              
40             ### Regex based filler - as opposed to HTML::Parser based HTML::FillInForm
41             ### arguments are positional
42             ### pos1 - text or textref - if textref it is modified in place
43             ### pos2 - hash or cgi obj ref, or array ref of hash and cgi obj refs
44             ### pos3 - target - to be used for choosing a specific form - default undef
45             ### pos4 - boolean fill in password fields - default is true
46             ### pos5 - hashref or arrayref of fields to ignore
47             sub form_fill {
48 68     68 0 141349 my $text = shift;
49 68 100       201 my $ref = ref($text) ? $text : \$text;
50 68         128 my $form = shift;
51 68         161 my $target = shift;
52 68         117 my $fill_password = shift;
53 68   100     316 my $ignore = shift || {};
54              
55 68         400 fill({
56             text => $ref,
57             form => $form,
58             target => $target,
59             fill_password => $fill_password,
60             ignore_fields => $ignore,
61             });
62              
63 68 100       395 return ref($text) ? 1 : $$ref;
64             }
65              
66             sub fill {
67 142     142 0 238 my $args = shift;
68 142         282 my $ref = $args->{'text'};
69 142         280 my $form = $args->{'form'};
70 142         252 my $target = $args->{'target'};
71 142         248 my $ignore = $args->{'ignore_fields'};
72 142         243 my $fill_password = $args->{'fill_password'};
73              
74 142 100       546 my $forms = UNIVERSAL::isa($form, 'ARRAY') ? $form : [$form];
75 142 100       439 $ignore = {map {$_ => 1} @$ignore} if UNIVERSAL::isa($ignore, 'ARRAY');
  5         14  
76 142 100       344 $fill_password = 1 if ! defined $fill_password;
77              
78              
79             ### allow for optionally removing comments and script
80 142         267 my @comment;
81             my @script;
82 142 100       463 if (defined($args->{'remove_script'}) ? $args->{'remove_script'} : $REMOVE_SCRIPT) {
    100          
83 139         448 $$ref =~ s|()|push(@script, $1);$MARKER_SCRIPT|egi;
  1         4  
  1         8  
84             }
85 142 100       488 if (defined($args->{'remove_comment'}) ? $args->{'remove_comment'} : $REMOVE_COMMENT) {
    100          
86 139         357 $$ref =~ s|()|push(@comment, $1);$MARKER_COMMENT|eg;
  0         0  
  0         0  
87             }
88              
89             ### if there is a target - focus in on it
90             ### possible bug here - name won't be found if
91             ### there is nested html inside the form tag that comes before
92             ### the name field - if no close form tag - don't swap in anything
93 142 100       342 if ($target) {
94 3         5 local $_TEMP_TARGET = $target;
95 3         182 $$ref =~ s{(
96             [^>]+ # some space
97             \bname=([\"\']?) # the name tag
98             $target # with the correct name (allows for regex)
99             \2 # closing quote
100             .+? # as much as there is
101             (?=)) # then end
102             }{
103 3         10 my $str = $1;
104 3         8 local $args->{'text'} = \$str;
105 3         7 local $args->{'remove_script'} = 0;
106 3         7 local $args->{'remove_comment'} = 0;
107 3         6 local $args->{'target'} = undef;
108 3         16 fill($args);
109 3         19 $str; # return of the s///;
110             }sigex;
111              
112             ### put scripts and comments back and return
113 3 50       8 $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1;
  0         0  
114 3 50       5 $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script != -1;
  0         0  
115 3         6 return 1;
116             }
117              
118             ### build a sub to get a value from the passed forms on a request basis
119 139         302 my %indexes = (); # store indexes for multivalued elements
120             my $get_form_value = sub {
121 138     138   210 my $key = shift;
122 138   66     454 my $all = $_[0] && $_[0] eq 'all';
123 138 50 33     484 if (! defined $key || ! length $key) {
124 0 0       0 return $all ? [] : undef;
125             }
126              
127 138         208 my $val;
128             my $meth;
129 138         269 foreach my $form (@$forms) {
130 140 50       288 next if ! ref $form;
131 140 100 100     726 if (UNIVERSAL::isa($form, 'HASH') && defined $form->{$key}) {
    100 33        
    100          
132 118         228 $val = $form->{$key};
133 118         220 last;
134             } elsif ($meth = UNIVERSAL::can($form, $args->{'object_method'} || $OBJECT_METHOD)) {
135 3         142 $val = $form->$meth($key);
136 3 100       91 last if defined $val;
137             } elsif (UNIVERSAL::isa($form, 'CODE')) {
138 1         4 $val = $form->($key, $_TEMP_TARGET);
139 1 50       12 last if defined $val;
140             }
141             }
142 138 100       258 if (! defined $val) {
143 17 100       58 return $all ? [] : undef;
144             }
145              
146             ### fix up the value some
147 121 100       465 if (UNIVERSAL::isa($val, 'CODE')) {
148 1         6 $val = $val->($key, $_TEMP_TARGET);
149             }
150 121 100       481 if (UNIVERSAL::isa($val, 'ARRAY')) {
    50          
151 26         55 $val = [@$val]; # copy the values
152             } elsif (ref $val) {
153             # die "Value for $key is not an array or a scalar";
154 0         0 $val = "$val"; # stringify anything else
155             }
156              
157             ### html escape them all
158 121 100       408 html_escape(\$_) foreach (ref($val) ? @$val : $val);
159              
160             ### allow for returning all elements
161             ### or one at a time
162 121 100       312 if ($all) {
    100          
163 40 100       121 return ref($val) ? $val : [$val];
164             } elsif (ref($val)) {
165 16   100     49 $indexes{$key} ||= 0;
166 16         27 my $ret = $val->[$indexes{$key}];
167 16 100       26 $ret = '' if ! defined $ret;
168 16         21 $indexes{$key} ++; # don't wrap - if we run out of values - we're done
169 16         39 return $ret;
170             } else {
171 65         167 return $val;
172             }
173 139         979 };
174              
175              
176             ###--------------------------------------------------------------###
177              
178             ### First pass
179             ### swap form elements if they have a name
180 139         1271 $$ref =~ s{
181             (] )+ >) # nested html ok
182             }{
183             ### get the type and name - intentionally exlude names with nested "'
184 119         326 my $tag = $1;
185 119   100     254 my $type = uc(get_tagval_by_key(\$tag, 'type') || '');
186 119         279 my $name = get_tagval_by_key(\$tag, 'name');
187              
188 119 100 100     521 if ($name && ! $ignore->{$name}) {
189 115 100 100     817 if (! $type
    100 100        
      100        
      100        
      100        
      100        
190             || ($type ne 'PASSWORD' && $type ne 'CHECKBOX' && $type ne 'RADIO')
191             || ($type eq 'PASSWORD' && $fill_password)) {
192              
193 78         163 my $value = $get_form_value->($name, 'next');
194 78 100       164 if (defined $value) {
    100          
195 73         166 swap_tagval_by_key(\$tag, 'value', $value);
196             } elsif (! defined get_tagval_by_key(\$tag, 'value')) {
197 2         7 swap_tagval_by_key(\$tag, 'value', '');
198             }
199              
200             } elsif ($type eq 'CHECKBOX'
201             || $type eq 'RADIO') {
202 35         74 my $values = $get_form_value->($name, 'all');
203 35 100       74 if (@$values) {
204 29         142 $tag =~ s{\s+\bCHECKED\b(?:=([\"\']?)checked\1)?(?=\s|>|/>)}{}ig;
205              
206 29         98 my $fvalue = get_tagval_by_key(\$tag, 'value');
207 29 100       78 $fvalue = 'on' if ! defined $fvalue;
208 29 50       58 if (defined $fvalue) {
209 29         62 foreach (@$values) {
210 35 100       90 next if $_ ne $fvalue;
211 11         129 $tag =~ s|(\s*/?>\s*)$| checked="checked"$1|;
212 11         31 last;
213             }
214             }
215             }
216             }
217              
218             }
219 119         883 $tag; # return of swap
220             }sigex;
221              
222              
223             ### Second pass
224             ### swap select boxes (must be done in such a way as to allow no closing tag)
225 139         281 my @start = ();
226 139         222 my @close = ();
227 139         845 push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*select\b)|ig;
228 139         470 push @close, pos($$ref) - length($1) while $$ref =~ m|(
229 139         445 for (my $i = 0; $i <= $#start; $i ++) {
230 18   66     88 while (defined($close[$i]) && $close[$i] < $start[$i]) {
231 0         0 splice (@close,$i,1,());
232             }
233 18 100 66     74 if ($i == $#start) {
    100          
234 8 100       55 $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
235             } elsif (! defined($close[$i]) || $close[$i] > $start[$i + 1]) {
236 1         5 $close[$i] = $start[$i + 1]; # set to start of next select if no closing or > next select
237             }
238             }
239 139         374 for (my $i = $#start; $i >= 0; $i --) {
240 18         48 my $opts = substr($$ref, $start[$i], $close[$i] - $start[$i]);
241 18 50       208 $opts =~ s{
242             (
243             (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )+ # nested html ok
244             >) # end of tag
245             }{}sxi || next;
246 18 50       45 next if ! $opts;
247 18         37 my $tag = $1;
248 18         41 my $name = get_tagval_by_key(\$tag, 'name');
249 18 100 66     70 next if ! defined($name) || ! length($name);
250 17 100       46 my $values = $ignore->{$name} ? [] : $get_form_value->($name, 'all');
251 17 100       47 if ($#$values != -1) {
252 11         67 my $n = $opts =~ s{
253             (]*>) # opening tag - no embedded > allowed
254             (.*?) # the text value
255             (?=) # the next tag
256             }{
257 31         93 my ($tag2, $opt) = ($1, $2);
258 31         71 $tag2 =~ s%\s+\bSELECTED\b(?:=([\"\']?)selected\1)?(?=\s|>|/>)%%ig;
259              
260 31         54 my $fvalues = get_tagval_by_key(\$tag2, 'value', 'all');
261 31 50       84 my $fvalue = @$fvalues ? $fvalues->[0]
    100          
262             : $opt =~ /^\s*(.*?)\s*$/ ? $1 : "";
263 31         47 foreach (@$values) {
264 41 100       70 next if $_ ne $fvalue;
265 12         78 $tag2 =~ s|(\s*/?>\s*)$| selected="selected"$1|;
266 12         19 last;
267             }
268 31         177 "$tag2$opt"; # return of the swap
269             }sigex;
270 11 50       25 if ($n) {
271 11         64 substr($$ref, $start[$i], $close[$i] - $start[$i], "$tag$opts");
272             }
273             }
274             }
275              
276              
277             ### Third pass
278             ### swap textareas (must be done in such a way as to allow no closing tag)
279 139         244 @start = ();
280 139         257 @close = ();
281 139         670 push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*textarea\b)|ig;
282 139         417 push @close, pos($$ref) - length($1) while $$ref =~ m|(
283 139         327 for (my $i = 0; $i <= $#start; $i ++) {
284 9   66     40 while (defined($close[$i]) && $close[$i] < $start[$i]) {
285 0         0 splice (@close,$i,1,()); # get rid of extra closes
286             }
287 9 100 66     35 if ($i == $#start) {
    100          
288 4 100       16 $close[$i] = length($$ref) if ! defined $close[$i]; # set to end of string if no closing
289             } elsif (! defined($close[$i]) || $close[$i] > $start[$i + 1]) {
290 1         5 splice(@close, $i, 0, $start[$i + 1]); # set to start of next select if no closing or > next select
291             }
292             }
293 139         236 my $offset = 0;
294 139         301 for (my $i = 0; $i <= $#start; $i ++) {
295 9         27 my $oldval = substr($$ref, $start[$i] + $offset, $close[$i] - $start[$i]);
296 9 50       76 $oldval =~ s{
297             (