1 package Maypole::Model::CDBI::AsForm;
10 use Class::DBI::Plugin::Type ();
14 # pjs -- Added new methods to @EXPORT
15 our @EXPORT = qw( to_cgi to_field _to_textarea _to_textfield _to_select
16 type_of _to_foreign_inputs _to_enum_select _to_bool_select
17 to_select_from_many _to_select_from_related hasmany_class
18 _to_hidden _rename_foreign_input _to_readonly
19 make_param_foreign make_hidden_elmnt make_hidden_elmnt
20 a_select_box unselect_element do_select search_inputs);
24 our $VERSION = '2.41';
27 # 08-09-05 - fixed broken has_a select box
29 # - _to_foreign_inputs now takes 3 positional parameters
30 # (accssr, fields, accssr_meta_info)
35 Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns
40 use Maypole::Model::CDBI::AsForm;
41 use base 'Class::DBI';
47 my %cgi_field = $class->to_cgi;
49 (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
54 # <form method="post"...>
55 # Title: <input type="text" name="Title" /> <br>
56 # Artist: <select name="Artist">
57 # <option value=1>Grateful Dead</option>
65 This module helps to generate HTML forms for creating new database rows
66 or editing existing rows. It maps column names in a database table to
67 HTML form elements which fit the schema. Large text fields are turned
68 into textareas, and fields with a has-a relationship to other
69 C<Class::DBI> tables are turned into select drop-downs populated with
70 objects from the joined class.
74 The module is a mix-in which adds two additional methods to your
75 C<Class::DBI>-derived class.
80 Returns hashref of search inputs elements to use in cgi.
82 Uses fields specified in search_fields, makes foreign inputs if necessary.
88 warn "In model search_inputs " if $class->model_debug;
89 $class = ref $class || $class;
90 #my $accssr_class = { $class->accessor_classes };
92 my $sfs = $class->search_fields;
94 foreach my $field ( @$sfs ) {
95 if ( ref $field eq "HASH" ) { # foreign search fields
96 my ($accssr, $cols) = each %$field;
98 # default to search fields for related
99 #$cols = $accssr_class->{$accssr}->search_fields;
100 die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
102 my $fcgi = $class->_to_foreign_inputs($accssr, $cols);
103 # unset the default values for a select box
104 foreach (keys %$fcgi) {
105 $class->unselect_element($fcgi->{$_});
107 $cgi{$accssr} = $fcgi;
108 #warn "Searchy inputs for field $field is " . Dumper($cgi{$accssr});
110 $cgi{$field} = $class->to_field($field);
111 $class->unselect_element($cgi{$field});
120 Retrieves object selected from a select box and puts in $r->objects[0].
121 The select box input must be named the same as the primary key.
123 NOTE only works with tables with single primary key for now.
129 $r->objects([ $self->retrieve($r->params->{$self->primary_column}) ]);
130 $r->template('view');
134 =head2 unselect_element
136 Unselects all options in a HTML::Element of type select.
137 It does nothing if element is not a select element.
141 sub unselect_element {
142 my ($self, $el) = @_;
143 #unless (ref $el eq 'HTML::Element') {
144 #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
145 if ($el->tag eq 'select') {
146 foreach my $opt ($el->content_list) {
147 $opt->attr('selected', undef) if $opt->attr('selected');
153 # make a select box from args
155 my ($self, $name, $vals, $selected_val, $contents) = @_;
156 die "Usage: Need a name and array ref of values to make a select boxes" unless ($name && $vals);
157 $selected_val ||= "";
158 $contents ||= $vals ;
160 my $a = HTML::Element->new('select', 'name' => $name);
163 foreach my $v ( @$vals ) {
164 my $opt = HTML::Element->new('option', 'value' => $v);
165 $opt->attr('selected' => 'selected') if $v eq $selected_val;
166 $c = $contents->[$i++] || $v;
167 $opt->push_content($c);
168 $a->push_content($opt);
174 =head2 make_hidden_elmnt
176 Makes a hidden HTML::Element and puts it in template_args{hidden_elements}
177 $model->make_hidden_elmnt($name, $val);
181 sub make_hidden_elmnt {
182 my ($self, $r, $col, $val) = @_;
183 my $elmnt = HTML::Element->new('input', 'type'=>'hidden', 'name'=>$col, 'value'=>$val);
185 $r->{template_args}{hidden_elements} ||= [];
186 push @{ $r->{template_args}{hidden_elements} }, $elmnt;
191 =head2 make_param_foreign
193 Makes a new foreign parameter out of parameter and accessor
194 Just puts accssr__FOREIGN__ in front of param name
198 sub make_param_foreign {
199 my ($self, $r, $p, $accssr) = @_;
200 $r->params->{$accssr . '__FOREIGN__' . $p} = $r->params->{$p};
205 This returns a hash mapping all the column names of the class to
206 HTML::Element objects representing form widgets.
208 pjs -- added a columns list argument to specify which columns to make
214 my ($class, @columns) = @_; # pjs -- added columns arg
215 @columns = $class->columns unless (@columns);
216 map { $_ => $class->to_field($_) } @columns;
220 =head2 to_field($field [, $how])
222 This maps an individual column to a form element. The C<how> argument
223 can be used to force the field type into one of C<textfield>, C<textarea>
224 or C<select>; you can use this is you want to avoid the automatic detection
225 of has-a relationships.
228 -- added support for enum and bool. Note for enum and bool you need
229 a better column_type method than the Plugin::Type ' s as it won't work
230 if you are using MySQL. I have not tried others.
231 See those method's docs below.
232 -- Foreign inputs for might_have, must_have, has_own, and has_many(i think).
233 -- Really any relationship except has_a and is_a as has_a gets a select box
234 and is_a are not considered foreign.
235 -- Note a good column_type sub can be
236 used to get the correct type for is_a columns.
237 -- More efficient _to_select -- no object creation.
238 -- Attempts to set default value in field for you using a "column_default"
239 method you write yourself or your CDBI driver like mysql writes.
245 my ($self, $field, $how) = @_;
246 my $class = ref $self || $self;
247 if ($how and $how =~ /^(text(area|field)|select)$/) {
249 my $meth = "_to_$how";
250 return $self->$meth($field);
253 my $meta = $self->meta_info;
254 my ($rel_type) = grep{ defined $meta->{$_}{$field} } keys %$meta;
256 my $fclass = $rel_type ? $meta->{$rel_type}{$field}{foreign_class} : '';
257 my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
260 return $self->_to_select($field, $fclass) if $rel_type eq 'has_a' and
263 # maybe foreign inputs
264 my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
265 if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_type eq 'has_own'))
267 return $self->_to_foreign_inputs($field, undef, $meta->{$rel_type}{$field});
272 if ($class->can('column_type')) {
273 $type = $class->column_type($field);
276 # Right, have some of this
277 eval "package $class; Class::DBI::Plugin::Type->import()";
278 $type = $class->column_type($field);
281 #return $self->_to_textfield($field)
282 # if $type and $type =~ /(var)?char/i; #common type
283 return $self->_to_textarea($field)
284 if $type and $type =~ /^(TEXT|BLOB)$/i;
285 return $self->_to_enum_select($field, $type)
286 if $type and $type =~ /^ENUM\((.*?)\)$/i;
287 return $self->_to_bool_select($field, $type)
288 if $type and $type =~ /^BOOL/i;
289 return $self->_to_readonly($field)
290 if $type and $type =~ /^readonly$/i;
291 return $self->_to_textfield($field);
295 my ($self, $col) = @_;
298 HTML::Element->new("textarea", name => $col, rows => "3", cols => "22");
304 $val = eval {$self->column_default($col);};
305 $val = '' unless defined $val;
307 $a->push_content($val);
308 $OLD_STYLE && return $a->as_HTML;
313 my ($self, $col) = @_;
320 $val = eval {$self->column_default($col);};
321 $val = '' unless defined $val;
324 my $a = HTML::Element->new("input", type => "text", name => $col);
325 $a->attr("value" => $val);
326 $OLD_STYLE && return $a->as_HTML;
331 # -- Rewrote this to be efficient -- no object creation.
332 # -- Added option for CDBI classes to specify a limiting clause
333 # via "has_a_select_limit".
334 # -- Added selected argument to set a selected
337 my ($self, $col, $hint, $selected) = @_;
339 if (not $col) { # class is making select box of self
340 $has_a_class = ref $self || $self;
341 $col = $self->primary_column;
344 $has_a_class = $hint || $self->__hasa_rels->{$col}->[0];
348 if (ref $self and my $id = eval { $self->$col->id }) {
349 $selected->{$id} = 1;
351 #pjs Possible sql limiting clause ("WHERE acol = 'X' " or "LIMIT 10", etc)
352 my $select_box_limit = eval { $self->has_a_select_limit->{$col} } || '' ;
354 # Get columns to appear in select box options on forms.
355 # TODO -- there is maybe a good idiom for this.
357 @select_box_cols = $has_a_class->columns('SelectBox');
358 @select_box_cols = $has_a_class->columns('Stringify')
359 unless @select_box_cols;
360 @select_box_cols = $has_a_class->_essential
361 unless @select_box_cols;
362 unshift @select_box_cols, $has_a_class->columns('Primary');
363 my $sql = "SELECT " . join( ', ', @select_box_cols) . " FROM " .
364 $has_a_class->table . " " . $select_box_limit;
365 my $opts_data = $self->db_Main->selectall_arrayref($sql);
367 my $a = HTML::Element->new("select", name => $col);
370 my $opt = HTML::Element->new("option", value => $id );
371 $opt->attr("selected" => "selected") if $selected->{$id};
372 my $content = eval {$has_a_class->stringify_selectbox($_);} ||
374 $opt->push_content( $content );
375 $a->push_content($opt);
377 $OLD_STYLE && return $a->as_HTML;
381 # Makes a readonly input box out of column's value
382 # Currently object method only
384 my ($self, $col, $val) = @_;
385 unless (defined $val) {
386 $self->_croak("Cannot call _to_readonly on class without value arg.")
390 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
391 'name' => $col, 'value'=>$val);
392 $OLD_STYLE && return $a->as_HTML;
396 =head2 _to_enum_select
398 $sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");
400 Returns an enum select box given a column name and an enum string.
401 NOTE: The Plugin::Type does not return an enum string for mysql enum columns.
402 This will not work unless you write your own column_type method in your model.
406 sub _to_enum_select {
407 my ($self, $col, $type) = @_;
408 $type =~ /ENUM\((.*?)\)/i;
409 (my $enum = $1) =~ s/'//g;
410 my @enum_vals = split /\s*,\s*/, $enum;
412 my $a = HTML::Element->new("select", name => $col);
414 my $sel = HTML::Element->new("option", value => $_);
415 $sel->attr("selected" => "selected") if ref $self
416 and eval { $self->$col eq $_ };
417 $sel->push_content($_);
418 $a->push_content($sel);
420 $OLD_STYLE && return $a->as_HTML;
425 =head2 _to_bool_select
427 my $sel = $self->_to_bool_select($column, $bool_string);
429 This makes select input for boolean column. You can provide a
430 bool string of form: Bool('zero','one') and those are used for option
431 content. Onthervise No and Yes are used.
432 TODO -- test without bool string.
436 sub _to_bool_select {
437 my ($self, $col, $type) = @_;
438 my @bool_text = ('No', 'Yes');
439 if ($type =~ /BOOL\((.+?)\)/i) {
440 (my $bool = $1) =~ s/'//g;
441 @bool_text = split /,/, $bool;
443 my $one= ref $self ? eval {$self->$col;} : $self->column_default($col);
444 my $a = HTML::Element->new("select", name => $col);
445 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
446 HTML::Element->new("option", value => 1) );
447 $opt0->attr("selected" => "selected") if not $one;
448 $opt0->push_content($bool_text[0]);
449 $opt1->attr("selected" => "selected") if $one;
450 $opt1->push_content($bool_text[1]);
451 $a->push_content($opt0, $opt1);
452 $OLD_STYLE && return $a->as_HTML;
457 =head2 _to_hidden($name, $value)
459 This makes a hidden html element. Give it a name and value.
463 my ($self, $name, $val) = @_;
464 return HTML::Element->new('input', 'type' => 'hidden',
465 'name' => $name, 'value'=>$val
471 =head2 _to_foreign_inputs
473 $html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]);
475 Get inputs for the accessor's class. Pass an array ref of fields to get
476 inputs for only those fields. Otherwise display_columns or all columns is used.
477 If you have the meta info handy for the accessor you can pass that too.
479 TODO make AsForm know more about the request like what action we are doing
480 so it can use edit columns or search_columns
482 NOTE , this names the foreign inputs is a particular way so they can be
483 processed with a general routine and so there are not name clashes.
487 sub _to_foreign_inputs {
488 my ($self, $accssr, $fields, $accssr_meta) = @_;
490 my $class_meta = $self->meta_info;
491 my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
493 $self->_croak( "No relationship for accessor $accssr") if not $rel_type;
494 $accssr_meta = $class_meta->{$rel_type}->{$accssr};
497 my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $accssr_meta->{foreign_class};
500 $fields = $classORobj->can('display_columns') ?
501 [$classORobj->display_columns] : [$classORobj->columns];
504 # Ignore our fkey in them to prevent infinite recursion
505 my $me = eval {$accssr_meta->{args}{foreign_column}} || '';
506 my $constrained = $accssr_meta->{args}{constraint};
508 foreach ( @$fields ) {
509 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
510 $inputs{$_} = $classORobj->to_field($_);
513 # Make hidden inputs for constrained columns unless we are editing object
514 # TODO -- is this right thing to do?
515 unless (ref $classORobj) {
516 $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_})
517 foreach ( keys %$constrained );
519 $self->_rename_foreign_input($accssr, \%inputs);
523 =head2 _rename_foreign_input
525 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
527 Recursively renames the foreign inputs made by to_foreign_inputs so they
528 can be processed generically. The format is "accessor__AsForeign_colname".
530 So if an Employee is a Person who has own Address and you call
532 Employee->to_field("person")
534 then you will get inputs for Address named like this:
536 person__AsForeign__address__AsForeign__street
537 person__AsForeign__address__AsForeign__city
538 person__AsForeign__address__AsForeign__state
539 person__AsForeign__address__AsForeign__zip
541 And the processor would know to create this address, put the address id in
542 person address slot, create the person and put the address id in the employee
543 before creating the employee.
547 sub _rename_foreign_input {
548 my ($self, $accssr, $input) = @_;
549 if ( ref $input ne 'HASH' ) {
550 my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
551 $input->attr( name => $new_name );
554 $self->_rename_foreign_input($accssr, $input->{$_})
555 foreach (keys %$input);
562 =head2 to_select_from_many
565 Usage: $object->to_select_from_many($accessor|$objects_to_select_from, [$element_name], [$options]);
567 CD->has_many( 'songs' => "Songs" );
568 ... in some nearby piece of code:
569 my $cd = CD->retrieve($id);
570 my $select_song_html = $cd->to_select_from_many('songs');
571 print "<h1>Choose your Favorite song from $cd</h1>";
572 print $select_song_html.as_XML;
575 # OR if you only want to select from a group of objects
577 my @favorites = $cd->favorite_songs;
578 my $select_from_favorites = $cd->to_select_from_many(\@favorites);
580 This an object method that makes a select box out of the objects related to this object by a has_many relationship. The select box only allows one selection.
581 The multiple attribute can easily be added if needed to the element returned :
582 $this_element->attr('multiple', 'multiple');
584 You can pass an array ref of objects to select from instead of the class accessor name if you already have the objects to select from.
586 Also, you can pass the name you want the element to have as a second argument.
587 The default is the primary key name (as returned by primary_column) of the firstobject that is being selected from.
589 If related class has a multi column pk, this dies for now.#strange things may happen as primary_column method is used.
594 sub to_select_from_many {
595 my ($self, $accessor, $elmnt_name) = @_;
596 my $objs = ref $accessor eq "ARRAY" ? $accessor : [$self->$accessor];
597 my $rel_class = ( @$objs ) ? ref $objs->[0] :
598 eval{$self->hasmany_class($accessor)};
600 $elmnt_name = eval {$rel_class->primary_column} || "__AF_TSFM_OBJS__"
603 return _to_select_from_objs($objs, $elmnt_name);
607 =head2 _to_select_from_objs($objects, $name, $selected);
609 Private method to makes a select box of objects passed with name passed.
610 Assumes they are same type
613 sub _to_select_from_objs {
614 my ($objs, $elmnt_name) = @_;
615 CGI::Carp::croak("Usage: element name required") unless ($elmnt_name);
616 # $elmnt_name ||= eval {$objs->[0]->primary_column};
617 # unless ($elmnt_name) {
619 # $self->_carp ("Element name arg. not passed and couldn't get element name from object 0. Number of objects in arg are: $num");
623 my $a = HTML::Element->new("select", name => $elmnt_name);
625 my $opt = HTML::Element->new("option", value => $_->id);
626 $opt->push_content($_->stringify_self);
627 $a->push_content($opt);
629 $OLD_STYLE && return $a->as_HTML;
635 # TODO this is crap. I think this will just be a public sub to select many objects from a class. Then you can do thingks like add them to has_many and stuff.
638 # usage: CD->has_many('songs', 'Song', 'cd_id');
639 # my $song_sel_element = $class->_to_select_many('songs', @options);
640 # @options have same form as a SQL::Abstract options with exception of
641 # -HINT element which is the class name if you want to give it.
642 # { '-HINT' => $classname, # so you can cheat, or be efficient
643 # 'logic'=> 'OR', # default is OR
644 # $limiting_col => $limit_val,
645 # $limiting_col2=> $limit_val2,
649 # make select box for has many. This is a multiple select box (select many)
650 # element. If you want to choose between on of the has_many's an object has (
651 # ie -- a cd has many songs and you want to choose one of the songs from it)
652 # then pass an additional hash ref of limiting cols and vals.
653 # $cd->_to_many_select('songs', {'cd_id' => $cd->id, . . .}
654 sub _to_select_many {
655 my ($self, $accessor, $hint, $where, $order ) = @_;
656 my $has_many_class = $hint || $self->hasmany_class($accessor);
658 %selected = map { $_->id => 1} $self->$accessor if ref $self;
660 my $pk = $has_many_class->primary_column;
661 my $a = $self->_to_select($pk, $has_many_class, \%selected, $where, $order);
662 $a->attr('multiple', 'multiple');
664 $OLD_STYLE && return $a->as_HTML;
671 sub _to_select_old_version {
672 my ($self, $col, $hint) = @_;
673 my $has_a_class = $hint || $self->__hasa_rels->{$col}->[0];
674 my @objs = $has_a_class->retrieve_all;
675 my $a = HTML::Element->new("select", name => $col);
677 my $sel = HTML::Element->new("option", value => $_->id);
678 $sel->attr("selected" => "selected")
680 and eval { $_->id eq $self->$col->id };
681 $sel->push_content($_->stringify_self);
682 $a->push_content($sel);
684 $OLD_STYLE && return $a->as_HTML;
690 ############################ HELPER METHODS ######################
691 ##################################################################
693 # hasmany_class($accessor) -- stole code from Maypole::Model::CDBI
694 # Returns class of has_many relationship when given the accessor
696 my ( $self, $accessor ) = @_;
697 $self->_croak("No accessor (2nd arg) passed to hasmany_class")
699 my $rel_meta = $self->meta_info('has_many' => $accessor);
702 if ( $mapping = $rel_meta->{args}->{mapping} and @$mapping ) {
703 return $rel_meta->{foreign_class}->meta_info('has_a')->{ $$mapping[0] }->{foreign_class};
706 return $rel_meta->{foreign_class};
713 =head1 ***NEW PJS Stuff**** GETTING SPECIFIC IN MODEL CLASS
715 You can tell AsForm some things in your model classes to get custom results. In particular you can have:
717 =head2 Custom column_type methods
719 Since much of this modules functionality relies on the subroutine C<column_type>
720 returning the type string from the database table definition Model classes can
721 benefit a great deal by writing their own. See example. This version tries to
722 call column_type with the model class first. IF your model's column_type returns
723 undef or it has no such method it falls back on
724 C<&Class::DBI::Plugin::Type::column_type> which is database independent but not
725 fully functional yet. For full functionality make a custom C<column_type> method
726 in your base model class and override it in subclasses at will. Some \
727 Class::DBI::* drivers such as Class::DBI::mysql have mostly functional ones.
729 With a column_type sub you can set bool options for users , make select boxes
730 for ordinary columns (by lying and returning an enum('blah', 'blh') string for a
731 column, get correct types for is_a inherited columns, optimize , and maybe more.
733 =head2 Appropriate elements for columns inherited from an is_a relationship
735 At least you have the power to get them by making column_type work.
737 =head2 Select box specifications for has_a columns.
739 You can specify columns to be selected for a select box's options
742 __Package__->columns('SelectBox' => qw/col1 col2/);
744 If you don't, 'Stringify' columns are used if they exist and lastly 'Essential'
745 columns. The 'Primary' column is always the option value. This means don't
746 include it in the 'SelectBox' columns unless you want it in the option content.
748 You can limit rows selected for the select box with a has_a_select_limit sub like so:
750 Customer->has_a(pay_plan => "PayPlan");
751 Customer->has_a(pick_fromTopFive => "Movie");
752 sub has_a_select_limit { {
753 pay_plan => "WHERE is_available = 1",
754 pick_fromTopFive => "ORDER BY rank ASC LIMIT 5" }
757 If you need complex stringification make a C<stringify_selectbox> sub which
758 takes an arrayref. Elements are in order specified in columns('SelectBox')
759 or whatever columns list was used. Otherwise, the array is joined on ' '.
769 Version 1.x of this module returned raw HTML instead of
770 C<HTML::Element> objects, which made it harder to manipulate the
771 HTML before sending it out. If you depend on the old behaviour, set
772 C<$Class::DBI::AsForm::OLD_STYLE> to a true value.
778 =head1 ORIGINAL AUTHOR
782 =head1 BUGS and QUERIES
784 Please direct all correspondence regarding this module to:
785 bug-Class-DBI-AsForm@rt.cpan.org
787 =head1 COPYRIGHT AND LICENSE
789 Copyright 2003-2004 by Simon Cozens / Tony Bowden
791 This library is free software; you can redistribute it and/or modify
792 it under the same terms as Perl itself.
796 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.