]>
Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/Fill.pm
3 ### CGI Extended Form Filler
5 ###----------------------------------------------------------------###
6 # Copyright 2003 - Paul Seamons #
7 # Distributed under the Perl Artistic License without warranty #
8 ###----------------------------------------------------------------###
10 ### See perldoc at bottom
14 @ISA @EXPORT @EXPORT_OK
26 @EXPORT = qw(form_fill);
27 @EXPORT_OK = qw(form_fill html_escape get_tagval_by_key swap_tagval_by_key);
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
36 $MARKER_SCRIPT = "\0SCRIPT\0";
37 $MARKER_COMMENT = "\0COMMENT\0";
38 $OBJECT_METHOD = "param";
40 ###----------------------------------------------------------------###
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
51 my $ref = ref($text) ? $text : \
$text;
53 my $forms = UNIVERSAL
::isa
($form, 'ARRAY') ? $form : [$form];
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;
61 ### allow for optionally removing comments and script
65 $$ref =~ s
|(<script
\b.+?</script
>)|push(@script, $1);$MARKER_SCRIPT|egi
;
67 if ($REMOVE_COMMENT) {
68 $$ref =~ s
|(<!--.*?-->)|push(@comment, $1);$MARKER_COMMENT|eg
;
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
76 local $TEMP_TARGET = $target;
77 $$ref =~ s
{(<form
# open form
79 \bname
=([\"\']?) # the name tag
80 $target # with the correct name (allows for regex)
82 .+? # as much as there is
83 (?=</form
>)) # then end
85 local $REMOVE_SCRIPT = undef;
86 local $REMOVE_COMMENT = undef;
87 &form_fill
($1, $form, undef, $fill_password, $ignore);
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;
96 ### build a sub to get a value
97 my %indexes = (); # store indexes for multivalued elements
98 my $get_form_value = sub {
100 my $all = $_[0] && $_[0] eq 'all';
101 if (! defined $key || ! length $key) {
102 return $all ? [] : undef;
107 foreach my $form (@$forms) {
109 if (UNIVERSAL
::isa
($form, 'HASH') && defined $form->{$key}) {
110 $val = $form->{$key};
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;
120 if (! defined $val) {
121 return $all ? [] : undef;
124 ### fix up the value some
125 if (UNIVERSAL
::isa
($val, 'CODE')) {
126 $val = &{ $val }($key, $TEMP_TARGET);
128 if (UNIVERSAL
::isa
($val, 'ARRAY')) {
129 $val = [@$val]; # copy the values
131 # die "Value for $key is not an array or a scalar";
132 $val = "$val"; # stringify anything else
135 ### html escape them all
136 &html_escape
(\
$_) foreach (ref($val) ? @$val : $val);
138 ### allow for returning all elements
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
153 ###--------------------------------------------------------------###
156 ### swap <input > form elements if they have a name
158 (<input \s
(?: ([\"\'])(?:|.*?[^\\])\
2 | [^>] )* >) # nested html ok
160 ### get the type and name - intentionally exlude names with nested "'
162 my $type = uc(&get_tagval_by_key
(\
$tag, 'type') || '');
163 my $name = &get_tagval_by_key
(\
$tag, 'name');
165 if ($name && ! $ignore->{$name}) {
170 || ($type eq 'PASSWORD' && $fill_password)) {
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', '');
179 } elsif ($type eq 'CHECKBOX'
180 || $type eq 'RADIO') {
181 my $values = &$get_form_value($name, 'all');
183 $tag =~ s{\s+\bCHECKED\b(?:=([\"\']?)checked\1)?(?=\s|>|/>)}{}ig;
185 if ($type eq 'CHECKBOX' && @$values == 1 && $values->[0] eq 'on') {
186 $tag =~ s
|(/?>\s
*)$| checked
="checked"$1|;
188 my $fvalue = &get_tagval_by_key
(\
$tag, 'value');
189 if (defined $fvalue) {
191 next if $_ ne $fvalue;
192 $tag =~ s
|(\s
*/?>\s
*)$| checked
="checked"$1|;
200 $tag; # return of swap
205 ### swap select boxes (must be done in such a way as to allow no closing tag)
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,());
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
220 for (my $i = $#start; $i >= 0; $i --) {
221 my $opts = substr($$ref, $start[$i], $close[$i] - $start[$i]);
223 (<select \s
# opening
224 (?: "" | '' | ([\"\']).*?[^\\]\
2 | [^>] )* # nested html ok
229 my $name = &get_tagval_by_key
(\
$tag, 'name');
230 my $values = $ignore->{$name} ? [] : &$get_form_value($name, 'all');
231 if ($#$values != -1) {
233 (<option
[^>]*>) # opening tag - no embedded > allowed
234 (.*?) # the text value
235 (?=<option
|$|</option
>) # the next tag
237 my ($tag2, $opt) = ($1, $2);
238 $tag2 =~ s
%\s
+\bSELECTED
\b(?:=([\"\']?)selected\
1)?(?=\s
|>|/>)%%ig;
240 my $fvalues = &get_tagval_by_key
(\
$tag2, 'value', 'all');
241 my $fvalue = @$fvalues ? $fvalues->[0]
242 : $opt =~ /^\s*(.*?)\s*$/ ? $1 : "";
244 next if $_ ne $fvalue;
245 $tag2 =~ s
|(\s
*/?>\s
*)$| selected
="selected"$1|;
248 "$tag2$opt"; # return of the swap
251 substr($$ref, $start[$i], $close[$i] - $start[$i], "$tag$opts");
258 ### swap textareas (must be done in such a way as to allow no closing tag)
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,());
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
273 for (my $i = $#start; $i >= 0; $i --) {
274 my $oldval = substr($$ref, $start[$i], $close[$i] - $start[$i]);
276 (<textarea \s
# opening
277 (?: "" | '' | ([\"\']).*?[^\\]\
2 | [^>] )* # nested html ok
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");
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;
294 ### yet another html escaper
295 ### allow pass by value or by reference (reference is modified inplace)
298 return $str if ! $str;
299 my $ref = ref($str) ? $str : \
$str;
301 $$ref =~ s/&/&/g;
304 $$ref =~ s/\"/"/g;
306 return ref($str) ? 1 : $$ref;
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
{
314 my $ref = ref($tag) ? $tag : \
$tag;
316 my $all = $_[0] && $_[0] eq 'all';
318 pos($$ref) = 0; # fix for regex below not resetting and forcing order on key value pairs
320 ### loop looking for tag pairs
322 (?<![\w\
.\
-]) # 0 - not proceded by letter or .
323 ([\w\
.\
-]+) # 1 - the key
325 (?: \s
*([\"\'])(|.*?[^\\])\
2 # 2 - a quote, 3 - the quoted
326 | ([^\s
/]*? (?=\s|>|/>)) # 4 - a non-quoted string
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;
335 return undef if ! $all;
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
{
344 my $ref = ref($tag) ? $tag : \
$tag;
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
353 (?: \s
* ([\"\']) (?:|.*?[^\\]) \
5 # 5 - the quote mark, the quoted
354 | [^\s
/]*? (?=\s|>|/>) # a non-quoted string (may be zero length)
356 | ([^\s
/]+?) (?=\s|>|/>) # 6 - a non keyvalue chunk (CHECKED)
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
365 } elsif (defined($6) && lc($6) eq $key) { # has matching key
366 if (! $n ++) { # only put value back on first match
376 ### append value on if none were swapped
378 $$ref =~ s
|(\s
*/?>\s
*)$| value
="$val"$1|;
382 return ref($tag) ? $n : $$ref;
389 ###----------------------------------------------------------------###
393 CGI::Ex::Fill - Yet another form filler
397 use CGI::Ex::Fill qw(form_fill);
399 my $text = my_own_template_from_somewhere();
403 # my $form = {key => 'value'}
405 # my $form = [CGI->new, CGI->new, {key1 => 'val1'}, CGI->new];
408 form_fill(\$text, $form); # modifies $text
410 # my $copy = form_fill($text, $form); # copies $text
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};
419 form_fill(\$text, $form, $formname, $fp, $ignore);
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}};
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).
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).
444 =head1 HTML COMMENT / JAVASCRIPT
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
463 This module may distributed under the same terms as Perl itself.
This page took 0.065849 seconds and 4 git commands to generate.