File Coverage

blib/lib/HTML/Transmorgify/FormChecksum.pm
Criterion Covered Total %
statement 158 206 76.7
branch 58 110 52.7
condition 10 27 37.0
subroutine 15 16 93.7
pod 0 4 0.0
total 241 363 66.3


line stmt bran cond sub pod time code
1              
2             package HTML::Transmorgify::FormChecksum;
3              
4 1     1   800 use strict;
  1         2  
  1         39  
5 1     1   5 use warnings;
  1         2  
  1         32  
6 1     1   6 use Digest::MD5 qw(md5_hex);
  1         1  
  1         52  
7 1     1   6 use HTML::Transmorgify qw(dangling %variables queue_intercept queue_capture run);
  1         1  
  1         112  
8 1     1   951 use URI::Escape;
  1         1384  
  1         84  
9 1     1   17 use Scalar::Util qw(refaddr blessed);
  1         2  
  1         64  
10 1     1   967 use YAML;
  1         7358  
  1         2326  
11             require Exporter;
12              
13             our @ISA = qw(HTML::Transmorgify Exporter);
14             our @EXPORT = qw(validate_form_submission);
15              
16             my %tags;
17             my $tag_package = { tag_package => __PACKAGE__ };
18              
19             our @rtmp;
20              
21             sub add_tags
22             {
23 1     1 0 2 my ($self, $tobj) = @_;
24 1         18 $self->intercept_shared($tobj, __PACKAGE__, 85, %tags);
25             }
26              
27 3     3 0 9 sub return_true { 1 }
28              
29             $tags{input} = undef;
30             $tags{button} = undef;
31             $tags{textarea} = undef;
32             $tags{"/textarea"} = undef;
33             $tags{select} = undef;
34             $tags{"/select"} = undef;
35             $tags{option} = undef;
36             $tags{"/option"} = undef;
37             $tags{"/form"} = \&dangling;
38             $tags{form} = \&form_tag;
39              
40             sub form_tag
41             {
42 4     4 0 8 my ($fattr, $closed) = @_;
43 4 50       8 die if $closed;
44              
45             #print STDERR "FORM CALLBACK CALLED\n" if $HTML::Transmorgify::debug;
46              
47 4         6 my (@input_tags);
48              
49             my %options;
50              
51             my $cb = sub {
52 18     18   24 my ($attr, $closed) = @_;
53 18 50       102 return 1 if $attr->static('disabled');
54 18         41 push(@input_tags, $attr);
55 18         50 my $id = $attr->raw('id');
56 18         47 my $name = $attr->raw('name');
57 18 50 33     58 $attr->set(name => $id)
      66        
58             if $id && ((! defined $name) || ($name ne $id));
59             # $attr->eval_at_runtime(1);
60 18         43 return 1;
61 4         24 };
62              
63 4         6 my %tac;
64             my $textarea_cb = sub {
65 0     0   0 my ($tattr, $closed) = @_;
66 0 0       0 die if $closed;
67 0 0       0 return 1 if $tattr->static('disabled');
68 0         0 $cb->($tattr, $closed);
69 0         0 my $tacid = refaddr($tattr);
70             queue_capture(sub {
71 0         0 my ($b) = @_;
72 0         0 $tac{$tacid} = $b;
73 0         0 });
74 0         0 return 1;
75 4         35 };
76              
77             my $select_cb = sub {
78             #print STDERR "SELECT CALLBACK\n";
79 2     2   6 my ($sattr, $closed) = @_;
80 2 50       14 return 1 if $sattr->static('disabled');
81 2         7 $cb->($sattr, $closed, "select");
82 2         8 my $opad = refaddr($sattr);
83 2         18 $options{$opad} = [];
84             my $option_cb = sub {
85             #print STDERR "OPTION CALLBACK\n";
86 4         10 my ($oattr, $closed) = @_;
87              
88 4         6 my $tuple = [$oattr];
89 4         6 push(@{$options{$opad}}, $tuple);
  4         10  
90 4 100       13 if (defined $oattr->raw('value')) {
    50          
91             #print STDERR "Remembering attribute value '$oattr' for $opad\n";
92             } elsif (! $closed) {
93             queue_capture(sub {
94 2         37 my ($b) = @_;
95 2         11 push(@$tuple, $b);
96 2         14 });
97             #print STDERR "Remembering inline value '@$b' for $opad\n";
98             } else {
99 0         0 die "
100             }
101 4         11 return 1;
102 2         17 };
103 2         10 queue_intercept(__PACKAGE__,
104             option => $option_cb,
105             "/select", => \&return_true,
106             );
107 2         6 return 1;
108 4         21 };
109             my $close_cb_rt = sub {
110             #print STDERR "# CLOSE CALLBACK\n" if $HTML::Transmorgify::debug;
111 3     3   7 my %vtype; # value type
112             my %pval; # possible value
113 0         0 my %hval; # hidden (readonly) value
114 0         0 my %can_collapse; # if there is only one possible, it can be readonly/hidden
115              
116 0         0 my %vdata;
117              
118 3         6 for my $input (@input_tags) {
119 15 50       88 next if $input->boolean('disabled');
120              
121 15         52 my $tag = $input->tag();
122 15         46 my $type = $input->get('type');
123 15         47 my $name = $input->get('name');
124 15         39 my $value = $input->get('value');
125 15         45 my $readonly = $input->boolean('readonly');
126              
127             #print STDERR "READONLY $tag $type $name = '$readonly'\n";
128              
129 15         36 $vtype{$name} = 'x';
130 15 100       60 if ($tag eq 'input') {
    50          
    100          
    50          
131 12 100 0     45 if ($type eq 'hidden') {
    100 0        
    100          
    50          
    50          
    0          
    0          
132             # XXX 2 hidden with the same name
133 3 50       10 $value = "" unless defined $value;
134 3         16 $hval{$name} = $value;
135 3         9 $vtype{$name} = 'v';
136             } elsif ($type eq 'radio') {
137 3 50       30 $value = "on" unless defined $value;
138 3         10 $pval{$name}{$value} = 1;
139 3         5 $vtype{$name} = 'm';
140 3 50       8 if ($readonly) {
141 0         0 $vtype{$name} = 'v';
142 0 0       0 $hval{$name} = $value
143             if $input->get('checked');
144             }
145 3 50       9 $can_collapse{$name} = 1
146             if $input->get('checked');
147             } elsif ($type eq 'submit') {
148 5 50       13 $value = "Submit Query" unless defined $value;
149 5         15 $pval{$name}{$value} = 1;
150 5         16 $vtype{$name} = 'm';
151             } elsif ($type eq 'image') {
152 0         0 delete $vtype{$name};
153 0         0 $vtype{"$name.x"} = 1;
154 0         0 $vtype{"$name.y"} = 1;
155             } elsif ($type eq 'checkbox') {
156 1 50       7 $value = "on" unless defined $value;
157 1 50       3 if ($readonly) {
158 0         0 $vtype{$name} = 'v';
159 0         0 $hval{$name} = $value;
160             } else {
161 1         3 $vtype{$name} = 'M';
162 1         5 $pval{$name}{$value} = 1;
163             }
164             } elsif ($type eq 'password' || $type eq 'text' || ! $type) {
165 0 0       0 if ($readonly) {
166 0         0 $vtype{$name} = 'v';
167 0         0 $hval{$name} = $value;
168             }
169             } elsif ($type eq 'file') {
170             # nada
171             } else {
172 0         0 die "unknown <$tag> type: '$type'";
173             }
174             } elsif ($tag eq 'button') {
175 0 0       0 if ($type eq 'submit') {
    0          
176 0         0 $pval{$name}{$value} = 1;
177 0         0 $vtype{$name} = 'm';
178             } elsif ($type eq 'button') {
179             # XXX push button
180 0         0 die;
181             } else {
182 0         0 die "unknown <$tag> type: '$type'";
183             }
184             } elsif ($tag eq 'select') {
185 2         5 my $a = refaddr($input);
186 2         3 for my $o (@{$options{$a}}) {
  2         8  
187 4         7 my ($oattr, $obuf) = @$o;
188 4         5 my $v;
189 4 100       7 if ($obuf) {
190 2         6 local(@rtmp) = ( '' );
191 2         12 run($obuf, \@rtmp);
192 2         6 $v = $rtmp[0];
193             } else {
194 2         8 $v = $oattr->get('value');
195             }
196             #print STDERR "Adding option $a - $oattr - $v\n";
197 4         14 $pval{$name}{$v} = 1;
198 4 50       10 $can_collapse{$name} = 1 if $oattr->get('selected');
199             }
200 2         5 $vtype{$name} = 'm';
201 2 50       9 if ($input->boolean('multiple', undef, 0)) {
202 2         6 $vtype{$name} = 'M';
203             }
204             } elsif ($tag eq 'textarea') {
205 1 50       14 if ($readonly) {
206             # XXX needs regression test
207 0         0 my $a = refaddr($input);
208 0         0 $vtype{$name} = 'v';
209 0         0 local(@rtmp) = ( '' );
210 0         0 run($tac{$a}, \@rtmp);
211 0         0 $hval{$name} = $rtmp[0];
212             }
213             } else {
214 0         0 die "tag='$tag'";
215             }
216             #print STDERR "VTYPE{$name} = $vtype{$name}\n";
217             }
218              
219 3         12 for my $p (keys %pval) {
220 7 50 33     22 if ($can_collapse{$p} && scalar(keys %{$pval{$p}}) == 1) {
  0         0  
221 0         0 ($hval{$p}) = keys %{$pval{$p}};
  0         0  
222 0         0 delete $pval{$p};
223 0         0 $vtype{$p} = 'v';
224             }
225 7 50       8 if (! keys %{$pval{$p}}) {
  7         29  
226 0         0 die;
227             }
228             }
229              
230 3         21 my $vtype_str = join("'", map { uri_escape($_) => $vtype{$_} } sort keys %vtype);
  11         154  
231              
232 13         78 my $particular_values = join(" ",
233             map {
234 3         56 join("'",
235 7         48 map { uri_escape($_) } sort keys %{$pval{$_}}
  7         23  
236             )
237             } sort keys %pval
238             );
239              
240 3         44 my $constraint = "$vtype_str $particular_values";
241              
242 3         22 $HTML::Transmorgify::result->[0] .= qq'';
243 3         9 $hval{" constraint"} = $constraint;
244              
245 3         12 my $str = $vtype_str . " " . $HTML::Transmorgify::variables{" secret"} . ' ';
246              
247 3         10 $str .= join(" ", map { $_ => uri_escape($hval{$_}) } sort keys %hval );
  6         160  
248 3         85 my $csum = md5_hex($str);
249             #print STDERR "STR = '$str' = $csum\n";
250              
251 3 50       12 if ($HTML::Transmorgify::debug) {
252             #print STDERR Dumper(\%pval);
253 0         0 print STDERR "SPVALKEY = " . join(' ', sort keys %pval) . "\n";
254 0         0 print STDERR "PARTICULAR VALUES = $particular_values.\n";
255 0         0 print STDERR "CSUMSTR=$str.\n";
256             }
257              
258 3         33 $HTML::Transmorgify::result->[0] .= qq'';
259 4         45 };
260              
261 4 50 33     32 print STDERR "SECRET SET\n" if $HTML::Transmorgify::debug && $HTML::Transmorgify::variables{' secret'};
262 4 50 33     23 print STDERR "NO SECRET SET\n" if $HTML::Transmorgify::debug && ! $HTML::Transmorgify::variables{' secret'};
263              
264             my $wrap = sub {
265 3     3   11 my (@args) = @_;
266             push(@$HTML::Transmorgify::rbuf, sub {
267 3         10 $close_cb_rt->(@args)
268 3         24 });
269 4         20 };
270              
271 4 100       33 queue_intercept(__PACKAGE__,
272             input => $cb,
273             button => $cb,
274             textarea => $cb,
275             select => $select_cb,
276             "/form" => ($HTML::Transmorgify::variables{" secret"}
277             ? $wrap
278             : \&return_true),
279             );
280 4         89 return 1;
281             };
282              
283             sub validate_form_submission
284             {
285 4     4 0 6213 my ($formdata, $secret) = @_;
286 4 100       22 return undef unless defined $secret; # no signing key
287              
288 3 50       12 return 0 unless defined $formdata->{' constraint'}; # no constraint sent
289 3 50       13 return 0 unless defined $formdata->{' csum'}; # no checksum sent
290 3         6 my $constraint = $formdata->{' constraint'};
291 3         20 $constraint =~ s/^(\S+) //;
292 3         10 my $vtype_str = $1;
293 3         14 my %vtypes = map { uri_unescape($_) } split(/'/, $vtype_str, -1);
  22         178  
294 3         48 my @sorted = sort keys %vtypes;
295              
296 3         7 my %pval;
297 11 100       80 @pval{grep { $vtypes{$_} eq 'm' || $vtypes{$_} eq 'M' } @sorted}
  13         58  
298             = map {
299 3         11 {
300             map {
301 7         46 uri_unescape($_) => 1
302             } split(/'/, $_, -1)
303             }
304             } split(/ /, $constraint, -1);
305              
306              
307             #use Data::Dumper;
308             #print Dumper(\%vtypes, \%pval);
309 3         12 my $str = "$vtype_str $secret ";
310 3         7 $str .= join(' ', map { $_ => uri_escape($formdata->{$_}) } ' constraint', grep { $vtypes{$_} eq 'v' } @sorted);
  6         136  
  11         25  
311              
312 3 50       64 if ($HTML::Transmorgify::debug) {
313 0 0       0 print STDERR "CPVALKEY = " . join(' ', grep { $vtypes{$_} eq 'm' || $vtypes{$_} eq 'M' } @sorted) . "\n";
  0         0  
314 0         0 print STDERR "CPARTICVLS = $constraint.\n";
315 0         0 print STDERR " CHECK =$str.\n";
316             }
317              
318 3         20 my $csum = md5_hex($str);
319              
320             #print STDERR "CSUMS: $csum\n : ".$formdata->{' csum'}."\n";
321 3 50       14 return 0 unless $csum eq $formdata->{' csum'}; # invalid signature
322              
323 3         16 for my $k (keys %$formdata) {
324             #print STDERR " CHECKING KEY $k ($vtypes{$k} - $formdata->{$k}).\n";
325 17 100       49 next if $k =~ /^ /;
326 11 50       26 return 0 unless $vtypes{$k}; # extra fields
327 11         21 my $val = $formdata->{$k};
328 11 50 33     28 return 0 if ref($val)
329             && ! uc($vtypes{$k}) eq $vtypes{$k};
330 11 100 100     46 if ($vtypes{$k} eq 'm' || $vtypes{$k} eq 'M') {
331 7 50       20 my @v = ref($val)
332             ? @$val
333             : $val;
334 7         12 for my $v (@v) {
335             #print STDERR "CHECKING VALUE $v\n";
336 7 50       34 return 0 unless $pval{$k}{$v} # illegal value
337             }
338             } else {
339 4 50       13 return 0 if ref($val); # multiples not allowed
340             }
341             #print STDERR "DONE\n";
342             }
343              
344 3         21 return 1;
345             }
346              
347             1;
348              
349             __END__