File Coverage

blib/lib/CGI/Application/Plugin/GenVal.pm

Criterion	Covered	Total	%
statement	22	29	75.8
branch	0	2	0.0
condition			n/a
subroutine	8	10	80.0
pod			n/a
total	30	41	73.1

line	stmt	bran	sub	time	code
1					package CGI::Application::Plugin::GenVal;
2
3	1		1	18869	use strict;
	1			3
	1			52
4	1		1	6	use warnings;
	1			2
	1			37
5	1		1	7	use Carp;
	1			6
	1			99
6
7	1		1	7	use vars qw ( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS );
	1			2
	1			299
8
9					require Exporter;
10					@ISA = qw(Exporter);
11
12					@EXPORT_OK = ( 'GenVal' );
13
14					%EXPORT_TAGS = (
15					all => [ 'GenVal' ],
16					std => [ 'GenVal' ],
17					);
18
19					$VERSION = '0.01_01';
20
21					my $genval;
22
23					sub import {
24					### The real object is in ::guts
25	0		0		$genval = new CGI::Application::Plugin::GenVal::guts( $_[1] );
26	0				CGI::Application::Plugin::GenVal->export_to_level(1, @_);
27					}#sub
28
29					sub GenVal {
30					### Grab CGI::Application based object and keep a reference to it
31	0	0	0		unless ( $genval->{params}->{__ca_obj} ) {
32	0				$genval->{params}->{__ca_obj} = shift;
33					}#unless
34	0				return $genval;
35					}#sub
36
37
38					package CGI::Application::Plugin::GenVal::guts;
39
40	1		1	8	use strict;
	1			1
	1			43
41	1		1	7	use warnings;
	1			1
	1			114
42	1		1	8	use Carp;
	1			2
	1			83
43	1		1	301	use Perl6::Junction qw /any/;
	0
	0
44
45					### Create simple object
46					sub new {
47					my $class = shift;
48					my $obj = {};
49					bless( $obj, $class );
50					return $obj;
51					}#sub
52
53
54					### Method for generating a HTML input tag
55					sub gen_input {
56					my $self = shift;
57
58					### Make sure they aren't trying to call directly
59					croak( "Can only be called as a method" ) unless ( ref( $self ) eq 'CGI::Application::Plugin::GenVal::guts' );
60
61					### Get CGI::Application based object
62					my $ca = $self->{params}->{__ca_obj};
63
64					### Input must be passed in as a single hash reference
65					croak( 'Must receive a single hash reference' ) if ( @_ > 1 \|\| ref $_[0] ne 'HASH' );
66
67					my $input = shift;
68
69					my $inputhtml;
70
71					### Generate style attribute from input schema
72					### Styles default to {all} then overloaded with style for specific type
73					### values are cloned so as not to effect referenced data
74					my $attrib_raw = {};
75					if ( $input->{style}->{all}->{ $input->{error}->{type} }->{style} ) {
76					_gen_input_addstyle( $attrib_raw, $input->{style}->{all}->{ $input->{error}->{type} }->{style} );
77					}#if
78					if ( $input->{style}->{ $input->{details}->{type} }->{ $input->{error}->{type} }->{style} ) {
79					_gen_input_addstyle( $attrib_raw, $input->{style}->{ $input->{details}->{type} }->{ $input->{error}->{type} }->{style} );
80					}#if
81
82					### Create style attribute for CGI.pm HTML generation
83					my $attrib_final = _gen_input_tag( $attrib_raw );
84
85					### Create Text field
86					if ( $input->{details}->{type} eq 'text' ) {
87					return $ca->query->textfield(
88					-name=>$input->{field},
89					-value=>$input->{value},
90					-size=>$input->{details}->{size},
91					-maxlength=>$input->{details}->{max},
92					%$attrib_final,
93					);
94					}#if
95
96					### Create password field
97					elsif ( $input->{details}->{type} eq 'password' ) {
98					return $ca->query->password_field(
99					-name=>$input->{field},
100					-value=>$input->{value},
101					-size=>$input->{details}->{size},
102					-maxlength=>$input->{details}->{max},
103					%$attrib_final,
104					);
105					}#if
106
107					### Create select field
108					### Data for select fields is loaded from a subroutine or method
109					elsif ( $input->{details}->{type} eq 'select' ) {
110					my ( $labels, $values, $default );
111					if ( $input->{details}->{source} =~ /^sub self (.*?)$/ ) {
112					eval " ( \$labels, \$values, \$default ) = \$ca->$1( \$input->{value} ); ";
113					if ($@) {
114					croak( "Error getting values for select '$input->{field}': $@" );
115					# $ca->error( $ca->loc( "Error getting values for select '%1': %2", $field, $@ ) );
116					}#if
117					}#if
118					elsif ( $input->{details}->{source} =~ /^sub (.*?)$/ ) {
119					eval " ( \$labels, \$values, \$default ) = $1( \$input->{value} ); ";
120					if ($@) {
121					croak( "Error getting values for select '$input->{field}': $@" );
122					# $ca->error( $ca->loc( "Error getting values for select '%1': %2", $field, $@ ) );
123					}#if
124					}#elsif
125					return $ca->query->popup_menu(
126					-name=>$input->{field},
127					-values=>$values,
128					-default=>$default,
129					-labels=>$labels,
130					%$attrib_final,
131					);
132					}#if
133
134					### Load custom input HTML field
135					### All HTML for input field comes from a method or subroutine
136					### These are passed the field value and CGI.pm style attributes
137					if ( $input->{details}->{type} eq 'custom' ) {
138					my $html;
139					if ( $input->{details}->{source} =~ /^sub self (.*?)$/ ) {
140					eval " \$html = \$ca->$1( \$input->{value}, \$attrib_final ); ";
141					if ($@) {
142					croak( "Error getting html for custom field '$input->{field}': $@" );
143					# $ca->error( $ca->loc( "Error getting html for custom field '$field': $@" ) );
144					}#if
145					}#if
146					elsif ( $input->{details}->{source} =~ /^sub (.*?)$/ ) {
147					eval " \$html = $1( \$input->{value}, \$attrib_final ); ";
148					if ($@) {
149					croak( "Error getting html for custom field '$input->{field}': $@" );
150					# $ca->error( $ca->loc( "Error getting html for custom field '$field': $@" ) );
151					}#if
152					}#elsif
153					return $html;
154					}#if
155					}#sub
156
157
158					sub _gen_input_addstyle {
159					### Make sure they aren't trying to call directly
160					croak( "Cannot be called directly" ) unless ( caller eq 'CGI::Application::Plugin::GenVal::guts' );
161
162					### Clone referenced style data from %$list
163					my ( $attrib, $list ) = @_;
164					while( my ( $key, $value ) = each %$list ) {
165					$attrib->{style}->{$key} = $value;
166					}#while
167					}#sub
168
169
170					sub _gen_input_tag {
171					### Make sure they aren't trying to call directly
172					croak( "Cannot be called directly" ) unless ( caller eq 'CGI::Application::Plugin::GenVal::guts' );
173
174					### Create CGI.pm style tag
175					my ( $attrib ) = @_;
176					my $return = {};
177					while( my ( $key, $value ) = each %{ $attrib->{style} } ) {
178					$return->{'-style'} .= "$key: $value; ";
179					}#while
180					return $return;
181					}#sub
182
183
184					### Generate DFV (Data::FormValidator) profile for Perl and JavaScript
185					### Returns both profiles and YAML schema reference
186					sub gen_dfv {
187					my $self = shift;
188
189					### Make sure they aren't trying to call directly
190					croak( "Can only be called as a method" ) unless ( ref( $self ) eq 'CGI::Application::Plugin::GenVal::guts' );
191
192					### Get CGI::Application based object
193					my $ca = $self->{params}->{__ca_obj};
194
195					### Input must be passed in as a single hash reference
196					croak( 'Must receive a single hash reference' ) if ( @_ > 1 \|\| ref $_[0] ne 'HASH' );
197
198					my ( $dfv ) = shift;
199
200					### Some defaults
201					$dfv->{prefix} = 'err_' unless $dfv->{prefix};
202					$dfv->{any_errors} = 'some_errors' unless $dfv->{any_errors};
203					$dfv->{required} = [] unless $dfv->{any_errors};
204
205					### also accepts required, required_hash, constraints_loaded
206
207					### These two are required
208					unless ( $dfv->{schema} ) {
209					croak( 'Need input schema' );
210					}#unless
211					unless ( $dfv->{form} ) {
212					croak( 'Need input form' );
213					}#unless
214
215					### Load YAML schema from file unless it's passed in
216					unless ( ref $dfv->{schema} ) {
217					my $capackage = ref $ca;
218					if ( defined( &{ "${capackage}::YAML" } ) && ref( $ca->YAML ) eq 'CGI::Application::Plugin::YAML' ) {
219					$dfv->{schema} = $ca->YAML->LoadFile( $dfv->{schema} );
220					}#if
221					else {
222					require YAML::Any;
223					$dfv->{schema} = YAML::Any::LoadFile( $dfv->{schema} );
224					}#else
225					}#unless
226
227					### Make skeleton Perl profile
228					my $dfv_profile_perl = {
229					required => [],
230					optional => [],
231					constraint_methods => {},
232					msgs => {
233					prefix => $dfv->{prefix},
234					any_errors => $dfv->{any_errors},
235					%{ $dfv->{msgs} },
236					},
237					};
238
239					### Make skeleton JavaScript profile
240					my $dfv_profile_js = {
241					required => [],
242					optional => [],
243					constraints => {},
244					msgs => {
245					prefix => $dfv->{prefix},
246					any_errors => $dfv->{any_errors},
247					%{ $dfv->{msgs} },
248					},
249					};
250
251					### Generate required fields list from schema
252					while ( my ($field, $settings) = each ( %{ $dfv->{schema}->{field_input} } ) ) {
253					next if ( any( @{ $dfv->{required} } ) eq $field );
254					if ( $settings->{required} && lc $settings->{required} ne 'no' ) {
255					push( @{ $dfv->{required} }, $field );
256					}#if
257					}#while
258
259					### Generate optional fields, also required fields from required_hash
260					### required_hash can either be $hashref->{field}->{required} = 1
261					### or $hashref->{field} = 1
262					foreach my $field ( @{ $dfv->{schema}->{ $dfv->{form} } } ) {
263					next if ( any( @{ $dfv->{required} } ) eq $field );
264					if ( ref $dfv->{required_hash}->{$field} eq 'HASH' ) {
265					if ( $dfv->{required_hash}->{$field}->{required} ) {
266					push( @{ $dfv->{required} }, $field );
267					}#if
268					else {
269					push( @{ $dfv->{optional} }, $field );
270					}#else
271					}#if
272					else {
273					if ( $dfv->{required_hash}->{$field} ) {
274					push( @{ $dfv->{required} }, $field );
275					}#if
276					else {
277					push( @{ $dfv->{optional} }, $field );
278					}#else
279					}#else
280					}#foreach
281
282					### Load required and optional into perl and js profiles
283					$dfv_profile_perl->{required} = $dfv->{required};
284					$dfv_profile_perl->{optional} = $dfv->{optional};
285					$dfv_profile_js->{required} = $dfv->{required};
286					$dfv_profile_js->{optional} = $dfv->{optional};
287
288					### Generate constraints
289					### Perl regexps get compiled and put into the new style constraint_methods
290					### JavaScript ones do not
291					### A rough check is done to see if the regexp is JavaScript compatible
292					while ( my ($field, $settings) = each ( %{ $dfv->{schema}->{field_input} } ) ) {
293					### Check for array of constraints
294					if ( ref $settings->{constraint} eq 'ARRAY' ) {
295					foreach my $constraint ( @{ $settings->{constraint} } ) {
296					my ( $constraint_perl, $constraint_js );
297					### Check for hash ref
298					if ( ref $constraint eq 'HASH' ) {
299					( $constraint_perl, $constraint_js ) = _gen_dfv_constraints_hash( $dfv, $constraint );
300					}#if
301					else {
302					( $constraint_perl, $constraint_js ) = _gen_dfv_constraints( $dfv, $constraint );
303					}#else
304					### ??? Do I need to set [] first?
305					push( @{ $dfv_profile_perl->{constraint_methods}->{$field} }, $constraint_perl );
306					if ( $constraint_js ) {
307					push( @{ $dfv_profile_js->{constraints}->{$field} }, $constraint_js );
308					}#if
309					}#foreach
310					}#if
311					### Check for constraint hash
312					elsif ( ref $settings->{constraint} eq 'HASH' ) {
313					my ( $constraint_perl, $constraint_js ) = _gen_dfv_constraints_hash( $dfv, $settings->{constraint} );
314					$dfv_profile_perl->{constraint_methods}->{$field} = $constraint_perl;
315					if ( $constraint_js ) {
316					$dfv_profile_js->{constraints}->{$field} = $constraint_js;
317					}#if
318					}#elsif
319					### Load constraint
320					else {
321					my ( $constraint_perl, $constraint_js ) = _gen_dfv_constraints( $dfv, $settings->{constraint} );
322					$dfv_profile_perl->{constraint_methods}->{$field} = $constraint_perl;
323					if ( $constraint_js ) {
324					$dfv_profile_js->{constraints}->{$field} = $constraint_js;
325					}#if
326					}#else
327					}#while
328
329					### Use Data::JavaScript to convert the Perl JS profile to JavaScript code
330					require Data::JavaScript;
331					unless ( $ca->GenVal->{params}->{__JS_IMPORTED} ) {
332					import Data::JavaScript;
333					$ca->GenVal->{params}->{__JS_IMPORTED} = 1;
334					}#unless
335
336					my $jsprofile = jsdump('dfv_profile', $dfv_profile_js);
337
338					### Create the JavaScript validation function
339					my $jsverify = qq~
340					\n~;
355
356					return ( $dfv_profile_perl, $jsverify, $dfv->{schema} );
357					}#sub
358
359
360					### Generate dfv constraints
361					sub _gen_dfv_constraints {
362					### Make sure they aren't trying to call directly
363					croak( "Cannot be called directly" ) unless ( caller eq 'CGI::Application::Plugin::GenVal::guts' );
364
365					my ( $dfv, $constraint ) = @_;
366					my ( $return_perl, $return_js );
367
368					### Create subroutine references for Perl profile
369					## JS doesn't support this
370					if ( $constraint =~ /^subref (.*?)$/ ) {
371					$return_perl = \&{$1};
372					}#if
373
374					### Create methods
375					elsif ( $constraint =~ /^method (.*?)$/ ) {
376					my $method = $1;
377					my $methodname;
378					if ( $method =~ /^([a-z0-9_]*)?\(/i ) {
379					$methodname = $1;
380					}#if
381					else {
382					$methodname = $method;
383					}#else
384
385					### Load constraint methods from DFV::Constraints
386					unless ( $dfv->{constraints_loaded}->{$methodname} ) {
387					require Data::FormValidator::Constraints;
388					if ( any( @Data::FormValidator::Constraints::EXPORT_OK ) eq $methodname ) {
389					Data::FormValidator::Constraints->import( $methodname );
390					}#if
391					$dfv->{constraints_loaded}->{$methodname} = 1;
392					}#unless
393
394					### Load straight into Perl profile
395					my $evaltext = qq~\$return_perl = $method;~;
396					eval $evaltext;
397					die( "Error loading constraint method $method: $@" ) if $@;
398
399					### Extract paramater for conversion to JS
400					### New style DFV methods are converted to old style ones for JavaScript
401					if ( $method =~ /^(.*)?$\s?(.+?)\s?$$/ ) {
402					my $methodname = $1;
403					my $params = $2;
404					eval "\$params = [$params];";
405					die( "Error loading constraint params $params: $@" ) if $@;
406					### Remove FV_ from start of name
407					my $name = $methodname;
408					$name =~ s/^FV_//i;
409					$return_js = {
410					constraint => $methodname,
411					params => $params,
412					name => $name,
413					};
414					}#if
415					else {
416					$method =~ s/[]//g;
417					$return_js = $method;
418					}#else
419					}#elsif
420
421					### Create regexps
422					### Js compatible
423					elsif ( $constraint =~ m#^/.*?/i?$# ) {
424					### Compile regexp into Perl profile
425					my $evaltext = qq~\$return_perl = qr$constraint;~;
426					eval $evaltext;
427					die( "Error compiling regexp $constraint: $@" ) if $@;
428					### Pass to JS
429					$return_js = $constraint;
430					}#elsif
431
432					### Perl only
433					elsif ( $constraint =~ m#^/.?/[sixm]$# ) {
434					### Compile regexp into Perl profile
435					my $evaltext = qq~\$return_perl = qr$constraint;~;
436					eval $evaltext;
437					die( "Error compiling regexp $constraint: $@" ) if $@;
438					}#elsif
439					return ( $return_perl, $return_js );
440					}#sub
441
442
443					### Generate contraints from a hash with contraint details
444					sub _gen_dfv_constraints_hash {
445					### Make sure they aren't trying to call directly
446					croak( "Cannot be called directly" ) unless ( caller eq 'CGI::Application::Plugin::GenVal::guts' );
447
448					my ( $dfv, $constraint ) = @_;
449
450					### Prepare return variables
451					my ( $return_perl, $return_js ) = ( {}, {} );
452
453					### Generate constraint from {constraint} key
454					my ( $constraint_perl, $constraint_js ) = _gen_dfv_constraints( $dfv, $constraint->{constraint} );
455					$return_perl->{constraint_method} = $constraint_perl;
456					if ( $constraint_js ) {
457					$return_js = $constraint_js;
458					}#if
459
460					### Copy additional contraint details
461					while ( my ($key, $value) = each ( %$constraint ) ) {
462					next if ( $key eq 'constraint' );
463					$return_perl->{$key} = $value;
464					if ( $return_js->{constraint} ) {
465					$return_js->{$key} = $value;
466					}#if
467					}#while
468					$return_js = undef unless ( keys %$return_js );
469					return ( $return_perl, $return_js );
470					}#sub
471
472
473					1;
474
475					__END__