File Coverage

blib/lib/Data/MuForm/Field.pm
Criterion Covered Total %
statement 334 379 88.1
branch 162 208 77.8
condition 36 60 60.0
subroutine 76 85 89.4
pod 11 70 15.7
total 619 802 77.1


line stmt bran cond sub pod time code
1             package Data::MuForm::Field;
2             # ABSTRACT: Base field package
3 92     92   45466 use Moo;
  92         117  
  92         401  
4 92     92   21516 use Types::Standard -types;
  92         418198  
  92         810  
5 92     92   250654 use Try::Tiny;
  92         19012  
  92         4791  
6 92     92   373 use Scalar::Util ('blessed', 'weaken');
  92         111  
  92         3650  
7 92     92   9025 use Data::Clone ('data_clone');
  92         23398  
  92         3255  
8 92     92   8657 use Data::MuForm::Localizer;
  92         150  
  92         1807  
9 92     92   8590 use Data::MuForm::Merge ('merge');
  92         135  
  92         243461  
10             with 'Data::MuForm::Common';
11              
12             has 'name' => ( is => 'rw', required => 1 );
13             has 'id' => ( is => 'rw', lazy => 1, builder => 'build_id' );
14             sub build_id {
15 78     78 1 5639 my $self = shift;
16 78 100 33     200 if ( my $meth = $self->get_method('build_id') ) {
    50          
17 3         10 return $meth->($self, @_);
18             }
19             elsif ( $self->form && $self->form->can('build_field_id') ) {
20 0         0 return $self->form->build_field_id($self);
21             }
22 75         2726 return $self->prefixed_name;
23             }
24             has 'prefixed_name' => ( is => 'rw', lazy => 1, builder => 'build_prefixed_name');
25             sub build_prefixed_name {
26 76     76 0 5087 my $self = shift;
27 76 50 33     1126 my $prefix = ( $self->form && $self->form->field_prefix ) ? $self->field_prefix. "." : '';
28 76         1925 return $prefix . $self->full_name;
29             }
30             has 'form' => ( is => 'rw', weak_ref => 1, predicate => 'has_form' );
31             has 'type' => ( is => 'ro', required => 1, default => 'Text' );
32             has 'default' => ( is => 'rw' );
33             has 'input' => ( is => 'rw', predicate => 'has_input', clearer => 'clear_input' );
34             has 'input_without_param' => ( is => 'rw', predicate => 'has_input_without_param' );
35             has 'value' => ( is => 'rw', predicate => 'has_value', clearer => 'clear_value' );
36             has 'init_value' => ( is => 'rw', predicate => 'has_init_value', clearer => 'clear_init_value' );
37             has 'no_value_if_empty' => ( is => 'rw' );
38             has 'input_param' => ( is => 'rw' );
39             has 'filled_from' => ( is => 'rw', clearer => 'clear_filled_from' );
40             has 'password' => ( is => 'rw', default => 0 );
41             has 'accessor' => ( is => 'rw', lazy => 1, builder => 'build_accessor' );
42             sub build_accessor {
43 443     443 0 19494 my $self = shift;
44 443         823 my $accessor = $self->name;
45 443 50       878 $accessor =~ s/^(.*)\.//g if ( $accessor =~ /\./ );
46 443         2118 return $accessor;
47             }
48             has 'custom' => ( is => 'rw' );
49             has 'parent' => ( is => 'rw', predicate => 'has_parent', weak_ref => 1 );
50             has 'source' => ( is => 'rw' );
51             has 'errors' => ( is => 'rw', isa => ArrayRef, default => sub {[]} );
52 663     663 0 11335 sub has_errors { my $self = shift; return scalar @{$self->errors}; }
  663         507  
  663         10716  
53 18     18 0 545 sub all_errors { my $self = shift; return @{$self->errors}; }
  18         12  
  18         247  
54 750     750 0 4048 sub clear_errors { $_[0]->{errors} = [] }
55       343 0   sub clear_error_fields { }
56              
57             # this is a permanent setting of active
58             has 'active' => ( is => 'rw', default => 1 );
59             # this is a temporary active set on the process call, cleared on clear_data
60             has '_active' => ( is => 'rw', predicate => '_has_active', clearer => '_clear_active' );
61 1     1 0 11 sub clear_inactive { $_[0]->active(1) }
62 0 0   0 1 0 sub inactive { return ( shift->active ? 0 : 1 ) }
63             sub is_active {
64 4945     4945 1 3503 my $self = shift;
65 4945 100       7780 return $self->_active if $self->_has_active;
66 4933         14299 return $self->active;
67             }
68       418 0   sub multiple { }
69 2     2 1 15 sub is_inactive { ! $_[0]->is_active }
70             has 'disabled' => ( is => 'rw', default => 0 );
71             has 'no_update' => ( is => 'rw', default => 0 );
72             has 'writeonly' => ( is => 'rw', default => 0 );
73             has 'is_contains' => ( is => 'rw' );
74             has 'apply' => ( is => 'rw', default => sub {[]} ); # for field defnitions
75 0     0 0 0 sub has_apply { return scalar @{$_[0]->{apply}} }
  0         0  
76             has 'base_apply' => ( is => 'rw', builder => 'build_base_apply' ); # for field classes
77 634     634 0 12084 sub build_base_apply {[]}
78 0     0 0 0 sub has_base_apply { return scalar @{$_[0]->{base_apply}} }
  0         0  
79             has 'trim' => ( is => 'rw', default => sub { *default_trim } );
80             sub default_trim {
81 525     525 0 581 my $value = shift;
82 525 100       769 return unless defined $value;
83 523 100       1139 my @values = ref $value eq 'ARRAY' ? @$value : ($value);
84 523         719 for (@values) {
85 561 100 100     1849 next if ref $_ or !defined;
86 478         823 s/^\s+//;
87 478         925 s/\s+$//;
88             }
89 523 100       1778 return ref $value eq 'ARRAY' ? \@values : $values[0];
90             }
91       2098 0   sub has_fields { } # compound fields will override
92             has 'methods' => ( is => 'rw', isa => HashRef, builder => 'build_methods', trigger => 1 );
93 637     637 0 18090 sub build_methods {{}}
94             sub _trigger_methods {
95 6     6   174 my ( $self, $new_methods ) = @_;
96 6         20 my $base_methods = $self->build_methods;
97 6         26 my $methods = merge($new_methods, $base_methods);
98 6         99 $self->{methods} = $methods;
99              
100             }
101             sub get_method {
102 1527     1527 0 1523 my ( $self, $meth_name ) = @_;
103 1527         5745 return $self->{methods}->{$meth_name};
104             }
105              
106             has 'validate_when_empty' => ( is => 'rw' );
107             has 'not_nullable' => ( is => 'rw' );
108       1089 0   sub is_repeatable {}
109       3 0   sub is_compound {}
110 128     128 0 1221 sub is_form {0}
111 289     289 0 756 sub no_fif {0}
112              
113             around BUILDARGS => sub {
114             my ( $orig, $class, %field_attr ) = @_;
115              
116             munge_field_attr(\%field_attr);
117              
118             return $class->$orig(%field_attr);
119             };
120              
121              
122             sub BUILD {
123 636     636 0 6704 my $self = shift;
124              
125 636 100       8643 if ( $self->form ) {
126             # To avoid memory cycles it needs to be weakened when
127             # it's set through a form.
128 588         26472 weaken($self->{localizer});
129 588         1160 weaken($self->{renderer});
130             }
131             else {
132             # Vivify. This would generally only happen in a standalone field, in tests.
133 48         5066 $self->localizer;
134 48         12269 $self->renderer;
135             }
136              
137 636         2298 $self->_install_methods;
138             }
139              
140             sub _install_methods {
141 636     636   672 my $self = shift;
142              
143 636 100       10432 if ( $self->form ) {
144 588         3957 my $suffix = $self->convert_full_name($self->full_name);
145 588         1065 foreach my $prefix ( 'validate', 'default' ) {
146 1176 100       21375 next if exists $self->methods->{$prefix};
147 1175         43522 my $meth_name = "${prefix}_$suffix";
148 1175 100       14605 if ( my $meth = $self->form->can($meth_name) ) {
149             my $wrap_sub = sub {
150 26     26   36 my $self = shift;
151 26         452 return $self->form->$meth($self);
152 19         169 };
153 19         128 $self->{methods}->{$prefix} = $wrap_sub;
154             }
155             }
156             }
157             }
158              
159              
160             sub fif {
161 423     423 1 5382 my $self = shift;
162 423 50       552 return unless $self->is_active;
163 423 50       909 return '' if $self->password;
164 423 100       1489 return $self->input if $self->has_input;
165 204 100       422 if ( $self->has_value ) {
166 122         258 my $value = $self->value;
167 122 100       309 $value = $self->transform_value_to_fif->($self, $value) if $self->has_transform_value_to_fif;
168 122         273 return $value;
169             }
170 82         370 return '';
171             }
172              
173              
174             sub full_name {
175 2019     2019 1 4383 my $field = shift;
176              
177 2019         3680 my $name = $field->name;
178 2019         2205 my $parent_name;
179             # field should always have a parent unless it's a standalone field test
180 2019 100       25641 if ( $field->parent ) {
181 2004         57631 $parent_name = $field->parent->full_name;
182             }
183 2019 100 100     14518 return $name unless defined $parent_name && length $parent_name;
184 550         1957 return $parent_name . '.' . $name;
185             }
186              
187             sub full_accessor {
188 0     0 1 0 my $field = shift;
189              
190 0         0 my $parent = $field->parent;
191 0 0       0 if( $field->is_contains ) {
192 0 0       0 return '' unless $parent;
193 0         0 return $parent->full_accessor;
194             }
195 0         0 my $accessor = $field->accessor;
196 0         0 my $parent_accessor;
197 0 0       0 if ( $parent ) {
198 0         0 $parent_accessor = $parent->full_accessor;
199             }
200 0 0 0     0 return $accessor unless defined $parent_accessor && length $parent_accessor;
201 0         0 return $parent_accessor . '.' . $accessor;
202             }
203              
204              
205             #====================
206             # Localization
207             #====================
208              
209             sub localize {
210 95     95 0 274 my ( $self, @message ) = @_;
211 95         1432 return $self->localizer->loc_($message[0]);
212             }
213              
214             has 'language' => ( is => 'rw', lazy => 1, builder => 'build_language' );
215 33     33 0 5649 sub build_language { 'en' }
216             has 'localizer' => (
217             is => 'rw', lazy => 1, builder => 'build_localizer',
218             );
219             sub build_localizer {
220 33     33 0 5162 my $self = shift;
221 33         318 return Data::MuForm::Localizer->new(
222             language => $self->language,
223             );
224             }
225              
226             #====================
227             # Rendering
228             #====================
229             has 'label' => ( is => 'rw', lazy => 1, builder => 'build_label' );
230             sub build_label {
231 97     97 1 8644 my $self = shift;
232 97 100       242 if ( my $meth = $self->get_method('build_label' ) ) {
233 1         4 return $meth->($self);
234             }
235 96         229 my $label = $self->name;
236 96         142 $label =~ s/_/ /g;
237 96         186 $label = ucfirst($label);
238 96         515 return $label;
239             }
240             sub loc_label {
241 95     95 0 1287 my $self = shift;
242 95         1314 return $self->localize($self->label);
243             }
244             has 'form_element' => ( is => 'rw', lazy => 1, builder => 'build_form_element' );
245 61     61 0 3668 sub build_form_element { 'input' }
246             has 'input_type' => ( is => 'rw', lazy => 1, builder => 'build_input_type' );
247 20     20 0 2400 sub build_input_type { 'text' }
248              
249             # could have everything in one big "pass to the renderer" hash?
250             has 'layout' => ( is => 'rw' );
251             has 'layout_group' => ( is => 'rw' );
252             has 'order' => ( is => 'rw', default => 0 );
253             has 'html5_type_attr' => ( is => 'rw' );
254              
255             sub base_render_args {
256 83     83 0 811 my $self = shift;
257 83   50     1256 my $args = {
258             name => $self->prefixed_name,
259             field_name => $self->name,
260             type => $self->type,
261             form_element => $self->form_element,
262             input_type => $self->input_type,
263             id => $self->id,
264             label => $self->loc_label,
265             required => $self->required,
266             errors => $self->errors || [],
267             fif => $self->fif,
268             layout_type => 'standard',
269             is_contains => $self->is_contains,
270             };
271 83         230 return $args;
272             }
273              
274             has 'render_args' => ( is => 'rw', lazy => 1, isa => HashRef, builder => 'build_render_args' );
275 58     58 0 7385 sub build_render_args {{}}
276             # this is really just here for testing fields. If you want to test a custom
277             # renderer in a field, pass it in.
278             has 'renderer' => (
279             is => 'rw', lazy => 1,
280             builder => 'build_renderer',
281             );
282             sub build_renderer {
283 33     33 0 5235 my $self = shift;
284 33         8132 require Data::MuForm::Renderer::Base;
285 33         743 return Data::MuForm::Renderer::Base->new( localizer => $self->localizer );
286             }
287              
288             sub get_render_args {
289 83     83 0 150 my ( $self, %args ) = @_;
290 83         1348 my $render_args = merge( $self->render_args, $self->base_render_args );
291 83         257 $render_args = merge( \%args, $render_args );
292 83         245 return $render_args;
293             }
294              
295             sub render {
296 57     57 0 244 my ( $self, $rargs ) = @_;
297 57         172 munge_render_field_attr($rargs);
298 57         185 my $render_args = $self->get_render_args(%$rargs);
299 57         1013 return $self->renderer->render_field($render_args);
300             }
301              
302             sub render_element {
303 9     9 0 106 my ( $self, $rargs ) = @_;
304 9         21 my $args = { element_attr => $rargs };
305 9         14 my $do_errors = delete $rargs->{do_errors};
306 9 50       30 $args->{do_errors} = defined $do_errors ? $do_errors : 1;
307 9         44 my $render_args = $self->get_render_args(%$args);
308 9         170 return $self->renderer->render_element($render_args);
309             }
310              
311             sub render_errors {
312 1     1 0 10 my ( $self, $rargs ) = @_;
313 1         3 my $render_args = $self->get_render_args( error_attr => $rargs );
314 1         19 return $self->renderer->render_errors($render_args);
315             }
316              
317             sub render_label {
318 1     1 0 10 my ( $self, $rargs, @args ) = @_;
319 1         4 my $render_args = $self->get_render_args( label_attr => $rargs );
320 1 50       19 $self->form->render_hook($render_args) if $self->form;
321 1         17 return $self->renderer->render_label($render_args, @args);
322             }
323              
324              
325             #===================
326             # Errors
327             #===================
328              
329             # handles message with and without variables
330             sub add_error {
331 109     109 1 560 my ( $self, @message ) = @_;
332 109         97 my $out;
333 109 100       293 if ( $message[0] !~ /{/ ) {
334 72         1228 $out = $self->localizer->loc_($message[0]);
335             }
336             else {
337 37         562 $out = $self->localizer->loc_x(@message);
338             }
339 109         600 return $self->push_error($out);
340             }
341              
342             sub add_error_px {
343 0     0 0 0 my ( $self, @message ) = @_;
344 0         0 my $out = $self->localizer->loc_px(@message);
345 0         0 return $self->push_error($out);;
346             }
347              
348             sub add_error_nx {
349 1     1 0 2 my ( $self, @message ) = @_;
350 1         21 my $out = $self->localizer->loc_nx(@message);
351 1         20 return $self->push_error($out);
352             }
353              
354             sub add_error_npx {
355 0     0 0 0 my ( $self, @message ) = @_;
356 0         0 my $out = $self->localizer->loc_npx(@message);
357 0         0 return $self->push_error($out);;
358             }
359              
360              
361              
362             sub push_error {
363 110     110 1 130 my $self = shift;
364 110         106 push @{$self->{errors}}, @_;
  110         277  
365 110 100       1872 if ( $self->parent ) {
366 65         1166 $self->parent->propagate_error($self);
367             }
368             }
369              
370 7     7 0 3720 sub clear { shift->clear_data }
371              
372             #===================
373             # Transforms
374             #===================
375              
376             # these are all coderefs
377             has 'transform_param_to_input' => ( is => 'rw', predicate => 'has_transform_param_to_input' );
378             has 'transform_input_to_value' => ( is => 'rw', predicate => 'has_transform_input_to_value' );
379             has 'transform_default_to_value' => ( is => 'rw', predicate => 'has_transform_default_to_value' );
380             has 'transform_value_after_validate' => ( is => 'rw', predicate => 'has_transform_value_after_validate' );
381             has 'transform_value_to_fif' => ( is => 'rw', predicate => 'has_transform_value_to_fif' );
382              
383             #====================================================================
384             # Validation
385             #====================================================================
386              
387             has 'required' => ( is => 'rw', default => 0 );
388             has 'required_when' => ( is => 'rw', isa => HashRef, predicate => 'has_required_when' );
389             has 'unique' => ( is => 'rw', predicate => 'has_unique' );
390 1 50   1 0 10 sub validated { !$_[0]->has_errors && $_[0]->has_input }
391       198 0   sub normalize_input { } # intended for field classes, to make sure input is in correct form, mostly multiple or not
392              
393             sub input_defined {
394 585     585 0 619 my ($self) = @_;
395 585 50       991 return unless $self->has_input;
396 585         985 return has_some_value( $self->input );
397             }
398              
399             sub has_some_value {
400 682     682 0 636 my $x = shift;
401              
402 682 100       977 return unless defined $x;
403 678 100       3083 return $x =~ /\S/ if !ref $x;
404 94 100       265 if ( ref $x eq 'ARRAY' ) {
405 23         42 for my $elem (@$x) {
406 24 100       50 return 1 if has_some_value($elem);
407             }
408 3         11 return 0;
409             }
410 71 50       135 if ( ref $x eq 'HASH' ) {
411 71         148 for my $key ( keys %$x ) {
412 73 100       139 return 1 if has_some_value( $x->{$key} );
413             }
414 7         23 return 0;
415             }
416 0 0       0 return 1 if blessed($x); # true if blessed, otherwise false
417 0 0       0 return 1 if ref( $x );
418 0         0 return;
419             }
420              
421              
422              
423       0 0   sub base_validate { }
424 442     442 1 3179 sub validate {1}
425              
426             sub field_validate {
427 610     610 0 41129 my $self = shift;
428              
429 610 50 66     1119 return if ( $self->has_fields && $self->skip_fields_without_input && ! $self->has_input );
      33        
430              
431 610         1394 $self->normalize_input;
432              
433 610         984 my $continue_validation = 1;
434 610 100 66     3968 if ( ( $self->required ||
    100 100        
    100 100        
    100          
435             ( $self->has_required_when && $self->match_when($self->required_when) ) ) &&
436             ( ! $self->has_input || ! $self->input_defined )) {
437 24         123 $self->add_error( $self->get_message('required'), field_label => $self->label );
438 24 100       994 if( $self->has_input ) {
439 16 50       165 $self->not_nullable ? $self->value($self->input) : $self->value(undef);
440             }
441              
442 24         33 $continue_validation = 0;
443             }
444             elsif ( $self->is_repeatable ) { }
445             elsif ( !$self->has_input ) {
446 39         46 $continue_validation = 0;
447             }
448             elsif ( !$self->input_defined ) {
449 19 100 100     207 if ( $self->not_nullable ) {
    100          
450 3         28 $self->value($self->input);
451             # handles the case where a compound field value needs to have empty subfields
452 3 50       19 $continue_validation = 0 unless $self->is_compound;
453             }
454             elsif ( $self->no_value_if_empty || $self->is_contains ) {
455 2         3 $continue_validation = 0;
456             }
457             else {
458 14         90 $self->value(undef);
459 14         23 $continue_validation = 0;
460             }
461             }
462 610 50 66     1422 return if ( !$continue_validation && !$self->validate_when_empty );
463              
464              
465 528 100       765 if ( $self->has_fields ) {
466 75         339 $self->fields_validate;
467             }
468             else {
469 453         640 my $input = $self->input;
470 453 100       1102 $input = $self->transform_input_to_value->($self, $input) if $self->has_transform_input_to_value;
471 453         1241 $self->value($input);
472             }
473              
474 528 100       2432 $self->value( $self->trim->($self->value) ) if $self->trim;
475              
476 528         1744 $self->validate($self->value); # this is field class validation. Do it before the other validations.
477              
478 528         2746 $self->apply_actions; # this could be either from the field definitions or from a custom field
479              
480             # this is validate_<field name> or methods->{validate => ...} validation
481 528 100       1330 if ( my $meth = $self->get_method('validate') ) {
482 19         30 $meth->($self);
483             }
484              
485 528 100       1515 if ( $self->has_transform_value_after_validate ) {
486 6         12 my $value = $self->value;
487 6         24 $value = $self->transform_value_after_validate->($self, $value);
488 6         35 $self->value($value);
489             }
490              
491 528         996 return ! $self->has_errors;
492             }
493              
494             sub transform_and_set_input {
495 416     416 0 396 my ( $self, $input ) = @_;
496 416 100       1016 $input = $self->transform_param_to_input->($self, $input) if $self->has_transform_param_to_input;
497 416         867 $self->input($input);
498             }
499              
500              
501             sub apply_actions {
502 528     528 0 494 my $self = shift;
503              
504 528         389 my $error_message;
505             local $SIG{__WARN__} = sub {
506 2     2   15 my $error = shift;
507 2         3 $error_message = $error;
508 2         14 return 1;
509 528         2491 };
510              
511             my $is_type = sub {
512 229 100   229   750 my $class = blessed shift or return;
513 183   33     584 return $class eq 'MooseX::Types::TypeDecorator' || $class->isa('Type::Tiny');
514 528         1109 };
515              
516 528         455 my @actions;
517 528         452 push @actions, @{ $self->base_apply }, @{ $self->apply };
  528         1198  
  528         1068  
518 528         2211 for my $action ( @actions ) {
519 134         460 $error_message = undef;
520             # the first time through value == input
521 134         157 my $value = $self->value;
522 134         101 my $new_value = $value;
523             # Moose constraints
524 134 100 66     349 if ( !ref $action || $is_type->($action) ) {
525 88         886 $action = { type => $action };
526             }
527 134 100       296 if ( my $when = $action->{when} ) {
528 6 100       15 next unless $self->match_when($when);
529             }
530 131 100       262 if ( exists $action->{type} ) {
    100          
    100          
    100          
    50          
531 95         69 my $tobj;
532 95 50       140 if ( $is_type->($action->{type}) ) {
533 95         571 $tobj = $action->{type};
534             }
535             else {
536 0         0 my $type = $action->{type};
537 0 0       0 $tobj = Moose::Util::TypeConstraints::find_type_constraint($type) or
538             die "Cannot find type constraint $type";
539             }
540 95 100 100     214 if ( $tobj->has_coercion && $tobj->validate($value) ) {
541 14         486 eval { $new_value = $tobj->coerce($value) };
  14         36  
542 14 50       39 if ($@) {
543 0 0       0 if ( $tobj->has_message ) {
544 0         0 $error_message = $tobj->message->($value);
545             }
546             else {
547 0         0 $error_message = $@;
548             }
549             }
550             else {
551 14         35 $self->value($new_value);
552             }
553              
554             }
555 95   66     928 $error_message ||= $tobj->validate($new_value);
556             }
557             # now maybe: http://search.cpan.org/~rgarcia/perl-5.10.0/pod/perlsyn.pod#Smart_matching_in_detail
558             # actions in a hashref
559             elsif ( ref $action->{check} eq 'CODE' ) {
560 11 100       29 if ( !$action->{check}->($value, $self) ) {
561 3         21 $error_message = $self->get_message('wrong_value');
562             }
563             }
564             elsif ( ref $action->{check} eq 'Regexp' ) {
565 6 100       29 if ( $value !~ $action->{check} ) {
566 5         23 $error_message = [$self->get_message('no_match'), 'value', $value];
567             }
568             }
569             elsif ( ref $action->{check} eq 'ARRAY' ) {
570 5 100       7 if ( !grep { $value eq $_ } @{ $action->{check} } ) {
  5         10  
  5         11  
571 4         10 $error_message = [$self->get_message('not_allowed'), 'value', $value];
572             }
573             }
574             elsif ( ref $action->{transform} eq 'CODE' ) {
575 14         16 $new_value = eval {
576 92     92   512 no warnings 'all';
  92         198  
  92         89587  
577 14         29 $action->{transform}->($value, $self);
578             };
579 14 50       37 if ($@) {
580 0   0     0 $error_message = $@ || $self->get_message('error_occurred');
581             }
582             else {
583 14         23 $self->value($new_value);
584             }
585             }
586 131 100       2640 if ( defined $error_message ) {
587 50 100       139 my @message = ref $error_message eq 'ARRAY' ? @$error_message : ($error_message);
588 50 100       92 if ( defined $action->{message} ) {
589 13         16 my $act_msg = $action->{message};
590 13 100       29 if ( ref $act_msg eq 'CODE' ) {
591 3         10 $act_msg = $act_msg->($value, $self, $error_message);
592             }
593 13 100       55 if ( ref $act_msg eq 'ARRAY' ) {
    50          
594 3         3 @message = @{$act_msg};
  3         8  
595             }
596             elsif ( ref \$act_msg eq 'SCALAR' ) {
597 10         18 @message = ($act_msg);
598             }
599             }
600 50         126 $self->add_error(@message);
601             }
602             }
603             }
604              
605             sub match_when {
606 12     12 0 460 my ( $self, $when ) = @_;
607              
608 12         12 my $matched = 0;
609 12         24 foreach my $key ( keys %$when ) {
610 12         16 my $check_against = $when->{$key};
611 12         21 my $from_form = ( $key =~ /^\+/ );
612 12         16 $key =~ s/^\+//;
613 12 100       222 my $field = $from_form ? $self->form->field($key) : $self->parent->subfield( $key );
614 12 50       65 unless ( $field ) {
615 0         0 warn "field '$key' not found processing 'when' for '" . $self->full_name . "'";
616 0         0 next;
617             }
618 12 50       33 my $field_fif = defined $field->fif ? $field->fif : '';
619 12 100       45 if ( ref $check_against eq 'CODE' ) {
    100          
    100          
620 4 100       15 $matched++
621             if $check_against->($field_fif, $self);
622             }
623             elsif ( ref $check_against eq 'ARRAY' ) {
624 2         4 foreach my $value ( @$check_against ) {
625 6 100       12 $matched++ if ( $value eq $field_fif );
626             }
627             }
628             elsif ( $check_against eq $field_fif ) {
629 3         5 $matched++;
630             }
631             else {
632 3         2 $matched = 0;
633 3         6 last;
634             }
635             }
636 12         70 return $matched;
637             }
638              
639             #====================================================================
640             # Filling
641             #====================================================================
642              
643             sub fill_from_params {
644 410     410 0 722 my ( $self, $input, $exists ) = @_;
645              
646 410         813 $self->filled_from('params');
647 410 100       762 if ( $exists ) {
    100          
    100          
648 341         655 $self->transform_and_set_input($input);
649             }
650             elsif ( $self->disabled ) {
651             }
652             elsif ( $self->has_input_without_param ) {
653 20         150 $self->transform_and_set_input($self->input_without_param);
654             }
655 410         593 return;
656             }
657              
658             sub fill_from_object {
659 210     210 0 313 my ( $self, $value ) = @_;
660              
661 210         408 $self->filled_from('object');
662 210         518 $self->value($value);
663              
664 210 50       3023 if ( $self->form ) {
665 210         3206 $self->form->init_value( $self, $value );
666             }
667             else {
668 0         0 $self->init_value($value);
669             #$result->_set_value($value);
670             }
671 210 50       1143 $self->value(undef) if $self->writeonly;
672              
673 210         336 return;
674             }
675              
676             sub fill_from_fields {
677 588     588 0 1126 my ( $self ) = @_;
678              
679 588 100       2664 if ( my @values = $self->get_default_value ) {
680 36 100       144 if ( $self->has_transform_default_to_value ) {
681 2         7 @values = $self->transform_default_to_value->($self, @values);
682             }
683 36 50       84 my $value = @values > 1 ? \@values : shift @values;
684 36 50       59 if ( defined $value ) {
685 36         86 $self->init_value($value);
686 36         136 $self->value($value);
687             }
688             }
689 588         740 return;
690             }
691              
692              
693             sub clear_data {
694 294     294 0 273 my $self = shift;
695 294         3577 $self->clear_input;
696 294         14398 $self->clear_value;
697 294         13048 $self->clear_errors;
698 294         3389 $self->_clear_active;
699 294         12998 $self->clear_filled_from;
700             }
701              
702             sub get_default_value {
703 716     716 0 578 my $self = shift;
704 716 100       1328 if ( my $meth = $self->get_method('default') ) {
    100          
705 10         28 return $meth->($self);
706             }
707             elsif ( defined $self->default ) {
708 37         114 return $self->default;
709             }
710 669         1435 return;
711             }
712              
713              
714             #====================================================================
715             # Messages
716             #====================================================================
717              
718             has 'messages' => ( is => 'rw', isa => HashRef, default => sub {{}} );
719 4     4   9 sub _get_field_message { my ($self, $msg) = @_; return $self->{messages}->{$msg}; }
  4         71  
720 66     66   76 sub _has_field_message { my ($self, $msg) = @_; exists $self->{messages}->{$msg}; }
  66         207  
721 0     0 0 0 sub set_message { my ($self, $msg, $value) = @_; $self->{messages}->{$msg} = $value; }
  0         0  
722              
723              
724             our $class_messages = {
725             'field_invalid' => 'field is invalid',
726             'range_too_low' => 'Value must be greater than or equal to [_1]',
727             'range_too_high' => 'Value must be less than or equal to [_1]',
728             'range_incorrect' => 'Value must be between {start} and {end}',
729             'wrong_value' => 'Wrong value',
730             'no_match' => '[_1] does not match',
731             'not_allowed' => '[_1] not allowed',
732             'error_occurred' => 'error occurred',
733             'required' => "'{field_label}' field is required",
734             'unique' => 'Duplicate value for [_1]', # this is used in the DBIC model
735             };
736              
737             sub get_class_messages {
738 61     61 0 1242 my $self = shift;
739 61         417 my $messages = { %$class_messages };
740 61         532 return $messages;
741             }
742              
743             sub get_message {
744 66     66 0 107 my ( $self, $msg ) = @_;
745              
746             # first look in messages set on individual field
747 66 100       218 return $self->_get_field_message($msg)
748             if $self->_has_field_message($msg);
749             # then look at form messages
750 62 100 100     936 return $self->form->_get_form_message($msg)
751             if $self->has_form && $self->form->_has_form_message($msg);
752             # then look for messages up through inherited field classes
753 61         8489 return $self->get_class_messages->{$msg};
754             }
755             sub all_messages {
756 0     0 0 0 my $self = shift;
757 0 0       0 my $form_messages = $self->has_form ? $self->form->messages : {};
758 0   0     0 my $field_messages = $self->messages || {};
759 0   0     0 my $lclass_messages = $self->my_class_messages || {};
760 0         0 return {%{$lclass_messages}, %{$form_messages}, %{$field_messages}};
  0         0  
  0         0  
  0         0  
761             }
762              
763             sub clone {
764 4892     4892 0 3520 my $self = shift;
765 4892         89579 return data_clone($self);
766             }
767              
768             sub get_result {
769 2     2 0 3 my $self = shift;
770 2         7 my $result = {
771             name => $self->name,
772             full_name => $self->full_name,
773             id => $self->id,
774             label => $self->label,
775             render_args => $self->render_args,
776             fif => $self->fif,
777             };
778 2 50       6 $result->{errors} = $self->errors if $self->has_errors;
779 2         411 return $result;
780             }
781              
782             sub convert_full_name {
783 632     632 0 769 my ( $self, $full_name ) = @_;
784 632         901 $full_name =~ s/\.\d+\./_/g;
785 632         935 $full_name =~ s/\./_/g;
786 632         954 return $full_name;
787             }
788              
789              
790             1;
791              
792             __END__
793              
794             =pod
795              
796             =encoding UTF-8
797              
798             =head1 NAME
799              
800             Data::MuForm::Field - Base field package
801              
802             =head1 VERSION
803              
804             version 0.03
805              
806             =head1 SYNOPSIS
807              
808             Instances of Field subclasses are generally built by L<Data::MuForm>
809             from 'has_field' declarations or the field_list.
810              
811             has_field 'my_field' => ( type => 'Integer' );
812             field_list => [
813             my_field => { type => 'Integer' }
814             ]
815              
816             Fields can also be added with add_field:
817              
818             $form->add_field( name => 'my_field', type => 'Integer' );
819              
820             You can create custom field classes:
821              
822             package MyApp::Field::MyText;
823             use Moo;
824             use Data::MuForm::Meta;
825             extends 'Data::MuForm::Field::Text';
826              
827             has 'my_attribute' => ( is => 'rw' );
828              
829             sub validate { <perform validation> }
830              
831             1;
832              
833             =head1 DESCRIPTION
834              
835             This is the base class for form fields. The 'type' of a field class
836             is used in the MuForm field_list or has_field to identify which field class to
837             load from the 'field_namespace' (or directly, when prefixed with '+').
838             If the type is not specified, it defaults to Text.
839              
840             See L<Data::MuForm::Manual::Fields> for a list of the fields and brief
841             descriptions of their structure.
842              
843             =head1 NAME
844              
845             Data::MuForm::Field
846              
847             =head1 ATTRIBUTES
848              
849             =head2 Names, types, accessor
850              
851             =over
852              
853             =item name
854              
855             The name of the field. Used in the HTML form. Often a db accessor.
856             The only required attribute.
857              
858             =item type
859              
860             The class or type of the field. The 'type' of L<Data::MuForm::Field::Currency>
861             is 'Currency'. Classes that you define yourself are prefixed with '+'.
862              
863             =item id
864              
865             The id to use when rendering.
866              
867             =item accessor
868              
869             If the name of your field is different than your database accessor, use
870             this attribute to provide the accessor.
871              
872             =item full_name
873              
874             The name of the field with all parents:
875              
876             'event.start_date.month'
877              
878             =item full_accessor
879              
880             The field accessor with all parents.
881              
882             =item prefixed_name
883              
884             The full_name plus the prefix provided in 'field_prefix'. Useful for multiple
885             forms on the same page.
886              
887             =item input_param
888              
889             By default we expect an input parameter based on the field name. This allows
890             you to look for a different input parameter.
891              
892             =back
893              
894             =head2 Field data
895              
896             =over
897              
898             =item active, inactive, is_active, is_inactive
899              
900             Determines which fields will be processed and rendered.
901              
902             Can be changed on a process call, and cleared afterward:
903              
904             $form->process( active => [ 'foo', 'bar' ], params => $params );
905              
906             You can use the is_inactive and is_active methods to check whether this particular
907             field is active. May be necessary to use in templates if you're changing the
908             active/inactive of some fields.
909              
910             if( $form->field('foo')->is_active ) { ... }
911              
912             =item input
913              
914             The input string from the parameters passed in. This is not usually set by
915             the user.
916              
917             =item value
918              
919             The value as it would come from or go into the database, after being
920             acted on by transforms and validation code. Used to construct the
921             C<< $form->values >> hash. Before validation is performed, the input is
922             copied to the 'value', and validation and constraints should act on 'value'.
923             After validation, C<< $form->value >> will get a hashref of the values.
924              
925             See also L<Data::MuForm::Manual::Transforms>.
926              
927             =item fif
928              
929             Values used to fill in the form. Read only.
930              
931             [% form.field('title').fif %]
932              
933             =item init_value
934              
935             Initial value populated by fill_from_object. You can tell if a field
936             has changed by comparing 'init_value' and 'value'. You wouldn't normally
937             change this.
938              
939             =item input_without_param
940              
941             Input for this field if there is no param. Set by default for Checkbox,
942             and Select, since an unchecked checkbox or unselected pulldown
943             does not return a parameter.
944              
945             =back
946              
947             =head2 Form, parent, etc
948              
949             =over
950              
951             =item form
952              
953             A reference to the containing form.
954              
955             =item parent
956              
957             A reference to the parent of this field. Compound fields are the
958             parents for the fields they contain.
959              
960             =item localizer
961              
962             Set from the form when fields are created.
963              
964             =item renderer
965              
966             Set from the form when fields are created.
967              
968             =back
969              
970             =head2 Errors
971              
972             =over
973              
974             =item errors
975              
976             Returns the error list (arrayref) for the field. Also provides
977             'all_errors', 'num_errors', 'has_errors', 'push_error' and 'clear_errors'.
978             Use 'add_error' to add an error to the array if you
979             want to localize the error message, or 'push_error' to skip
980             the localization.
981              
982             =item add_error
983              
984             Add an error to the list of errors. Error message will be localized
985             using 'localize' method, and the Localizer (default is
986             Data::MuForm::Localizer, which use a gettext style .po file).
987              
988             return $field->add_error( 'bad data' ) if $bad;
989              
990             =item push_error
991              
992             Adds an error to the list of errors without localization.
993              
994             =item error_fields
995              
996             The form and Compound fields will have an array of errors from the subfields.
997              
998             =back
999              
1000             =head2 methods
1001              
1002             A 'methods' hashref allows setting various coderefs, 'build_id', 'build_label',
1003             'build_options', 'validate', 'default'.
1004              
1005             methods => { build_id => \&my_build_id } - coderef for constructing the id
1006             methods => { build_label => \&my_build_label } - coderef for constructing the label
1007              
1008             =over
1009              
1010             =item build_id
1011              
1012             A coderef to build the field's id. If one doesn't exist, will use a form 'build_field_id'
1013             method. Fallback is to use the field's full name.
1014              
1015             =item build_label
1016              
1017             =item build_options
1018              
1019             =item validate
1020              
1021             =item default
1022              
1023             =back
1024              
1025             =head2 render_args
1026              
1027             The 'render_args' hashref contains keys which are used in rendering, with shortcuts
1028             for easier specification in a field definition.
1029              
1030             element_attr - ea
1031             label_attr - la
1032             wrapper_attr - wa
1033             error_attr - era
1034             element_wrapper_attr - ewa
1035              
1036             has_field 'foo' => ( render_args => { element_attr => { readonly => 1, my_attr => 'abc' }} );
1037             has_field 'foo' => ( 'ra.ea' => { readonly => 1, my_attr => 'abc' } );
1038             has_field 'foo' => ( 'ra'.wa.class' => ['mb10', 'wr66'] );
1039              
1040             Note the the 'name', 'id', and 'value' of fields is set by field attributes. Though
1041             it is possible to override the id in render_args, it then won't be available for
1042             other code such as 'errors_by_id'. There is some behavior associated with the 'disabled'
1043             flag too.
1044              
1045             label - Text label for this field. Defaults to ucfirst field name.
1046             id - Used in 'id="<id>"' in HTML
1047             disabled - Boolean to set field disabled
1048              
1049             The order attribute may be used to set the order in which fields are rendered.
1050              
1051             order - Used for sorting errors and fields. Built automatically,
1052             but may also be explicitly set. Auto sequence is by 5: 5, 10, 15, etc
1053              
1054             =head2 Flags
1055              
1056             =over
1057              
1058             =item password
1059              
1060             Prevents the entered value from being displayed in the form
1061              
1062             =item writeonly
1063              
1064             The initial value is not taken from the database
1065              
1066             =item no_update
1067              
1068             Do not include this field in C<< $form->values >>, and so it won't be updated in the database.
1069              
1070             =item not_nullable
1071              
1072             Fields that contain 'empty' values such as '' are changed to undef in the validation process.
1073             If this flag is set, the value is not changed to undef. If your database column requires
1074             an empty string instead of a null value (such as a NOT NULL column), set this attribute.
1075              
1076             has_field 'description' => (
1077             type => 'TextArea',
1078             not_nullable => 1,
1079             );
1080              
1081             This attribute is also used when you want an empty array to stay an empty array and not
1082             be set to undef.
1083              
1084             It's also used when you have a compound field and you want the 'value' returned
1085             to contain subfields with undef, instead of the whole field to be undef.
1086              
1087             =back
1088              
1089             =head2 Defaults
1090              
1091             See also the documentation on L<Data::MuForm::Manual::Defaults>.
1092              
1093             =over
1094              
1095             =item default method
1096              
1097             Note: do *not* set defaults by setting the 'checked' or 'selected' attributes
1098             in options. The code will be unaware that defaults have been set.
1099              
1100             has_field 'foo' => ( methods => { default => \&my_default } );
1101             sub my_default { }
1102             OR
1103             has_field 'foo';
1104             sub default_foo { }
1105              
1106             Supply a coderef (which will be a method on the field).
1107             If not specified and a form method with a name of
1108             C<< default_<field_name> >> exists, it will be used.
1109              
1110             =item default
1111              
1112             Provide an initial value in the field declaration:
1113              
1114             has_field 'bax' => ( default => 'Default bax' );
1115              
1116             =back
1117              
1118             =head1 Constraints and Validations
1119              
1120             See also L<Data::MuForm::Manual::Validation>.
1121              
1122             =head2 Constraints set in attributes
1123              
1124             =over
1125              
1126             =item required
1127              
1128             Flag indicating whether this field must have a value
1129              
1130             =item unique
1131              
1132             For DB field - check for uniqueness. Action is performed by
1133             the DB model.
1134              
1135             =item apply
1136              
1137             Use the 'apply' keyword to specify an ArrayRef of constraints and coercions to
1138             be executed on the field at field_validate time.
1139              
1140             has_field 'test' => (
1141             apply => [ TinyType,
1142             { check => sub {...}, message => { } },
1143             { transform => sub { ... lc(shift) ... } }
1144             ],
1145             );
1146              
1147             =back
1148              
1149             =head2 messages
1150              
1151             has_field 'foo' => ( messages => { required => '...', unique => '...' } );
1152             or
1153             has_field 'foo' => ( 'msg.required' => '...' );
1154              
1155             Set messages created by MuForm by setting in the 'messages'
1156             hashref or with the 'msg.<msg_name>' shortcut. Some field subclasses have additional
1157             settable messages.
1158              
1159             required: Error message text added to errors if required field is not present.
1160             The default is "Field <field label> is required".
1161              
1162             =head2 Transforms
1163              
1164             There are a number of methods to provide finely tuned transformation of the
1165             input or value.
1166              
1167             See also L<Data::MuForm::Manual::Transforms>.
1168              
1169             =over 4
1170              
1171             =item transform_input_to_value
1172              
1173             In FH was 'inflate_method'.
1174              
1175             Transforms the string that was submitted in params (and copied to 'input') when
1176             it's stored in the 'value' attribute during validation.
1177              
1178             =item transform_value_to_fif
1179              
1180             In FH was 'deflate_method'.
1181              
1182             When you get 'fif' for the field and the 'value' is used (as opposed to input)
1183             transforms the value to a string suitable for filling in a form field.
1184              
1185             =item transform_default_to_value
1186              
1187             In FH was inflate_default_method.
1188              
1189             Transform the 'default' provided by an 'model' or 'init_values' or 'default' when it's stored
1190             in the 'value'.
1191              
1192             =item transform_value_after_validate
1193              
1194             In FH was 'deflate_value_method';
1195              
1196             Transform the value after validation has been performs, in order to return
1197             a different form in C<< $form->value >>.
1198              
1199             =item transform_param_to_input
1200              
1201             Transform the param when it's stored in 'input'. Will change what the user sees
1202             in a re-presented form.
1203              
1204             =item trim
1205              
1206             A transform to trim the field. The default 'trim' sub
1207             strips beginning and trailing spaces.
1208             Set this attribute to null to skip trimming, or supply a different
1209             sub.
1210              
1211             trim => sub {
1212             my $string = shift;
1213             <do something>
1214             return $string;
1215             }
1216              
1217             Trimming is performed before any other defined actions.
1218              
1219             =back
1220              
1221             =head1 Processing and validating the field
1222              
1223             See also L<Data::MuForm::Manual::Validation>.
1224              
1225             =head2 Validate method
1226              
1227             has_field 'foo' => ( methods => { validate => \&foo_validation } );
1228             sub foo_validation { }
1229             OR
1230             has_field 'foo';
1231             sub validate_foo { }
1232              
1233             Supply a coderef (which will be a method on the field).
1234             If not specified and a form method with a name of
1235             C<< validate_<field_name> >> exists, it will be used instead.
1236              
1237             Periods in field names will be replaced by underscores, so that the field
1238             'addresses.city' will use the 'validate_addresses_city' method for validation.
1239              
1240             =head2 apply actions
1241              
1242             Use Type::Tiny types;
1243              
1244             use Types::Standard ('PosInteger');
1245             has_field 'foo' => ( apply => [ PosInteger ] );
1246              
1247             =head2 validate
1248              
1249             This field method can be used in addition to or instead of 'apply' actions
1250             in custom field classes.
1251             It should validate the field data and set error messages on
1252             errors with C<< $field->add_error >>.
1253              
1254             sub validate {
1255             my $field = shift;
1256             my $value = $field->value;
1257             return $field->add_error( ... ) if ( ... );
1258             }
1259              
1260             =head1 AUTHOR
1261              
1262             Gerda Shank
1263              
1264             =head1 COPYRIGHT AND LICENSE
1265              
1266             This software is copyright (c) 2017 by Gerda Shank.
1267              
1268             This is free software; you can redistribute it and/or modify it under
1269             the same terms as the Perl 5 programming language system itself.
1270              
1271             =cut