File Coverage

blib/lib/Class/DBI/FormBuilder.pm
Criterion Covered Total %
statement 65 723 8.9
branch 2 358 0.5
condition 0 135 0.0
subroutine 18 86 20.9
pod 27 27 100.0
total 112 1329 8.4


line stmt bran cond sub pod time code
1             package Class::DBI::FormBuilder;
2              
3 31     31   27166 use warnings;
  31         71  
  31         1786  
4 31     31   172 use strict;
  31         65  
  31         1295  
5 31     31   179 use Carp();
  31         60  
  31         547  
6              
7 31     31   171 use List::Util();
  31         52  
  31         5399  
8 31     31   52181 use CGI::FormBuilder 3;
  31         1260674  
  31         1493  
9 31     31   29519 use Class::DBI::FormBuilder::Meta::Table;
  31         120  
  31         335  
10              
11 31     31   50772 use UNIVERSAL::require;
  31         62910  
  31         1411  
12              
13 31     31   1036 use constant ME => 0;
  31         59  
  31         2334  
14 31     31   160 use constant THEM => 1;
  31         61  
  31         3638  
15 31     31   167 use constant FORM => 2;
  31         61  
  31         1534  
16 31     31   171 use constant FIELD => 3;
  31         70  
  31         1407  
17 31     31   184 use constant COLUMN => 4;
  31         63  
  31         1586  
18              
19 31     31   190 use base 'Class::Data::Inheritable';
  31         90  
  31         55111  
20              
21             our $VERSION = '0.483';
22              
23             # process_extras *must* come 2nd last
24             our @BASIC_FORM_MODIFIERS = qw( pks options file timestamp text process_extras final );
25              
26             # C::FB sometimes gets confused when passed CDBI::Column objects as field names,
27             # hence all the map {''.$_} column filters. Some of them are probably unnecessary,
28             # but I need to track down which. UPDATE: the dev version now uses map { $_->name }
29             # everywhere.
30              
31             # CDBI has accessor_name *and* mutator_name methods, so potentially, each column could
32             # have 2 methods to get/set its values, neither of which are the column's name.
33              
34             # Column objects can be queried for these method names: $col->accessor and $col->mutator
35              
36             # Not sure yet what to do about caller-supplied column names.
37              
38             # General strategy: don't stringify anything until sending stuff to CGI::FB, at which point:
39             # 1. stringify all values
40             # 2. test field names to see if they are (CDBI column) objects, and if so, extract the
41             # appropriate accessor or mutator name
42              
43             # UPDATE: forms should be built with $column->name as the field name, because in general
44             # form submissions will need to do both get and set operations. So the form handling
45             # methods should assume forms supply column names, and should look up column mutator/accessor
46             # as appropriate.
47              
48             our %ValidMap = ( varchar => 'VALUE',
49             char => 'VALUE', # includes MySQL enum and set - UPDATE - not since 0.41
50            
51             enum => 'VALUE',
52             set => 'VALUE',
53            
54             blob => 'VALUE', # includes MySQL text
55             text => 'VALUE',
56            
57             integer => 'INT',
58             bigint => 'INT',
59             smallint => 'INT',
60             tinyint => 'INT',
61             int => 'INT',
62            
63             date => 'VALUE',
64             time => 'VALUE',
65             datetime => 'VALUE',
66            
67             # normally you want to skip validating a timestamp column...
68             #timestamp => 'VALUE',
69            
70             double => 'NUM',
71             float => 'NUM',
72             decimal => 'NUM',
73             numeric => 'NUM',
74             );
75            
76             __PACKAGE__->mk_classdata( field_processors => {} );
77             __PACKAGE__->mk_classdata( post_processors => {} );
78            
79             {
80             # field_processors
81             my $built_ins = { # default in form_pks
82             HIDDEN => [ '+HIDDEN', '+VALUE' ],
83            
84             '+HIDDEN' => sub { $_[FORM]->field( name => $_[FIELD],
85             type => 'hidden',
86             ) },
87            
88             VALUE => '+VALUE',
89            
90             '+VALUE' => sub
91             {
92             my $value;
93            
94             my $accessor = $_[COLUMN]->accessor;
95            
96             eval { $value = $_[THEM]->$accessor if ref( $_[THEM] ) };
97            
98             if ( $@ )
99             {
100             die sprintf "Error running +VALUE on '%s' field: '%s' (value: '%s'): $@",
101             $_[THEM], $_[COLUMN]->accessor, defined $value ? $value : 'undef';
102             }
103            
104             $value = ''.$value if defined $value; # CGI::FB chokes on objects
105            
106             if ( ! defined $value )
107             {
108             # if the column can be NULL, and the value is undef, we have no way of
109             # knowing whether the value has never been set, or has been set to NULL
110             if ( ! $_[ME]->table_meta( $_[THEM] )->column( $_[FIELD] )->nullable )
111             {
112             # but if the column can not be NULL, and the value is undef,
113             # set it to the default for the column
114             $value = $_[ME]->table_meta( $_[THEM] )->column( $_[FIELD] )->default;
115             }
116             }
117            
118             $_[FORM]->field( name => $_[FIELD],
119             value => $value,
120             );
121             },
122            
123             TIMESTAMP => 'READONLY',
124            
125             DISABLED => [ '+DISABLED', '+VALUE' ],
126            
127             '+DISABLED' => sub { $_[FORM]->field( name => $_[FIELD],
128             disabled => 1,
129             class => 'Disabled',
130             ) },
131            
132             READONLY => [ '+READONLY', '+VALUE' ],
133            
134             '+READONLY' => sub { $_[FORM]->field( name => $_[FIELD],
135             readonly => 1,
136             class => 'ReadOnly',
137             ) },
138            
139             FILE => [ '+FILE', '+VALUE' ],
140            
141             '+FILE' => sub
142             {
143             my $value = $_[THEM]->get( $_[FIELD] ) if ref( $_[THEM] );
144            
145             $_[FORM]->field( name => $_[FIELD],
146             type => 'file',
147             );
148             },
149            
150             # default in form_options
151             OPTIONS_FROM_DB => [ '+OPTIONS_FROM_DB', '+VALUE' ],
152            
153             '+OPTIONS_FROM_DB' => sub
154             {
155             my ( $series, $multiple ) =
156             $_[ME]->table_meta( $_[THEM] )->column( $_[FIELD] )->options;
157            
158             return unless @$series;
159            
160             $_[FORM]->field( name => $_[FIELD],
161             options => $series,
162             multiple => $multiple,
163             );
164             },
165            
166             '+REQUIRED' => sub { $_[FORM]->field( name => $_[FIELD],
167             required => 1,
168             ) },
169            
170             '+NULL' => sub {},
171            
172             '+ADD_FIELD' => sub { $_[FORM]->field( name => $_[FIELD],
173             # need to set something to vivify the field
174             required => 0,
175             ) },
176            
177             };
178            
179             __PACKAGE__->field_processors( $built_ins );
180             }
181              
182             {
183             # post processors - note that the calling code is responsible for loading prerequisites
184             # of a processor e.g. HTML::Tree
185             my $built_ins = {
186             PrettyPrint => sub
187             {
188             my ( $me, $form, $render, undef, %args ) = @_;
189            
190             # the
is a trick to force HTML::TB to put the
191             # noscript in the body and not in the head
192             my $html_in = '
' . $render->( $form, %args );
193            
194             my $tree = HTML::TreeBuilder->new;
195            
196             $tree->store_comments( 1 );
197             #$tree->ignore_unknown( 0 );
198             $tree->no_space_compacting( 1 );
199             #$tree->warn( 1 );
200            
201             $tree->parse( $html_in );
202             $tree->eof;
203            
204             my $html_out = $tree->guts->as_HTML( undef, ' ', {} );
205            
206             $tree->delete;
207            
208             # clean up after the
trick, and remove the outer div
209             # added by the guts() call (which removed html-head-body implicit tags)
210             $html_out =~ s'^
\s*
\s*
'';
211             $html_out =~ s'$'';
212            
213             return $html_out;
214             },
215            
216             # Duplicates => sub ... # removed after revision 368
217            
218             NoTextAreas => sub
219             {
220             my ( $me, $form, $render, undef, %args ) = @_;
221            
222             foreach my $field ( $form->field )
223             {
224             $field->type( 'text' ) if $field->type eq 'textarea';
225             }
226            
227             return $render->( $form, %args );
228             },
229            
230             };
231            
232             __PACKAGE__->post_processors( $built_ins );
233             }
234            
235             sub import
236             {
237 31     31   125 my ( $class, %args ) = @_;
238            
239 31         231 my $caller = caller(0);
240            
241 31 50       2780 $caller->can( 'form_builder_defaults' ) || $caller->mk_classdata( 'form_builder_defaults', {} );
242            
243             # replace CGI::FB's render() method with a hookable version
244             {
245 31         793 my $render = \&CGI::FormBuilder::render;
  31         115  
246            
247             my $hookable_render = sub
248             {
249 0     0   0 my ( $form, %args ) = @_;
250            
251 0 0 0     0 if ( my $post_processor = delete( $args{post_process} ) || $form->__cdbi_original_args__->{post_process} )
252             {
253             # the pp can mess with the form, then render it (as in the else clause below), then mess
254             # with the HTML, before returning the HTML
255 0         0 my $pp_args = $form->__cdbi_original_args__->{post_process_args};
256            
257 0 0       0 my $pp = ref( $post_processor ) eq 'CODE' ? $post_processor : $class->post_processors->{ $post_processor };
258            
259 0         0 return $pp->( $class, $form, $render, $pp_args, %args );
260             }
261             else
262             {
263 0         0 return $render->( $form, %args );
264             }
265 31         168 };
266            
267 31     31   242 no warnings 'redefine';
  31         64  
  31         3667  
268 31         151 *CGI::FormBuilder::render = $hookable_render;
269             }
270            
271             # To support subclassing, store the FB (sub)class on the caller, and use that whenever we need
272             # to call an internal method on the CDBI::FB class
273             # i.e. say $them->__form_builder_subclass__ instead of __PACKAGE__
274 31         155 $caller->mk_classdata( __form_builder_subclass__ => $class );
275            
276             # _col_name_from_mutator_or_object() needs a cache of mutator_name => column_name
277             # on each CDBI class. Note that this accessor is used in a slightly unusual way,
278             # by including a key on the CDBI class. Otherwise, lookups on one class could
279             # fall through to an inherited map, rather than the map for the class we're
280             # interested in. So the map is only stored on $caller.
281 31         720 $caller->mk_classdata( __mutator_to_name__ => {} );
282            
283 31         720 my @export = qw( as_form
284             search_form
285            
286             as_form_with_related
287            
288             as_multiform
289             create_from_multiform
290            
291             update_or_create_from_form
292            
293             update_from_form_with_related
294            
295             retrieve_from_form
296             search_from_form
297             search_like_from_form
298             search_where_from_form
299            
300             find_or_create_from_form
301             retrieve_or_create_from_form
302             );
303            
304 31 50       195 if ( $args{BePoliteToFromForm} )
305             {
306 31     31   176 no strict 'refs';
  31         76  
  31         3684  
307 0         0 *{"$caller\::${_}_fb"} = \&{"${_}_form"} for qw( update_from create_from );
  0         0  
  0         0  
308             }
309             else
310             {
311 31         133 push @export, qw( update_from_form create_from_form );
312             }
313            
314 31     31   1024 no strict 'refs';
  31         78  
  31         10754  
315 31         177 *{"$caller\::$_"} = \&$_ for @export;
  465         10897  
316             }
317              
318             =head1 NAME
319              
320             Class::DBI::FormBuilder - Class::DBI/CGI::FormBuilder integration
321              
322             =head1 SYNOPSIS
323              
324              
325             package Film;
326             use strict;
327             use warnings;
328            
329             use base 'Class::DBI';
330             use Class::DBI::FormBuilder;
331            
332             # for indented output:
333             # use Class::DBI::FormBuilder PrettyPrint => 'ALL';
334            
335             # POST all forms to server
336             Film->form_builder_defaults->{method} = 'post';
337            
338             # customise how some fields are built:
339             # 'actor' is a has_a field, and the
340             # related table has 1000's of rows, so we don't want the default popup widget,
341             # we just want to show the current value
342             Film->form_builder_defaults->{process_fields}->{actor} = 'VALUE';
343            
344             # 'trailer' stores an mpeg file, but CDBI::FB cannot automatically detect
345             # file upload fields, so need to tell it:
346             Film->form_builder_defaults->{process_fields}->{trailer} = 'FILE';
347            
348             # has_a fields will be automatically set to 'required'. Additional fields can be specified:
349             Film->form_builder_defaults->{required} = qw( foo bar );
350            
351            
352            
353             # In a nearby piece of code...
354            
355             my $film = Film->retrieve( $id );
356             print $film->as_form( params => $q )->render; # or $r if mod_perl
357            
358             # For a search app:
359             my $search_form = Film->search_form; # as_form plus a few tweaks
360            
361            
362             # A fairly complete mini-app:
363            
364             my $form = Film->as_form( params => $q ); # or $r if mod_perl
365            
366             if ( $form->submitted and $form->validate )
367             {
368             # whatever you need:
369            
370             my $obj = Film->create_from_form( $form );
371             my $obj = Film->update_from_form( $form );
372             my $obj = Film->update_or_create_from_form( $form );
373             my $obj = Film->retrieve_from_form( $form );
374            
375             my $iter = Film->search_from_form( $form );
376             my $iter = Film->search_like_from_form( $form );
377             my $iter = Film->search_where_from_form( $form );
378            
379             my $obj = Film->find_or_create_from_form( $form );
380             my $obj = Film->retrieve_or_create_from_form( $form );
381            
382             print $form->confirm;
383             }
384             else
385             {
386             print $form->render;
387             }
388            
389             # See CGI::FormBuilder docs and website for lots more information.
390            
391             =head1 DESCRIPTION
392              
393             B
394             accessors/mutators are different from the column name>. The documentation is also broken w.r.t. this.
395              
396             This module creates a L form from a CDBI class or object. If
397             from an object, it populates the form fields with the object's values.
398              
399             Column metadata and CDBI relationships are analyzed and the fields of the form are modified accordingly.
400             For instance, MySQL C and C columns are configured as C
401             C widgets as appropriate, and appropriate widgets are built for C, C
402             and C relationships. Further relationships can be added by subclassing. C columns
403             are set as 'required' fields in create/update forms.
404              
405             A demonstration app (using L) can be viewed at
406              
407             http://beerfb.riverside-cms.co.uk
408            
409             =head1 Customising field construction
410              
411             Often, the default behaviour will be unsuitable. For instance, a C relationship might point to
412             a related table with thousands of records. A popup widget with all these records is probably not useful.
413             Also, it will take a long time to build, so post-processing the form to re-design the field is a
414             poor solution.
415              
416             Instead, you can pass an extra C argument in the call to C (or you can
417             set it in C).
418              
419             Many of the internal routines use this mechanism for configuring fields. A manually set '+'
420             (basic) processor will be B to any other automatic processing, whereas a manually set shortcut
421             processor (no '+') will B all automatic processing.
422              
423             You can add your own processors to the internal table of processors - see C.
424              
425             =head2 process_fields
426              
427             This is a hashref, with keys being field names. Values can be:
428              
429             =over 4
430              
431             =item Name of a built-in
432              
433             basic shortcut
434             -------------------------------------------------------------------------------
435             +HIDDEN HIDDEN make the field hidden
436             +VALUE VALUE display the current value
437             +READONLY READONLY display the current value - not editable
438             +DISABLED DISABLED display the current value - not editable, not selectable, (not submitted?)
439             +FILE FILE build a file upload widget
440             +OPTIONS_FROM_DB OPTIONS_FROM_DB check if the column is constrained to a few values
441             +REQUIRED make the field required
442             +NULL no-op - useful for debugging
443             +ADD_FIELD add a new field to the form (only necessary if the field is empty)
444             TIMESTAMP used to process TIMESTAMP fields, defaults to DISABLED, but you can
445             easily replace it with a different behaviour
446             +SET_VALUE($value) set the value of the field to $value - DEPRECATED - use +SET_value
447             +SET_$foo($value) SET_$foo($value) set the $foo attribute of the field to $value
448            
449             The 'basic' versions apply only their own modification. The 'shortcut' version also applies
450             the C<+VALUE> processor.
451            
452             C currently only supports MySQL ENUM or SET columns. You probably won't need to use
453             this explicitly, as it's already used internally.
454              
455             The C<+ADD_FIELD> processor is only necessary if you need to add a new field to a form, but don't want to
456             use any of the other processors on it.
457              
458             =item Reference to a subroutine, or anonymous coderef
459              
460             The coderef will be passed the L class or subclass, the CDBI class or
461             object, the L form object, and the field name as arguments, and should build the
462             named field.
463              
464             =item Package name
465              
466             Name of a package with a suitable C subroutine. Gets called with the same arguments as
467             the coderef.
468              
469             =item Arrayref of the above
470              
471             Applies each processor in order.
472              
473             =back
474              
475             The key C<__FINAL__> is reserved for C, so don't name any form fields C<__FINAL__>. If a
476             field processor is set in C<__FINAL__>, then it will be applied to all fields, after all other
477             processors have run.
478              
479             =head1 Customising C output
480              
481             C replaces C with a hookable version of C.
482             The hook is a coderef, or the name of a built-in, supplied in the C argument (which can
483             be set in the call to C, C, C, or in C). The coderef
484             is passed the following arguments:
485              
486             $class the CDBI::FormBuilder class or subclass
487             $form the CGI::FormBuilder form object
488             $render reference to &CGI::FormBuilder::render
489             $pp_args value of the post_process_args argument, or undef
490             %args the arguments used in the CGI::FormBuilder->new call
491              
492             The coderef should return HTML markup for the form, probably by calling C<< $render->( $form, %args ) >>.
493              
494             =over 4
495              
496             =item PrettyPrint
497              
498             A pretty-printer coderef is available in the hashref of built-in post-processors:
499              
500             my $pretty = Class::DBI::FormBuilder->post_processors->{PrettyPrint};
501            
502             So you can turn on pretty printing for a class by setting:
503              
504             My::Class->form_builder_defaults->{post_process} = Class::DBI::FormBuilder->post_processors->{PrettyPrint};
505            
506             =item NoTextAreas
507              
508             This post-processor ensures that any fields configured as C