File Coverage

blib/lib/MVC/Neaf/X/Form/Data.pm
Criterion Covered Total %
statement 51 52 98.0
branch 8 14 57.1
condition 3 4 75.0
subroutine 13 13 100.0
pod 4 4 100.0
total 79 87 90.8


line stmt bran cond sub pod time code
1             package MVC::Neaf::X::Form::Data;
2              
3 6     6   39 use strict;
  6         14  
  6         171  
4 6     6   29 use warnings;
  6         18  
  6         271  
5             our $VERSION = '0.2901';
6              
7             =head1 NAME
8              
9             MVC::Neaf::X::Form::Data - Form validation result object.
10              
11             =head1 CAUTION
12              
13             This module should be moved into a separate distribution or (ideally)
14             merged with an existing module with similar functionality.
15              
16             Possible candidates include L, L,
17             L, and more.
18              
19             =head1 DESCRIPTION
20              
21             See L.
22             This class is not expected to be created and used directly.
23              
24             =head1 METHODS
25              
26             =cut
27              
28 6     6   3268 use Digest::SHA qw(sha1);
  6         19082  
  6         508  
29 6     6   966 use MVC::Neaf::Util qw( encode_b64 );
  6         15  
  6         355  
30 6     6   992 use URI::Escape;
  6         2960  
  6         386  
31              
32 6     6   37 use parent qw(MVC::Neaf::X);
  6         13  
  6         82  
33              
34             =head2 new( %options )
35              
36             %options may include:
37              
38             =over
39              
40             =item * data - data that passed validation
41              
42             =item * error - fields that failed validation with correspondent error messages.
43              
44             =item * raw - data as it was before validation.
45             This should in theory match data + error, but isn't check in any way.
46              
47             =back
48              
49             =cut
50              
51             =head2 fields()
52              
53             Return fields currently in either data or raw hashes.
54              
55             =cut
56              
57             sub fields {
58 1     1 1 11 my $self = shift;
59              
60 1         2 my %megahash = (%{ $self->raw }, %{ $self->data });
  1         8  
  1         3  
61 1         11 return keys %megahash;
62             };
63              
64             =head2 is_valid()
65              
66             Returns true if data passed validation, false otherwise.
67              
68             =cut
69              
70             sub is_valid {
71 9     9 1 1008 my $self = shift;
72 9         14 return !%{ $self->error };
  9         16  
73             };
74              
75             =head2 data
76              
77             Returns data that passed validation as hashref.
78             This MAY be incomplete, check is_valid() first.
79              
80             =head2 data( "key" )
81              
82             Get specific data item.
83              
84             =head2 data( key => $newvalue )
85              
86             Set specific data item.
87              
88             =head2 error
89              
90             Returns errors that occurred during validation.
91              
92             =head2 error( "key" )
93              
94             Get specific error item.
95              
96             =head2 error( key => $newvalue )
97              
98             Set specific error item. This may be used to invalidate a value
99             after additional checks, and will also reset is_valid.
100              
101             =head2 raw
102              
103             Returns raw input values as hashref.
104             Only keys subject to validation will be retained.
105              
106             This may be useful for sending the data back for resubmission.
107              
108             =head2 raw( "key" )
109              
110             Get specific raw item.
111              
112             =head2 raw( key => $newvalue )
113              
114             Set specific raw item.
115              
116             =cut
117              
118             foreach (qw(data error raw)) {
119             my $method = $_;
120              
121             my $code = sub {
122 35     35   8581 my $self = shift;
123              
124 35   100     132 my $hash = $self->{$method} ||= {};
125 35 100       228 return $hash unless @_;
126              
127 1         2 my $param = shift;
128 1 50       4 return $hash->{param} unless @_;
129              
130 1         42 $hash->{$param} = shift;
131 1         5 return $self;
132             };
133              
134 6     6   1611 no strict 'refs'; ## no critic
  6         13  
  6         2215  
135             *$method = $code;
136             };
137              
138             =head2 as_url( %override )
139              
140             Return the cleansed form data as one url-encoded line.
141             The keys are sorted, and empty/undef values are discarded.
142              
143             Arrays are NOT supported (yet). This may change in the future.
144              
145             =cut
146              
147             sub as_url {
148 3     3 1 6 my ($self, %override) = @_;
149              
150 3 50       6 my %data = ( %{ $self->{data} || {} }, %override );
  3         13  
151              
152             return join '&'
153 3         10 , map { uri_escape_utf8( $_ ). "=". uri_escape_utf8( $data{$_} ) }
154 3 50       10 grep { defined $data{$_} and length $data{$_} }
  3         14  
155             sort keys %data;
156             };
157              
158             =head2 sign( %options )
159              
160             Sign data with a key.
161             Empty values are discarded.
162             The same data set with the same key is guaranteed to produce the same signature,
163             at least in the same module version.
164              
165             Options may include:
166              
167             =over
168              
169             =item * key (required) - the encryption key. If unsure, run pwgen(1) and
170             hardcode something from its output.
171              
172             =item * crypt = CODE($data, $key) - use that function for encryption.
173             The default is simple sha1-based hash.
174             You may need a more secure alternative.
175              
176             =item * override = %hash - override these values.
177              
178             =item * discard = @list - discard these values. This takes over override.
179             May be needed e.g. to check if the form matches signature that comes with the
180             form itself.
181              
182             =back
183              
184             =cut
185              
186             sub sign {
187 2     2 1 608 my ($self, %opt) = @_;
188              
189             $self->my_croak( "key parameter is required" )
190 2 50       8 unless $opt{key};
191              
192 2 50       13 my %override = ( %{ $opt{override} || {} }
193 2 50       2 , map { $_ => '' } @{ $opt{exclude} || [] } );
  0         0  
  2         9  
194 2   50     11 $opt{crypt} ||= \&_default_sign;
195              
196 2         6 return $opt{crypt}->( $self->as_url( %override ), $opt{key});
197             };
198              
199             # A weak ad-hoc HMAC. Use a better one...
200             sub _default_sign {
201 2     2   74 my ($data, $key) = @_;
202 2         18 return encode_b64( sha1( join "?", $key, $data, $key ) );
203             };
204              
205             =head1 LICENSE AND COPYRIGHT
206              
207             This module is part of L suite.
208              
209             Copyright 2016-2023 Konstantin S. Uvarin C.
210              
211             This program is free software; you can redistribute it and/or modify it
212             under the terms of either: the GNU General Public License as published
213             by the Free Software Foundation; or the Artistic License.
214              
215             See L for more information.
216              
217             =cut
218              
219             1;