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; /
17 use Class::DBI::Plugin::Type ();
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 %]
123 #####################################################
128 __PACKAGE__->has_a('job_employer' => 'Employer');
129 __PACKAGE__->has_a('contact' => 'Contact')
132 __PACKAGE__->has_a('cont_employer' => 'Employer');
133 __PACKAGE__->has_many('jobs' => 'Job',
134 { join => { job_employer => 'cont_employer' },
135 constraint => { 'finshed' => 0 },
136 order_by => "created ASC",
141 __PACKAGE__->has_many('jobs' => 'Job',);
142 __PACKAGE__->has_many('contacts' => 'Contact',
143 order_by => 'name DESC',
147 # Choose some jobs to add to a contact (has multiple attribute).
148 my $job_sel = Contact->to_field('jobs'); # Uses constraint and order by
151 # Choose a job from $contact->jobs
152 my $job_sel = $contact->to_field('jobs');
161 This module helps to generate HTML forms for creating new database rows
162 or editing existing rows. It maps column names in a database table to
163 HTML form elements which fit the schema. Large text fields are turned
164 into textareas, and fields with a has-a relationship to other
165 C<Class::DBI> tables are turned into select drop-downs populated with
166 objects from the joined class.
169 =head1 ARGUMENTS HASH
171 This provides a convenient way to tweak AsForm's behavior in exceptional or
172 not so exceptional instances. Below describes the arguments hash and
176 $beer->to_field($col, $how, $args);
177 $beer->to_field($col, $args);
179 Not all _to_* methods pay attention to all arguments. For example, '_to_textfield' does not look in $args->{'items'} at all.
183 =item name -- the name the element will have , this trumps the derived name.
185 $beer->to_field('brewery', 'readonly', {
189 =item value -- the initial value the element will have, trumps derived value
191 $beer->to_field('brewery', 'textfield', {
192 name => 'brewery_id', value => $beer->brewery,
193 # however, no need to set value since $beer is object
196 =item items -- array of items generally used to make select box options
198 Can be array of objects, hashes, arrays, or strings, or just a hash.
201 $beer->to_field(rating => select => {
202 items => [1 , 2, 3, 4, 5],
205 # Select a Brewery to visit in the UK
206 Brewery->to_field(brewery_id => {
207 items => [ Brewery->search_like(location => 'UK') ],
210 # Make a select for a boolean field
211 $Pub->to_field('open' , { items => [ {'Open' => 1, 'Closed' => 0 } ] });
213 =item selected -- something representing which item is selected in a select box
215 $beer->to_field('brewery', {
216 selected => $beer->brewery, # again not necessary since caller is obj.
219 Can be an simple scalar id, an object, or an array of either
221 =item class -- the class for which the input being made for field pertains to.
223 This in almost always derived in cases where it may be difficult to derive, --
224 # Select beers to serve on handpump
225 Pub->to_field(handpumps => select => {
226 class => 'Beer', order_by => 'name ASC', multiple => 1,
229 =item column_type -- a string representing column type
231 $pub->to_field('open', 'bool_select', {
232 column_type => "bool('Closed', 'Open'),
235 =item column_nullable -- flag saying if column is nullable or not
237 Generally this can be set to get or not get a null/empty option added to
238 a select box. AsForm attempts to call "$class->column_nullable" to set this
239 and it defaults to true if there is no shuch method.
241 $beer->to_field('brewery', { column_nullable => 1 });
243 =item r or request -- the Mapyole request object
245 =item uri -- uri for a link , used in methods such as _to_link_hidden
247 $beer->to_field('brewery', 'link_hidden',
248 {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery});
249 # an html link that is also a hidden input to the object. R is required to
250 # make the uri unless you pass a uri
252 =item order_by, constraint, join
254 These are used in making select boxes. order_by is a simple order by clause
255 and constraint and join are hashes used to limit the rows selected. The
256 difference is that join uses methods of the object and constraint uses
257 static values. You can also specify these in the relationship definitions.
258 See the relationships documentation of how to set arbitrayr meta info.
260 BeerDB::LondonBeer->has_a('brewery', 'BeerDB::Brewery',
261 order_by => 'brewery_name ASC',
262 constraint => {location => 'London'},
263 'join' => {'brewery_tablecolumn => 'beer_obj_column'},
266 =item no_hidden_constraints --
268 Tell AsForm not to make hidden inputs for relationship constraints. It does
269 this sometimes when making foreign inputs. However, i think it should not
270 do this and that the FromCGI 's _create_related method should do it.
276 $self->to_cgi([@columns, $args]);
278 This returns a hash mapping all the column names to HTML::Element objects
279 representing form widgets. It takes two opitonal arguments -- a list of
280 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.
282 $self->to_cgi(); # uses $self->columns; # most used
283 $self->to_cgi(qw/brewery style rating/); # sometimes
284 # and on rare occassions this is desireable if you have a lot of fields
285 # and dont want to call to_field a bunch of times just to tweak one or
287 $self->to_cgi(@cols, {brewery => {
288 how => 'textfield' # too big for select
291 column_nullable => 0,
293 items => ['Ale', 'Lager']
300 my ($class, @columns) = @_; # pjs -- added columns arg
303 @columns = $class->columns;
304 # Eventually after stabalization, we could add display_columns
305 #keys map { $_ => 1 } ($class->display_columns, $class->columns);
308 if ( ref $columns[-1] eq 'HASH' ) { $args = pop @columns; }
310 map { $_ => $class->to_field($_, $args->{$_}) } @columns;
313 =head2 to_field($field [, $how][, $args])
315 This maps an individual column to a form element. The C<how> argument
316 can be used to force the field type into any you want. All that you need
317 is a method named "_to_$how" in your class. Your class inherits many from
320 If C<how> is specified but the class cannot call the method it maps to,
321 then AsForm will issue a warning and the default input will be made.
322 You can write your own "_to_$how" methods and AsForm comes with many.
323 See C<HOW Methods>. You can also pass this argument in $args->{how}.
329 my ($self, $field, $how, $args) = @_;
330 print STDERR "---------------------------------\n";
331 print STDERR "[to_field] self : $self\n";
332 print STDERR "[to_field] args : field : $field , how : $how , args : $args\n";
333 print STDERR "[to_field] caller : ", join(' ',caller), "\n";
334 if (ref $how) { $args = $how; $how = ''; }
335 unless ($how) { $how = $args->{how} || ''; }
336 #warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n";
337 # Set sensible default value
338 if ($field and not defined $args->{default}) {
339 my $def = $self->column_default($field) ;
340 # exclude defaults we don't want actually put as value for input
342 $def = $def =~ /(^0000-00-00.*$|^0[0]*$|^0\.00$|CURRENT_TIMESTAMP|NULL)/i ? '' : $def ;
343 $args->{default} = $def;
347 return $self->_field_from_how($field, $how, $args) ||
348 $self->_field_from_relationship($field, $args) ||
349 $self->_field_from_column($field, $args) ||
350 $self->_to_textfield($field, $args);
356 my $cgi = $class->search_inputs ([$args]); # optional $args
358 Returns hash or hashref of search inputs elements for a class making sure the
359 inputs are empty of any initial values.
360 You can specify what columns you want inputs for in
362 by the method "search_columns". The default is "display_columns".
363 If you want to te search on columns in related classes you can do that by
364 specifying a one element hashref in place of the column name where
365 the key is the related "column" (has_a or has_many method for example) and
366 the value is a list ref of columns to search on in the related class.
369 sub BeerDB::Beer::search_columns {
370 return ( 'name' , 'rating', { brewery => [ 'name', 'location'] } );
373 # Now foreign inputs are made for Brewery name and location and the
374 # there will be no name clashing and processing can be automated.
380 my ($class, $args) = @_;
381 $class = ref $class || $class;
382 #my $accssr_class = { $class->accessor_classes };
385 $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns];
387 foreach my $field ( @{ $args->{columns} } ) {
389 no_hidden_constraints => 1,
390 column_nullable => 1, # empty option on select boxes
393 if ( ref $field eq "HASH" ) { # foreign search fields
394 my ($accssr, $cols) = each %$field;
395 $base_args->{columns} = $cols;
397 # default to search fields for related
398 #$cols = $accssr_class->{$accssr}->search_columns;
399 die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
401 my $fcgi = $class->to_field($accssr, 'foreign_inputs', $base_args);
403 # unset the default values for a select box
404 foreach (keys %$fcgi) {
405 my $el = $fcgi->{$_};
406 if ($el->tag eq 'select') {
408 $class->unselect_element($el);
409 my ($first, @content) = $el->content_list;
410 my @fc = $first->content_list;
411 my $val = $first ? $first->attr('value') : undef;
412 if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or
414 #(defined $first->attr('value') or $first->attr('value') ne ''))
415 # push an empty option on stactk
416 $el->unshift_content(HTML::Element->new('option'));
421 $cgi{$accssr} = $fcgi;
422 delete $base_args->{columns};
424 $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} });
425 my $el = $cgi{$field};
426 if ($el->tag eq 'select') {
427 $class->unselect_element($el);
428 my ($first, @content) = $el->content_list;
429 if ($first and $first->content_list) { # something
430 #(defined $first->attr('value') or $first->attr('value') ne ''))
431 # push an empty option on stactk
432 $el->unshift_content(HTML::Element->new('option'));
443 =head2 unselect_element
445 unselect any selected elements in a HTML::Element select list widget
448 sub unselect_element {
449 my ($self, $el) = @_;
450 #unless (ref $el eq 'HTML::Element') {
451 #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
452 if ($el->tag eq 'select') {
453 foreach my $opt ($el->content_list) {
454 $opt->attr('selected', undef) if $opt->attr('selected');
459 =head2 _field_from_how($field, $how,$args)
461 Returns an input element based the "how" parameter or nothing at all.
466 sub _field_from_how {
467 my ($self, $field, $how, $args) = @_;
471 my $meth = "_to_$how";
472 if (not $self->can($meth)) {
473 warn "Class can not $meth";
476 return $self->$meth($field, $args);
479 =head2 _field_from_relationship($field, $args)
481 Returns an input based on the relationship associated with the field or nothing.
484 For has_a it will give select box
488 sub _field_from_relationship {
489 my ($self, $field, $args) = @_;
490 return unless $field;
491 my $rel_meta = $self->related_meta('r',$field) || return;
492 my $rel_name = $rel_meta->{name};
493 #my $meta = $self->meta_info;
494 #grep{ defined $meta->{$_}{$field} } keys %$meta;
495 my $fclass = $rel_meta->foreign_class;
496 my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
499 if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) {
500 # This condictions allows for trumping of the has_a args
501 if (not $rel_meta->{args}{no_select} and not $args->{no_select})
503 $args->{class} = $fclass;
504 return $self->_to_select($field, $args);
508 # maybe has many select
509 if ($rel_meta->{name} eq 'has_many' and $fclass_is_cdbi and ref $self) {
510 # This condictions allows for trumping of the has_a args
511 if (not $rel_meta->{args}{no_select} and not $args->{no_select})
513 $args->{class} = $fclass;
514 my @itms = $self->$field; # need list not iterator
515 $args->{items} = \@itms;
516 return $self->_to_select($field, $args);
521 # maybe foreign inputs
522 my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
523 if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_name eq 'has_own'))
525 $args->{related_meta} = $rel_meta; # suspect faster to set these args
526 return $self->_to_foreign_inputs($field, $args);
531 =head2 _field_from_column($field, $args)
533 Returns an input based on the column's characteristics, namely type, or nothing.
538 sub _field_from_column {
539 my ($self, $field, $args) = @_;
540 # this class and pk are default class and field at this point
541 my $class = $args->{class} || $self;
542 $class = ref $class || $class;
543 $field ||= ($class->primary_columns)[0]; # TODO
546 unless ($args->{column_type}) {
547 if ($class->can('column_type')) {
548 $args->{column_type} = $class->column_type($field);
550 # Right, have some of this
551 eval "package $class; Class::DBI::Plugin::Type->import()";
552 $args->{column_type} = $class->column_type($field);
555 my $type = $args->{column_type};
557 return $self->_to_textfield($field, $args)
558 if $type and $type =~ /^(VAR)?CHAR/i; #common type
559 return $self->_to_textarea($field, $args)
560 if $type and $type =~ /^(TEXT|BLOB)$/i;
561 return $self->_to_enum_select($field, $args)
562 if $type and $type =~ /^ENUM\((.*?)\)$/i;
563 return $self->_to_bool_select($field, $args)
564 if $type and $type =~ /^BOOL/i;
565 return $self->_to_readonly($field, $args)
566 if $type and $type =~ /^readonly$/i;
572 my ($self, $col, $args) = @_;
573 my $class = $args->{class} || $self;
574 $class = ref $class || $class;
575 $col ||= ($class->primary_columns)[0]; # TODO
578 my $val = $args->{value};
580 unless (defined $val) {
585 $val = $args->{default};
586 $val = '' unless defined $val;
589 my ($rows, $cols) = _box($val);
590 $rows = $args->{rows} if $args->{rows};
591 $cols = $args->{cols} if $args->{cols};;
592 my $name = $args->{name} || $col;
594 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
595 $a->push_content($val);
596 $OLD_STYLE && return $a->as_HTML;
601 my ($self, $col, $args ) = @_;
602 use Carp qw/confess/;
603 confess "No col passed to _to_textfield" unless $col;
605 my $val = $args->{value};
606 my $name = $args->{name} || $col;
608 unless (defined $val) {
610 # Case where column inflates.
611 # Input would get stringification which could be not good.
612 # as in the case of Time::Piece objects
613 $val = $self->can($col) ? $self->$col : ''; # in case it is a virtual column
615 if (my $meta = $self->related_meta('',$col)) {
616 if (my $code = $meta->{args}{deflate4edit} || $meta->{args}{deflate} ) {
617 $val = ref $code ? &$code($val) : $val->$code;
619 elsif ( $val->isa('Class::DBI') ) {
623 #warn "No deflate4edit code defined for $val of type " .
624 #ref $val . ". Using the stringified value in textfield..";
628 $val = $val->id if $val->isa("Class::DBI");
634 $val = $args->{default};
635 $val = '' unless defined $val;
639 # THIS If section is neccessary or you end up with "value" for a vaiue
641 $val = '' unless defined $val;
642 $a = HTML::Element->new("input", type => "text", name => $name, value =>$val);
643 $OLD_STYLE && return $a->as_HTML;
650 # my ($self, $col, $hint) = @_;
651 # my $fclass = $hint || $self->__hasa_rels->{$col}->[0];
652 # my @objs = $fclass->retrieve_all;
653 # my $a = HTML::Element->new("select", name => $col);
655 # my $sel = HTML::Element->new("option", value => $_->id);
656 # $sel->attr("selected" => "selected")
658 # and eval { $_->id eq $self->$col->id };
659 # $sel->push_content($_->stringify_self);
660 # $a->push_content($sel);
662 # $OLD_STYLE && return $a->as_HTML;
669 =head2 recognized arguments
671 selected => $object|$id,
674 where => SQL 'WHERE' clause,
675 order_by => SQL 'ORDER BY' clause,
676 constraint => hash of constraints to search
677 limit => SQL 'LIMIT' clause,
678 items => [ @items_of_same_type_to_select_from ],
679 class => $class_we_are_selecting_from
680 stringify => $stringify_coderef|$method_name
685 # select box requirements
686 # 1. a select box for objecs of a has_a related class -- DONE
687 =head2 1. a select box out of a has_a or has_many related class.
688 # For has_a the default behavior is to make a select box of every element in
689 # related class and you choose one.
690 #Or explicitly you can create one and pass options like where and order
691 BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
693 # For has_many the default is to get a multiple select box with all objects.
694 # If called as an object method, the objects existing ones will be selected.
695 Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"});
698 =head2 2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun.
700 BeerDB::Beer->to_field('', 'select', $options)
702 BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
703 # with PK as ID, $Class->to_field() same.
704 BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
705 # specify exact where clause
707 =head2 3. If you already have a list of objects to select from --
709 BeerDB:;Beer->to_field($col, 'select' , {items => $objects});
711 # 3. a select box for arbitrary set of objects
712 # Pass array ref of objects as first arg rather than field
713 $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
719 my ($self, $col, $args) = @_;
720 warn "\n---\n[_to_select] col : $col\n";
721 warn "[_to_select] self : $self\n";
722 warn "[_to_select] args : ",Dumper($args), "\n";
723 warn "[_to_select] caller : ",caller(),"\n";
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}) {
731 $a->attr('multiple', 'multiple');
740 unless ($args->{class}) {
741 $args->{class} = ref $self || $self;
742 # object selected if called with one
743 $args->{selected} = { $self->id => 1}
744 if not $args->{selected} and ref $self;
746 $col = $args->{class}->primary_column;
747 $args->{name} ||= $col;
749 # Related Class maybe ?
750 elsif ($rel_meta = $self->related_meta('r:)', $col) ) {
751 $args->{class} = $rel_meta->{foreign_class};
752 # related objects pre selected if object
754 # "Has many" -- Issues:
755 # 1) want to select one or many from list if self is an object
756 # Thats about all we can do really,
757 # 2) except for mapping which is TODO and would
758 # do something like add to and take away from list of permissions for
761 # Hasmany select one from list if ref self
762 if ($rel_meta->{name} =~ /has_many/i and ref $self) {
763 my @itms = $self->$col; # need list not iterator
764 $args->{items} = \@itms;
765 my $a = $self->_select_guts($col, $args);
766 $OLD_STYLE && return $a->as_HTML;
769 $args->{selected} ||= [ $self->$col ] if ref $self;
770 #warn "selected is " . Dumper($args->{selected});
771 my $c = $rel_meta->{args}{constraint} || {};
772 my $j = $rel_meta->{args}{join} || {};
775 @join = map { $_ ." = ". $self->_attr($_) } keys %$j;
777 my @constr= map { "$_ = '$c->{$_}'"} keys %$c;
778 $args->{where} ||= join (' AND ', (@join, @constr));
779 $args->{order_by} ||= $rel_meta->{args}{order_by};
780 $args->{limit} ||= $rel_meta->{args}{limit};
784 # We could say :Col is name and we are selecting out of class arg.
787 # die "Usage _to_select. $col not related to any class to select from. ";
792 unless ( defined $args->{column_nullable} ) {
793 $args->{column_nullable} = $self->can('column_nullable') ?
794 $self->column_nullable($col) : 1;
797 # Get items to select from
798 my $items = _select_items($args); # array of hashrefs
800 # Turn items into objects if related
801 if ($rel_meta and not $args->{no_construct}) {
803 push @objs, $rel_meta->{foreign_class}->construct($_) foreach @$items;
804 $args->{items} = \@objs;
806 $args->{items} = $items;
810 warn "Just got items. They are " . Dumper($args->{items});
814 # Make select HTML element
815 $a = $self->_select_guts($col, $args);
817 if ($args->{multiple}) {
818 $a->attr('multiple', 'multiple');
822 $OLD_STYLE && return $a->as_HTML;
831 # returns the intersection of list refs a and b
832 sub _list_intersect {
834 my %isect; my %union;
835 foreach my $e (@$a, @$b) { $union{$e}++ && $isect{$e}++ }
841 # Get Items returns array of hashrefs
844 my $fclass = $args->{class};
845 my @disp_cols = @{$args->{columns} || []};
846 @disp_cols = $fclass->columns('SelectBox') unless @disp_cols;
847 @disp_cols = $fclass->columns('Stringify')unless @disp_cols;
848 @disp_cols = $fclass->_essential unless @disp_cols;
849 unshift @disp_cols, $fclass->columns('Primary');
850 #my %isect = _list_intersect(\@pks, \@disp_cols);
851 #foreach (@pks) { push @sel_cols, $_ unless $isect{$_}; }
852 #push @sel_cols, @disp_cols;
854 #warn "in select items. args are : " . Dumper($args);
856 if ($args->{'distinct'}) {
857 $distinct = 'DISTINCT ';
860 my $sql = "SELECT $distinct" . join( ', ', @disp_cols) .
861 " FROM " . $fclass->table;
863 $sql .= " WHERE " . $args->{where} if $args->{where};
864 $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
865 $sql .= " LIMIT " . $args->{limit} if $args->{limit};
866 #warn "_select_items sql is : $sql";
868 my $sth = $fclass->db_Main->prepare($sql);
871 while ( my $d = $sth->fetchrow_hashref ) {push @data, $d};
877 # Makes a readonly input box out of column's value
878 # No args makes object to readonly
880 my ($self, $col, $args) = @_;
881 my $val = $args->{value};
882 if (not defined $val ) { # object to readonly
883 $self->_croak("AsForm: To readonly field called as class method without a value") unless ref $self;
885 $col = $self->primary_column;
887 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
888 'name' => $col, 'value'=>$val);
889 $OLD_STYLE && return $a->as_HTML;
894 =head2 _to_enum_select
896 Returns a select box for the an enum column type.
900 sub _to_enum_select {
901 my ($self, $col, $args) = @_;
902 my $type = $args->{column_type};
903 $type =~ /ENUM\((.*?)\)/i;
904 (my $enum = $1) =~ s/'//g;
905 my @enum_vals = split /\s*,\s*/, $enum;
907 # determine which is pre selected --
908 my $selected = eval { $self->$col };
909 $selected = $args->{default} unless defined $selected;
910 $selected = $enum_vals[0] unless defined $selected;
912 my $a = HTML::Element->new("select", name => $col);
914 my $sel = HTML::Element->new("option", value => $_);
915 $sel->attr("selected" => "selected") if $_ eq $selected ;
916 $sel->push_content($_);
917 $a->push_content($sel);
919 $OLD_STYLE && return $a->as_HTML;
924 =head2 _to_bool_select
926 Returns a "No/Yes" select box for a boolean column type.
929 # TCODO fix this mess with args
930 sub _to_bool_select {
931 my ($self, $col, $args) = @_;
932 my $type = $args->{column_type};
933 my @bool_text = ('No', 'Yes');
934 if ($type =~ /BOOL\((.+?)\)/i) {
935 (my $bool = $1) =~ s/'//g;
936 @bool_text = split /,/, $bool;
941 my $selected = $args->{value} if defined $args->{value};
942 $selected = $args->{selected} unless defined $selected;
943 $selected = ref $self ? eval {$self->$col;} : $args->{default}
944 unless (defined $selected);
946 my $a = HTML::Element->new("select", name => $col);
947 if ($args->{column_nullable} || $args->{value} eq '') {
948 my $null = HTML::Element->new("option");
949 $null->attr('selected', 'selected') if $args->{value} eq '';
950 $a->push_content( $null );
953 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
954 HTML::Element->new("option", value => 1) );
955 $opt0->push_content($bool_text[0]);
956 $opt1->push_content($bool_text[1]);
957 unless ($selected eq '') {
958 $opt0->attr("selected" => "selected") if not $selected;
959 $opt1->attr("selected" => "selected") if $selected;
961 $a->push_content($opt0, $opt1);
962 $OLD_STYLE && return $a->as_HTML;
967 =head2 _to_hidden($field, $args)
969 This makes a hidden html element input. It uses the "name" and "value"
970 arguments. If one or both are not there, it will look for an object in
971 "items->[0]" or the caller. Then it will use $field or the primary key for
972 name and the value of the column by the derived name.
977 my ($self, $field, $args) = @_;
979 my ($name, $value) = ($args->{'name'}, $args->{value});
980 $name = $field unless defined $name;
981 if (! defined $name and !defined $value) { # check for objects
982 my $obj = $args->{items}->[0] || $self;
983 unless (ref $obj) { die "_to_hidden cannot determine a value. It was passed a value argument or items object or called with an object."; }
984 $name = $obj->primary_column->name unless $name;
985 $value = $obj->$name unless $value;
988 return HTML::Element->new('input', 'type' => 'hidden',
989 'name' => $name, 'value'=>$value);
993 =head2 _to_link_hidden($col, $args)
995 Makes a link with a hidden input with the id of $obj as the value and name.
996 Name defaults to the objects primary key. The object defaults to self.
1000 sub _to_link_hidden {
1001 my ($self, $accessor, $args) = @_;
1002 my $r = eval {$self->controller} || $args->{r} || '';
1003 my $uri = $args->{uri} || '';
1005 $self->_croak("_to_link_hidden cant get uri. No Maypole Request class (\$r) or uri arg. Need one or other.")
1008 if (ref $self) { # hidding linking self
1010 $name = $args->{name} || $obj->primary_column->name;
1012 elsif ($obj = $args->{items}->[0]) {
1013 $name = $args->{name} || $accessor || $obj->primary_column->name;
1014 # TODO use meta data above maybe
1016 else { # hiding linking related object with id in args
1017 $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
1018 $name = $args->{name} || $accessor ; #$obj->primary_column->name;
1019 # TODO use meta data above maybe
1021 $self->_croak("_to_link_hidden has no object") unless ref $obj;
1022 my $href = $uri || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
1023 my $a = HTML::Element->new('a', 'href' => $href);
1024 $a->push_content("$obj");
1025 $a->push_content($self->to_field('blahfooey', 'hidden', {name => $name, value => $obj->id} ));
1027 $OLD_STYLE && return $a->as_HTML;
1031 =head2 _to_foreign_inputs
1033 Creates inputs for a foreign class, usually related to the calling class or
1034 object. In names them so they do not clash with other names and so they
1035 can be processed generically. See _rename_foreign_inputs below and
1036 Maypole::Model::CDBI::FromCGI::classify_foreign_inputs.
1038 Arguments this recognizes are :
1040 related_meta -- if you have this, great, othervise it will determine or die
1041 columns -- list of columns to make inputs for
1042 request (r) -- TODO the Maypole request so we can see what action
1046 sub _to_foreign_inputs {
1047 my ($self, $accssr, $args) = @_;
1048 my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr);
1049 my $fields = $args->{columns};
1051 $self->_croak( "No relationship for accessor $accssr");
1054 my $rel_type = $rel_meta->{name};
1055 my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_meta->{foreign_class};
1058 $fields = $classORobj->can('display_columns') ?
1059 [$classORobj->display_columns] : [$classORobj->columns];
1062 # Ignore our fkey in them to prevent infinite recursion
1063 my $me = eval {$rel_meta->{args}{foreign_key}} ||
1064 eval {$rel_meta->{args}{foreign_column}}
1065 || ''; # what uses foreign_column has_many or might_have
1066 my $constrained = $rel_meta->{args}{constraint};
1068 foreach ( @$fields ) {
1069 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
1070 $inputs{$_} = $classORobj->to_field($_);
1073 # Make hidden inputs for constrained columns unless we are editing object
1074 # TODO -- is this right thing to do?
1075 unless (ref $classORobj || $args->{no_hidden_constraints}) {
1076 $inputs{$_} = $classORobj->to_field('blahfooey', 'hidden',
1077 {name => $_, value => $constrained->{$_}} )
1078 foreach ( keys %$constrained );
1080 $self->_rename_foreign_input($accssr, \%inputs);
1085 =head2 _hash_selected
1087 *Function* to make sense out of the "selected" argument which has values of the
1088 options that should be selected by default when making a select box. It
1089 can be in a number formats. This method returns a map of which options to
1090 select with the values being the keys in the map ( {val1 => 1, val2 = 1} ).
1092 Currently this method handles the following formats for the "selected" argument
1093 and in the following ways
1095 Object -- uses the id method to get the value
1096 Scalar -- assumes it *is* the value
1097 Array ref of objects -- same as Object
1098 Arrays of data -- uses the 0th element in each
1099 Hashes of data -- uses key named 'id'
1106 sub _hash_selected {
1108 my $selected = $args->{value} || $args->{selected};
1109 #warn "**** SELECTED is $selected ****";
1110 my $type = ref $selected;
1111 return $selected unless $selected and $type ne 'HASH';
1112 #warn "Selected dump : " . Dumper($selected);
1114 if ($type and $type ne 'ARRAY') {
1115 my $id = $selected->id;
1121 return { $selected => 1};
1125 # Array of objs, arrays, hashes, or just scalalrs.
1126 elsif ($type eq 'ARRAY') {
1128 my $ltype = ref $selected->[0];
1130 if ($ltype and $ltype ne 'ARRAY') {
1131 %hashed = map { $_->id => 1 } @$selected;
1133 # Arrays of data with id first
1134 elsif ($ltype and $ltype eq 'ARRAY') {
1135 %hashed = map { $_->[0] => 1 } @$selected;
1137 # Hashes using pk or id key
1138 elsif ($ltype and $ltype eq 'HASH') {
1139 my $pk = $args->{class}->primary_column || 'id';
1140 %hashed = map { $_->{$pk} => 1 } @$selected;
1144 %hashed = map { $_ => 1 } @$selected;
1148 else { warn "AsForm Could not hash the selected argument: $selected"; }
1156 Internal api method to make the actual select box form elements.
1159 Items to make options out of can be
1161 Array of CDBI objects.
1163 Array or Array refs with cols from class,
1171 my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
1173 #$args->{stringify} ||= 'stringify_selectbox';
1175 $args->{selected} = _hash_selected($args) if defined $args->{selected};
1176 my $name = $args->{name} || $col;
1177 my $a = HTML::Element->new('select', name => $name);
1178 $a->attr( %{$args->{attr}} ) if $args->{attr};
1180 if ($args->{column_nullable}) {
1181 my $null_element = HTML::Element->new('option', value => '');
1182 $null_element->attr(selected => 'selected')
1183 if ($args->{selected}{'null'});
1184 $a->push_content($null_element);
1187 my $items = $args->{items};
1188 my $type = ref $items;
1189 my $proto = eval { ref $items->[0]; } || "";
1190 my $optgroups = $args->{optgroups} || '';
1192 # Array of hashes, one for each optgroup
1195 foreach (@$optgroups) {
1196 my $ogrp= HTML::Element->new('optgroup', label => $_);
1197 $ogrp->push_content($self->_options_from_hash($items->[$i], $args));
1198 $a->push_content($ogrp);
1203 elsif ($type eq 'HASH') {
1204 warn "making select of single hash";
1205 $a->push_content($self->_options_from_hash($items, $args));
1208 elsif ( $type eq 'ARRAY' and not ref $items->[0] ) {
1209 warn "making select of single array";
1210 $a->push_content($self->_options_from_array($items, $args));
1213 elsif ( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) {
1214 # make select of objects
1215 warn "making select of objects\n";
1216 $a->push_content($self->_options_from_objects($items, $args));
1219 elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) {
1220 warn "making select of array of arrays\n";
1221 $a->push_content($self->_options_from_arrays($items, $args));
1224 elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) {
1225 warn "making select of array of \n";
1226 $a->push_content($self->_options_from_hashes($items, $args));
1228 die "You passed a weird type of data structure to me. Here it is: " .
1237 =head2 _options_from_objects ( $objects, $args);
1239 Private method to makes a options out of objects. It attempts to call each
1240 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
1242 *Note only single primary keys supported
1245 sub _options_from_objects {
1246 my ($self, $items, $args) = @_;
1247 my $selected = $args->{selected} || {};
1248 my $stringify = $args->{stringify} || $self->stringify_column;
1250 warn "self : $self\n";
1251 warn "stringify : $stringify\n";
1252 warn "stringify column : ", $self->stringify_column, "\n";
1253 warn "stringify in args : ", $args->{stringify}, "\n";
1258 my $opt = HTML::Element->new("option", value => $id);
1259 $id =~ s/^0*//; # leading zeros no good in hash key
1260 $opt->attr(selected => "selected") if $selected->{$id};
1261 my $content = $stringify ? $_->$stringify : "$_";
1262 $opt->push_content($content);
1268 sub _options_from_arrays {
1269 my ($self, $items, $args) = @_;
1270 my $selected = $args->{selected} || {};
1272 my $class = $args->{class} || '';
1273 my $stringify = $args->{stringify} || $self->stringify_column;
1274 for my $item (@$items) {
1275 my @pks; # for future multiple key support
1276 push @pks, shift @$item foreach $class->columns('Primary');
1278 $id =~ s/^0+//; # In case zerofill is on .
1279 my $val = defined $id ? $id : '';
1280 my $opt = HTML::Element->new("option", value =>$val);
1281 $opt->attr(selected => "selected") if $selected->{$id};
1283 my $content = ($class and $stringify and $class->can($stringify)) ?
1284 $class->$stringify($_) :
1285 join( '/', map { $_ if $_; }@{$item} );
1286 $opt->push_content( $content );
1293 sub _options_from_array {
1294 my ($self, $items, $args) = @_;
1295 my $selected = $args->{selected} || {};
1298 my $val = defined $_ ? $_ : '';
1299 my $opt = HTML::Element->new("option", value => $val);
1300 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1301 $opt->attr(selected => "selected") if $selected->{$_};
1302 $opt->push_content( $_ );
1308 sub _options_from_hash {
1309 my ($self, $items, $args) = @_;
1310 my $selected = $args->{selected} || {};
1313 my @values = values %$items;
1314 # hash Key is the option content and the hash value is option value
1315 for (sort keys %$items) {
1316 my $val = defined $items->{$_} ? $items->{$_} : '';
1317 my $opt = HTML::Element->new("option", value => $val);
1318 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1319 $opt->attr(selected => "selected") if $selected->{$items->{$_}};
1320 $opt->push_content( $_ );
1327 sub _options_from_hashes {
1328 my ($self, $items, $args) = @_;
1329 warn "_options_from_hashes called with $self,", Dumper($items), Dumper($args), "\n";
1330 my $selected = $args->{selected} || {};
1331 my $pk = eval {$args->{class}->primary_column} || 'id';
1332 my $fclass = $args->{class} || '';
1333 my $stringify = $args->{stringify} || $self->stringify_column;
1335 for my $item (@$items) {
1336 my $val = defined $item->{$pk} ? $item->{$pk} : '';
1337 my $opt = HTML::Element->new("option", value => $val);
1338 $opt->attr(selected => "selected") if $selected->{$val};
1340 if ($fclass and $stringify and $fclass->can($stringify)) {
1341 $content = bless ($item,$fclass)->$stringify();
1342 } elsif ( $stringify ) {
1343 $content = $item->{$stringify};
1345 $content = join(' ', map {$item->{$_} } keys %$item);
1347 $opt->push_content( $content );
1354 #sub _to_select_or_create {
1355 # my ($self, $col, $args) = @_;
1356 # $args->{name} ||= $col;
1357 # my $select = $self->to_field($col, 'select', $args);
1358 # $args->{name} = "create_" . $args->{name};
1359 # my $create = $self->to_field($col, 'foreign_inputs', $args);
1360 # $create->{'__select_or_create__'} =
1361 # $self->to_field('__select_or_create__',{ name => '__select_or_create__' , value => 1 } );
1362 # return ($select, $create);
1368 Makes a checkbox element -- TODO
1372 # checkboxes: if no data in hand (ie called as class method), replace
1373 # with a radio button, in order to allow this field to be left
1374 # unspecified in search / add forms.
1377 # TODO -- make this general checkboxse
1381 my ($self, $col, $args) = @_;
1382 my $nullable = eval {self->column_nullable($col)} || 0;
1383 return $self->_to_radio($col) if !ref($self) || $nullable;
1384 my $value = $self->$col;
1385 my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1386 $a->attr("checked" => 'true') if $value eq 'Y';
1392 Makes a radio button element -- TODO
1395 # TODO -- make this general radio butons
1398 my ($self, $col) = @_;
1399 my $value = ref $self && $self->$col || '';
1400 my $nullable = eval {self->column_nullable($col)} || 0;
1401 my $a = HTML::Element->new("span");
1402 my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1403 my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1404 my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1405 $ry->push_content('Yes'); $rn->push_content('No');
1406 $ru->push_content('n/a') if $nullable;
1407 if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1408 elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1409 elsif ($nullable) { $ru->attr("checked" => 'true') }
1410 $a->push_content($ry, $rn);
1411 $a->push_content($ru) if $nullable;
1417 ############################ HELPER METHODS ######################
1418 ##################################################################
1420 =head2 _rename_foreign_input
1422 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1424 Recursively renames the foreign inputs made by _to_foreign_inputs so they
1425 can be processed generically. It uses foreign_input_delimiter.
1427 So if an Employee is a Person who has_many Addresses and you call and the
1428 method 'foreign_input_delimiter' returns '__AF__' then
1430 Employee->to_field("person");
1432 will get inputs for the Person as well as their Address (by default,
1433 override _field_from_relationship to change logic) named like this:
1435 person__AF__address__AF__street
1436 person__AF__address__AF__city
1437 person__AF__address__AF__state
1438 person__AF__address__AF__zip
1440 And the processor would know to create this address, put the address id in
1441 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.
1445 sub _rename_foreign_input {
1446 my ($self, $accssr, $element) = @_;
1447 my $del = $self->foreign_input_delimiter;
1449 if ( ref $element ne 'HASH' ) {
1450 # my $new_name = $accssr . "__AF__" . $input->attr('name');
1451 $element->attr( name => $accssr . $del . $element->attr('name'));
1454 $self->_rename_foreign_input($accssr, $element->{$_})
1455 foreach (keys %$element);
1459 =head2 foreign_input_delimiter
1461 This tells AsForm what to use to delmit forieign input names. This is important
1462 to avoid name clashes as well as automating processing of forms.
1466 sub foreign_input_delimiter { '__AF__' };
1470 This functions computes the dimensions of a textarea based on the value
1478 my ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1481 my @rows = split /^/, $text;
1482 my $cols = $min_cols;
1485 my $len = length $_;
1487 $cols = $len if $len > $cols;
1488 $cols = $max_cols if $cols > $max_cols;
1491 $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1492 $rows = $min_rows if $rows < $min_rows;
1493 $rows = $max_rows if $rows > $max_rows;
1496 else { ($min_rows, $min_cols) }
1506 15-07-2004 -- Initial version
1513 Peter Speltz, Aaron Trevena
1515 =head1 AUTHORS EMERITUS
1517 Simon Cozens, Tony Bowden
1523 chekbox generalization
1524 radio generalization
1526 Make link_hidden use standard make_url stuff when it gets in Maypole
1527 How do you tell AF --" I want a has_many select box for this every time so,
1528 when you call "to_field($this_hasmany)" you get a select box
1530 =head1 BUGS and QUERIES
1532 Please direct all correspondence regarding this module to:
1535 =head1 COPYRIGHT AND LICENSE
1537 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1539 This library is free software; you can redistribute it and/or modify
1540 it under the same terms as Perl itself.
1544 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.