1 package Maypole::Model::CDBI::AsForm;
5 # _to_select_or_create -- select input stays
6 # _to_create_or_select -- create input trumps
10 # has_many select -- $obj->to_field($has_many_col); # select one form many
11 # -- $class->to_field($has_many_col); # foreign inputs
12 # $class->search_inputs; /
20 use Class::DBI::Plugin::Type ();
25 # pjs -- Added new methods to @EXPORT
28 to_cgi to_field foreign_input_delimiter search_inputs unselect_element
29 _field_from_how _field_from_relationship _field_from_column
30 _to_textarea _to_textfield _to_select _select_guts
31 _to_foreign_inputs _to_enum_select _to_bool_select
32 _to_hidden _to_link_hidden _rename_foreign_input _to_readonly
33 _options_from_objects _options_from_arrays _options_from_hashes
34 _options_from_array _options_from_hash
41 Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns
46 use Maypole::Model::CDBI::AsForm;
47 use base 'Class::DBI';
53 my %cgi_field = $self->to_cgi;
55 (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
60 # Example of has_many select
62 __PACKAGE__->has_a('job_employer' => 'Employer');
63 __PACKAGE__->has_a('contact' => 'Contact')
66 __PACKAGE__->has_a('cont_employer' => 'Employer');
67 __PACKAGE__->has_many('jobs' => 'Job',
68 { join => { job_employer => 'cont_employer' },
69 constraint => { 'finshed' => 0 },
70 order_by => "created ASC",
75 __PACKAGE__->has_many('jobs' => 'Job',);
76 __PACKAGE__->has_many('contacts' => 'Contact',
77 order_by => 'name DESC',
81 # Choose some jobs to add to a contact (has multiple attribute).
82 my $job_sel = Contact->to_field('jobs'); # Uses constraint and order by
85 # Choose a job from $contact->jobs
86 my $job_sel = $contact->to_field('jobs');
92 This module helps to generate HTML forms for creating new database rows
93 or editing existing rows. It maps column names in a database table to
94 HTML form elements which fit the schema. Large text fields are turned
95 into textareas, and fields with a has-a relationship to other
96 C<Class::DBI> tables are turned into select drop-downs populated with
97 objects from the joined class.
100 =head1 ARGUMENTS HASH
102 This provides a convenient way to tweak AsForm's behavior in exceptional or
103 not so exceptional instances. Below describes the arguments hash and
107 $beer->to_field($col, $how, $args);
108 $beer->to_field($col, $args);
110 Not all _to_* methods pay attention to all arguments. For example, '_to_textfield' does not look in $args->{'items'} at all.
114 =item name -- the name the element will have , this trumps the derived name.
116 $beer->to_field('brewery', 'readonly', {
120 =item value -- the initial value the element will have, trumps derived value
122 $beer->to_field('brewery', 'textfield', {
123 name => 'brewery_id', value => $beer->brewery,
124 # however, no need to set value since $beer is object
127 =item items -- array of items generally used to make select box options
129 Can be array of objects, hashes, arrays, or strings, or just a hash.
132 $beer->to_field(rating => select => {
133 items => [1 , 2, 3, 4, 5],
136 # Select a Brewery to visit in the UK
137 Brewery->to_field(brewery_id => {
138 items => [ Brewery->search_like(location => 'UK') ],
141 # Make a select for a boolean field
142 $Pub->to_field('open' , { items => [ {'Open' => 1, 'Closed' => 0 } ] });
144 =item selected -- something representing which item is selected in a select box
146 $beer->to_field('brewery', {
147 selected => $beer->brewery, # again not necessary since caller is obj.
150 Can be an simple scalar id, an object, or an array of either
152 =item class -- the class for which the input being made for field pertains to.
154 This in almost always derived in cases where it may be difficult to derive, --
155 # Select beers to serve on handpump
156 Pub->to_field(handpumps => select => {
157 class => 'Beer', order_by => 'name ASC', multiple => 1,
160 =item column_type -- a string representing column type
162 $pub->to_field('open', 'bool_select', {
163 column_type => "bool('Closed', 'Open'),
166 =item column_nullable -- flag saying if column is nullable or not
168 Generally this can be set to get or not get a null/empty option added to
169 a select box. AsForm attempts to call "$class->column_nullable" to set this
170 and it defaults to true if there is no shuch method.
172 $beer->to_field('brewery', { column_nullable => 1 });
174 =item r or request -- the mapyole request object
176 =item uri -- uri for a link , used in methods such as _to_link_hidden
178 $beer->to_field('brewery', 'link_hidden',
179 {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery});
180 # an html link that is also a hidden input to the object. R is required to
181 # make the uri unless you pass a uri
183 =item order_by, constraint, join
185 These are used in making select boxes. order_by is a simple order by clause
186 and constraint and join are hashes used to limit the rows selected. The
187 difference is that join uses methods of the object and constraint uses
188 static values. You can also specify these in the relationship arguments.
190 BeerDB::LondonBeer->has_a('brewery', 'BeerDB::Brewery',
191 order_by => 'brewery_name ASC',
192 constraint => {location => 'London'},
193 'join' => {'brewery_tablecolumn => 'beer_obj_column'},
196 =item no_hidden_constraints --
198 Tell AsForm not to make hidden inputs for relationship constraints. It does
199 this sometimes when making foreign inputs .
205 $self->to_cgi([@columns, $args]);
207 This returns a hash mapping all the column names to HTML::Element objects
208 representing form widgets. It takes two opitonal arguments -- a list of
209 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.
211 $self->to_cgi(); # uses $self->columns; # most used
212 $self->to_cgi(qw/brewery style rating/); # sometimes
213 # and on rare occassions this is desireable if you have a lot of fields
214 # and dont want to call to_field a bunch of times just to tweak one or
216 $self->to_cgi(@cols, {brewery => {
217 how => 'textfield' # too big for select
220 column_nullable => 0,
222 items => ['Ale', 'Lager']
229 my ($class, @columns) = @_; # pjs -- added columns arg
232 @columns = $class->columns;
233 # Eventually after stabalization, we could add display_columns
234 #keys map { $_ => 1 } ($class->display_columns, $class->columns);
237 if ( ref $columns[-1] eq 'HASH' ) { $args = pop @columns; }
239 map { $_ => $class->to_field($_, $args->{$_}) } @columns;
242 =head2 to_field($field [, $how][, $args])
244 This maps an individual column to a form element. The C<how> argument
245 can be used to force the field type into any you want. All that you need
246 is a method named "_to_$how" in your class. Your class inherits many from
247 AsForm already. Override them at will.
249 If C<how> is specified but the class cannot call the method it maps to,
250 then AsForm will issue a warning and the default input will be made.
251 You can write your own "_to_$how" methods and AsForm comes with many.
252 See C<HOW Methods>. You can also pass this argument in $args->{how}.
258 my ($self, $field, $how, $args) = @_;
259 if (ref $how) { $args = $how; $how = ''; }
260 unless ($how) { $how = $args->{how} || ''; }
261 #warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n";
263 #if (ref $field) { $args = $field; $field = '' }
266 #warn "args to_field are $field, . " . Dumper($how) . " , " . Dumper($args);
269 return $self->_field_from_how($field, $how, $args) ||
270 $self->_field_from_relationship($field, $args) ||
271 $self->_field_from_column($field, $args) ||
272 $self->_to_textfield($field, $args);
277 my $cgi = $class->search_inputs ([$args]); # optional $args
279 Returns hash or hashref of search inputs elements for a class making sure the
280 inputs are empty of any initial values.
281 You can specify what columns you want inputs for in
283 by the method "search_columns". The default is "display_columns".
284 If you want to te search on columns in related classes you can do that by
285 specifying a one element hashref in place of the column name where
286 the key is the related "column" (has_a or has_many method for example) and
287 the value is a list ref of columns to search on in the related class.
290 sub BeerDB::Beer::search_columns {
291 return ( 'name' , 'rating', { brewery => [ 'name', 'location'] } );
294 # Now foreign inputs are made for Brewery name and location and the
295 # there will be no name clashing and processing can be automated.
301 my ($class, $args) = @_;
302 $class = ref $class || $class;
303 #my $accssr_class = { $class->accessor_classes };
306 $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns];
308 foreach my $field ( @{ $args->{columns} } ) {
310 no_hidden_constraints => 1,
311 column_nullable => 1, # empty option on select boxes
314 if ( ref $field eq "HASH" ) { # foreign search fields
315 my ($accssr, $cols) = each %$field;
316 $base_args->{columns} = $cols;
318 # default to search fields for related
319 #$cols = $accssr_class->{$accssr}->search_columns;
320 die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
322 my $fcgi = $class->to_field($accssr, 'foreign_inputs', $base_args);
324 # unset the default values for a select box
325 foreach (keys %$fcgi) {
326 my $el = $fcgi->{$_};
327 if ($el->tag eq 'select') {
329 $class->unselect_element($el);
330 my ($first, @content) = $el->content_list;
331 my @fc = $first->content_list;
332 my $val = $first ? $first->attr('value') : undef;
333 if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or
335 #(defined $first->attr('value') or $first->attr('value') ne ''))
336 # push an empty option on stactk
337 $el->unshift_content(HTML::Element->new('option'));
342 $cgi{$accssr} = $fcgi;
343 delete $base_args->{columns};
346 $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} });
347 my $el = $cgi{$field};
348 if ($el->tag eq 'select') {
349 $class->unselect_element($el);
350 my ($first, @content) = $el->content_list;
351 if ($first and $first->content_list) { # something
352 #(defined $first->attr('value') or $first->attr('value') ne ''))
353 # push an empty option on stactk
354 $el->unshift_content(HTML::Element->new('option'));
365 =head2 unselect_element
367 unselect any selected elements in a HTML::Element select list widget
370 sub unselect_element {
371 my ($self, $el) = @_;
372 #unless (ref $el eq 'HTML::Element') {
373 #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
374 if ($el->tag eq 'select') {
375 foreach my $opt ($el->content_list) {
376 $opt->attr('selected', undef) if $opt->attr('selected');
381 =head2 _field_from_how($field, $how,$args)
383 Returns an input element based the "how" parameter or nothing at all.
388 sub _field_from_how {
389 my ($self, $field, $how, $args) = @_;
393 my $meth = "_to_$how";
394 if (not $self->can($meth)) {
395 warn "Class can not $meth";
398 return $self->$meth($field, $args);
402 =head2 _field_from_relationship($field, $args)
404 Returns an input based on the relationship associated with the field or nothing.
407 For has_a it will give select box
411 sub _field_from_relationship {
412 my ($self, $field, $args) = @_;
413 return unless $field;
414 my $rel_meta = $self->related_meta('r',$field) || return;
415 my $rel_name = $rel_meta->{name};
416 #my $meta = $self->meta_info;
417 #grep{ defined $meta->{$_}{$field} } keys %$meta;
418 my $fclass = $rel_meta->foreign_class;
419 my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
422 if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) {
423 # This condictions allows for trumping of the has_a args
424 if (not $rel_meta->{args}{no_select} and not $args->{no_select})
426 $args->{class} = $fclass;
427 return $self->_to_select($field, $args);
431 # maybe has many select
432 if ($rel_meta->{name} eq 'has_many' and $fclass_is_cdbi and ref $self) {
433 # This condictions allows for trumping of the has_a args
434 if (not $rel_meta->{args}{no_select} and not $args->{no_select})
436 $args->{class} = $fclass;
437 my @itms = $self->$field; # need list not iterator
438 $args->{items} = \@itms;
439 return $self->_to_select($field, $args);
446 #NOOO! maybe select from has_many
447 # if ($rel_type eq 'has_many' and ref $self) {
448 # $args->{items} ||= [$self->$field];
449 # # arg name || fclass pk name || field
450 # if (not $args->{name}) {
451 # $args->{name} = eval{$fclass->primary_column->name} || $field;
453 # return $self->_to_select($field, $args);
456 # maybe foreign inputs
457 my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
458 if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_name eq 'has_own'))
460 $args->{related_meta} = $rel_meta; # suspect faster to set these args
461 return $self->_to_foreign_inputs($field, $args);
466 =head2 _field_from_column($field, $args)
468 Returns an input based on the column's characteristics, namely type, or nothing.
473 sub _field_from_column {
474 my ($self, $field, $args) = @_;
475 return unless $field;
476 my $class = ref $self || $self;
478 unless ($args->{column_type}) {
479 if ($class->can('column_type')) {
480 $args->{column_type} = $class->column_type($field);
483 # Right, have some of this
484 eval "package $class; Class::DBI::Plugin::Type->import()";
485 $args->{column_type} = $class->column_type($field);
488 my $type = $args->{column_type};
490 return $self->_to_textfield($field, $args)
491 if $type and $type =~ /^(VAR)?CHAR/i; #common type
492 return $self->_to_textarea($field, $args)
493 if $type and $type =~ /^(TEXT|BLOB)$/i;
494 return $self->_to_enum_select($field, $args)
495 if $type and $type =~ /^ENUM\((.*?)\)$/i;
496 return $self->_to_bool_select($field, $args)
497 if $type and $type =~ /^BOOL/i;
498 return $self->_to_readonly($field, $args)
499 if $type and $type =~ /^readonly$/i;
505 my ($self, $col, $args) = @_;
508 my $val = $args->{value};
510 unless (defined $val) {
515 $val = eval {$self->column_default($col);};
516 $val = '' unless defined $val;
519 my ($rows, $cols) = _box($val);
520 $rows = $args->{rows} if $args->{rows};
521 $cols = $args->{cols} if $args->{cols};;
522 my $name = $args->{name} || $col;
524 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
525 $a->push_content($val);
526 $OLD_STYLE && return $a->as_HTML;
531 my ($self, $col, $args ) = @_;
532 use Carp qw/confess/;
533 confess "No col passed to _to_textfield" unless $col;
535 my $val = $args->{value};
536 my $name = $args->{name} || $col;
538 unless (defined $val) {
540 # Case where column inflates.
541 # Input would get stringification which could be not good.
542 # as in the case of Time::Piece objects
543 $val = $self->can($col) ? $self->$col : ''; # in case it is a virtual column
545 if (my $meta = $self->related_meta('',$col)) {
546 if (my $code = $meta->{args}{deflate4edit} || $meta->{args}{deflate} ) {
547 $val = ref $code ? &$code($val) : $val->$code;
549 elsif ( $val->isa('Class::DBI') ) {
553 #warn "No deflate4edit code defined for $val of type " .
554 #ref $val . ". Using the stringified value in textfield..";
558 $val = $val->id if $val->isa("Class::DBI");
564 $val = eval {$self->column_default($col);};
565 $val = '' unless defined $val;
569 # THIS If section is neccessary or you end up with "value" for a vaiue
571 $val = '' unless defined $val;
572 $a = HTML::Element->new("input", type => "text", name => $name, value =>$val);
573 $OLD_STYLE && return $a->as_HTML;
578 # Too expensive version -- TODO
580 # my ($self, $col, $hint) = @_;
581 # my $fclass = $hint || $self->__hasa_rels->{$col}->[0];
582 # my @objs = $fclass->retrieve_all;
583 # my $a = HTML::Element->new("select", name => $col);
585 # my $sel = HTML::Element->new("option", value => $_->id);
586 # $sel->attr("selected" => "selected")
588 # and eval { $_->id eq $self->$col->id };
589 # $sel->push_content($_->stringify_self);
590 # $a->push_content($sel);
592 # $OLD_STYLE && return $a->as_HTML;
599 # -- Rewrote this to be efficient -- no object creation.
600 # -- Added option for CDBI classes to specify a limiting clause
601 # via "has_a_select_limit".
602 # -- Added selected argument to set a selected
604 =head2 recognized arguments
606 selected => $object|$id,
609 where => SQL 'WHERE' clause,
610 order_by => SQL 'ORDER BY' clause,
611 limit => SQL 'LIMIT' clause,
612 items => [ @items_of_same_type_to_select_from ],
613 class => $class_we_are_selecting_from
614 stringify => $stringify_coderef|$method_name
619 # select box requirements
620 # 1. a select box for objecs of a has_a related class -- DONE
621 =head2 1. a select box out of a has_a or has_many related class.
622 # For has_a the default behavior is to make a select box of every element in
623 # related class and you choose one.
624 #Or explicitly you can create one and pass options like where and order
625 BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
627 # For has_many the default is to get a multiple select box with all objects.
628 # If called as an object method, the objects existing ones will be selected.
629 Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"});
632 =head2 2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun.
634 BeerDB::Beer->to_field('', 'select', $options)
636 BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
637 # with PK as ID, $Class->to_field() same.
638 BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
639 # specify exact where clause
641 =head2 3. If you already have a list of objects to select from --
643 BeerDB:;Beer->to_field($col, 'select' , {items => $objects});
645 # 3. a select box for arbitrary set of objects
646 # Pass array ref of objects as first arg rather than field
647 $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
653 my ($self, $col, $args) = @_;
655 # Do we have items already ? Go no further.
656 if ($args->{items} and ref $args->{items}) {
657 my $a = $self->_select_guts($col, $args);
658 $OLD_STYLE && return $a->as_HTML;
659 if ($args->{multiple}) { $a->attr('multiple', 'multiple');}
663 # Else what are we making a select box out of ?
664 # No Column parameter -- means making a select box of args->class or self
665 # Using all rows from class's table
667 unless ($args->{class}) {
668 $args->{class} = ref $self || $self;
669 # object selected if called with one
670 $args->{selected} = { $self->id => 1}
671 if not $args->{selected} and ref $self;
673 $col = $args->{class}->primary_column;
675 # Related Class maybe ?
676 elsif (my $rel_meta = $self->related_meta('r:)', $col) ) {
677 $args->{class} = $rel_meta->{foreign_class};
678 # related objects pre selected if object
680 # "Has many" -- Issues:
681 # 1) want to select one or many from list if self is an object
682 # Thats about all we can do really,
683 # 2) except for mapping which is TODO and would
684 # do something like add to and take away from list of permissions for
687 # Hasmany select one from list if ref self
688 if ($rel_meta->{name} =~ /has_many/i and ref $self) {
689 my @itms = $self->$col; # need list not iterator
690 $args->{items} = \@itms;
691 my $a = $self->_select_guts($col, $args);
692 $OLD_STYLE && return $a->as_HTML;
696 $args->{selected} ||= [ $self->$col ] if ref $self;
697 #warn "selected is " . Dumper($args->{selected});
698 my $c = $rel_meta->{args}{constraint} || {};
699 my $j = $rel_meta->{args}{join} || {};
702 @join = map { $_ ." = ". $self->_attr($_) } keys %$j;
704 my @constr= map { "$_ = '$c->{$_}'"} keys %$c;
705 $args->{where} ||= join (' AND ', (@join, @constr));
706 $args->{order_by} ||= $rel_meta->{args}{order_by};
707 $args->{limit} ||= $rel_meta->{args}{limit};
711 # We could say :Col is name and we are selecting out of class arg.
714 #$args->{name} = $col;
715 die "Usage _to_select. $col not related to any class to select from. ";
720 unless ( defined $args->{column_nullable} ) {
721 $args->{column_nullable} = $self->can('column_nullable') ?
722 $self->column_nullable($col) : 1;
725 # Get items to select from
726 $args->{items} = _select_items($args);
728 #warn "Just got items. They are " . Dumper($args->{items});
730 # Make select HTML element
731 $a = $self->_select_guts($col, $args);
733 if ($args->{multiple}) {$a->attr('multiple', 'multiple');}
736 $OLD_STYLE && return $a->as_HTML;
745 # returns the intersection of list refs a and b
746 sub _list_intersect {
748 my %isect; my %union;
749 foreach my $e (@$a, @$b) { $union{$e}++ && $isect{$e}++ }
758 my $fclass = $args->{class};
759 my @disp_cols = @{$args->{columns} || []};
760 @disp_cols = $fclass->columns('SelectBox') unless @disp_cols;
761 @disp_cols = $fclass->columns('Stringify')unless @disp_cols;
762 @disp_cols = $fclass->_essential unless @disp_cols;
763 unshift @disp_cols, $fclass->columns('Primary');
764 #my %isect = _list_intersect(\@pks, \@disp_cols);
765 #foreach (@pks) { push @sel_cols, $_ unless $isect{$_}; }
766 #push @sel_cols, @disp_cols;
768 #warn "in select items. args are : " . Dumper($args);
770 if ($args->{'distinct'}) {
771 $distinct = 'DISTINCT ';
774 my $sql = "SELECT $distinct" . join( ', ', @disp_cols) .
775 " FROM " . $fclass->table;
777 $sql .= " WHERE " . $args->{where} if $args->{where};
778 $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
779 $sql .= " LIMIT " . $args->{limit} if $args->{limit};
780 #warn "_select_items sql is : $sql";
782 return $fclass->db_Main->selectall_arrayref($sql);
787 # Makes a readonly input box out of column's value
788 # No args makes object to readonly
790 my ($self, $col, $args) = @_;
791 my $val = $args->{value};
792 if (not defined $val ) { # object to readonly
793 $self->_croak("AsForm: To readonly field called as class method without a value") unless ref $self;
795 $col = $self->primary_column;
797 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
798 'name' => $col, 'value'=>$val);
799 $OLD_STYLE && return $a->as_HTML;
804 =head2 _to_enum_select
806 $sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");
808 Returns an enum select box given a column name and an enum string.
809 NOTE: The Plugin::Type does not return an enum string for mysql enum columns.
810 This will not work unless you write your own column_type method in your model.
814 sub _to_enum_select {
815 my ($self, $col, $args) = @_;
816 my $type = $args->{column_type};
817 $type =~ /ENUM\((.*?)\)/i;
818 (my $enum = $1) =~ s/'//g;
819 my @enum_vals = split /\s*,\s*/, $enum;
821 # determine which is pre selected --
822 # if obj, the value is , otherwise use column_default which is the first
823 # value in the enum list unless it has been overridden
824 my $selected = eval { $self->$col };
825 $selected = eval{$self->column_default($col)} unless defined $selected;
826 $selected = $enum_vals[0] unless defined $selected;
828 my $a = HTML::Element->new("select", name => $col);
830 my $sel = HTML::Element->new("option", value => $_);
831 $sel->attr("selected" => "selected") if $_ eq $selected ;
832 $sel->push_content($_);
833 $a->push_content($sel);
835 $OLD_STYLE && return $a->as_HTML;
840 =head2 _to_bool_select
842 my $sel = $self->_to_bool_select($column, $bool_string);
844 This makes select input for boolean column. You can provide a
845 bool string of form: Bool('zero','one') and those are used for option
846 content. Onthervise No and Yes are used.
847 TODO -- test without bool string.
851 # TCODO fix this mess with args
852 sub _to_bool_select {
853 my ($self, $col, $args) = @_;
854 my $type = $args->{column_type};
855 my @bool_text = ('No', 'Yes');
856 if ($type =~ /BOOL\((.+?)\)/i) {
857 (my $bool = $1) =~ s/'//g;
858 @bool_text = split /,/, $bool;
863 my $selected = $args->{value} if defined $args->{value};
864 $selected = $args->{selected} unless defined $selected;
865 $selected = ref $self ? eval {$self->$col;} : $self->column_default($col)
866 unless (defined $selected);
868 my $a = HTML::Element->new("select", name => $col);
869 if ($args->{column_nullable} || $args->{value} eq '') {
870 my $null = HTML::Element->new("option");
871 $null->attr('selected', 'selected') if $args->{value} eq '';
872 $a->push_content( $null );
875 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
876 HTML::Element->new("option", value => 1) );
877 $opt0->push_content($bool_text[0]);
878 $opt1->push_content($bool_text[1]);
879 unless ($selected eq '') {
880 $opt0->attr("selected" => "selected") if not $selected;
881 $opt1->attr("selected" => "selected") if $selected;
883 $a->push_content($opt0, $opt1);
884 $OLD_STYLE && return $a->as_HTML;
889 =head2 _to_hidden($col, $args)
891 This makes a hidden html element. Give it a name and value or if name is
892 a ref it will use the PK name and value of the object.
897 my ($self, $name, $val) = @_;
900 if (ref $name and $name->isa("Class::DBI")) {
902 $name= ($obj->primary_columns)[0]->name;
906 $val = $args->{value};
907 $name = $args->{name} if $args->{name};
909 elsif (not $name ) { # hidding object caller
910 $self->_croak("No object available in _to_hidden") unless ref $self;
911 $name = ($self->primary_column)[0]->name;
914 return HTML::Element->new('input', 'type' => 'hidden',
915 'name' => $name, 'value'=>$val
919 =head2 _to_link_hidden($col, $args)
921 Makes a link with a hidden input with the id of $obj as the value and name.
922 Name defaults to the objects primary key. The object defaults to self.
926 sub _to_link_hidden {
927 my ($self, $accessor, $args) = @_;
928 my $r = eval {$self->controller} || $args->{r} || '';
929 my $uri = $args->{uri} || '';
931 $self->_croak("_to_link_hidden cant get uri. No Maypole Request class (\$r) or uri arg. Need one or other.")
934 if (ref $self) { # hidding linking self
936 $name = $args->{name} || $obj->primary_column->name;
938 elsif ($obj = $args->{items}->[0]) {
939 $name = $args->{name} || $accessor || $obj->primary_column->name;
940 # TODO use meta data above maybe
942 else { # hiding linking related object with id in args
943 $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
944 $name = $args->{name} || $accessor ; #$obj->primary_column->name;
945 # TODO use meta data above maybe
947 $self->_croak("_to_link_hidden has no object") unless ref $obj;
948 my $href = $uri || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
949 my $a = HTML::Element->new('a', 'href' => $href);
950 $a->push_content("$obj");
951 $a->push_content($self->_to_hidden($name, $obj->id));
952 $OLD_STYLE && return $a->as_HTML;
956 =head2 _to_foreign_inputs
958 $html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]);
960 Get inputs for the accessor's class. Pass an array ref of fields to get
961 inputs for only those fields. Otherwise display_columns or all columns is used.
962 If you have the meta info handy for the accessor you can pass that too.
964 TODO make AsForm know more about the request like what action we are doing
965 so it can use edit columns or search_columns
967 NOTE , this names the foreign inputs is a particular way so they can be
968 processed with a general routine and so there are not name clashes.
971 related_meta -- if you have this, great, othervise it will determine or die
972 columns -- list of columns to make inputs for
976 sub _to_foreign_inputs {
977 my ($self, $accssr, $args) = @_;
978 my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr);
979 my $fields = $args->{columns};
981 $self->_croak( "No relationship for accessor $accssr");
984 my $rel_type = $rel_meta->{name};
985 my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_meta->{foreign_class};
988 $fields = $classORobj->can('display_columns') ?
989 [$classORobj->display_columns] : [$classORobj->columns];
992 # Ignore our fkey in them to prevent infinite recursion
993 my $me = eval {$rel_meta->{args}{foreign_column}} || '';
994 my $constrained = $rel_meta->{args}{constraint};
996 foreach ( @$fields ) {
997 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
998 $inputs{$_} = $classORobj->to_field($_);
1001 # Make hidden inputs for constrained columns unless we are editing object
1002 # TODO -- is this right thing to do?
1003 unless (ref $classORobj || $args->{no_hidden_constraints}) {
1004 $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_})
1005 foreach ( keys %$constrained );
1007 $self->_rename_foreign_input($accssr, \%inputs);
1012 =head2 _hash_selected
1014 Method to make sense out of the "selected" argument which can be in a number
1015 of formats perhaps. It returns a hashref with the the values of options to be
1018 Below handles these formats for the "selected" slot in the arguments hash:
1019 Object (with id method)
1020 Scalar (assumes it is value)
1021 Array ref *OF* objects, arrays of data (0 elmnt used), hashes of data
1022 (id key used), and simple scalars.
1030 sub _hash_selected {
1032 my $selected = $args->{value} || $args->{selected};
1033 #warn "**** SELECTED is $selected ****";
1034 my $type = ref $selected;
1035 return $selected unless $selected and $type ne 'HASH';
1036 #warn "Selected dump : " . Dumper($selected);
1038 if ($type and $type ne 'ARRAY') {
1039 my $id = $selected->id;
1045 return { $selected => 1};
1049 # Array of objs, arrays, hashes, or just scalalrs.
1050 elsif ($type eq 'ARRAY') {
1052 my $ltype = ref $selected->[0];
1054 if ($ltype and $ltype ne 'ARRAY') {
1055 %hashed = map { $_->id => 1 } @$selected;
1057 # Arrays of data with id first
1058 elsif ($ltype and $ltype eq 'ARRAY') {
1059 %hashed = map { $_->[0] => 1 } @$selected;
1061 # Hashes using pk or id key
1062 elsif ($ltype and $ltype eq 'HASH') {
1063 my $pk = $args->{class}->primary_column || 'id';
1064 %hashed = map { $_->{$pk} => 1 } @$selected;
1068 %hashed = map { $_ => 1 } @$selected;
1072 else { warn "AsForm Could not hash the selected argument: $selected"; }
1080 Internal api method to make the actual select box form elements.
1082 3 types of lists making for --
1084 Array of CDBI objects.
1086 Array or Array refs with cols from class,
1094 my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
1096 #$args->{stringify} ||= 'stringify_selectbox';
1098 $args->{selected} = _hash_selected($args) if defined $args->{selected};
1099 my $name = $args->{name} || $col;
1100 my $a = HTML::Element->new('select', name => $name);
1101 $a->attr( %{$args->{attr}} ) if $args->{attr};
1103 if ($args->{column_nullable}) {
1104 my $null_element = HTML::Element->new('option', value => '');
1105 $null_element->attr(selected => 'selected')
1106 if ($args->{selected}{'null'});
1107 $a->push_content($null_element);
1110 my $items = $args->{items};
1111 my $type = ref $items;
1112 my $proto = eval { ref $items->[0]; } || "";
1113 my $optgroups = $args->{optgroups} || '';
1115 # Array of hashes, one for each optgroup
1118 foreach (@$optgroups) {
1119 my $ogrp= HTML::Element->new('optgroup', label => $_);
1120 $ogrp->push_content($self->_options_from_hash($items->[$i], $args));
1121 $a->push_content($ogrp);
1126 elsif ($type eq 'HASH') {
1127 $a->push_content($self->_options_from_hash($items, $args));
1130 elsif ( $type eq 'ARRAY' and not ref $items->[0] ) {
1131 $a->push_content($self->_options_from_array($items, $args));
1134 elsif( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) {
1135 # make select of objects
1136 $a->push_content($self->_options_from_objects($items, $args));
1139 elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) {
1140 $a->push_content($self->_options_from_arrays($items, $args));
1143 elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) {
1144 $a->push_content($self->_options_from_hashes($items, $args));
1147 die "You passed a weird type of data structure to me. Here it is: " .
1156 =head2 _options_from_objects ( $objects, $args);
1158 Private method to makes a options out of objects. It attempts to call each
1159 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
1161 *Note only single primary keys supported
1164 sub _options_from_objects {
1165 my ($self, $items, $args) = @_;
1166 my $selected = $args->{selected} || {};
1167 my $stringify = $args->{stringify} || '';
1171 my $opt = HTML::Element->new("option", value => $id);
1172 $id =~ s/^0*//; # leading zeros no good in hash key
1173 $opt->attr(selected => "selected") if $selected->{$id};
1174 my $content = $stringify ? $_->stringify : "$_";
1175 $opt->push_content($content);
1181 sub _options_from_arrays {
1182 my ($self, $items, $args) = @_;
1183 my $selected = $args->{selected} || {};
1185 my $class = $args->{class} || '';
1186 my $stringify = $args->{stringify} || '';
1187 for my $item (@$items) {
1188 my @pks; # for future multiple key support
1189 push @pks, shift @$item foreach $class->columns('Primary');
1191 $id =~ s/^0+//; # In case zerofill is on .
1192 my $val = defined $id ? $id : '';
1193 my $opt = HTML::Element->new("option", value =>$val);
1194 $opt->attr(selected => "selected") if $selected->{$id};
1196 my $content = ($class and $stringify and $class->can($stringify)) ?
1197 $class->$stringify($_) :
1198 join( '/', map { $_ if $_; }@{$item} );
1199 $opt->push_content( $content );
1206 sub _options_from_array {
1207 my ($self, $items, $args) = @_;
1208 my $selected = $args->{selected} || {};
1211 my $val = defined $_ ? $_ : '';
1212 my $opt = HTML::Element->new("option", value => $val);
1213 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1214 $opt->attr(selected => "selected") if $selected->{$_};
1215 $opt->push_content( $_ );
1221 sub _options_from_hash {
1222 my ($self, $items, $args) = @_;
1223 my $selected = $args->{selected} || {};
1226 my @values = values %$items;
1227 # hash Key is the option content and the hash value is option value
1228 for (sort keys %$items) {
1229 my $val = defined $items->{$_} ? $items->{$_} : '';
1230 my $opt = HTML::Element->new("option", value => $val);
1231 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1232 $opt->attr(selected => "selected") if $selected->{$items->{$_}};
1233 $opt->push_content( $_ );
1240 sub _options_from_hashes {
1241 my ($self, $items, $args) = @_;
1242 my $selected = $args->{selected} || {};
1243 my $pk = eval {$args->{class}->primary_column} || 'id';
1244 my $fclass = $args->{class} || '';
1245 my $stringify = $args->{stringify} || '';
1248 my $val = defined $_->{$pk} ? $_->{$pk} : '';
1249 my $opt = HTML::Element->new("option", value => $val);
1250 $opt->attr(selected => "selected") if $selected->{$val};
1251 my $content = ($fclass and $stringify and $fclass->can($stringify)) ?
1252 $fclass->$stringify($_) :
1254 $opt->push_content( $content );
1261 #sub _to_select_or_create {
1262 # my ($self, $col, $args) = @_;
1263 # $args->{name} ||= $col;
1264 # my $select = $self->to_field($col, 'select', $args);
1265 # $args->{name} = "create_" . $args->{name};
1266 # my $create = $self->to_field($col, 'foreign_inputs', $args);
1267 # $create->{'__select_or_create__'} =
1268 # $self->to_field('__select_or_create__',{ name => '__select_or_create__' , value => 1 } );
1269 # return ($select, $create);
1273 # checkboxes: if no data in hand (ie called as class method), replace
1274 # with a radio button, in order to allow this field to be left
1275 # unspecified in search / add forms.
1278 # TODO -- make this general checkboxse
1282 my ($self, $col, $args) = @_;
1283 my $nullable = eval {self->column_nullable($col)} || 0;
1284 return $self->_to_radio($col) if !ref($self) || $nullable;
1285 my $value = $self->$col;
1286 my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1287 $a->attr("checked" => 'true') if $value eq 'Y';
1292 # TODO -- make this general radio butons
1295 my ($self, $col) = @_;
1296 my $value = ref $self && $self->$col || '';
1297 my $nullable = eval {self->column_nullable($col)} || 0;
1298 my $a = HTML::Element->new("span");
1299 my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1300 my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1301 my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1302 $ry->push_content('Yes'); $rn->push_content('No');
1303 $ru->push_content('n/a') if $nullable;
1304 if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1305 elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1306 elsif ($nullable) { $ru->attr("checked" => 'true') }
1307 $a->push_content($ry, $rn);
1308 $a->push_content($ru) if $nullable;
1314 ############################ HELPER METHODS ######################
1315 ##################################################################
1317 =head2 _rename_foreign_input
1319 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1321 Recursively renames the foreign inputs made by _to_foreign_inputs so they
1322 can be processed generically. It uses foreign_input_delimiter.
1324 So if an Employee is a Person who has_many Addresses and you call and the
1325 method 'foreign_input_delimiter' returns '__AF__' then
1327 Employee->to_field("person");
1329 will get inputs for the Person as well as their Address (by default,
1330 override _field_from_relationship to change logic) named like this:
1332 person__AF__address__AF__street
1333 person__AF__address__AF__city
1334 person__AF__address__AF__state
1335 person__AF__address__AF__zip
1337 And the processor would know to create this address, put the address id in
1338 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.
1342 sub _rename_foreign_input {
1343 my ($self, $accssr, $element) = @_;
1344 my $del = $self->foreign_input_delimiter;
1346 if ( ref $element ne 'HASH' ) {
1347 # my $new_name = $accssr . "__AF__" . $input->attr('name');
1348 $element->attr( name => $accssr . $del . $element->attr('name'));
1351 $self->_rename_foreign_input($accssr, $element->{$_})
1352 foreach (keys %$element);
1356 =head2 foreign_input_delimiter
1358 This tells AsForm what to use to delmit forieign_input names with. The name has the form -- $foreign_accessor. $DELIMITER . $foreign_column
1362 sub foreign_input_delimiter { '__AF__' };
1366 This functions computes the dimensions of a textarea based on the value
1374 my ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1377 my @rows = split /^/, $text;
1378 my $cols = $min_cols;
1381 my $len = length $_;
1383 $cols = $len if $len > $cols;
1384 $cols = $max_cols if $cols > $max_cols;
1387 $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1388 $rows = $min_rows if $rows < $min_rows;
1389 $rows = $max_rows if $rows > $max_rows;
1392 else { ($min_rows, $min_cols) }
1407 Peter Speltz, Aaron Trevena
1409 =head1 AUTHORS EMERITUS
1411 Simon Cozens, Tony Bowden
1417 chekbox generalization
1418 radio generalization
1420 Make link_hidden use standard make_url stuff when it gets in Maypole
1421 How do you tell AF --" I want a has_many select box for this every time so,
1422 when you call "to_field($this_hasmany)" you get a select box
1424 =head1 BUGS and QUERIES
1426 Please direct all correspondence regarding this module to:
1429 =head1 COPYRIGHT AND LICENSE
1431 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1433 This library is free software; you can redistribute it and/or modify
1434 it under the same terms as Perl itself.
1438 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.