1 package Maypole::Model::CDBI::AsForm;
10 use Class::DBI::Plugin::Type ();
17 to_cgi to_field foreign_input_delimiter search_inputs unselect_element
18 _field_from_how _field_from_relationship _field_from_column
19 _to_textarea _to_textfield _to_select _select_guts
20 _to_foreign_inputs _to_enum_select _to_bool_select
21 _to_hidden _to_link_hidden _rename_foreign_input _to_readonly
22 _options_from_objects _options_from_arrays _options_from_hashes
23 _options_from_array _options_from_hash
30 Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns
35 use Maypole::Model::CDBI::AsForm;
36 use base 'Class::DBI';
42 my %cgi_field = $self->to_cgi;
44 (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
52 # Somewhere else in a Maypole application about beer...
57 $beer->to_field('brewery', 'textfield', {
58 name => 'brewery_id', value => $beer->brewery,
59 # however, no need to set value since $beer is object
63 $beer->to_field(rating => select => {
64 items => [1 , 2, 3, 4, 5],
67 # Select a Brewery to visit in the UK
68 Brewery->to_field(brewery_id => {
69 items => [ Brewery->search_like(location => 'UK') ],
72 # Make a select for a boolean field
73 $Pub->to_field('open' , { items => [ {'Open' => 1, 'Closed' => 0 } ] });
75 $beer->to_field('brewery', {
76 selected => $beer->brewery, # again not necessary since caller is obj.
80 $beer->to_field('brewery', 'link_hidden', {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery});
81 # an html link that is also a hidden input to the object. R is required to
82 # make the uri unless you pass a uri
86 #####################################################
95 <span class="field"> [% classmetadata.colnames.$col %] : </span>
97 [% object.to_field(col).as_XML %]
105 <span class="field"> Brewery : </span>
107 [% object.to_field('brewery', { selected => 23} ).as_XML %]
116 #####################################################
121 __PACKAGE__->has_a('job_employer' => 'Employer');
122 __PACKAGE__->has_a('contact' => 'Contact')
125 __PACKAGE__->has_a('cont_employer' => 'Employer');
126 __PACKAGE__->has_many('jobs' => 'Job',
127 { join => { job_employer => 'cont_employer' },
128 constraint => { 'finshed' => 0 },
129 order_by => "created ASC",
134 __PACKAGE__->has_many('jobs' => 'Job',);
135 __PACKAGE__->has_many('contacts' => 'Contact',
136 order_by => 'name DESC',
140 # Choose some jobs to add to a contact (has multiple attribute).
141 my $job_sel = Contact->to_field('jobs'); # Uses constraint and order by
144 # Choose a job from $contact->jobs
145 my $job_sel = $contact->to_field('jobs');
154 This module helps to generate HTML forms for creating new database rows
155 or editing existing rows. It maps column names in a database table to
156 HTML form elements which fit the schema. Large text fields are turned
157 into textareas, and fields with a has-a relationship to other
158 C<Class::DBI> tables are turned into select drop-downs populated with
159 objects from the joined class.
162 =head1 ARGUMENTS HASH
164 This provides a convenient way to tweak AsForm's behavior in exceptional or
165 not so exceptional instances. Below describes the arguments hash and
169 $beer->to_field($col, $how, $args);
170 $beer->to_field($col, $args);
172 Not all _to_* methods pay attention to all arguments. For example, '_to_textfield' does not look in $args->{'items'} at all.
176 =item name -- the name the element will have , this trumps the derived name.
178 $beer->to_field('brewery', 'readonly', {
182 =item value -- the initial value the element will have, trumps derived value
184 $beer->to_field('brewery', 'textfield', {
185 name => 'brewery_id', value => $beer->brewery,
186 # however, no need to set value since $beer is object
189 =item items -- array of items generally used to make select box options
191 Can be array of objects, hashes, arrays, or strings, or just a hash.
194 $beer->to_field(rating => select => {
195 items => [1 , 2, 3, 4, 5],
198 # Select a Brewery to visit in the UK
199 Brewery->to_field(brewery_id => {
200 items => [ Brewery->search_like(location => 'UK') ],
203 # Make a select for a boolean field
204 $Pub->to_field('open' , { items => [ {'Open' => 1, 'Closed' => 0 } ] });
206 =item selected -- something representing which item is selected in a select box
208 $beer->to_field('brewery', {
209 selected => $beer->brewery, # again not necessary since caller is obj.
212 Can be an simple scalar id, an object, or an array of either
214 =item class -- the class for which the input being made for field pertains to.
216 This in almost always derived in cases where it may be difficult to derive, --
217 # Select beers to serve on handpump
218 Pub->to_field(handpumps => select => {
219 class => 'Beer', order_by => 'name ASC', multiple => 1,
222 =item column_type -- a string representing column type
224 $pub->to_field('open', 'bool_select', {
225 column_type => "bool('Closed', 'Open'),
228 =item column_nullable -- flag saying if column is nullable or not
230 Generally this can be set to get or not get a null/empty option added to
231 a select box. AsForm attempts to call "$class->column_nullable" to set this
232 and it defaults to true if there is no shuch method.
234 $beer->to_field('brewery', { column_nullable => 1 });
236 =item r or request -- the Mapyole request object
238 =item uri -- uri for a link , used in methods such as _to_link_hidden
240 $beer->to_field('brewery', 'link_hidden',
241 {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery});
242 # an html link that is also a hidden input to the object. R is required to
243 # make the uri unless you pass a uri
245 =item order_by, constraint, join
247 These are used in making select boxes. order_by is a simple order by clause
248 and constraint and join are hashes used to limit the rows selected. The
249 difference is that join uses methods of the object and constraint uses
250 static values. You can also specify these in the relationship definitions.
251 See the relationships documentation of how to set arbitrayr meta info.
253 BeerDB::LondonBeer->has_a('brewery', 'BeerDB::Brewery',
254 order_by => 'brewery_name ASC',
255 constraint => {location => 'London'},
256 'join' => {'brewery_tablecolumn => 'beer_obj_column'},
259 =item no_hidden_constraints --
261 Tell AsForm not to make hidden inputs for relationship constraints. It does
262 this sometimes when making foreign inputs. However, i think it should not
263 do this and that the FromCGI 's _create_related method should do it.
269 $self->to_cgi([@columns, $args]);
271 This returns a hash mapping all the column names to HTML::Element objects
272 representing form widgets. It takes two opitonal arguments -- a list of
273 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.
275 $self->to_cgi(); # uses $self->columns; # most used
276 $self->to_cgi(qw/brewery style rating/); # sometimes
277 # and on rare occassions this is desireable if you have a lot of fields
278 # and dont want to call to_field a bunch of times just to tweak one or
280 $self->to_cgi(@cols, {brewery => {
281 how => 'textfield' # too big for select
284 column_nullable => 0,
286 items => ['Ale', 'Lager']
293 my ($class, @columns) = @_;
296 @columns = $class->columns;
297 # Eventually after stabalization, we could add display_columns
298 #keys map { $_ => 1 } ($class->display_columns, $class->columns);
300 if ( ref $columns[-1] eq 'HASH' ) {
301 $args = pop @columns;
304 map { $_ => $class->to_field($_, $args->{$_}) } @columns;
307 =head2 to_field($field [, $how][, $args])
309 This maps an individual column to a form element. The C<how> argument
310 can be used to force the field type into any you want. All that you need
311 is a method named "_to_$how" in your class. Your class inherits many from
314 If C<how> is specified but the class cannot call the method it maps to,
315 then AsForm will issue a warning and the default input will be made.
316 You can write your own "_to_$how" methods and AsForm comes with many.
317 See C<HOW Methods>. You can also pass this argument in $args->{how}.
323 my ($self, $field, $how, $args) = @_;
324 if (ref $how) { $args = $how; $how = ''; }
325 unless ($how) { $how = $args->{how} || ''; }
326 #warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n";
327 # Set sensible default value
328 if ($field and not defined $args->{default}) {
329 my $def = $self->column_default($field) ;
330 # exclude defaults we don't want actually put as value for input
332 $def = $def =~ /(^0000-00-00.*$|^0[0]*$|^0\.00$|CURRENT_TIMESTAMP|NULL)/i ? '' : $def ;
333 $args->{default} = $def;
337 return $self->_field_from_how($field, $how, $args) ||
338 $self->_field_from_relationship($field, $args) ||
339 $self->_field_from_column($field, $args) ||
340 $self->_to_textfield($field, $args);
346 my $cgi = $class->search_inputs ([$args]); # optional $args
348 Returns hash or hashref of search inputs elements for a class making sure the
349 inputs are empty of any initial values.
350 You can specify what columns you want inputs for in
352 by the method "search_columns". The default is "display_columns".
353 If you want to te search on columns in related classes you can do that by
354 specifying a one element hashref in place of the column name where
355 the key is the related "column" (has_a or has_many method for example) and
356 the value is a list ref of columns to search on in the related class.
359 sub BeerDB::Beer::search_columns {
360 return ( 'name' , 'rating', { brewery => [ 'name', 'location'] } );
363 # Now foreign inputs are made for Brewery name and location and the
364 # there will be no name clashing and processing can be automated.
370 my ($class, $args) = @_;
371 $class = ref $class || $class;
372 #my $accssr_class = { $class->accessor_classes };
375 $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns];
377 foreach my $field ( @{ $args->{columns} } ) {
379 no_hidden_constraints => 1,
380 column_nullable => 1, # empty option on select boxes
383 if ( ref $field eq "HASH" ) { # foreign search fields
384 my ($accssr, $cols) = each %$field;
385 $base_args->{columns} = $cols;
387 # default to search fields for related
388 #$cols = $accssr_class->{$accssr}->search_columns;
389 die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
391 my $fcgi = $class->to_field($accssr, 'foreign_inputs', $base_args);
393 # unset the default values for a select box
394 foreach (keys %$fcgi) {
395 my $el = $fcgi->{$_};
396 if ($el->tag eq 'select') {
398 $class->unselect_element($el);
399 my ($first, @content) = $el->content_list;
400 my @fc = $first->content_list;
401 my $val = $first ? $first->attr('value') : undef;
402 if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or
404 # push an empty option on stactk
405 $el->unshift_content(HTML::Element->new('option'));
410 $cgi{$accssr} = $fcgi;
411 delete $base_args->{columns};
413 $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} });
414 my $el = $cgi{$field};
415 if ($el->tag eq 'select') {
416 $class->unselect_element($el);
417 my ($first, @content) = $el->content_list;
418 if ($first and $first->content_list) { # something
419 #(defined $first->attr('value') or $first->attr('value') ne ''))
420 # push an empty option on stactk
421 $el->unshift_content(HTML::Element->new('option'));
432 =head2 unselect_element
434 unselect any selected elements in a HTML::Element select list widget
437 sub unselect_element {
438 my ($self, $el) = @_;
439 if (ref $el && $el->can('tag') && $el->tag eq 'select') {
440 foreach my $opt ($el->content_list) {
441 $opt->attr('selected', undef) if $opt->attr('selected');
446 =head2 _field_from_how($field, $how,$args)
448 Returns an input element based the "how" parameter or nothing at all.
453 sub _field_from_how {
454 my ($self, $field, $how, $args) = @_;
458 my $meth = "_to_$how";
459 if (not $self->can($meth)) {
460 warn "Class can not $meth";
463 return $self->$meth($field, $args);
466 =head2 _field_from_relationship($field, $args)
468 Returns an input based on the relationship associated with the field or nothing.
471 For has_a it will give select box
475 sub _field_from_relationship {
476 my ($self, $field, $args) = @_;
477 return unless $field;
478 my $rel_meta = $self->related_meta('r',$field) || return;
479 my $rel_name = $rel_meta->{name};
480 my $fclass = $rel_meta->foreign_class;
481 my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
484 if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) {
485 # This condictions allows for trumping of the has_a args
486 if (not $rel_meta->{args}{no_select} and not $args->{no_select}) {
487 $args->{class} = $fclass;
488 return $self->_to_select($field, $args);
492 # maybe has many select
493 if ($rel_meta->{name} eq 'has_many' and $fclass_is_cdbi and ref $self) {
494 # This condictions allows for trumping of the has_a args
495 if (not $rel_meta->{args}{no_select} and not $args->{no_select}) {
496 $args->{class} = $fclass;
497 my @itms = $self->$field; # need list not iterator
498 $args->{items} = \@itms;
499 return $self->_to_select($field, $args);
504 # maybe foreign inputs
505 my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
506 if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_name eq 'has_own')) {
507 $args->{related_meta} = $rel_meta; # suspect faster to set these args
508 return $self->_to_foreign_inputs($field, $args);
513 =head2 _field_from_column($field, $args)
515 Returns an input based on the column's characteristics, namely type, or nothing.
520 sub _field_from_column {
521 my ($self, $field, $args) = @_;
522 # this class and pk are default class and field at this point
523 my $class = $args->{class} || $self;
524 $class = ref $class || $class;
525 $field ||= ($class->primary_columns)[0]; # TODO
528 unless ($args->{column_type}) {
529 if ($class->can('column_type')) {
530 $args->{column_type} = $class->column_type($field);
532 # Right, have some of this
533 eval "package $class; Class::DBI::Plugin::Type->import()";
534 $args->{column_type} = $class->column_type($field);
537 my $type = $args->{column_type};
539 return $self->_to_textfield($field, $args)
540 if $type and $type =~ /^(VAR)?CHAR/i; #common type
541 return $self->_to_textarea($field, $args)
542 if $type and $type =~ /^(TEXT|BLOB)$/i;
543 return $self->_to_enum_select($field, $args)
544 if $type and $type =~ /^ENUM\((.*?)\)$/i;
545 return $self->_to_bool_select($field, $args)
546 if $type and $type =~ /^BOOL/i;
547 return $self->_to_readonly($field, $args)
548 if $type and $type =~ /^readonly$/i;
554 my ($self, $col, $args) = @_;
555 my $class = $args->{class} || $self;
556 $class = ref $class || $class;
557 $col ||= ($class->primary_columns)[0]; # TODO
560 my $val = $args->{value};
562 unless (defined $val) {
566 $val = $args->{default};
567 $val = '' unless defined $val;
570 my ($rows, $cols) = _box($val);
571 $rows = $args->{rows} if $args->{rows};
572 $cols = $args->{cols} if $args->{cols};;
573 my $name = $args->{name} || $col;
575 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
576 $a->push_content($val);
577 $OLD_STYLE && return $a->as_HTML;
582 my ($self, $col, $args ) = @_;
583 use Carp qw/confess/;
584 confess "No col passed to _to_textfield" unless $col;
586 my $val = $args->{value};
587 my $name = $args->{name} || $col;
589 unless (defined $val) {
591 # Case where column inflates.
592 # Input would get stringification which could be not good.
593 # as in the case of Time::Piece objects
594 $val = $self->can($col) ? $self->$col : ''; # in case it is a virtual column
596 if (my $meta = $self->related_meta('',$col)) {
597 if (my $code = $meta->{args}{deflate4edit} || $meta->{args}{deflate} ) {
598 $val = ref $code ? &$code($val) : $val->$code;
599 } elsif ( $val->isa('Class::DBI') ) {
602 #warn "No deflate4edit code defined for $val of type " .
603 #ref $val . ". Using the stringified value in textfield..";
606 $val = $val->id if $val->isa("Class::DBI");
611 $val = $args->{default};
612 $val = '' unless defined $val;
616 # THIS If section is neccessary or you end up with "value" for a vaiue
618 $val = '' unless defined $val;
619 $a = HTML::Element->new("input", type => "text", name => $name, value =>$val);
620 $OLD_STYLE && return $a->as_HTML;
624 =head2 recognized arguments
626 selected => $object|$id,
629 where => SQL 'WHERE' clause,
630 order_by => SQL 'ORDER BY' clause,
631 constraint => hash of constraints to search
632 limit => SQL 'LIMIT' clause,
633 items => [ @items_of_same_type_to_select_from ],
634 class => $class_we_are_selecting_from
635 stringify => $stringify_coderef|$method_name
638 =head2 1. a select box out of a has_a or has_many related class.
639 # For has_a the default behavior is to make a select box of every element in
640 # related class and you choose one.
641 #Or explicitly you can create one and pass options like where and order
642 BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
644 # For has_many the default is to get a multiple select box with all objects.
645 # If called as an object method, the objects existing ones will be selected.
646 Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"});
649 =head2 2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun.
651 BeerDB::Beer->to_field('', 'select', $options)
653 BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
654 # with PK as ID, $Class->to_field() same.
655 BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
656 # specify exact where clause
658 =head2 3. If you already have a list of objects to select from --
660 BeerDB:;Beer->to_field($col, 'select' , {items => $objects});
662 # 3. a select box for arbitrary set of objects
663 # Pass array ref of objects as first arg rather than field
664 $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
670 my ($self, $col, $args) = @_;
673 # Do we have items already ? Go no further.
674 if ($args->{items} and ref $args->{items}) {
675 my $a = $self->_select_guts($col, $args);
676 $OLD_STYLE && return $a->as_HTML;
677 if ($args->{multiple}) {
678 $a->attr('multiple', 'multiple');
687 unless ($args->{class}) {
688 $args->{class} = ref $self || $self;
689 # object selected if called with one
690 $args->{selected} = { $self->id => 1}
691 if not $args->{selected} and ref $self;
693 $col = $args->{class}->primary_column;
694 $args->{name} ||= $col;
696 # Related Class maybe ?
697 elsif ($rel_meta = $self->related_meta('r:)', $col) ) {
698 $args->{class} = $rel_meta->{foreign_class};
699 # related objects pre selected if object
700 # "Has many" -- Issues:
701 # 1) want to select one or many from list if self is an object
702 # Thats about all we can do really,
703 # 2) except for mapping which is TODO and would
704 # do something like add to and take away from list of permissions for
707 # Hasmany select one from list if ref self
708 if ($rel_meta->{name} =~ /has_many/i and ref $self) {
709 my @itms = $self->$col; # need list not iterator
710 $args->{items} = \@itms;
711 my $a = $self->_select_guts($col, $args);
712 $OLD_STYLE && return $a->as_HTML;
715 $args->{selected} ||= [ $self->$col ] if ref $self;
716 #warn "selected is " . Dumper($args->{selected});
717 my $c = $rel_meta->{args}{constraint} || {};
718 my $j = $rel_meta->{args}{join} || {};
721 @join = map { $_ ." = ". $self->_attr($_) } keys %$j;
723 my @constr= map { "$_ = '$c->{$_}'"} keys %$c;
724 $args->{where} ||= join (' AND ', (@join, @constr));
725 $args->{order_by} ||= $rel_meta->{args}{order_by};
726 $args->{limit} ||= $rel_meta->{args}{limit};
731 unless ( defined $args->{column_nullable} ) {
732 $args->{column_nullable} = $self->can('column_nullable') ?
733 $self->column_nullable($col) : 1;
736 # Get items to select from
737 my $items = _select_items($args); # array of hashrefs
739 # Turn items into objects if related
740 if ($rel_meta and not $args->{no_construct}) {
742 push @objs, $rel_meta->{foreign_class}->construct($_) foreach @$items;
743 $args->{items} = \@objs;
745 $args->{items} = $items;
748 # Make select HTML element
749 $a = $self->_select_guts($col, $args);
751 if ($args->{multiple}) {
752 $a->attr('multiple', 'multiple');
756 $OLD_STYLE && return $a->as_HTML;
765 # returns the intersection of list refs a and b
766 sub _list_intersect {
768 my %isect; my %union;
769 foreach my $e (@$a, @$b) {
770 $union{$e}++ && $isect{$e}++;
778 # Get Items returns array of hashrefs
781 my $fclass = $args->{class};
782 my @disp_cols = @{$args->{columns} || []};
783 @disp_cols = $fclass->columns('SelectBox') unless @disp_cols;
784 @disp_cols = $fclass->columns('Stringify')unless @disp_cols;
785 @disp_cols = $fclass->_essential unless @disp_cols;
786 unshift @disp_cols, $fclass->columns('Primary');
787 #my %isect = _list_intersect(\@pks, \@disp_cols);
788 #foreach (@pks) { push @sel_cols, $_ unless $isect{$_}; }
789 #push @sel_cols, @disp_cols;
791 #warn "in select items. args are : " . Dumper($args);
793 if ($args->{'distinct'}) {
794 $distinct = 'DISTINCT ';
797 my $sql = "SELECT $distinct" . join( ', ', @disp_cols) .
798 " FROM " . $fclass->table;
800 $sql .= " WHERE " . $args->{where} if $args->{where};
801 $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
802 $sql .= " LIMIT " . $args->{limit} if $args->{limit};
803 #warn "_select_items sql is : $sql";
805 my $sth = $fclass->db_Main->prepare($sql);
808 while ( my $d = $sth->fetchrow_hashref ) {
815 # Makes a readonly input box out of column's value
816 # No args makes object to readonly
818 my ($self, $col, $args) = @_;
819 my $val = $args->{value};
820 if (not defined $val ) { # object to readonly
821 $self->_croak("AsForm: To readonly field called as class method without a value") unless ref $self;
823 $col = $self->primary_column;
825 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
826 'name' => $col, 'value'=>$val);
827 $OLD_STYLE && return $a->as_HTML;
832 =head2 _to_enum_select
834 Returns a select box for the an enum column type.
838 sub _to_enum_select {
839 my ($self, $col, $args) = @_;
840 my $type = $args->{column_type};
841 $type =~ /ENUM\((.*?)\)/i;
842 (my $enum = $1) =~ s/'//g;
843 my @enum_vals = split /\s*,\s*/, $enum;
845 # determine which is pre selected
846 my $selected = eval { $self->$col };
847 $selected = $args->{default} unless defined $selected;
848 $selected = $enum_vals[0] unless defined $selected;
850 my $a = HTML::Element->new("select", name => $col);
852 my $sel = HTML::Element->new("option", value => $_);
853 $sel->attr("selected" => "selected") if $_ eq $selected ;
854 $sel->push_content($_);
855 $a->push_content($sel);
857 $OLD_STYLE && return $a->as_HTML;
862 =head2 _to_bool_select
864 Returns a "No/Yes" select box for a boolean column type.
868 # TODO fix this mess with args
869 sub _to_bool_select {
870 my ($self, $col, $args) = @_;
871 my $type = $args->{column_type};
872 my @bool_text = ('No', 'Yes');
873 if ($type =~ /BOOL\((.+?)\)/i) {
874 (my $bool = $1) =~ s/'//g;
875 @bool_text = split /,/, $bool;
879 my $selected = $args->{value} if defined $args->{value};
880 $selected = $args->{selected} unless defined $selected;
881 $selected = ref $self ? eval {$self->$col;} : $args->{default}
882 unless (defined $selected);
884 my $a = HTML::Element->new("select", name => $col);
885 if ($args->{column_nullable} || $args->{value} eq '') {
886 my $null = HTML::Element->new("option");
887 $null->attr('selected', 'selected') if $args->{value} eq '';
888 $a->push_content( $null );
891 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
892 HTML::Element->new("option", value => 1) );
893 $opt0->push_content($bool_text[0]);
894 $opt1->push_content($bool_text[1]);
895 unless ($selected eq '') {
896 $opt0->attr("selected" => "selected") if not $selected;
897 $opt1->attr("selected" => "selected") if $selected;
899 $a->push_content($opt0, $opt1);
900 $OLD_STYLE && return $a->as_HTML;
904 =head2 _to_hidden($field, $args)
906 This makes a hidden html element input. It uses the "name" and "value"
907 arguments. If one or both are not there, it will look for an object in
908 "items->[0]" or the caller. Then it will use $field or the primary key for
909 name and the value of the column by the derived name.
914 my ($self, $field, $args) = @_;
916 my ($name, $value) = ($args->{'name'}, $args->{value});
917 $name = $field unless defined $name;
918 if (! defined $name and !defined $value) { # check for objects
919 my $obj = $args->{items}->[0] || $self;
921 die "_to_hidden cannot determine a value. It was passed a value argument or items object or called with an object.";
923 $name = $obj->primary_column->name unless $name;
924 $value = $obj->$name unless $value;
927 return HTML::Element->new('input', 'type' => 'hidden',
928 'name' => $name, 'value'=>$value);
931 =head2 _to_link_hidden($col, $args)
933 Makes a link with a hidden input with the id of $obj as the value and name.
934 Name defaults to the objects primary key. The object defaults to self.
938 sub _to_link_hidden {
939 my ($self, $accessor, $args) = @_;
940 my $r = eval {$self->controller} || $args->{r} || '';
941 my $uri = $args->{uri} || '';
942 $self->_croak("_to_link_hidden cant get uri. No Maypole Request class (\$r) or uri arg. Need one or other.")
945 if (ref $self) { # hidding linking self
947 $name = $args->{name} || $obj->primary_column->name;
948 } elsif ($obj = $args->{items}->[0]) {
949 $name = $args->{name} || $accessor || $obj->primary_column->name;
950 # TODO use meta data above maybe
951 } else { # hiding linking related object with id in args
952 $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
953 $name = $args->{name} || $accessor ; #$obj->primary_column->name;
954 # TODO use meta data above maybe
956 $self->_croak("_to_link_hidden has no object") unless ref $obj;
957 my $href = $uri || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
958 my $a = HTML::Element->new('a', 'href' => $href);
959 $a->push_content("$obj");
960 $a->push_content($self->to_field('blahfooey', 'hidden', {name => $name, value => $obj->id} ));
962 $OLD_STYLE && return $a->as_HTML;
966 =head2 _to_foreign_inputs
968 Creates inputs for a foreign class, usually related to the calling class or
969 object. In names them so they do not clash with other names and so they
970 can be processed generically. See _rename_foreign_inputs below and
971 Maypole::Model::CDBI::FromCGI::classify_foreign_inputs.
973 Arguments this recognizes are :
975 related_meta -- if you have this, great, othervise it will determine or die
976 columns -- list of columns to make inputs for
977 request (r) -- TODO the Maypole request so we can see what action
981 sub _to_foreign_inputs {
982 my ($self, $accssr, $args) = @_;
983 my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr);
984 my $fields = $args->{columns};
986 $self->_carp( "[_to_foreign_inputs] No relationship for accessor $accssr");
990 my $rel_type = $rel_meta->{name};
991 my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_meta->{foreign_class};
994 $fields = $classORobj->can('display_columns') ?
995 [$classORobj->display_columns] : [$classORobj->columns];
998 # Ignore our fkey in them to prevent infinite recursion
999 my $me = eval {$rel_meta->{args}{foreign_key}} ||
1000 eval {$rel_meta->{args}{foreign_column}}
1001 || ''; # what uses foreign_column has_many or might_have
1002 my $constrained = $rel_meta->{args}{constraint};
1004 foreach ( @$fields ) {
1005 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
1006 $inputs{$_} = $classORobj->to_field($_);
1009 # Make hidden inputs for constrained columns unless we are editing object
1010 # TODO -- is this right thing to do?
1011 unless (ref $classORobj || $args->{no_hidden_constraints}) {
1012 foreach ( keys %$constrained ) {
1013 $inputs{$_} = $classORobj->to_field('blahfooey', 'hidden',
1014 { name => $_, value => $constrained->{$_}} );
1017 $self->_rename_foreign_input($accssr, \%inputs);
1022 =head2 _hash_selected
1024 *Function* to make sense out of the "selected" argument which has values of the
1025 options that should be selected by default when making a select box. It
1026 can be in a number formats. This method returns a map of which options to
1027 select with the values being the keys in the map ( {val1 => 1, val2 = 1} ).
1029 Currently this method handles the following formats for the "selected" argument
1030 and in the following ways
1032 Object -- uses the id method to get the value
1033 Scalar -- assumes it *is* the value
1034 Array ref of objects -- same as Object
1035 Arrays of data -- uses the 0th element in each
1036 Hashes of data -- uses key named 'id'
1044 sub _hash_selected {
1046 my $selected = $args->{value} || $args->{selected};
1047 my $type = ref $selected;
1048 return $selected unless $selected and $type ne 'HASH';
1051 if ($type and $type ne 'ARRAY') {
1052 my $id = $selected->id;
1058 return { $selected => 1};
1061 # Array of objs, arrays, hashes, or just scalalrs.
1062 elsif ($type eq 'ARRAY') {
1064 my $ltype = ref $selected->[0];
1066 if ($ltype and $ltype ne 'ARRAY') {
1067 %hashed = map { $_->id => 1 } @$selected;
1069 # Arrays of data with id first
1070 elsif ($ltype and $ltype eq 'ARRAY') {
1071 %hashed = map { $_->[0] => 1 } @$selected;
1073 # Hashes using pk or id key
1074 elsif ($ltype and $ltype eq 'HASH') {
1075 my $pk = $args->{class}->primary_column || 'id';
1076 %hashed = map { $_->{$pk} => 1 } @$selected;
1080 %hashed = map { $_ => 1 } @$selected;
1084 warn "AsForm Could not hash the selected argument: $selected";
1093 Internal api method to make the actual select box form elements.
1096 Items to make options out of can be
1098 Array of CDBI objects.
1100 Array or Array refs with cols from class,
1106 my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
1108 $args->{selected} = _hash_selected($args) if defined $args->{selected};
1109 my $name = $args->{name} || $col;
1110 my $a = HTML::Element->new('select', name => $name);
1111 $a->attr( %{$args->{attr}} ) if $args->{attr};
1113 if ($args->{column_nullable}) {
1114 my $null_element = HTML::Element->new('option', value => '');
1115 $null_element->attr(selected => 'selected')
1116 if ($args->{selected}{'null'});
1117 $a->push_content($null_element);
1120 my $items = $args->{items};
1121 my $type = ref $items;
1122 my $proto = eval { ref $items->[0]; } || "";
1123 my $optgroups = $args->{optgroups} || '';
1125 # Array of hashes, one for each optgroup
1128 foreach (@$optgroups) {
1129 my $ogrp= HTML::Element->new('optgroup', label => $_);
1130 $ogrp->push_content($self->_options_from_hash($items->[$i], $args));
1131 $a->push_content($ogrp);
1137 elsif ($type eq 'HASH') {
1138 $a->push_content($self->_options_from_hash($items, $args));
1141 elsif ( $type eq 'ARRAY' and not ref $items->[0] ) {
1142 $a->push_content($self->_options_from_array($items, $args));
1145 elsif ( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) {
1146 # make select of objects
1147 $a->push_content($self->_options_from_objects($items, $args));
1150 elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) {
1151 $a->push_content($self->_options_from_arrays($items, $args));
1154 elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) {
1155 $a->push_content($self->_options_from_hashes($items, $args));
1157 die "You passed a weird type of data structure to me. Here it is: " .
1166 =head2 _options_from_objects ( $objects, $args);
1168 Private method to makes a options out of objects. It attempts to call each
1169 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
1171 *Note only single primary keys supported
1174 sub _options_from_objects {
1175 my ($self, $items, $args) = @_;
1176 my $selected = $args->{selected} || {};
1179 for my $object (@$items) {
1180 my $stringify = $args->{stringify};
1181 if ($object->can('stringify_column') ) {
1182 $stringify ||= $object->stringify_column if ($object->stringify_column && $object->can($object->stringify_column));
1184 my $id = $object->id;
1185 my $opt = HTML::Element->new("option", value => $id);
1186 $id =~ s/^0*//; # leading zeros no good in hash key
1187 $opt->attr(selected => "selected") if $selected->{$id};
1188 my $content = $stringify ? $object->$stringify : "$object";
1189 $opt->push_content($content);
1195 sub _options_from_arrays {
1196 my ($self, $items, $args) = @_;
1197 my $selected = $args->{selected} || {};
1199 my $class = $args->{class} || '';
1200 my $stringify = $args->{stringify};
1201 $stringify ||= $self->stringify_column if ($self->can('stringify_column'));
1202 for my $item (@$items) {
1203 my @pks; # for future multiple key support
1204 push @pks, shift @$item foreach $class->columns('Primary');
1206 $id =~ s/^0+//; # In case zerofill is on .
1207 my $val = defined $id ? $id : '';
1208 my $opt = HTML::Element->new("option", value =>$val);
1209 $opt->attr(selected => "selected") if $selected->{$id};
1210 my $content = ($class and $stringify and $class->can($stringify)) ?
1211 $class->$stringify($_) :
1212 join( '/', map { $_ if $_; }@{$item} );
1213 $opt->push_content( $content );
1220 sub _options_from_array {
1221 my ($self, $items, $args) = @_;
1222 my $selected = $args->{selected} || {};
1225 my $val = defined $_ ? $_ : '';
1226 my $opt = HTML::Element->new("option", value => $val);
1227 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1228 $opt->attr(selected => "selected") if $selected->{$_};
1229 $opt->push_content( $_ );
1235 sub _options_from_hash {
1236 my ($self, $items, $args) = @_;
1237 my $selected = $args->{selected} || {};
1240 my @values = values %$items;
1241 # hash Key is the option content and the hash value is option value
1242 for (sort keys %$items) {
1243 my $val = defined $items->{$_} ? $items->{$_} : '';
1244 my $opt = HTML::Element->new("option", value => $val);
1245 $opt->attr(selected => "selected") if $selected->{$items->{$_}};
1246 $opt->push_content( $_ );
1253 sub _options_from_hashes {
1254 my ($self, $items, $args) = @_;
1255 my $selected = $args->{selected} || {};
1256 my $pk = eval {$args->{class}->primary_column} || 'id';
1257 my $fclass = $args->{class} || '';
1258 my $stringify = $args->{stringify};
1259 $stringify ||= $self->stringify_column if ( $self->can('stringify_column') );
1261 for my $item (@$items) {
1262 my $val = defined $item->{$pk} ? $item->{$pk} : '';
1263 my $opt = HTML::Element->new("option", value => $val);
1264 $opt->attr(selected => "selected") if $selected->{$val};
1266 if ($fclass and $stringify and $fclass->can($stringify)) {
1267 $content = bless ($item,$fclass)->$stringify();
1268 } elsif ( $stringify ) {
1269 $content = $item->{$stringify};
1271 $content = join(' ', map {$item->{$_} } keys %$item);
1274 $opt->push_content( $content );
1283 Makes a checkbox element -- TODO
1287 # checkboxes: if no data in hand (ie called as class method), replace
1288 # with a radio button, in order to allow this field to be left
1289 # unspecified in search / add forms.
1292 # TODO -- make this general checkboxse
1296 my ($self, $col, $args) = @_;
1297 my $nullable = eval {self->column_nullable($col)} || 0;
1298 return $self->_to_radio($col) if !ref($self) || $nullable;
1299 my $value = $self->$col;
1300 my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1301 $a->attr("checked" => 'true') if $value eq 'Y';
1307 Makes a radio button element -- TODO
1310 # TODO -- make this general radio butons
1313 my ($self, $col) = @_;
1314 my $value = ref $self && $self->$col || '';
1315 my $nullable = eval {self->column_nullable($col)} || 0;
1316 my $a = HTML::Element->new("span");
1317 my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1318 my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1319 my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1320 $ry->push_content('Yes'); $rn->push_content('No');
1321 $ru->push_content('n/a') if $nullable;
1322 if ($value eq 'Y') {
1323 $ry->attr("checked" => 'true');
1324 } elsif ($value eq 'N') {
1325 $rn->attr("checked" => 'true');
1326 } elsif ($nullable) {
1327 $ru->attr("checked" => 'true');
1329 $a->push_content($ry, $rn);
1330 $a->push_content($ru) if $nullable;
1336 ############################ HELPER METHODS ######################
1337 ##################################################################
1339 =head2 _rename_foreign_input
1341 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1343 Recursively renames the foreign inputs made by _to_foreign_inputs so they
1344 can be processed generically. It uses foreign_input_delimiter.
1346 So if an Employee is a Person who has_many Addresses and you call and the
1347 method 'foreign_input_delimiter' returns '__AF__' then
1349 Employee->to_field("person");
1351 will get inputs for the Person as well as their Address (by default,
1352 override _field_from_relationship to change logic) named like this:
1354 person__AF__address__AF__street
1355 person__AF__address__AF__city
1356 person__AF__address__AF__state
1357 person__AF__address__AF__zip
1359 And the processor would know to create this address, put the address id in
1360 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.
1364 sub _rename_foreign_input {
1365 my ($self, $accssr, $element) = @_;
1366 my $del = $self->foreign_input_delimiter;
1368 if ( ref $element ne 'HASH' ) {
1369 # my $new_name = $accssr . "__AF__" . $input->attr('name');
1370 $element->attr( name => $accssr . $del . $element->attr('name'));
1372 $self->_rename_foreign_input($accssr, $element->{$_})
1373 foreach (keys %$element);
1377 =head2 foreign_input_delimiter
1379 This tells AsForm what to use to delmit forieign input names. This is important
1380 to avoid name clashes as well as automating processing of forms.
1384 sub foreign_input_delimiter { '__AF__' };
1388 This functions computes the dimensions of a textarea based on the value
1394 my ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1397 my @rows = split /^/, $text;
1398 my $cols = $min_cols;
1401 my $len = length $_;
1403 $cols = $len if $len > $cols;
1404 $cols = $max_cols if $cols > $max_cols;
1407 $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1408 $rows = $min_rows if $rows < $min_rows;
1409 $rows = $max_rows if $rows > $max_rows;
1412 ($min_rows, $min_cols);
1423 15-07-2004 -- Initial version
1430 Peter Speltz, Aaron Trevena
1432 =head1 AUTHORS EMERITUS
1434 Simon Cozens, Tony Bowden
1439 checkbox generalization
1440 radio generalization
1441 Make link_hidden use standard make_url stuff when it gets in Maypole
1442 How do you tell AF --" I want a has_many select box for this every time so,
1443 when you call "to_field($this_hasmany)" you get a select box
1445 =head1 BUGS and QUERIES
1447 Please direct all correspondence regarding this module to:
1450 =head1 COPYRIGHT AND LICENSE
1452 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1454 This library is free software; you can redistribute it and/or modify
1455 it under the same terms as Perl itself.
1459 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.