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.54
10              
11             =cut
12              
13             ###----------------------------------------------------------------###
14             # Copyright - Paul Seamons #
15             # Distributed under the Perl Artistic License without warranty #
16             ###----------------------------------------------------------------###
17              
18 22     22   13031 use strict;
  22         38  
  22         557  
19 22     22   91 use warnings;
  22         31  
  22         511  
20 22     22   83 use Exporter qw(import);
  22         31  
  22         60042  
21              
22             our $VERSION = '2.54'; # 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 80933 my $text = shift;
49 68 100       170 my $ref = ref($text) ? $text : \$text;
50 68         87 my $form = shift;
51 68         88 my $target = shift;
52 68         82 my $fill_password = shift;
53 68   100     247 my $ignore = shift || {};
54              
55 68         244 fill({
56             text => $ref,
57             form => $form,
58             target => $target,
59             fill_password => $fill_password,
60             ignore_fields => $ignore,
61             });
62              
63 68 100       292 return ref($text) ? 1 : $$ref;
64             }
65              
66             sub fill {
67 142     142 0 175 my $args = shift;
68 142         181 my $ref = $args->{'text'};
69 142         174 my $form = $args->{'form'};
70 142         163 my $target = $args->{'target'};
71 142         180 my $ignore = $args->{'ignore_fields'};
72 142         164 my $fill_password = $args->{'fill_password'};
73              
74 142 100       371 my $forms = UNIVERSAL::isa($form, 'ARRAY') ? $form : [$form];
75 142 100       297 $ignore = {map {$_ => 1} @$ignore} if UNIVERSAL::isa($ignore, 'ARRAY');
  5         14  
76 142 100       240 $fill_password = 1 if ! defined $fill_password;
77              
78              
79             ### allow for optionally removing comments and script
80 142         177 my @comment;
81             my @script;
82 142 100       322 if (defined($args->{'remove_script'}) ? $args->{'remove_script'} : $REMOVE_SCRIPT) {
    100          
83 139         544 $$ref =~ s|()|push(@script, $1);$MARKER_SCRIPT|egi;
  1         3  
  1         5  
84             }
85 142 100       309 if (defined($args->{'remove_comment'}) ? $args->{'remove_comment'} : $REMOVE_COMMENT) {
    100          
86 139         242 $$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       222 if ($target) {
94 3         6 local $_TEMP_TARGET = $target;
95 3         116 $$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         11 my $str = $1;
104 3         8 local $args->{'text'} = \$str;
105 3         7 local $args->{'remove_script'} = 0;
106 3         5 local $args->{'remove_comment'} = 0;
107 3         6 local $args->{'target'} = undef;
108 3         28 fill($args);
109 3         22 $str; # return of the s///;
110             }sigex;
111              
112             ### put scripts and comments back and return
113 3 50       20 $$ref =~ s/$MARKER_COMMENT/shift(@comment)/eg if $#comment != -1;
  0         0  
114 3 50       6 $$ref =~ s/$MARKER_SCRIPT/ shift(@script) /eg if $#script != -1;
  0         0  
115 3         7 return 1;
116             }
117              
118             ### build a sub to get a value from the passed forms on a request basis
119 139         212 my %indexes = (); # store indexes for multivalued elements
120             my $get_form_value = sub {
121 138     138   176 my $key = shift;
122 138   66     337 my $all = $_[0] && $_[0] eq 'all';
123 138 50 33     364 if (! defined $key || ! length $key) {
124 0 0       0 return $all ? [] : undef;
125             }
126              
127 138         164 my $val;
128             my $meth;
129 138         198 foreach my $form (@$forms) {
130 140 50       237 next if ! ref $form;
131 140 100 100     575 if (UNIVERSAL::isa($form, 'HASH') && defined $form->{$key}) {
    100 33        
    100          
132 118         162 $val = $form->{$key};
133 118         157 last;
134             } elsif ($meth = UNIVERSAL::can($form, $args->{'object_method'} || $OBJECT_METHOD)) {
135 3         8 $val = $form->$meth($key);
136 3 100       56 last if defined $val;
137             } elsif (UNIVERSAL::isa($form, 'CODE')) {
138 1         2 $val = $form->($key, $_TEMP_TARGET);
139 1 50       7 last if defined $val;
140             }
141             }
142 138 100       224 if (! defined $val) {
143 17 100       38 return $all ? [] : undef;
144             }
145              
146             ### fix up the value some
147 121 100       327 if (UNIVERSAL::isa($val, 'CODE')) {
148 1         2 $val = $val->($key, $_TEMP_TARGET);
149             }
150 121 100       298 if (UNIVERSAL::isa($val, 'ARRAY')) {
    50          
151 26         51 $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       282 html_escape(\$_) foreach (ref($val) ? @$val : $val);
159              
160             ### allow for returning all elements
161             ### or one at a time
162 121 100       207 if ($all) {
    100          
163 40 100       87 return ref($val) ? $val : [$val];
164             } elsif (ref($val)) {
165 16   100     71 $indexes{$key} ||= 0;
166 16         19 my $ret = $val->[$indexes{$key}];
167 16 100       27 $ret = '' if ! defined $ret;
168 16         20 $indexes{$key} ++; # don't wrap - if we run out of values - we're done
169 16         31 return $ret;
170             } else {
171 65         112 return $val;
172             }
173 139         639 };
174              
175              
176             ###--------------------------------------------------------------###
177              
178             ### First pass
179             ### swap form elements if they have a name
180 139         924 $$ref =~ s{
181             (] )+ >) # nested html ok
182             }{
183             ### get the type and name - intentionally exlude names with nested "'
184 119         289 my $tag = $1;
185 119   100     237 my $type = uc(get_tagval_by_key(\$tag, 'type') || '');
186 119         252 my $name = get_tagval_by_key(\$tag, 'name');
187              
188 119 100 100     403 if ($name && ! $ignore->{$name}) {
189 115 100 100     568 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         133 my $value = $get_form_value->($name, 'next');
194 78 100       124 if (defined $value) {
    100          
195 73         111 swap_tagval_by_key(\$tag, 'value', $value);
196             } elsif (! defined get_tagval_by_key(\$tag, 'value')) {
197 2         5 swap_tagval_by_key(\$tag, 'value', '');
198             }
199              
200             } elsif ($type eq 'CHECKBOX'
201             || $type eq 'RADIO') {
202 35         51 my $values = $get_form_value->($name, 'all');
203 35 100       58 if (@$values) {
204 29         82 $tag =~ s{\s+\bCHECKED\b(?:=([\"\']?)checked\1)?(?=\s|>|/>)}{}ig;
205              
206 29         47 my $fvalue = get_tagval_by_key(\$tag, 'value');
207 29 100       53 $fvalue = 'on' if ! defined $fvalue;
208 29 50       41 if (defined $fvalue) {
209 29         38 foreach (@$values) {
210 35 100       65 next if $_ ne $fvalue;
211 11         63 $tag =~ s|(\s*/?>\s*)$| checked="checked"$1|;
212 11         22 last;
213             }
214             }
215             }
216             }
217              
218             }
219 119         662 $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         232 my @start = ();
226 139         157 my @close = ();
227 139         520 push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*select\b)|ig;
228 139         344 push @close, pos($$ref) - length($1) while $$ref =~ m|(
229 139         302 for (my $i = 0; $i <= $#start; $i ++) {
230 18   66     77 while (defined($close[$i]) && $close[$i] < $start[$i]) {
231 0         0 splice (@close,$i,1,());
232             }
233 18 100 66     53 if ($i == $#start) {
    100          
234 8 100       23 $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         3 $close[$i] = $start[$i + 1]; # set to start of next select if no closing or > next select
237             }
238             }
239 139         262 for (my $i = $#start; $i >= 0; $i --) {
240 18         42 my $opts = substr($$ref, $start[$i], $close[$i] - $start[$i]);
241 18 50       155 $opts =~ s{
242             (
243             (?: "" | '' | ([\"\']).*?[^\\]\2 | [^>] )+ # nested html ok
244             >) # end of tag
245             }{}sxi || next;
246 18 50       37 next if ! $opts;
247 18         39 my $tag = $1;
248 18         33 my $name = get_tagval_by_key(\$tag, 'name');
249 18 100 66     66 next if ! defined($name) || ! length($name);
250 17 100       39 my $values = $ignore->{$name} ? [] : $get_form_value->($name, 'all');
251 17 100       36 if ($#$values != -1) {
252 11         60 my $n = $opts =~ s{
253             (]*>) # opening tag - no embedded > allowed
254             (.*?) # the text value
255             (?=) # the next tag
256             }{
257 31         69 my ($tag2, $opt) = ($1, $2);
258 31         58 $tag2 =~ s%\s+\bSELECTED\b(?:=([\"\']?)selected\1)?(?=\s|>|/>)%%ig;
259              
260 31         57 my $fvalues = get_tagval_by_key(\$tag2, 'value', 'all');
261 31 50       80 my $fvalue = @$fvalues ? $fvalues->[0]
    100          
262             : $opt =~ /^\s*(.*?)\s*$/ ? $1 : "";
263 31         46 foreach (@$values) {
264 41 100       61 next if $_ ne $fvalue;
265 12         54 $tag2 =~ s|(\s*/?>\s*)$| selected="selected"$1|;
266 12         18 last;
267             }
268 31         139 "$tag2$opt"; # return of the swap
269             }sigex;
270 11 50       21 if ($n) {
271 11         48 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         166 @start = ();
280 139         145 @close = ();
281 139         365 push @start, pos($$ref) - length($1) while $$ref =~ m|(<\s*textarea\b)|ig;
282 139         277 push @close, pos($$ref) - length($1) while $$ref =~ m|(
283 139         253 for (my $i = 0; $i <= $#start; $i ++) {
284 9   66     42 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     59 if ($i == $#start) {
    100          
288 4 100       12 $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         3 splice(@close, $i, 0, $start[$i + 1]); # set to start of next select if no closing or > next select
291             }
292             }
293 139         155 my $offset = 0;
294 139         245 for (my $i = 0; $i <= $#start; $i ++) {
295 9         21 my $oldval = substr($$ref, $start[$i] + $offset, $close[$i] - $start[$i]);
296 9 50       66 $oldval =~ s{
297             (