1 package Maypole::Model::CDBI::AsForm;
6 # has_many select -- $obj->to_field($has_many_col); # select one form many
7 # -- $class->to_field($has_many_col); # foreign inputs
8 # $class->search_inputs; /
16 use Class::DBI::Plugin::Type ();
21 # pjs -- Added new methods to @EXPORT
24 to_cgi to_field foreign_input_delimiter search_inputs unselect_element
25 _field_from_how _field_from_relationship _field_from_column
26 _to_textarea _to_textfield _to_select _select_guts
27 _to_foreign_inputs _to_enum_select _to_bool_select
28 _to_hidden _to_link_hidden _rename_foreign_input _to_readonly
29 _options_from_objects _options_from_arrays _options_from_hashes
30 _options_from_array _options_from_hash
37 Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns
42 use Maypole::Model::CDBI::AsForm;
43 use base 'Class::DBI';
49 my %cgi_field = $self->to_cgi;
51 (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
59 # Somewhere else in a Maypole application about beer...
64 $beer->to_field('brewery', 'textfield', {
65 name => 'brewery_id', value => $beer->brewery,
66 # however, no need to set value since $beer is object
70 $beer->to_field(rating => select => {
71 items => [1 , 2, 3, 4, 5],
74 # Select a Brewery to visit in the UK
75 Brewery->to_field(brewery_id => {
76 items => [ Brewery->search_like(location => 'UK') ],
79 # Make a select for a boolean field
80 $Pub->to_field('open' , { items => [ {'Open' => 1, 'Closed' => 0 } ] });
82 $beer->to_field('brewery', {
83 selected => $beer->brewery, # again not necessary since caller is obj.
87 $beer->to_field('brewery', 'link_hidden', {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery});
88 # an html link that is also a hidden input to the object. R is required to
89 # make the uri unless you pass a uri
93 #####################################################
102 <span class="field"> [% classmetadata.colnames.$col %] : </span>
104 [% object.to_field(col).as_XML %]
112 <span class="field"> Brewery : </span>
114 [% object.to_field('brewery', { selected => 23} ).as_XML %]
121 #####################################################
126 __PACKAGE__->has_a('job_employer' => 'Employer');
127 __PACKAGE__->has_a('contact' => 'Contact')
130 __PACKAGE__->has_a('cont_employer' => 'Employer');
131 __PACKAGE__->has_many('jobs' => 'Job',
132 { join => { job_employer => 'cont_employer' },
133 constraint => { 'finshed' => 0 },
134 order_by => "created ASC",
139 __PACKAGE__->has_many('jobs' => 'Job',);
140 __PACKAGE__->has_many('contacts' => 'Contact',
141 order_by => 'name DESC',
145 # Choose some jobs to add to a contact (has multiple attribute).
146 my $job_sel = Contact->to_field('jobs'); # Uses constraint and order by
149 # Choose a job from $contact->jobs
150 my $job_sel = $contact->to_field('jobs');
159 This module helps to generate HTML forms for creating new database rows
160 or editing existing rows. It maps column names in a database table to
161 HTML form elements which fit the schema. Large text fields are turned
162 into textareas, and fields with a has-a relationship to other
163 C<Class::DBI> tables are turned into select drop-downs populated with
164 objects from the joined class.
167 =head1 ARGUMENTS HASH
169 This provides a convenient way to tweak AsForm's behavior in exceptional or
170 not so exceptional instances. Below describes the arguments hash and
174 $beer->to_field($col, $how, $args);
175 $beer->to_field($col, $args);
177 Not all _to_* methods pay attention to all arguments. For example, '_to_textfield' does not look in $args->{'items'} at all.
181 =item name -- the name the element will have , this trumps the derived name.
183 $beer->to_field('brewery', 'readonly', {
187 =item value -- the initial value the element will have, trumps derived value
189 $beer->to_field('brewery', 'textfield', {
190 name => 'brewery_id', value => $beer->brewery,
191 # however, no need to set value since $beer is object
194 =item items -- array of items generally used to make select box options
196 Can be array of objects, hashes, arrays, or strings, or just a hash.
199 $beer->to_field(rating => select => {
200 items => [1 , 2, 3, 4, 5],
203 # Select a Brewery to visit in the UK
204 Brewery->to_field(brewery_id => {
205 items => [ Brewery->search_like(location => 'UK') ],
208 # Make a select for a boolean field
209 $Pub->to_field('open' , { items => [ {'Open' => 1, 'Closed' => 0 } ] });
211 =item selected -- something representing which item is selected in a select box
213 $beer->to_field('brewery', {
214 selected => $beer->brewery, # again not necessary since caller is obj.
217 Can be an simple scalar id, an object, or an array of either
219 =item class -- the class for which the input being made for field pertains to.
221 This in almost always derived in cases where it may be difficult to derive, --
222 # Select beers to serve on handpump
223 Pub->to_field(handpumps => select => {
224 class => 'Beer', order_by => 'name ASC', multiple => 1,
227 =item column_type -- a string representing column type
229 $pub->to_field('open', 'bool_select', {
230 column_type => "bool('Closed', 'Open'),
233 =item column_nullable -- flag saying if column is nullable or not
235 Generally this can be set to get or not get a null/empty option added to
236 a select box. AsForm attempts to call "$class->column_nullable" to set this
237 and it defaults to true if there is no shuch method.
239 $beer->to_field('brewery', { column_nullable => 1 });
241 =item r or request -- the Mapyole request object
243 =item uri -- uri for a link , used in methods such as _to_link_hidden
245 $beer->to_field('brewery', 'link_hidden',
246 {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery});
247 # an html link that is also a hidden input to the object. R is required to
248 # make the uri unless you pass a uri
250 =item order_by, constraint, join
252 These are used in making select boxes. order_by is a simple order by clause
253 and constraint and join are hashes used to limit the rows selected. The
254 difference is that join uses methods of the object and constraint uses
255 static values. You can also specify these in the relationship definitions.
256 See the relationships documentation of how to set arbitrayr meta info.
258 BeerDB::LondonBeer->has_a('brewery', 'BeerDB::Brewery',
259 order_by => 'brewery_name ASC',
260 constraint => {location => 'London'},
261 'join' => {'brewery_tablecolumn => 'beer_obj_column'},
264 =item no_hidden_constraints --
266 Tell AsForm not to make hidden inputs for relationship constraints. It does
267 this sometimes when making foreign inputs. However, i think it should not
268 do this and that the FromCGI 's _create_related method should do it.
274 $self->to_cgi([@columns, $args]);
276 This returns a hash mapping all the column names to HTML::Element objects
277 representing form widgets. It takes two opitonal arguments -- a list of
278 columns and a hashref of hashes of arguments for each column. If called with an object like for editing, the inputs will have the object's values.
280 $self->to_cgi(); # uses $self->columns; # most used
281 $self->to_cgi(qw/brewery style rating/); # sometimes
282 # and on rare occassions this is desireable if you have a lot of fields
283 # and dont want to call to_field a bunch of times just to tweak one or
285 $self->to_cgi(@cols, {brewery => {
286 how => 'textfield' # too big for select
289 column_nullable => 0,
291 items => ['Ale', 'Lager']
298 my ($class, @columns) = @_; # pjs -- added columns arg
301 @columns = $class->columns;
302 # Eventually after stabalization, we could add display_columns
303 #keys map { $_ => 1 } ($class->display_columns, $class->columns);
306 if ( ref $columns[-1] eq 'HASH' ) { $args = pop @columns; }
308 map { $_ => $class->to_field($_, $args->{$_}) } @columns;
311 =head2 to_field($field [, $how][, $args])
313 This maps an individual column to a form element. The C<how> argument
314 can be used to force the field type into any you want. All that you need
315 is a method named "_to_$how" in your class. Your class inherits many from
316 AsForm already. Override them at will.
318 If C<how> is specified but the class cannot call the method it maps to,
319 then AsForm will issue a warning and the default input will be made.
320 You can write your own "_to_$how" methods and AsForm comes with many.
321 See C<HOW Methods>. You can also pass this argument in $args->{how}.
327 my ($self, $field, $how, $args) = @_;
328 if (ref $how) { $args = $how; $how = ''; }
329 unless ($how) { $how = $args->{how} || ''; }
330 #warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n";
331 # Set sensible default value
332 unless ($args->{default}) {
333 my $def = $self->column_default($field);
334 # exclude defaults we don't want actually put as value for input
336 $def = $def =~ /(^0000-00-00.*$|^0[0]*$|^0\.00$|CURRENT_TIMESTAMP|NULL)/i ? '' : $def ;
337 $args->{default} = $def;
343 return $self->_field_from_how($field, $how, $args) ||
344 $self->_field_from_relationship($field, $args) ||
345 $self->_field_from_column($field, $args) ||
346 $self->_to_textfield($field, $args);
352 my $cgi = $class->search_inputs ([$args]); # optional $args
354 Returns hash or hashref of search inputs elements for a class making sure the
355 inputs are empty of any initial values.
356 You can specify what columns you want inputs for in
358 by the method "search_columns". The default is "display_columns".
359 If you want to te search on columns in related classes you can do that by
360 specifying a one element hashref in place of the column name where
361 the key is the related "column" (has_a or has_many method for example) and
362 the value is a list ref of columns to search on in the related class.
365 sub BeerDB::Beer::search_columns {
366 return ( 'name' , 'rating', { brewery => [ 'name', 'location'] } );
369 # Now foreign inputs are made for Brewery name and location and the
370 # there will be no name clashing and processing can be automated.
376 my ($class, $args) = @_;
377 $class = ref $class || $class;
378 #my $accssr_class = { $class->accessor_classes };
381 $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns];
383 foreach my $field ( @{ $args->{columns} } ) {
385 no_hidden_constraints => 1,
386 column_nullable => 1, # empty option on select boxes
389 if ( ref $field eq "HASH" ) { # foreign search fields
390 my ($accssr, $cols) = each %$field;
391 $base_args->{columns} = $cols;
393 # default to search fields for related
394 #$cols = $accssr_class->{$accssr}->search_columns;
395 die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
397 my $fcgi = $class->to_field($accssr, 'foreign_inputs', $base_args);
399 # unset the default values for a select box
400 foreach (keys %$fcgi) {
401 my $el = $fcgi->{$_};
402 if ($el->tag eq 'select') {
404 $class->unselect_element($el);
405 my ($first, @content) = $el->content_list;
406 my @fc = $first->content_list;
407 my $val = $first ? $first->attr('value') : undef;
408 if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or
410 #(defined $first->attr('value') or $first->attr('value') ne ''))
411 # push an empty option on stactk
412 $el->unshift_content(HTML::Element->new('option'));
417 $cgi{$accssr} = $fcgi;
418 delete $base_args->{columns};
421 $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} });
422 my $el = $cgi{$field};
423 if ($el->tag eq 'select') {
424 $class->unselect_element($el);
425 my ($first, @content) = $el->content_list;
426 if ($first and $first->content_list) { # something
427 #(defined $first->attr('value') or $first->attr('value') ne ''))
428 # push an empty option on stactk
429 $el->unshift_content(HTML::Element->new('option'));
440 =head2 unselect_element
442 unselect any selected elements in a HTML::Element select list widget
445 sub unselect_element {
446 my ($self, $el) = @_;
447 #unless (ref $el eq 'HTML::Element') {
448 #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
449 if ($el->tag eq 'select') {
450 foreach my $opt ($el->content_list) {
451 $opt->attr('selected', undef) if $opt->attr('selected');
456 =head2 _field_from_how($field, $how,$args)
458 Returns an input element based the "how" parameter or nothing at all.
463 sub _field_from_how {
464 my ($self, $field, $how, $args) = @_;
468 my $meth = "_to_$how";
469 if (not $self->can($meth)) {
470 warn "Class can not $meth";
473 return $self->$meth($field, $args);
477 =head2 _field_from_relationship($field, $args)
479 Returns an input based on the relationship associated with the field or nothing.
482 For has_a it will give select box
486 sub _field_from_relationship {
487 my ($self, $field, $args) = @_;
488 return unless $field;
489 my $rel_meta = $self->related_meta('r',$field) || return;
490 my $rel_name = $rel_meta->{name};
491 #my $meta = $self->meta_info;
492 #grep{ defined $meta->{$_}{$field} } keys %$meta;
493 my $fclass = $rel_meta->foreign_class;
494 my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
497 if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) {
498 # This condictions allows for trumping of the has_a args
499 if (not $rel_meta->{args}{no_select} and not $args->{no_select})
501 $args->{class} = $fclass;
502 return $self->_to_select($field, $args);
506 # maybe has many select
507 if ($rel_meta->{name} eq 'has_many' and $fclass_is_cdbi and ref $self) {
508 # This condictions allows for trumping of the has_a args
509 if (not $rel_meta->{args}{no_select} and not $args->{no_select})
511 $args->{class} = $fclass;
512 my @itms = $self->$field; # need list not iterator
513 $args->{items} = \@itms;
514 return $self->_to_select($field, $args);
521 #NOOO! maybe select from has_many
522 # if ($rel_type eq 'has_many' and ref $self) {
523 # $args->{items} ||= [$self->$field];
524 # # arg name || fclass pk name || field
525 # if (not $args->{name}) {
526 # $args->{name} = eval{$fclass->primary_column->name} || $field;
528 # return $self->_to_select($field, $args);
531 # maybe foreign inputs
532 my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
533 if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_name eq 'has_own'))
535 $args->{related_meta} = $rel_meta; # suspect faster to set these args
536 return $self->_to_foreign_inputs($field, $args);
541 =head2 _field_from_column($field, $args)
543 Returns an input based on the column's characteristics, namely type, or nothing.
548 sub _field_from_column {
549 my ($self, $field, $args) = @_;
550 return unless $field;
551 my $class = ref $self || $self;
553 unless ($args->{column_type}) {
554 if ($class->can('column_type')) {
555 $args->{column_type} = $class->column_type($field);
558 # Right, have some of this
559 eval "package $class; Class::DBI::Plugin::Type->import()";
560 $args->{column_type} = $class->column_type($field);
563 my $type = $args->{column_type};
565 return $self->_to_textfield($field, $args)
566 if $type and $type =~ /^(VAR)?CHAR/i; #common type
567 return $self->_to_textarea($field, $args)
568 if $type and $type =~ /^(TEXT|BLOB)$/i;
569 return $self->_to_enum_select($field, $args)
570 if $type and $type =~ /^ENUM\((.*?)\)$/i;
571 return $self->_to_bool_select($field, $args)
572 if $type and $type =~ /^BOOL/i;
573 return $self->_to_readonly($field, $args)
574 if $type and $type =~ /^readonly$/i;
580 my ($self, $col, $args) = @_;
583 my $val = $args->{value};
585 unless (defined $val) {
590 $val = $args->{default};
591 $val = '' unless defined $val;
594 my ($rows, $cols) = _box($val);
595 $rows = $args->{rows} if $args->{rows};
596 $cols = $args->{cols} if $args->{cols};;
597 my $name = $args->{name} || $col;
599 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
600 $a->push_content($val);
601 $OLD_STYLE && return $a->as_HTML;
606 my ($self, $col, $args ) = @_;
607 use Carp qw/confess/;
608 confess "No col passed to _to_textfield" unless $col;
610 my $val = $args->{value};
611 my $name = $args->{name} || $col;
613 unless (defined $val) {
615 # Case where column inflates.
616 # Input would get stringification which could be not good.
617 # as in the case of Time::Piece objects
618 $val = $self->can($col) ? $self->$col : ''; # in case it is a virtual column
620 if (my $meta = $self->related_meta('',$col)) {
621 if (my $code = $meta->{args}{deflate4edit} || $meta->{args}{deflate} ) {
622 $val = ref $code ? &$code($val) : $val->$code;
624 elsif ( $val->isa('Class::DBI') ) {
628 #warn "No deflate4edit code defined for $val of type " .
629 #ref $val . ". Using the stringified value in textfield..";
633 $val = $val->id if $val->isa("Class::DBI");
639 $val = $args->{default};
640 $val = '' unless defined $val;
644 # THIS If section is neccessary or you end up with "value" for a vaiue
646 $val = '' unless defined $val;
647 $a = HTML::Element->new("input", type => "text", name => $name, value =>$val);
648 $OLD_STYLE && return $a->as_HTML;
655 # my ($self, $col, $hint) = @_;
656 # my $fclass = $hint || $self->__hasa_rels->{$col}->[0];
657 # my @objs = $fclass->retrieve_all;
658 # my $a = HTML::Element->new("select", name => $col);
660 # my $sel = HTML::Element->new("option", value => $_->id);
661 # $sel->attr("selected" => "selected")
663 # and eval { $_->id eq $self->$col->id };
664 # $sel->push_content($_->stringify_self);
665 # $a->push_content($sel);
667 # $OLD_STYLE && return $a->as_HTML;
674 =head2 recognized arguments
676 selected => $object|$id,
679 where => SQL 'WHERE' clause,
680 order_by => SQL 'ORDER BY' clause,
681 constraint => hash of constraints to search
682 limit => SQL 'LIMIT' clause,
683 items => [ @items_of_same_type_to_select_from ],
684 class => $class_we_are_selecting_from
685 stringify => $stringify_coderef|$method_name
690 # select box requirements
691 # 1. a select box for objecs of a has_a related class -- DONE
692 =head2 1. a select box out of a has_a or has_many related class.
693 # For has_a the default behavior is to make a select box of every element in
694 # related class and you choose one.
695 #Or explicitly you can create one and pass options like where and order
696 BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
698 # For has_many the default is to get a multiple select box with all objects.
699 # If called as an object method, the objects existing ones will be selected.
700 Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"});
703 =head2 2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun.
705 BeerDB::Beer->to_field('', 'select', $options)
707 BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
708 # with PK as ID, $Class->to_field() same.
709 BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
710 # specify exact where clause
712 =head2 3. If you already have a list of objects to select from --
714 BeerDB:;Beer->to_field($col, 'select' , {items => $objects});
716 # 3. a select box for arbitrary set of objects
717 # Pass array ref of objects as first arg rather than field
718 $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
724 my ($self, $col, $args) = @_;
726 # Do we have items already ? Go no further.
727 if ($args->{items} and ref $args->{items}) {
728 my $a = $self->_select_guts($col, $args);
729 $OLD_STYLE && return $a->as_HTML;
730 if ($args->{multiple}) { $a->attr('multiple', 'multiple');}
738 unless ($args->{class}) {
739 $args->{class} = ref $self || $self;
740 # object selected if called with one
741 $args->{selected} = { $self->id => 1}
742 if not $args->{selected} and ref $self;
744 $col = $args->{class}->primary_column;
746 # Related Class maybe ?
747 elsif ($rel_meta = $self->related_meta('r:)', $col) ) {
748 $args->{class} = $rel_meta->{foreign_class};
749 # related objects pre selected if object
751 # "Has many" -- Issues:
752 # 1) want to select one or many from list if self is an object
753 # Thats about all we can do really,
754 # 2) except for mapping which is TODO and would
755 # do something like add to and take away from list of permissions for
758 # Hasmany select one from list if ref self
759 if ($rel_meta->{name} =~ /has_many/i and ref $self) {
760 my @itms = $self->$col; # need list not iterator
761 $args->{items} = \@itms;
762 my $a = $self->_select_guts($col, $args);
763 $OLD_STYLE && return $a->as_HTML;
767 $args->{selected} ||= [ $self->$col ] if ref $self;
768 #warn "selected is " . Dumper($args->{selected});
769 my $c = $rel_meta->{args}{constraint} || {};
770 my $j = $rel_meta->{args}{join} || {};
773 @join = map { $_ ." = ". $self->_attr($_) } keys %$j;
775 my @constr= map { "$_ = '$c->{$_}'"} keys %$c;
776 $args->{where} ||= join (' AND ', (@join, @constr));
777 $args->{order_by} ||= $rel_meta->{args}{order_by};
778 $args->{limit} ||= $rel_meta->{args}{limit};
782 # We could say :Col is name and we are selecting out of class arg.
785 #$args->{name} = $col;
786 die "Usage _to_select. $col not related to any class to select from. ";
791 unless ( defined $args->{column_nullable} ) {
792 $args->{column_nullable} = $self->can('column_nullable') ?
793 $self->column_nullable($col) : 1;
796 # Get items to select from
797 my $items = _select_items($args); # array of hashrefs
799 # Turn items into objects if related
800 if ($rel_meta and not $args->{no_construct}) {
802 push @objs, $rel_meta->{foreign_class}->construct($_) foreach @$items;
803 $args->{items} = \@objs;
805 else { $args->{items} = $items; }
808 #warn "Just got items. They are " . Dumper($args->{items});
810 # Make select HTML element
811 $a = $self->_select_guts($col, $args);
813 if ($args->{multiple}) {$a->attr('multiple', 'multiple');}
816 $OLD_STYLE && return $a->as_HTML;
825 # returns the intersection of list refs a and b
826 sub _list_intersect {
828 my %isect; my %union;
829 foreach my $e (@$a, @$b) { $union{$e}++ && $isect{$e}++ }
835 # Get Items returns array of hashrefs
838 my $fclass = $args->{class};
839 my @disp_cols = @{$args->{columns} || []};
840 @disp_cols = $fclass->columns('SelectBox') unless @disp_cols;
841 @disp_cols = $fclass->columns('Stringify')unless @disp_cols;
842 @disp_cols = $fclass->_essential unless @disp_cols;
843 unshift @disp_cols, $fclass->columns('Primary');
844 #my %isect = _list_intersect(\@pks, \@disp_cols);
845 #foreach (@pks) { push @sel_cols, $_ unless $isect{$_}; }
846 #push @sel_cols, @disp_cols;
848 #warn "in select items. args are : " . Dumper($args);
850 if ($args->{'distinct'}) {
851 $distinct = 'DISTINCT ';
854 my $sql = "SELECT $distinct" . join( ', ', @disp_cols) .
855 " FROM " . $fclass->table;
857 $sql .= " WHERE " . $args->{where} if $args->{where};
858 $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
859 $sql .= " LIMIT " . $args->{limit} if $args->{limit};
860 #warn "_select_items sql is : $sql";
862 my $sth = $fclass->db_Main->prepare($sql);
865 while ( my $d = $sth->fetchrow_hashref ) {push @data, $d};
871 # Makes a readonly input box out of column's value
872 # No args makes object to readonly
874 my ($self, $col, $args) = @_;
875 my $val = $args->{value};
876 if (not defined $val ) { # object to readonly
877 $self->_croak("AsForm: To readonly field called as class method without a value") unless ref $self;
879 $col = $self->primary_column;
881 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
882 'name' => $col, 'value'=>$val);
883 $OLD_STYLE && return $a->as_HTML;
888 =head2 _to_enum_select
890 Returns a select box for the an enum column type.
894 sub _to_enum_select {
895 my ($self, $col, $args) = @_;
896 my $type = $args->{column_type};
897 $type =~ /ENUM\((.*?)\)/i;
898 (my $enum = $1) =~ s/'//g;
899 my @enum_vals = split /\s*,\s*/, $enum;
901 # determine which is pre selected --
902 my $selected = eval { $self->$col };
903 $selected = $args->{default} unless defined $selected;
904 $selected = $enum_vals[0] unless defined $selected;
906 my $a = HTML::Element->new("select", name => $col);
908 my $sel = HTML::Element->new("option", value => $_);
909 $sel->attr("selected" => "selected") if $_ eq $selected ;
910 $sel->push_content($_);
911 $a->push_content($sel);
913 $OLD_STYLE && return $a->as_HTML;
918 =head2 _to_bool_select
920 Returns a "No/Yes" select box for a boolean column type.
923 # TCODO fix this mess with args
924 sub _to_bool_select {
925 my ($self, $col, $args) = @_;
926 my $type = $args->{column_type};
927 my @bool_text = ('No', 'Yes');
928 if ($type =~ /BOOL\((.+?)\)/i) {
929 (my $bool = $1) =~ s/'//g;
930 @bool_text = split /,/, $bool;
935 my $selected = $args->{value} if defined $args->{value};
936 $selected = $args->{selected} unless defined $selected;
937 $selected = ref $self ? eval {$self->$col;} : $args->{default}
938 unless (defined $selected);
940 my $a = HTML::Element->new("select", name => $col);
941 if ($args->{column_nullable} || $args->{value} eq '') {
942 my $null = HTML::Element->new("option");
943 $null->attr('selected', 'selected') if $args->{value} eq '';
944 $a->push_content( $null );
947 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
948 HTML::Element->new("option", value => 1) );
949 $opt0->push_content($bool_text[0]);
950 $opt1->push_content($bool_text[1]);
951 unless ($selected eq '') {
952 $opt0->attr("selected" => "selected") if not $selected;
953 $opt1->attr("selected" => "selected") if $selected;
955 $a->push_content($opt0, $opt1);
956 $OLD_STYLE && return $a->as_HTML;
961 =head2 _to_hidden($field, $args)
963 This makes a hidden html element input. It uses the "name" and "value"
964 arguments. If one or both are not there, it will look for an object in
965 "items->[0]" or the caller. Then it will use $field or the primary key for
966 name and the value of the column by the derived name.
971 my ($self, $field, $args) = @_;
973 my ($name, $value) = ($args->{'name'}, $args->{value});
974 $name = $field unless defined $name;
975 if (! defined $name and !defined $value) { # check for objects
976 my $obj = $args->{items}->[0] || $self;
977 unless (ref $obj) { die "_to_hidden cannot determine a value. It was passed a value argument or items object or called with an object."; }
978 $name = $obj->primary_column->name unless $name;
979 $value = $obj->$name unless $value;
982 return HTML::Element->new('input', 'type' => 'hidden',
983 'name' => $name, 'value'=>$value);
987 =head2 _to_link_hidden($col, $args)
989 Makes a link with a hidden input with the id of $obj as the value and name.
990 Name defaults to the objects primary key. The object defaults to self.
994 sub _to_link_hidden {
995 my ($self, $accessor, $args) = @_;
996 my $r = eval {$self->controller} || $args->{r} || '';
997 my $uri = $args->{uri} || '';
999 $self->_croak("_to_link_hidden cant get uri. No Maypole Request class (\$r) or uri arg. Need one or other.")
1002 if (ref $self) { # hidding linking self
1004 $name = $args->{name} || $obj->primary_column->name;
1006 elsif ($obj = $args->{items}->[0]) {
1007 $name = $args->{name} || $accessor || $obj->primary_column->name;
1008 # TODO use meta data above maybe
1010 else { # hiding linking related object with id in args
1011 $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
1012 $name = $args->{name} || $accessor ; #$obj->primary_column->name;
1013 # TODO use meta data above maybe
1015 $self->_croak("_to_link_hidden has no object") unless ref $obj;
1016 my $href = $uri || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
1017 my $a = HTML::Element->new('a', 'href' => $href);
1018 $a->push_content("$obj");
1019 $a->push_content($self->to_field('blahfooey', 'hidden', {name => $name, value => $obj->id} ));
1021 $OLD_STYLE && return $a->as_HTML;
1025 =head2 _to_foreign_inputs
1027 Creates inputs for a foreign class, usually related to the calling class or
1028 object. In names them so they do not clash with other names and so they
1029 can be processed generically. See _rename_foreign_inputs below and
1030 Maypole::Model::CDBI::FromCGI::classify_foreign_inputs.
1032 Arguments this recognizes are :
1034 related_meta -- if you have this, great, othervise it will determine or die
1035 columns -- list of columns to make inputs for
1036 request (r) -- TODO the Maypole request so we can see what action
1040 sub _to_foreign_inputs {
1041 my ($self, $accssr, $args) = @_;
1042 my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr);
1043 my $fields = $args->{columns};
1045 $self->_croak( "No relationship for accessor $accssr");
1048 my $rel_type = $rel_meta->{name};
1049 my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_meta->{foreign_class};
1052 $fields = $classORobj->can('display_columns') ?
1053 [$classORobj->display_columns] : [$classORobj->columns];
1056 # Ignore our fkey in them to prevent infinite recursion
1057 my $me = eval {$rel_meta->{args}{foreign_key}} ||
1058 eval {$rel_meta->{args}{foreign_column}}
1059 || ''; # what uses foreign_column has_many or might_have
1060 my $constrained = $rel_meta->{args}{constraint};
1062 foreach ( @$fields ) {
1063 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
1064 $inputs{$_} = $classORobj->to_field($_);
1067 # Make hidden inputs for constrained columns unless we are editing object
1068 # TODO -- is this right thing to do?
1069 unless (ref $classORobj || $args->{no_hidden_constraints}) {
1070 $inputs{$_} = $classORobj->to_field('blahfooey', 'hidden',
1071 {name => $_, value => $constrained->{$_}} )
1072 foreach ( keys %$constrained );
1074 $self->_rename_foreign_input($accssr, \%inputs);
1079 =head2 _hash_selected
1081 *Function* to make sense out of the "selected" argument which has values of the
1082 options that should be selected by default when making a select box. It
1083 can be in a number formats. This method returns a map of which options to
1084 select with the values being the keys in the map ( {val1 => 1, val2 = 1} ).
1086 Currently this method handles the following formats for the "selected" argument
1087 and in the following ways
1089 Object -- uses the id method to get the value
1090 Scalar -- assumes it *is* the value
1091 Array ref of objects -- same as Object
1092 Arrays of data -- uses the 0th element in each
1093 Hashes of data -- uses key named 'id'
1100 sub _hash_selected {
1102 my $selected = $args->{value} || $args->{selected};
1103 #warn "**** SELECTED is $selected ****";
1104 my $type = ref $selected;
1105 return $selected unless $selected and $type ne 'HASH';
1106 #warn "Selected dump : " . Dumper($selected);
1108 if ($type and $type ne 'ARRAY') {
1109 my $id = $selected->id;
1115 return { $selected => 1};
1119 # Array of objs, arrays, hashes, or just scalalrs.
1120 elsif ($type eq 'ARRAY') {
1122 my $ltype = ref $selected->[0];
1124 if ($ltype and $ltype ne 'ARRAY') {
1125 %hashed = map { $_->id => 1 } @$selected;
1127 # Arrays of data with id first
1128 elsif ($ltype and $ltype eq 'ARRAY') {
1129 %hashed = map { $_->[0] => 1 } @$selected;
1131 # Hashes using pk or id key
1132 elsif ($ltype and $ltype eq 'HASH') {
1133 my $pk = $args->{class}->primary_column || 'id';
1134 %hashed = map { $_->{$pk} => 1 } @$selected;
1138 %hashed = map { $_ => 1 } @$selected;
1142 else { warn "AsForm Could not hash the selected argument: $selected"; }
1150 Internal api method to make the actual select box form elements.
1153 Items to make options out of can be
1155 Array of CDBI objects.
1157 Array or Array refs with cols from class,
1165 my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
1167 #$args->{stringify} ||= 'stringify_selectbox';
1169 $args->{selected} = _hash_selected($args) if defined $args->{selected};
1170 my $name = $args->{name} || $col;
1171 my $a = HTML::Element->new('select', name => $name);
1172 $a->attr( %{$args->{attr}} ) if $args->{attr};
1174 if ($args->{column_nullable}) {
1175 my $null_element = HTML::Element->new('option', value => '');
1176 $null_element->attr(selected => 'selected')
1177 if ($args->{selected}{'null'});
1178 $a->push_content($null_element);
1181 my $items = $args->{items};
1182 my $type = ref $items;
1183 my $proto = eval { ref $items->[0]; } || "";
1184 my $optgroups = $args->{optgroups} || '';
1186 # Array of hashes, one for each optgroup
1189 foreach (@$optgroups) {
1190 my $ogrp= HTML::Element->new('optgroup', label => $_);
1191 $ogrp->push_content($self->_options_from_hash($items->[$i], $args));
1192 $a->push_content($ogrp);
1197 elsif ($type eq 'HASH') {
1198 $a->push_content($self->_options_from_hash($items, $args));
1201 elsif ( $type eq 'ARRAY' and not ref $items->[0] ) {
1202 $a->push_content($self->_options_from_array($items, $args));
1205 elsif( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) {
1206 # make select of objects
1207 $a->push_content($self->_options_from_objects($items, $args));
1210 elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) {
1211 $a->push_content($self->_options_from_arrays($items, $args));
1214 elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) {
1215 $a->push_content($self->_options_from_hashes($items, $args));
1218 die "You passed a weird type of data structure to me. Here it is: " .
1227 =head2 _options_from_objects ( $objects, $args);
1229 Private method to makes a options out of objects. It attempts to call each
1230 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
1232 *Note only single primary keys supported
1235 sub _options_from_objects {
1236 my ($self, $items, $args) = @_;
1237 my $selected = $args->{selected} || {};
1238 my $stringify = $args->{stringify} || '';
1242 my $opt = HTML::Element->new("option", value => $id);
1243 $id =~ s/^0*//; # leading zeros no good in hash key
1244 $opt->attr(selected => "selected") if $selected->{$id};
1245 my $content = $stringify ? $_->stringify : "$_";
1246 $opt->push_content($content);
1252 sub _options_from_arrays {
1253 my ($self, $items, $args) = @_;
1254 my $selected = $args->{selected} || {};
1256 my $class = $args->{class} || '';
1257 my $stringify = $args->{stringify} || '';
1258 for my $item (@$items) {
1259 my @pks; # for future multiple key support
1260 push @pks, shift @$item foreach $class->columns('Primary');
1262 $id =~ s/^0+//; # In case zerofill is on .
1263 my $val = defined $id ? $id : '';
1264 my $opt = HTML::Element->new("option", value =>$val);
1265 $opt->attr(selected => "selected") if $selected->{$id};
1267 my $content = ($class and $stringify and $class->can($stringify)) ?
1268 $class->$stringify($_) :
1269 join( '/', map { $_ if $_; }@{$item} );
1270 $opt->push_content( $content );
1277 sub _options_from_array {
1278 my ($self, $items, $args) = @_;
1279 my $selected = $args->{selected} || {};
1282 my $val = defined $_ ? $_ : '';
1283 my $opt = HTML::Element->new("option", value => $val);
1284 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1285 $opt->attr(selected => "selected") if $selected->{$_};
1286 $opt->push_content( $_ );
1292 sub _options_from_hash {
1293 my ($self, $items, $args) = @_;
1294 my $selected = $args->{selected} || {};
1297 my @values = values %$items;
1298 # hash Key is the option content and the hash value is option value
1299 for (sort keys %$items) {
1300 my $val = defined $items->{$_} ? $items->{$_} : '';
1301 my $opt = HTML::Element->new("option", value => $val);
1302 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1303 $opt->attr(selected => "selected") if $selected->{$items->{$_}};
1304 $opt->push_content( $_ );
1311 sub _options_from_hashes {
1312 my ($self, $items, $args) = @_;
1313 my $selected = $args->{selected} || {};
1314 my $pk = eval {$args->{class}->primary_column} || 'id';
1315 my $fclass = $args->{class} || '';
1316 my $stringify = $args->{stringify} || '';
1319 my $val = defined $_->{$pk} ? $_->{$pk} : '';
1320 my $opt = HTML::Element->new("option", value => $val);
1321 $opt->attr(selected => "selected") if $selected->{$val};
1322 my $content = ($fclass and $stringify and $fclass->can($stringify)) ?
1323 $fclass->$stringify($_) :
1324 join(' ', keys %$_);
1325 $opt->push_content( $content );
1332 #sub _to_select_or_create {
1333 # my ($self, $col, $args) = @_;
1334 # $args->{name} ||= $col;
1335 # my $select = $self->to_field($col, 'select', $args);
1336 # $args->{name} = "create_" . $args->{name};
1337 # my $create = $self->to_field($col, 'foreign_inputs', $args);
1338 # $create->{'__select_or_create__'} =
1339 # $self->to_field('__select_or_create__',{ name => '__select_or_create__' , value => 1 } );
1340 # return ($select, $create);
1346 Makes a checkbox element -- TODO
1350 # checkboxes: if no data in hand (ie called as class method), replace
1351 # with a radio button, in order to allow this field to be left
1352 # unspecified in search / add forms.
1355 # TODO -- make this general checkboxse
1359 my ($self, $col, $args) = @_;
1360 my $nullable = eval {self->column_nullable($col)} || 0;
1361 return $self->_to_radio($col) if !ref($self) || $nullable;
1362 my $value = $self->$col;
1363 my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1364 $a->attr("checked" => 'true') if $value eq 'Y';
1370 Makes a radio button element -- TODO
1373 # TODO -- make this general radio butons
1376 my ($self, $col) = @_;
1377 my $value = ref $self && $self->$col || '';
1378 my $nullable = eval {self->column_nullable($col)} || 0;
1379 my $a = HTML::Element->new("span");
1380 my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1381 my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1382 my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1383 $ry->push_content('Yes'); $rn->push_content('No');
1384 $ru->push_content('n/a') if $nullable;
1385 if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1386 elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1387 elsif ($nullable) { $ru->attr("checked" => 'true') }
1388 $a->push_content($ry, $rn);
1389 $a->push_content($ru) if $nullable;
1395 ############################ HELPER METHODS ######################
1396 ##################################################################
1398 =head2 _rename_foreign_input
1400 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1402 Recursively renames the foreign inputs made by _to_foreign_inputs so they
1403 can be processed generically. It uses foreign_input_delimiter.
1405 So if an Employee is a Person who has_many Addresses and you call and the
1406 method 'foreign_input_delimiter' returns '__AF__' then
1408 Employee->to_field("person");
1410 will get inputs for the Person as well as their Address (by default,
1411 override _field_from_relationship to change logic) named like this:
1413 person__AF__address__AF__street
1414 person__AF__address__AF__city
1415 person__AF__address__AF__state
1416 person__AF__address__AF__zip
1418 And the processor would know to create this address, put the address id in
1419 person->{address} data slot, insert the person and put the person id in the employee->{person} data slot and then insert the employee with that data.
1423 sub _rename_foreign_input {
1424 my ($self, $accssr, $element) = @_;
1425 my $del = $self->foreign_input_delimiter;
1427 if ( ref $element ne 'HASH' ) {
1428 # my $new_name = $accssr . "__AF__" . $input->attr('name');
1429 $element->attr( name => $accssr . $del . $element->attr('name'));
1432 $self->_rename_foreign_input($accssr, $element->{$_})
1433 foreach (keys %$element);
1437 =head2 foreign_input_delimiter
1439 This tells AsForm what to use to delmit forieign input names. This is important
1440 to avoid name clashes as well as automating processing of forms.
1444 sub foreign_input_delimiter { '__AF__' };
1448 This functions computes the dimensions of a textarea based on the value
1456 my ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1459 my @rows = split /^/, $text;
1460 my $cols = $min_cols;
1463 my $len = length $_;
1465 $cols = $len if $len > $cols;
1466 $cols = $max_cols if $cols > $max_cols;
1469 $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1470 $rows = $min_rows if $rows < $min_rows;
1471 $rows = $max_rows if $rows > $max_rows;
1474 else { ($min_rows, $min_cols) }
1484 15-07-2004 -- Initial version
1491 Peter Speltz, Aaron Trevena
1493 =head1 AUTHORS EMERITUS
1495 Simon Cozens, Tony Bowden
1501 chekbox generalization
1502 radio generalization
1504 Make link_hidden use standard make_url stuff when it gets in Maypole
1505 How do you tell AF --" I want a has_many select box for this every time so,
1506 when you call "to_field($this_hasmany)" you get a select box
1508 =head1 BUGS and QUERIES
1510 Please direct all correspondence regarding this module to:
1513 =head1 COPYRIGHT AND LICENSE
1515 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1517 This library is free software; you can redistribute it and/or modify
1518 it under the same terms as Perl itself.
1522 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.