1 package Maypole::Model::CDBI::AsForm;
8 use Class::DBI::Plugin::Type ();
15 to_cgi to_field foreign_input_delimiter search_inputs unselect_element
16 _field_from_how _field_from_relationship _field_from_column
17 _to_textarea _to_textfield _to_select _select_guts
18 _to_foreign_inputs _to_enum_select _to_bool_select
19 _to_hidden _to_link_hidden _rename_foreign_input _to_readonly
20 _options_from_objects _options_from_arrays _options_from_hashes
21 _options_from_array _options_from_hash
28 Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns
33 use Maypole::Model::CDBI::AsForm;
34 use base 'Class::DBI';
40 my %cgi_field = $self->to_cgi;
42 (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
50 # Somewhere else in a Maypole application about beer...
55 $beer->to_field('brewery', 'textfield', {
56 name => 'brewery_id', value => $beer->brewery,
57 # however, no need to set value since $beer is object
61 $beer->to_field(rating => select => {
62 items => [1 , 2, 3, 4, 5],
65 # Select a Brewery to visit in the UK
66 Brewery->to_field(brewery_id => {
67 items => [ Brewery->search_like(location => 'UK') ],
70 # Make a select for a boolean field
71 $Pub->to_field('open' , { items => [ {'Open' => 1, 'Closed' => 0 } ] });
73 $beer->to_field('brewery', {
74 selected => $beer->brewery, # again not necessary since caller is obj.
78 $beer->to_field('brewery', 'link_hidden', {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery});
79 # an html link that is also a hidden input to the object. R is required to
80 # make the uri unless you pass a uri
84 #####################################################
93 <span class="field"> [% classmetadata.colnames.$col %] : </span>
95 [% object.to_field(col).as_XML %]
103 <span class="field"> Brewery : </span>
105 [% object.to_field('brewery', { selected => 23} ).as_XML %]
114 #####################################################
119 __PACKAGE__->has_a('job_employer' => 'Employer');
120 __PACKAGE__->has_a('contact' => 'Contact')
123 __PACKAGE__->has_a('cont_employer' => 'Employer');
124 __PACKAGE__->has_many('jobs' => 'Job',
125 { join => { job_employer => 'cont_employer' },
126 constraint => { 'finshed' => 0 },
127 order_by => "created ASC",
132 __PACKAGE__->has_many('jobs' => 'Job',);
133 __PACKAGE__->has_many('contacts' => 'Contact',
134 order_by => 'name DESC',
138 # Choose some jobs to add to a contact (has multiple attribute).
139 my $job_sel = Contact->to_field('jobs'); # Uses constraint and order by
142 # Choose a job from $contact->jobs
143 my $job_sel = $contact->to_field('jobs');
152 This module helps to generate HTML forms for creating new database rows
153 or editing existing rows. It maps column names in a database table to
154 HTML form elements which fit the schema. Large text fields are turned
155 into textareas, and fields with a has-a relationship to other
156 C<Class::DBI> tables are turned into select drop-downs populated with
157 objects from the joined class.
160 =head1 ARGUMENTS HASH
162 This provides a convenient way to tweak AsForm's behavior in exceptional or
163 not so exceptional instances. Below describes the arguments hash and
167 $beer->to_field($col, $how, $args);
168 $beer->to_field($col, $args);
170 Not all _to_* methods pay attention to all arguments. For example, '_to_textfield' does not look in $args->{'items'} at all.
174 =item name -- the name the element will have , this trumps the derived name.
176 $beer->to_field('brewery', 'readonly', {
180 =item value -- the initial value the element will have, trumps derived value
182 $beer->to_field('brewery', 'textfield', {
183 name => 'brewery_id', value => $beer->brewery,
184 # however, no need to set value since $beer is object
187 =item items -- array of items generally used to make select box options
189 Can be array of objects, hashes, arrays, or strings, or just a hash.
192 $beer->to_field(rating => select => {
193 items => [1 , 2, 3, 4, 5],
196 # Select a Brewery to visit in the UK
197 Brewery->to_field(brewery_id => {
198 items => [ Brewery->search_like(location => 'UK') ],
201 # Make a select for a boolean field
202 $Pub->to_field('open' , { items => [ {'Open' => 1, 'Closed' => 0 } ] });
204 =item selected -- something representing which item is selected in a select box
206 $beer->to_field('brewery', {
207 selected => $beer->brewery, # again not necessary since caller is obj.
210 Can be an simple scalar id, an object, or an array of either
212 =item class -- the class for which the input being made for field pertains to.
214 This in almost always derived in cases where it may be difficult to derive, --
215 # Select beers to serve on handpump
216 Pub->to_field(handpumps => select => {
217 class => 'Beer', order_by => 'name ASC', multiple => 1,
220 =item column_type -- a string representing column type
222 $pub->to_field('open', 'bool_select', {
223 column_type => "bool('Closed', 'Open'),
226 =item column_nullable -- flag saying if column is nullable or not
228 Generally this can be set to get or not get a null/empty option added to
229 a select box. AsForm attempts to call "$class->column_nullable" to set this
230 and it defaults to true if there is no shuch method.
232 $beer->to_field('brewery', { column_nullable => 1 });
234 =item r or request -- the Mapyole request object
236 =item uri -- uri for a link , used in methods such as _to_link_hidden
238 $beer->to_field('brewery', 'link_hidden',
239 {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery});
240 # an html link that is also a hidden input to the object. R is required to
241 # make the uri unless you pass a uri
243 =item order_by, constraint, join
245 These are used in making select boxes. order_by is a simple order by clause
246 and constraint and join are hashes used to limit the rows selected. The
247 difference is that join uses methods of the object and constraint uses
248 static values. You can also specify these in the relationship definitions.
249 See the relationships documentation of how to set arbitrayr meta info.
251 BeerDB::LondonBeer->has_a('brewery', 'BeerDB::Brewery',
252 order_by => 'brewery_name ASC',
253 constraint => {location => 'London'},
254 'join' => {'brewery_tablecolumn => 'beer_obj_column'},
257 =item no_hidden_constraints --
259 Tell AsForm not to make hidden inputs for relationship constraints. It does
260 this sometimes when making foreign inputs. However, i think it should not
261 do this and that the FromCGI 's _create_related method should do it.
267 $self->to_cgi([@columns, $args]);
269 This returns a hash mapping all the column names to HTML::Element objects
270 representing form widgets. It takes two opitonal arguments -- a list of
271 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.
273 $self->to_cgi(); # uses $self->columns; # most used
274 $self->to_cgi(qw/brewery style rating/); # sometimes
275 # and on rare occassions this is desireable if you have a lot of fields
276 # and dont want to call to_field a bunch of times just to tweak one or
278 $self->to_cgi(@cols, {brewery => {
279 how => 'textfield' # too big for select
282 column_nullable => 0,
284 items => ['Ale', 'Lager']
291 my ($class, @columns) = @_;
294 @columns = $class->columns;
295 # Eventually after stabalization, we could add display_columns
296 #keys map { $_ => 1 } ($class->display_columns, $class->columns);
298 if ( ref $columns[-1] eq 'HASH' ) {
299 $args = pop @columns;
302 map { $_ => $class->to_field($_, $args->{$_}) } @columns;
305 =head2 to_field($field [, $how][, $args])
307 This maps an individual column to a form element. The C<how> argument
308 can be used to force the field type into any you want. All that you need
309 is a method named "_to_$how" in your class. Your class inherits many from
312 If C<how> is specified but the class cannot call the method it maps to,
313 then AsForm will issue a warning and the default input will be made.
314 You can write your own "_to_$how" methods and AsForm comes with many.
315 See C<HOW Methods>. You can also pass this argument in $args->{how}.
321 my ($self, $field, $how, $args) = @_;
322 if (ref $how) { $args = $how; $how = ''; }
323 unless ($how) { $how = $args->{how} || ''; }
324 #warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n";
325 # Set sensible default value
326 if ($field and not defined $args->{default}) {
327 my $def = $self->column_default($field) ;
328 # exclude defaults we don't want actually put as value for input
330 $def = $def =~ /(^0000-00-00.*$|^0[0]*$|^0\.00$|CURRENT_TIMESTAMP|NULL)/i ? '' : $def ;
331 $args->{default} = $def;
335 return $self->_field_from_how($field, $how, $args) ||
336 $self->_field_from_relationship($field, $args) ||
337 $self->_field_from_column($field, $args) ||
338 $self->_to_textfield($field, $args);
344 my $cgi = $class->search_inputs ([$args]); # optional $args
346 Returns hash or hashref of search inputs elements for a class making sure the
347 inputs are empty of any initial values.
348 You can specify what columns you want inputs for in
350 by the method "search_columns". The default is "display_columns".
351 If you want to te search on columns in related classes you can do that by
352 specifying a one element hashref in place of the column name where
353 the key is the related "column" (has_a or has_many method for example) and
354 the value is a list ref of columns to search on in the related class.
357 sub BeerDB::Beer::search_columns {
358 return ( 'name' , 'rating', { brewery => [ 'name', 'location'] } );
361 # Now foreign inputs are made for Brewery name and location and the
362 # there will be no name clashing and processing can be automated.
368 my ($class, $args) = @_;
369 $class = ref $class || $class;
370 #my $accssr_class = { $class->accessor_classes };
373 $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns];
375 foreach my $field ( @{ $args->{columns} } ) {
377 no_hidden_constraints => 1,
378 column_nullable => 1, # empty option on select boxes
381 if ( ref $field eq "HASH" ) { # foreign search fields
382 my ($accssr, $cols) = each %$field;
383 $base_args->{columns} = $cols;
385 # default to search fields for related
386 #$cols = $accssr_class->{$accssr}->search_columns;
387 die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
389 my $fcgi = $class->to_field($accssr, 'foreign_inputs', $base_args);
391 # unset the default values for a select box
392 foreach (keys %$fcgi) {
393 my $el = $fcgi->{$_};
394 if ($el->tag eq 'select') {
396 $class->unselect_element($el);
397 my ($first, @content) = $el->content_list;
398 my @fc = $first->content_list;
399 my $val = $first ? $first->attr('value') : undef;
400 if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or
402 # push an empty option on stactk
403 $el->unshift_content(HTML::Element->new('option'));
408 $cgi{$accssr} = $fcgi;
409 delete $base_args->{columns};
411 $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} });
412 my $el = $cgi{$field};
413 if ($el->tag eq 'select') {
414 $class->unselect_element($el);
415 my ($first, @content) = $el->content_list;
416 if ($first and $first->content_list) { # something
417 #(defined $first->attr('value') or $first->attr('value') ne ''))
418 # push an empty option on stactk
419 $el->unshift_content(HTML::Element->new('option'));
430 =head2 unselect_element
432 unselect any selected elements in a HTML::Element select list widget
435 sub unselect_element {
436 my ($self, $el) = @_;
437 if (ref $el && $el->can('tag') && $el->tag eq 'select') {
438 foreach my $opt ($el->content_list) {
439 $opt->attr('selected', undef) if $opt->attr('selected');
444 =head2 _field_from_how($field, $how,$args)
446 Returns an input element based the "how" parameter or nothing at all.
451 sub _field_from_how {
452 my ($self, $field, $how, $args) = @_;
456 my $meth = "_to_$how";
457 if (not $self->can($meth)) {
458 warn "Class can not $meth";
461 return $self->$meth($field, $args);
464 =head2 _field_from_relationship($field, $args)
466 Returns an input based on the relationship associated with the field or nothing.
469 For has_a it will give select box
473 sub _field_from_relationship {
474 my ($self, $field, $args) = @_;
475 return unless $field;
476 my $rel_meta = $self->related_meta('r',$field) || return;
477 my $rel_name = $rel_meta->{name};
478 my $fclass = $rel_meta->foreign_class;
479 my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
482 if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) {
483 # This condictions allows for trumping of the has_a args
484 if (not $rel_meta->{args}{no_select} and not $args->{no_select}) {
485 $args->{class} = $fclass;
486 return $self->_to_select($field, $args);
490 # maybe has many select
491 if ($rel_meta->{name} eq 'has_many' and $fclass_is_cdbi and ref $self) {
492 # This condictions allows for trumping of the has_a args
493 if (not $rel_meta->{args}{no_select} and not $args->{no_select}) {
494 $args->{class} = $fclass;
495 my @itms = $self->$field; # need list not iterator
496 $args->{items} = \@itms;
497 return $self->_to_select($field, $args);
502 # maybe foreign inputs
503 my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
504 if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_name eq 'has_own')) {
505 $args->{related_meta} = $rel_meta; # suspect faster to set these args
506 return $self->_to_foreign_inputs($field, $args);
511 =head2 _field_from_column($field, $args)
513 Returns an input based on the column's characteristics, namely type, or nothing.
518 sub _field_from_column {
519 my ($self, $field, $args) = @_;
520 # this class and pk are default class and field at this point
521 my $class = $args->{class} || $self;
522 $class = ref $class || $class;
523 $field ||= ($class->primary_columns)[0]; # TODO
526 unless ($args->{column_type}) {
527 if ($class->can('column_type')) {
528 $args->{column_type} = $class->column_type($field);
530 # Right, have some of this
531 eval "package $class; Class::DBI::Plugin::Type->import()";
532 $args->{column_type} = $class->column_type($field);
535 my $type = $args->{column_type};
537 return $self->_to_textfield($field, $args)
538 if $type and $type =~ /^(VAR)?CHAR/i; #common type
539 return $self->_to_textarea($field, $args)
540 if $type and $type =~ /^(TEXT|BLOB)$/i;
541 return $self->_to_enum_select($field, $args)
542 if $type and $type =~ /^ENUM\((.*?)\)$/i;
543 return $self->_to_bool_select($field, $args)
544 if $type and $type =~ /^BOOL/i;
545 return $self->_to_readonly($field, $args)
546 if $type and $type =~ /^readonly$/i;
552 my ($self, $col, $args) = @_;
553 my $class = $args->{class} || $self;
554 $class = ref $class || $class;
555 $col ||= ($class->primary_columns)[0]; # TODO
558 my $val = $args->{value};
560 unless (defined $val) {
564 $val = $args->{default};
565 $val = '' unless defined $val;
568 my ($rows, $cols) = _box($val);
569 $rows = $args->{rows} if $args->{rows};
570 $cols = $args->{cols} if $args->{cols};;
571 my $name = $args->{name} || $col;
573 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
574 $a->push_content($val);
575 $OLD_STYLE && return $a->as_HTML;
580 my ($self, $col, $args ) = @_;
581 use Carp qw/confess/;
582 confess "No col passed to _to_textfield" unless $col;
584 my $val = $args->{value};
585 my $name = $args->{name} || $col;
587 unless (defined $val) {
589 # Case where column inflates.
590 # Input would get stringification which could be not good.
591 # as in the case of Time::Piece objects
592 $val = $self->can($col) ? $self->$col : ''; # in case it is a virtual column
594 if (my $meta = $self->related_meta('',$col)) {
595 if (my $code = $meta->{args}{deflate4edit} || $meta->{args}{deflate} ) {
596 $val = ref $code ? &$code($val) : $val->$code;
597 } elsif ( $val->isa('Class::DBI') ) {
600 #warn "No deflate4edit code defined for $val of type " .
601 #ref $val . ". Using the stringified value in textfield..";
604 $val = $val->id if $val->isa("Class::DBI");
609 $val = $args->{default};
610 $val = '' unless defined $val;
614 # THIS If section is neccessary or you end up with "value" for a vaiue
616 $val = '' unless defined $val;
617 $a = HTML::Element->new("input", type => "text", name => $name, value =>$val);
618 $OLD_STYLE && return $a->as_HTML;
622 =head2 recognized arguments
624 selected => $object|$id,
627 where => SQL 'WHERE' clause,
628 order_by => SQL 'ORDER BY' clause,
629 constraint => hash of constraints to search
630 limit => SQL 'LIMIT' clause,
631 items => [ @items_of_same_type_to_select_from ],
632 class => $class_we_are_selecting_from
633 stringify => $stringify_coderef|$method_name
636 =head2 1. a select box out of a has_a or has_many related class.
637 # For has_a the default behavior is to make a select box of every element in
638 # related class and you choose one.
639 #Or explicitly you can create one and pass options like where and order
640 BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
642 # For has_many the default is to get a multiple select box with all objects.
643 # If called as an object method, the objects existing ones will be selected.
644 Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"});
647 =head2 2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun.
649 BeerDB::Beer->to_field('', 'select', $options)
651 BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
652 # with PK as ID, $Class->to_field() same.
653 BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
654 # specify exact where clause
656 =head2 3. If you already have a list of objects to select from --
658 BeerDB:;Beer->to_field($col, 'select' , {items => $objects});
660 # 3. a select box for arbitrary set of objects
661 # Pass array ref of objects as first arg rather than field
662 $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
668 my ($self, $col, $args) = @_;
671 # Do we have items already ? Go no further.
672 if ($args->{items} and ref $args->{items}) {
673 my $a = $self->_select_guts($col, $args);
674 $OLD_STYLE && return $a->as_HTML;
675 if ($args->{multiple}) {
676 $a->attr('multiple', 'multiple');
685 unless ($args->{class}) {
686 $args->{class} = ref $self || $self;
687 # object selected if called with one
688 $args->{selected} = { $self->id => 1}
689 if not $args->{selected} and ref $self;
691 $col = $args->{class}->primary_column;
692 $args->{name} ||= $col;
694 # Related Class maybe ?
695 elsif ($rel_meta = $self->related_meta('r:)', $col) ) {
696 $args->{class} = $rel_meta->{foreign_class};
697 # related objects pre selected if object
698 # "Has many" -- Issues:
699 # 1) want to select one or many from list if self is an object
700 # Thats about all we can do really,
701 # 2) except for mapping which is TODO and would
702 # do something like add to and take away from list of permissions for
705 # Hasmany select one from list if ref self
706 if ($rel_meta->{name} =~ /has_many/i and ref $self) {
707 my @itms = $self->$col; # need list not iterator
708 $args->{items} = \@itms;
709 my $a = $self->_select_guts($col, $args);
710 $OLD_STYLE && return $a->as_HTML;
713 $args->{selected} ||= [ $self->$col ] if ref $self;
714 #warn "selected is " . Dumper($args->{selected});
715 my $c = $rel_meta->{args}{constraint} || {};
716 my $j = $rel_meta->{args}{join} || {};
719 @join = map { $_ ." = ". $self->_attr($_) } keys %$j;
721 my @constr= map { "$_ = '$c->{$_}'"} keys %$c;
722 $args->{where} ||= join (' AND ', (@join, @constr));
723 $args->{order_by} ||= $rel_meta->{args}{order_by};
724 $args->{limit} ||= $rel_meta->{args}{limit};
729 unless ( defined $args->{column_nullable} ) {
730 $args->{column_nullable} = $self->can('column_nullable') ?
731 $self->column_nullable($col) : 1;
734 # Get items to select from
735 my $items = _select_items($args); # array of hashrefs
737 # Turn items into objects if related
738 if ($rel_meta and not $args->{no_construct}) {
740 push @objs, $rel_meta->{foreign_class}->construct($_) foreach @$items;
741 $args->{items} = \@objs;
743 $args->{items} = $items;
746 # Make select HTML element
747 $a = $self->_select_guts($col, $args);
749 if ($args->{multiple}) {
750 $a->attr('multiple', 'multiple');
754 $OLD_STYLE && return $a->as_HTML;
763 # returns the intersection of list refs a and b
764 sub _list_intersect {
766 my %isect; my %union;
767 foreach my $e (@$a, @$b) {
768 $union{$e}++ && $isect{$e}++;
776 # Get Items returns array of hashrefs
779 my $fclass = $args->{class};
780 my @disp_cols = @{$args->{columns} || []};
781 @disp_cols = $fclass->columns('SelectBox') unless @disp_cols;
782 @disp_cols = $fclass->columns('Stringify')unless @disp_cols;
783 @disp_cols = $fclass->_essential unless @disp_cols;
784 unshift @disp_cols, $fclass->columns('Primary');
785 #my %isect = _list_intersect(\@pks, \@disp_cols);
786 #foreach (@pks) { push @sel_cols, $_ unless $isect{$_}; }
787 #push @sel_cols, @disp_cols;
789 #warn "in select items. args are : " . Dumper($args);
791 if ($args->{'distinct'}) {
792 $distinct = 'DISTINCT ';
795 my $sql = "SELECT $distinct" . join( ', ', @disp_cols) .
796 " FROM " . $fclass->table;
798 $sql .= " WHERE " . $args->{where} if $args->{where};
799 $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
800 $sql .= " LIMIT " . $args->{limit} if $args->{limit};
801 #warn "_select_items sql is : $sql";
803 my $sth = $fclass->db_Main->prepare($sql);
806 while ( my $d = $sth->fetchrow_hashref ) {
813 # Makes a readonly input box out of column's value
814 # No args makes object to readonly
816 my ($self, $col, $args) = @_;
817 my $val = $args->{value};
818 if (not defined $val ) { # object to readonly
819 $self->_croak("AsForm: To readonly field called as class method without a value") unless ref $self;
821 $col = $self->primary_column;
823 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
824 'name' => $col, 'value'=>$val);
825 $OLD_STYLE && return $a->as_HTML;
830 =head2 _to_enum_select
832 Returns a select box for the an enum column type.
836 sub _to_enum_select {
837 my ($self, $col, $args) = @_;
838 my $type = $args->{column_type};
839 $type =~ /ENUM\((.*?)\)/i;
840 (my $enum = $1) =~ s/'//g;
841 my @enum_vals = split /\s*,\s*/, $enum;
843 # determine which is pre selected
844 my $selected = eval { $self->$col };
845 $selected = $args->{default} unless defined $selected;
846 $selected = $enum_vals[0] unless defined $selected;
848 my $a = HTML::Element->new("select", name => $col);
850 my $sel = HTML::Element->new("option", value => $_);
851 $sel->attr("selected" => "selected") if $_ eq $selected ;
852 $sel->push_content($_);
853 $a->push_content($sel);
855 $OLD_STYLE && return $a->as_HTML;
860 =head2 _to_bool_select
862 Returns a "No/Yes" select box for a boolean column type.
866 # TODO fix this mess with args
867 sub _to_bool_select {
868 my ($self, $col, $args) = @_;
869 my $type = $args->{column_type};
870 my @bool_text = ('No', 'Yes');
871 if ($type =~ /BOOL\((.+?)\)/i) {
872 (my $bool = $1) =~ s/'//g;
873 @bool_text = split /,/, $bool;
877 my $selected = $args->{value} if defined $args->{value};
878 $selected = $args->{selected} unless defined $selected;
879 $selected = ref $self ? eval {$self->$col;} : $args->{default}
880 unless (defined $selected);
882 my $a = HTML::Element->new("select", name => $col);
883 if ($args->{column_nullable} || $args->{value} eq '') {
884 my $null = HTML::Element->new("option");
885 $null->attr('selected', 'selected') if $args->{value} eq '';
886 $a->push_content( $null );
889 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
890 HTML::Element->new("option", value => 1) );
891 $opt0->push_content($bool_text[0]);
892 $opt1->push_content($bool_text[1]);
893 unless ($selected eq '') {
894 $opt0->attr("selected" => "selected") if not $selected;
895 $opt1->attr("selected" => "selected") if $selected;
897 $a->push_content($opt0, $opt1);
898 $OLD_STYLE && return $a->as_HTML;
902 =head2 _to_hidden($field, $args)
904 This makes a hidden html element input. It uses the "name" and "value"
905 arguments. If one or both are not there, it will look for an object in
906 "items->[0]" or the caller. Then it will use $field or the primary key for
907 name and the value of the column by the derived name.
912 my ($self, $field, $args) = @_;
914 my ($name, $value) = ($args->{'name'}, $args->{value});
915 $name = $field unless defined $name;
916 if (! defined $name and !defined $value) { # check for objects
917 my $obj = $args->{items}->[0] || $self;
919 die "_to_hidden cannot determine a value. It was passed a value argument or items object or called with an object.";
921 $name = $obj->primary_column->name unless $name;
922 $value = $obj->$name unless $value;
925 return HTML::Element->new('input', 'type' => 'hidden',
926 'name' => $name, 'value'=>$value);
929 =head2 _to_link_hidden($col, $args)
931 Makes a link with a hidden input with the id of $obj as the value and name.
932 Name defaults to the objects primary key. The object defaults to self.
936 sub _to_link_hidden {
937 my ($self, $accessor, $args) = @_;
938 my $r = eval {$self->controller} || $args->{r} || '';
939 my $uri = $args->{uri} || '';
940 $self->_croak("_to_link_hidden cant get uri. No Maypole Request class (\$r) or uri arg. Need one or other.")
943 if (ref $self) { # hidding linking self
945 $name = $args->{name} || $obj->primary_column->name;
946 } elsif ($obj = $args->{items}->[0]) {
947 $name = $args->{name} || $accessor || $obj->primary_column->name;
948 # TODO use meta data above maybe
949 } else { # hiding linking related object with id in args
950 $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
951 $name = $args->{name} || $accessor ; #$obj->primary_column->name;
952 # TODO use meta data above maybe
954 $self->_croak("_to_link_hidden has no object") unless ref $obj;
955 my $href = $uri || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
956 my $a = HTML::Element->new('a', 'href' => $href);
957 $a->push_content("$obj");
958 $a->push_content($self->to_field('blahfooey', 'hidden', {name => $name, value => $obj->id} ));
960 $OLD_STYLE && return $a->as_HTML;
964 =head2 _to_foreign_inputs
966 Creates inputs for a foreign class, usually related to the calling class or
967 object. In names them so they do not clash with other names and so they
968 can be processed generically. See _rename_foreign_inputs below and
969 Maypole::Model::CDBI::FromCGI::classify_foreign_inputs.
971 Arguments this recognizes are :
973 related_meta -- if you have this, great, othervise it will determine or die
974 columns -- list of columns to make inputs for
975 request (r) -- TODO the Maypole request so we can see what action
979 sub _to_foreign_inputs {
980 my ($self, $accssr, $args) = @_;
981 my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr);
982 my $fields = $args->{columns};
984 $self->_carp( "[_to_foreign_inputs] No relationship for accessor $accssr");
988 my $rel_type = $rel_meta->{name};
989 my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_meta->{foreign_class};
992 $fields = $classORobj->can('display_columns') ?
993 [$classORobj->display_columns] : [$classORobj->columns];
996 # Ignore our fkey in them to prevent infinite recursion
997 my $me = eval {$rel_meta->{args}{foreign_key}} ||
998 eval {$rel_meta->{args}{foreign_column}}
999 || ''; # what uses foreign_column has_many or might_have
1000 my $constrained = $rel_meta->{args}{constraint};
1002 foreach ( @$fields ) {
1003 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
1004 $inputs{$_} = $classORobj->to_field($_);
1007 # Make hidden inputs for constrained columns unless we are editing object
1008 # TODO -- is this right thing to do?
1009 unless (ref $classORobj || $args->{no_hidden_constraints}) {
1010 foreach ( keys %$constrained ) {
1011 $inputs{$_} = $classORobj->to_field('blahfooey', 'hidden',
1012 { name => $_, value => $constrained->{$_}} );
1015 $self->_rename_foreign_input($accssr, \%inputs);
1020 =head2 _hash_selected
1022 *Function* to make sense out of the "selected" argument which has values of the
1023 options that should be selected by default when making a select box. It
1024 can be in a number formats. This method returns a map of which options to
1025 select with the values being the keys in the map ( {val1 => 1, val2 = 1} ).
1027 Currently this method handles the following formats for the "selected" argument
1028 and in the following ways
1030 Object -- uses the id method to get the value
1031 Scalar -- assumes it *is* the value
1032 Array ref of objects -- same as Object
1033 Arrays of data -- uses the 0th element in each
1034 Hashes of data -- uses key named 'id'
1042 sub _hash_selected {
1044 my $selected = $args->{value} || $args->{selected};
1045 my $type = ref $selected;
1046 return $selected unless $selected and $type ne 'HASH';
1049 if ($type and $type ne 'ARRAY') {
1050 my $id = $selected->id;
1056 return { $selected => 1};
1059 # Array of objs, arrays, hashes, or just scalalrs.
1060 elsif ($type eq 'ARRAY') {
1062 my $ltype = ref $selected->[0];
1064 if ($ltype and $ltype ne 'ARRAY') {
1065 %hashed = map { $_->id => 1 } @$selected;
1067 # Arrays of data with id first
1068 elsif ($ltype and $ltype eq 'ARRAY') {
1069 %hashed = map { $_->[0] => 1 } @$selected;
1071 # Hashes using pk or id key
1072 elsif ($ltype and $ltype eq 'HASH') {
1073 my $pk = $args->{class}->primary_column || 'id';
1074 %hashed = map { $_->{$pk} => 1 } @$selected;
1078 %hashed = map { $_ => 1 } @$selected;
1082 warn "AsForm Could not hash the selected argument: $selected";
1091 Internal api method to make the actual select box form elements.
1094 Items to make options out of can be
1096 Array of CDBI objects.
1098 Array or Array refs with cols from class,
1104 my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
1106 $args->{selected} = _hash_selected($args) if defined $args->{selected};
1107 my $name = $args->{name} || $col;
1108 my $a = HTML::Element->new('select', name => $name);
1109 $a->attr( %{$args->{attr}} ) if $args->{attr};
1111 if ($args->{column_nullable}) {
1112 my $null_element = HTML::Element->new('option', value => '');
1113 $null_element->attr(selected => 'selected')
1114 if ($args->{selected}{'null'});
1115 $a->push_content($null_element);
1118 my $items = $args->{items};
1119 my $type = ref $items;
1120 my $proto = eval { ref $items->[0]; } || "";
1121 my $optgroups = $args->{optgroups} || '';
1123 # Array of hashes, one for each optgroup
1126 foreach (@$optgroups) {
1127 my $ogrp= HTML::Element->new('optgroup', label => $_);
1128 $ogrp->push_content($self->_options_from_hash($items->[$i], $args));
1129 $a->push_content($ogrp);
1135 elsif ($type eq 'HASH') {
1136 $a->push_content($self->_options_from_hash($items, $args));
1139 elsif ( $type eq 'ARRAY' and not ref $items->[0] ) {
1140 $a->push_content($self->_options_from_array($items, $args));
1143 elsif ( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) {
1144 # make select of objects
1145 $a->push_content($self->_options_from_objects($items, $args));
1148 elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) {
1149 $a->push_content($self->_options_from_arrays($items, $args));
1152 elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) {
1153 $a->push_content($self->_options_from_hashes($items, $args));
1155 die "You passed a weird type of data structure to me. Here it is: " .
1164 =head2 _options_from_objects ( $objects, $args);
1166 Private method to makes a options out of objects. It attempts to call each
1167 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
1169 *Note only single primary keys supported
1172 sub _options_from_objects {
1173 my ($self, $items, $args) = @_;
1174 my $selected = $args->{selected} || {};
1177 for my $object (@$items) {
1178 my $stringify = $args->{stringify};
1179 if ($object->can('stringify_column') ) {
1180 $stringify ||= $object->stringify_column if ($object->stringify_column && $object->can($object->stringify_column));
1182 my $id = $object->id;
1183 my $opt = HTML::Element->new("option", value => $id);
1184 $id =~ s/^0*//; # leading zeros no good in hash key
1185 $opt->attr(selected => "selected") if $selected->{$id};
1186 my $content = $stringify ? $object->$stringify : "$object";
1187 $opt->push_content($content);
1193 sub _options_from_arrays {
1194 my ($self, $items, $args) = @_;
1195 my $selected = $args->{selected} || {};
1197 my $class = $args->{class} || '';
1198 my $stringify = $args->{stringify};
1199 $stringify ||= $self->stringify_column if ($self->can('stringify_column'));
1200 for my $item (@$items) {
1201 my @pks; # for future multiple key support
1202 push @pks, shift @$item foreach $class->columns('Primary');
1204 $id =~ s/^0+//; # In case zerofill is on .
1205 my $val = defined $id ? $id : '';
1206 my $opt = HTML::Element->new("option", value =>$val);
1207 $opt->attr(selected => "selected") if $selected->{$id};
1208 my $content = ($class and $stringify and $class->can($stringify)) ?
1209 $class->$stringify($_) :
1210 join( '/', map { $_ if $_; }@{$item} );
1211 $opt->push_content( $content );
1218 sub _options_from_array {
1219 my ($self, $items, $args) = @_;
1220 my $selected = $args->{selected} || {};
1223 my $val = defined $_ ? $_ : '';
1224 my $opt = HTML::Element->new("option", value => $val);
1225 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1226 $opt->attr(selected => "selected") if $selected->{$_};
1227 $opt->push_content( $_ );
1233 sub _options_from_hash {
1234 my ($self, $items, $args) = @_;
1235 my $selected = $args->{selected} || {};
1238 my @values = values %$items;
1239 # hash Key is the option content and the hash value is option value
1240 for (sort keys %$items) {
1241 my $val = defined $items->{$_} ? $items->{$_} : '';
1242 my $opt = HTML::Element->new("option", value => $val);
1243 $opt->attr(selected => "selected") if $selected->{$items->{$_}};
1244 $opt->push_content( $_ );
1251 sub _options_from_hashes {
1252 my ($self, $items, $args) = @_;
1253 my $selected = $args->{selected} || {};
1254 my $pk = eval {$args->{class}->primary_column} || 'id';
1255 my $fclass = $args->{class} || '';
1256 my $stringify = $args->{stringify};
1257 $stringify ||= $self->stringify_column if ( $self->can('stringify_column') );
1259 for my $item (@$items) {
1260 my $val = defined $item->{$pk} ? $item->{$pk} : '';
1261 my $opt = HTML::Element->new("option", value => $val);
1262 $opt->attr(selected => "selected") if $selected->{$val};
1264 if ($fclass and $stringify and $fclass->can($stringify)) {
1265 $content = bless ($item,$fclass)->$stringify();
1266 } elsif ( $stringify ) {
1267 $content = $item->{$stringify};
1269 $content = join(' ', map {$item->{$_} } keys %$item);
1272 $opt->push_content( $content );
1281 Makes a checkbox element -- TODO
1285 # checkboxes: if no data in hand (ie called as class method), replace
1286 # with a radio button, in order to allow this field to be left
1287 # unspecified in search / add forms.
1290 # TODO -- make this general checkboxse
1294 my ($self, $col, $args) = @_;
1295 my $nullable = eval {self->column_nullable($col)} || 0;
1296 return $self->_to_radio($col) if !ref($self) || $nullable;
1297 my $value = $self->$col;
1298 my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1299 $a->attr("checked" => 'true') if $value eq 'Y';
1305 Makes a radio button element -- TODO
1308 # TODO -- make this general radio butons
1311 my ($self, $col) = @_;
1312 my $value = ref $self && $self->$col || '';
1313 my $nullable = eval {self->column_nullable($col)} || 0;
1314 my $a = HTML::Element->new("span");
1315 my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1316 my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1317 my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1318 $ry->push_content('Yes'); $rn->push_content('No');
1319 $ru->push_content('n/a') if $nullable;
1320 if ($value eq 'Y') {
1321 $ry->attr("checked" => 'true');
1322 } elsif ($value eq 'N') {
1323 $rn->attr("checked" => 'true');
1324 } elsif ($nullable) {
1325 $ru->attr("checked" => 'true');
1327 $a->push_content($ry, $rn);
1328 $a->push_content($ru) if $nullable;
1334 ############################ HELPER METHODS ######################
1335 ##################################################################
1337 =head2 _rename_foreign_input
1339 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1341 Recursively renames the foreign inputs made by _to_foreign_inputs so they
1342 can be processed generically. It uses foreign_input_delimiter.
1344 So if an Employee is a Person who has_many Addresses and you call and the
1345 method 'foreign_input_delimiter' returns '__AF__' then
1347 Employee->to_field("person");
1349 will get inputs for the Person as well as their Address (by default,
1350 override _field_from_relationship to change logic) named like this:
1352 person__AF__address__AF__street
1353 person__AF__address__AF__city
1354 person__AF__address__AF__state
1355 person__AF__address__AF__zip
1357 And the processor would know to create this address, put the address id in
1358 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.
1362 sub _rename_foreign_input {
1363 my ($self, $accssr, $element) = @_;
1364 my $del = $self->foreign_input_delimiter;
1366 if ( ref $element ne 'HASH' ) {
1367 # my $new_name = $accssr . "__AF__" . $input->attr('name');
1368 $element->attr( name => $accssr . $del . $element->attr('name'));
1370 $self->_rename_foreign_input($accssr, $element->{$_})
1371 foreach (keys %$element);
1375 =head2 foreign_input_delimiter
1377 This tells AsForm what to use to delmit forieign input names. This is important
1378 to avoid name clashes as well as automating processing of forms.
1382 sub foreign_input_delimiter { '__AF__' };
1386 This functions computes the dimensions of a textarea based on the value
1392 my ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1395 my @rows = split /^/, $text;
1396 my $cols = $min_cols;
1399 my $len = length $_;
1401 $cols = $len if $len > $cols;
1402 $cols = $max_cols if $cols > $max_cols;
1405 $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1406 $rows = $min_rows if $rows < $min_rows;
1407 $rows = $max_rows if $rows > $max_rows;
1410 ($min_rows, $min_cols);
1421 15-07-2004 -- Initial version
1428 Peter Speltz, Aaron Trevena
1430 =head1 AUTHORS EMERITUS
1432 Simon Cozens, Tony Bowden
1437 checkbox generalization
1438 radio generalization
1439 Make link_hidden use standard make_url stuff when it gets in Maypole
1440 How do you tell AF --" I want a has_many select box for this every time so,
1441 when you call "to_field($this_hasmany)" you get a select box
1443 =head1 BUGS and QUERIES
1445 Please direct all correspondence regarding this module to:
1448 =head1 COPYRIGHT AND LICENSE
1450 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1452 This library is free software; you can redistribute it and/or modify
1453 it under the same terms as Perl itself.
1457 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.