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; /
21 use Class::DBI::Plugin::Type ();
26 # pjs -- Added new methods to @EXPORT
29 to_cgi to_field make_element_foreign search_inputs unselect_element
30 _field_from_how _field_from_relationship _field_from_column
31 _to_textarea _to_textfield _to_select _select_guts
32 _to_foreign_inputs _to_enum_select _to_bool_select
33 _to_hidden _to_link_hidden _rename_foreign_input _to_readonly
34 _options_from_objects _options_from_arrays _options_from_hashes
35 _options_from_array _options_from_hash _to_select_or_create
50 Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns
55 use Maypole::Model::CDBI::AsForm;
56 use base 'Class::DBI';
62 my %cgi_field = $self->to_cgi;
64 (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
69 # Example of has_many select
71 __PACKAGE__->has_a('job_employer' => 'Employer');
72 __PACKAGE__->has_a('contact' => 'Contact')
75 __PACKAGE__->has_a('cont_employer' => 'Employer');
76 __PACKAGE__->has_many('jobs' => 'Job',
77 { join => { job_employer => 'cont_employer' },
78 constraint => { 'finshed' => 0 },
79 order_by => "created ASC",
84 __PACKAGE__->has_many('jobs' => 'Job',);
85 __PACKAGE__->has_many('contacts' => 'Contact',
86 order_by => 'name DESC',
90 # Choose some jobs to add to a contact (has multiple attribute).
91 my $job_sel = Contact->to_field('jobs'); # Uses constraint and order by
94 # Choose a job from $contact->jobs
95 my $job_sel = $contact->to_field('jobs');
101 This module helps to generate HTML forms for creating new database rows
102 or editing existing rows. It maps column names in a database table to
103 HTML form elements which fit the schema. Large text fields are turned
104 into textareas, and fields with a has-a relationship to other
105 C<Class::DBI> tables are turned into select drop-downs populated with
106 objects from the joined class.
109 =head1 ARGUMENTS HASH
111 This provides a convenient way to tweak AsForm's behavior in exceptional or
112 not so exceptional instances. Below describes the arguments hash and
116 $beer->to_field($col, $how, $args);
117 $beer->to_field($col, $args);
119 Not all _to_* methods pay attention to all arguments. For example, '_to_textfield' does not look in $args->{'items'} at all.
121 =item name -- the name the element will have , this trumps the derived name.
123 $beer->to_field('brewery', 'readonly', {
127 =item value -- the initial value the element will have, trumps derived value
129 $beer->to_field('brewery', 'textfield', {
130 name => 'brewery_id', value => $beer->brewery,
131 # however, no need to set value since $beer is object
134 =item items -- array of items generally used to make select box options
136 Can be array of objects, hashes, arrays, or strings, or just a hash.
139 $beer->to_field(rating => select => {
140 items => [1 , 2, 3, 4, 5],
143 # Select a Brewery to visit in the UK
144 Brewery->to_field(brewery_id => {
145 items => [ Brewery->search_like(location => 'UK') ],
148 # Make a select for a boolean field
149 $Pub->to_field('open' , { items => [ {'Open' => 1, 'Closed' => 0 } ] });
151 =item selected -- something representing which item is selected in a select box
153 $beer->to_field('brewery', {
154 selected => $beer->brewery, # again not necessary since caller is obj.
157 Can be an simple scalar id, an object, or an array of either
159 =item class -- the class for which the input being made for field pertains to.
161 This in almost always derived in cases where it may be difficult to derive, --
162 # Select beers to serve on handpump
163 Pub->to_field(handpumps => select => {
164 class => 'Beer', order_by => 'name ASC', multiple => 1,
167 =item column_type -- a string representing column type
169 $pub->to_field('open', 'bool_select', {
170 column_type => "bool('Closed', 'Open'),
173 =item column_nullable -- flag saying if column is nullable or not
175 Generally this can be set to get or not get a null/empty option added to
176 a select box. AsForm attempts to call "$class->column_nullable" to set this
177 and it defaults to true if there is no shuch method.
179 $beer->to_field('brewery', { column_nullable => 1 });
181 =item r or request -- the mapyole request object
183 =item uri -- uri for a link , used in methods such as _to_link_hidden
185 $beer->to_field('brewery', 'link_hidden',
186 {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery});
187 # an html link that is also a hidden input to the object. R is required to
188 # make the uri unless you pass a uri
190 =item order_by, constraint, join
192 These are used in making select boxes. order_by is a simple order by clause
193 and constraint and join are hashes used to limit the rows selected. The
194 difference is that join uses methods of the object and constraint uses
195 static values. You can also specify these in the relationship arguments.
197 BeerDB::LondonBeer->has_a('brewery', 'BeerDB::Brewery',
198 order_by => 'brewery_name ASC',
199 constraint => {location => 'London'},
200 'join' => {'brewery_tablecolumn => 'beer_obj_column'},
203 =item no_hidden_constraints --
205 Tell AsForm not to make hidden inputs for relationship constraints. It does
206 this sometimes when making foreign inputs .
211 $self->to_cgi([@columns, $args]);
213 This returns a hash mapping all the column names to HTML::Element objects
214 representing form widgets. It takes two opitonal arguments -- a list of
215 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.
217 $self->to_cgi(); # uses $self->columns; # most used
218 $self->to_cgi(qw/brewery style rating/); # sometimes
219 # and on rare occassions this is desireable if you have a lot of fields
220 # and dont want to call to_field a bunch of times just to tweak one or
222 $self->to_cgi(@cols, {brewery => {
223 how => 'textfield' # too big for select
226 column_nullable => 0,
228 items => ['Ale', 'Lager']
235 my ($class, @columns) = @_; # pjs -- added columns arg
238 @columns = $class->columns;
241 if ( ref $columns[-1] eq 'HASH' ) { $args = pop @columns; }
243 map { $_ => $class->to_field($_, $args->{$_}) } @columns;
246 =head2 to_field($field [, $how][, $args])
248 This maps an individual column to a form element. The C<how> argument
249 can be used to force the field type into any you want. It tells AsForm how
250 to make the input ie-- forces it to use the method "_to_$how".
251 If C<how> is specified but the class cannot call the method it maps to,
252 then AsForm will issue a warning and the default input will be made.
253 You can write your own "_to_$how" methods and AsForm comes with many.
254 See C<HOW Methods>. You can also pass this argument in $args->{how}.
260 my ($self, $field, $how, $args) = @_;
261 if (ref $how) { $args = $how; $how = ''; }
262 unless ($how) { $how = $args->{how} || ''; }
263 #warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n";
265 #if (ref $field) { $args = $field; $field = '' }
268 #warn "args to_field are $field, . " . Dumper($how) . " , " . Dumper($args);
271 return $self->_field_from_how($field, $how, $args) ||
272 $self->_field_from_relationship($field, $args) ||
273 $self->_field_from_column($field, $args) ||
274 $self->_to_textfield($field, $args);
279 my $cgi = $class->search_inputs ([$args]); # optional $args
281 Returns hash or hashref of search inputs elements for a class making sure the
282 inputs are empty of any initial values.
283 You can specify what columns you want inputs for in
285 by the method "search_columns". The default is "display_columns".
286 If you want to te search on columns in related classes you can do that by
287 specifying a one element hashref in place of the column name where
288 the key is the related "column" (has_a or has_many method for example) and
289 the value is a list ref of columns to search on in the related class.
292 sub BeerDB::Beer::search_columns {
293 return ( 'name' , 'rating', { brewery => [ 'name', 'location'] } );
296 # Now foreign inputs are made for Brewery name and location and the
297 # there will be no name clashing and processing can be automated.
303 my ($class, $args) = @_;
304 $class = ref $class || $class;
305 #my $accssr_class = { $class->accessor_classes };
308 $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns];
310 foreach my $field ( @{ $args->{columns} } ) {
312 no_hidden_constraints => 1,
313 column_nullable => 1, # empty option on select boxes
316 if ( ref $field eq "HASH" ) { # foreign search fields
317 my ($accssr, $cols) = each %$field;
318 $base_args->{columns} = $cols;
320 # default to search fields for related
321 #$cols = $accssr_class->{$accssr}->search_columns;
322 die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
324 my $fcgi = $class->to_field($accssr, 'foreign_inputs', $base_args);
326 # unset the default values for a select box
327 foreach (keys %$fcgi) {
328 my $el = $fcgi->{$_};
329 if ($el->tag eq 'select') {
331 $class->unselect_element($el);
332 my ($first, @content) = $el->content_list;
333 my @fc = $first->content_list;
334 my $val = $first ? $first->attr('value') : undef;
335 if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or
337 #(defined $first->attr('value') or $first->attr('value') ne ''))
338 # push an empty option on stactk
339 $el->unshift_content(HTML::Element->new('option'));
344 $cgi{$accssr} = $fcgi;
345 delete $base_args->{columns};
348 $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} });
349 my $el = $cgi{$field};
350 if ($el->tag eq 'select') {
351 $class->unselect_element($el);
352 my ($first, @content) = $el->content_list;
353 if ($first and $first->content_list) { # something
354 #(defined $first->attr('value') or $first->attr('value') ne ''))
355 # push an empty option on stactk
356 $el->unshift_content(HTML::Element->new('option'));
367 sub unselect_element {
368 my ($self, $el) = @_;
369 #unless (ref $el eq 'HTML::Element') {
370 #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
371 if ($el->tag eq 'select') {
372 foreach my $opt ($el->content_list) {
373 $opt->attr('selected', undef) if $opt->attr('selected');
378 =head2 _field_from_how($field, $how,$args)
380 Returns an input element based the "how" parameter or nothing at all.
385 sub _field_from_how {
386 my ($self, $field, $how, $args) = @_;
387 #if (ref $how) { $args = $how; $how = undef; }
388 #warn "In filed from how . filed is $field how is $how. args ar e" . Dumper($args) . " \n";
392 my $meth = "_to_$how";
393 if (not $self->can($meth)) {
394 warn "Class can not $meth";
397 return $self->$meth($field, $args);
401 =head2 _field_from_relationship($field, $args)
403 Returns an input based on the relationship associated with the field or nothing.
406 For has_a it will give select box
410 sub _field_from_relationship {
411 my ($self, $field, $args) = @_;
412 #warn "In filed from rel . filed is $field \n";
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 #warn "Dumper of relmeta. " . Dumper($rel_meta);
423 if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) {
424 # This condictions allows for trumping of the has_a args
425 if (not $rel_meta->{args}{no_select} and not $args->{no_select})
427 $args->{class} = $fclass;
428 return $self->_to_select($field, $args);
432 # maybe has many select
433 if ($rel_meta->{name} eq 'has_many' and $fclass_is_cdbi and ref $self) {
434 # This condictions allows for trumping of the has_a args
435 if (not $rel_meta->{args}{no_select} and not $args->{no_select})
437 $args->{class} = $fclass;
438 $args->{items} = $self->$field;
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;
477 #warn "Class is $class\n";
479 unless ($args->{column_type}) {
480 $args->{column_type} = $class->column_type($field);
481 if ($class->can('column_type')) {
482 $args->{column_type} = $class->column_type($field);
485 # Right, have some of this
486 eval "package $class; Class::DBI::Plugin::Type->import()";
487 $args->{column_type} = $class->column_type($field);
490 my $type = $args->{column_type};
492 return $self->_to_textfield($field, $args)
493 if $type and $type =~ /(VAR)?CHAR/i; #common type
494 return $self->_to_textarea($field, $args)
495 if $type and $type =~ /^(TEXT|BLOB)$/i;
496 return $self->_to_enum_select($field, $args)
497 if $type and $type =~ /^ENUM\((.*?)\)$/i;
498 return $self->_to_bool_select($field, $args)
499 if $type and $type =~ /^BOOL/i;
500 return $self->_to_readonly($field, $args)
501 if $type and $type =~ /^readonly$/i;
507 my ($self, $col, $args) = @_;
510 my $val = $args->{value};
512 unless (defined $val) {
517 $val = eval {$self->column_default($col);};
518 $val = '' unless defined $val;
521 my ($rows, $cols) = _box($val);
522 $rows = $args->{rows} if $args->{rows};
523 $cols = $args->{cols} if $args->{cols};;
524 my $name = $args->{name} || $col;
526 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
527 $a->push_content($val);
528 $OLD_STYLE && return $a->as_HTML;
533 my ($self, $col, $args ) = @_;
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 #warn "Meta for $col";
547 if (my $code = $meta->{args}{deflate4edit} || $meta->{args}{deflate} ) {
548 $val = ref $code ? &$code($val) : $val->$code;
550 elsif ( $val->isa('Class::DBI') ) {
554 #warn "No deflate4edit code defined for $val of type " .
555 #ref $val . ". Using the stringified value in textfield..";
559 #warn "No meta for $col but ref $val.\n";
560 $val = $val->id if $val->isa("Class::DBI");
566 $val = eval {$self->column_default($col);};
567 $val = '' unless defined $val;
570 my $a = HTML::Element->new("input", type => "text", name => $name, value =>
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 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 $args->{items} = [ $self->$col ];
690 my $a = $self->_select_guts($col, $args);
691 $OLD_STYLE && return $a->as_HTML;
695 $args->{selected} ||= [ $self->$col ] if ref $self;
696 #warn "selected is " . Dumper($args->{selected});
697 my $c = $rel_meta->{args}{constraint} || {};
698 my $j = $rel_meta->{args}{join} || {};
701 @join = map { $_ ." = ". $self->_attr($_) } keys %$j;
703 my @constr= map { "$_ = '$c->{$_}'"} keys %$c;
704 $args->{where} ||= join (' AND ', (@join, @constr));
705 $args->{order_by} ||= $rel_meta->{args}{order_by};
706 $args->{limit} ||= $rel_meta->{args}{limit};
710 # We could say :Col is name and we are selecting out of class arg.
713 #$args->{name} = $col;
714 die "Usage _to_select. $col not related to any class to select from. ";
719 unless ( defined $args->{column_nullable} ) {
720 $args->{column_nullable} = $self->can('column_nullable') ?
721 $self->column_nullable($col) : 1;
724 # Get items to select from
725 $args->{items} = _select_items($args);
726 #warn "Items selecting from are " . Dumper($args->{items});
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, $val) = @_;
791 if (! $col) { # object to readonly
793 $col = $self->primary_column;
795 unless (defined $val) {
796 $self->_croak("Cannot get value in _to_readonly .")
800 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
801 'name' => $col, 'value'=>$val);
802 $OLD_STYLE && return $a->as_HTML;
807 =head2 _to_enum_select
809 $sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");
811 Returns an enum select box given a column name and an enum string.
812 NOTE: The Plugin::Type does not return an enum string for mysql enum columns.
813 This will not work unless you write your own column_type method in your model.
817 sub _to_enum_select {
818 my ($self, $col, $args) = @_;
819 my $type = $args->{column_type};
820 $type =~ /ENUM\((.*?)\)/i;
821 (my $enum = $1) =~ s/'//g;
822 my @enum_vals = split /\s*,\s*/, $enum;
824 # determine which is pre selected --
825 # if obj, the value is , otherwise use column_default which is the first
826 # value in the enum list unless it has been overridden
827 my $selected = eval { $self->$col };
828 $selected = eval{$self->column_default($col)} unless defined $selected;
829 $selected = $enum_vals[0] unless defined $selected;
831 my $a = HTML::Element->new("select", name => $col);
833 my $sel = HTML::Element->new("option", value => $_);
834 $sel->attr("selected" => "selected") if $_ eq $selected ;
835 $sel->push_content($_);
836 $a->push_content($sel);
838 $OLD_STYLE && return $a->as_HTML;
843 =head2 _to_bool_select
845 my $sel = $self->_to_bool_select($column, $bool_string);
847 This makes select input for boolean column. You can provide a
848 bool string of form: Bool('zero','one') and those are used for option
849 content. Onthervise No and Yes are used.
850 TODO -- test without bool string.
854 # TCODO fix this mess with args
855 sub _to_bool_select {
856 my ($self, $col, $args) = @_;
857 #warn "In to_bool select\n";
858 my $type = $args->{column_type};
859 my @bool_text = ('No', 'Yes');
860 if ($type =~ /BOOL\((.+?)\)/i) {
861 (my $bool = $1) =~ s/'//g;
862 @bool_text = split /,/, $bool;
867 my $selected = $args->{value} if defined $args->{value};
868 $selected = $args->{selected} unless defined $selected;
869 $selected = ref $self ? eval {$self->$col;} : $self->column_default($col)
870 unless (defined $selected);
872 my $a = HTML::Element->new("select", name => $col);
873 if ($args->{column_nullable} || $args->{value} eq '') {
874 my $null = HTML::Element->new("option");
875 $null->attr('selected', 'selected') if $args->{value} eq '';
876 $a->push_content( $null );
879 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
880 HTML::Element->new("option", value => 1) );
881 $opt0->push_content($bool_text[0]);
882 $opt1->push_content($bool_text[1]);
883 unless ($selected eq '') {
884 $opt0->attr("selected" => "selected") if not $selected;
885 $opt1->attr("selected" => "selected") if $selected;
887 $a->push_content($opt0, $opt1);
888 $OLD_STYLE && return $a->as_HTML;
893 =head2 _to_hidden($col, $args)
895 This makes a hidden html element. Give it a name and value or if name is
896 a ref it will use the PK name and value of the object.
901 my ($self, $name, $val) = @_;
904 if (ref $name and $name->isa("Class::DBI")) {
906 $name= ($obj->primary_columns)[0]->name;
910 $val = $args->{value};
911 $name = $args->{name} if $args->{name};
913 elsif (not $name ) { # hidding object caller
914 $self->_croak("No object available in _to_hidden") unless ref $self;
915 $name = ($self->primary_column)[0]->name;
918 return HTML::Element->new('input', 'type' => 'hidden',
919 'name' => $name, 'value'=>$val
923 =head2 _to_link_hidden($col, $args)
925 Makes a link with a hidden input with the id of $obj as the value and name.
926 Name defaults to the objects primary key. The object defaults to self.
930 sub _to_link_hidden {
931 my ($self, $accessor, $args) = @_;
932 my $r = eval {$self->controller} || $args->{r} || '';
933 my $uri = $args->{uri} || '';
935 $self->_croak("_to_link_hidden cant get uri. No Maypole Request class (\$r) or uri arg. Need one or other.")
938 if (ref $self) { # hidding linking self
940 $name = $args->{name} || $obj->primary_column->name;
942 elsif ($obj = $args->{items}->[0]) {
944 $name = $args->{name} || $obj->primary_column->name; # TODO make use meta data
947 else { # hiding linking related object with id in args
948 $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
949 $name = $args->{name} || $obj->primary_column->name; # TODO make use meta data
951 $self->_croak("_to_link_hidden has no object") unless ref $obj;
952 my $href = $uri || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
953 my $a = HTML::Element->new('a', 'href' => $href);
954 $a->push_content("$obj");
955 $a->push_content($self->_to_hidden($name, $obj->id));
956 $OLD_STYLE && return $a->as_HTML;
962 =head2 _to_foreign_inputs
964 $html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]);
966 Get inputs for the accessor's class. Pass an array ref of fields to get
967 inputs for only those fields. Otherwise display_columns or all columns is used.
968 If you have the meta info handy for the accessor you can pass that too.
970 TODO make AsForm know more about the request like what action we are doing
971 so it can use edit columns or search_columns
973 NOTE , this names the foreign inputs is a particular way so they can be
974 processed with a general routine and so there are not name clashes.
977 related_meta -- if you have this, great, othervise it will determine or die
978 columns -- list of columns to make inputs for
982 sub _to_foreign_inputs {
983 my ($self, $accssr, $args) = @_;
984 my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr);
985 my $fields = $args->{columns};
987 $self->_croak( "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_column}} || '';
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 $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_})
1011 foreach ( keys %$constrained );
1013 $self->_rename_foreign_input($accssr, \%inputs);
1018 =head2 _hash_selected
1020 Method to make sense out of the "selected" argument which can be in a number
1021 of formats perhaps. It returns a hashref with the the values of options to be
1024 Below handles these formats for the "selected" slot in the arguments hash:
1025 Object (with id method)
1026 Scalar (assumes it is value)
1027 Array ref *OF* objects, arrays of data (0 elmnt used), hashes of data
1028 (id key used), and simple scalars.
1036 sub _hash_selected {
1038 my $selected = $args->{value} || $args->{selected};
1039 return $selected unless $selected and ref $selected ne 'HASH';
1040 #warn "Selected dump : " . Dumper($selected);
1041 my $type = ref $selected;
1043 if ($type and $type ne 'ARRAY') {
1044 return {$selected->id => 1};
1048 return { $selected => 1};
1052 # Array of objs, arrays, hashes, or just scalalrs.
1053 elsif ($type eq 'ARRAY') {
1055 my $ltype = ref $selected->[0];
1057 if ($ltype and $ltype ne 'ARRAY') {
1058 %hashed = map { $_->id => 1 } @$selected;
1060 # Arrays of data with id first
1061 elsif ($ltype and $ltype eq 'ARRAY') {
1062 %hashed = map { $_->[0] => 1 } @$selected;
1064 # Hashes using pk or id key
1065 elsif ($ltype and $ltype eq 'HASH') {
1066 my $pk = $args->{class}->primary_column || 'id';
1067 %hashed = map { $_->{$pk} => 1 } @$selected;
1071 %hashed = map { $_ => 1 } @$selected;
1075 else { warn "AsForm Could not hash the selected argument: $selected"; }
1083 Internal api method to make the actual select box form elements.
1085 3 types of lists making for --
1087 Array of CDBI objects.
1089 Array or Array refs with cols from class,
1097 my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
1099 #$args->{stringify} ||= 'stringify_selectbox';
1100 $args->{selected} = _hash_selected($args) if defined $args->{selected};
1101 my $name = $args->{name} || $col;
1102 my $a = HTML::Element->new('select', name => $name);
1103 $a->attr( %{$args->{attr}} ) if $args->{attr};
1105 if ($args->{column_nullable}) {
1106 my $null_element = HTML::Element->new('option', value => '');
1107 $null_element->attr(selected => 'selected')
1108 if ($args->{selected}{'null'});
1109 $a->push_content($null_element);
1112 my $items = $args->{items};
1113 my $type = ref $items;
1114 my $proto = eval { ref $items->[0]; } || "";
1115 warn "Type is $type, proto is $proto\n";
1117 if ($type eq 'HASH') {
1118 $a->push_content($self->_options_from_hash($items, $args));
1121 elsif ( $type eq 'ARRAY' and not ref $items->[0] ) {
1122 $a->push_content($self->_options_from_array($items, $args));
1125 elsif( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) {
1126 # make select of objects
1127 $a->push_content($self->_options_from_objects($items, $args));
1130 elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) {
1131 $a->push_content($self->_options_from_arrays($items, $args));
1134 elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) {
1135 $a->push_content($self->_options_from_hashes($items, $args));
1138 die "You passed a weird type of data structure to me. Here it is: " .
1153 =head2 _options_from_objects ( $objects, $args);
1155 Private method to makes a options out of objects. It attempts to call each
1156 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
1159 sub _options_from_objects {
1160 my ($self, $items, $args) = @_;
1161 my $selected = $args->{selected} || {};
1162 my $stringify = $args->{stringify} || '';
1165 my $opt = HTML::Element->new("option", value => $_->id);
1166 $opt->attr(selected => "selected") if $selected->{$_->id};
1167 my $content = $stringify ? $_->stringify : "$_";
1168 $opt->push_content($content);
1174 sub _options_from_arrays {
1175 my ($self, $items, $args) = @_;
1176 my $selected = $args->{selected} || {};
1178 my $class = $args->{class} || '';
1179 my $stringify = $args->{stringify} || '';
1180 for my $item (@$items) {
1181 my @pks; # for future multiple key support
1182 push @pks, shift @$item foreach $class->columns('Primary');
1184 $id =~ ~ s/^0+//; # In case zerofill is on .
1185 my $opt = HTML::Element->new("option", value => $id );
1186 $opt->attr(selected => "selected") if $selected->{$id};
1188 my $content = ($class and $stringify and $class->can($stringify)) ?
1189 $class->$stringify($_) :
1190 join( '/', map { $_ if $_; }@{$item} );
1191 $opt->push_content( $content );
1198 sub _options_from_array {
1199 my ($self, $items, $args) = @_;
1200 my $selected = $args->{selected} || {};
1203 my $opt = HTML::Element->new("option", value => $_ );
1204 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1205 $opt->attr(selected => "selected") if $selected->{$_};
1206 $opt->push_content( $_ );
1212 sub _options_from_hash {
1213 my ($self, $items, $args) = @_;
1214 my $selected = $args->{selected} || {};
1217 my @values = values %$items;
1218 # hash Key is the option content and the hash value is option value
1219 for (sort keys %$items) {
1220 my $opt = HTML::Element->new("option", value => $items->{$_} );
1221 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1222 $opt->attr(selected => "selected") if $selected->{$items->{$_}};
1223 $opt->push_content( $_ );
1230 sub _options_from_hashes {
1231 my ($self, $items, $args) = @_;
1232 my $selected = $args->{selected} || {};
1233 my $pk = eval {$args->{class}->primary_column} || 'id';
1234 my $fclass = $args->{class} || '';
1235 my $stringify = $args->{stringify} || '';
1238 my $val = $_->{$pk};
1239 my $opt = HTML::Element->new("option", value => $val );
1240 $opt->attr(selected => "selected") if $selected->{$val};
1241 my $content = $fclass and $stringify and $fclass->can($stringify) ?
1242 $fclass->$stringify($_) :
1244 $opt->push_content( $content );
1250 sub _to_select_or_create {
1251 my ($self, $col, $args) = @_;
1252 $args->{name} ||= $col;
1253 my $select = $self->to_field($col, 'select', $args);
1254 $args->{name} = "create_" . $args->{name};
1255 my $create = $self->to_field($col, 'foreign_inputs', $args);
1256 $create->{'__select_or_create__'} =
1257 $self->to_field('__select_or_create__',{ name => '__select_or_create__' , value => 1 } );
1259 return ($select, $create);
1265 # checkboxes: if no data in hand (ie called as class method), replace
1266 # with a radio button, in order to allow this field to be left
1267 # unspecified in search / add forms.
1270 # TODO -- make this general checkboxse
1274 my ($self, $col, $args) = @_;
1275 my $nullable = eval {self->column_nullable($col)} || 0;
1277 return $self->_to_radio($col) if !ref($self) || $nullable;
1278 my $value = $self->$col;
1279 my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1280 $a->attr("checked" => 'true') if $value eq 'Y';
1285 # TODO -- make this general radio butons
1288 my ($self, $col) = @_;
1289 my $value = ref $self && $self->$col || '';
1290 my $nullable = eval {self->column_nullable($col)} || 0;
1291 my $a = HTML::Element->new("span");
1292 my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1293 my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1294 my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1295 $ry->push_content('Yes'); $rn->push_content('No');
1296 $ru->push_content('n/a') if $nullable;
1297 if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1298 elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1299 elsif ($nullable) { $ru->attr("checked" => 'true') }
1300 $a->push_content($ry, $rn);
1301 $a->push_content($ru) if $nullable;
1307 ############################ HELPER METHODS ######################
1308 ##################################################################
1310 =head2 _rename_foreign_input
1312 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1314 Recursively renames the foreign inputs made by _to_foreign_inputs so they
1315 can be processed generically. The format is "accessor__AsForeign_colname".
1317 So if an Employee is a Person who has_own Address and you call
1319 Employee->to_field("person")
1321 then you will get inputs for the Person as well as their Address (by default,
1322 override _field_from_relationship to change logic) named like this:
1324 person__AsForeign__address__AsForeign__street
1325 person__AsForeign__address__AsForeign__city
1326 person__AsForeign__address__AsForeign__state
1327 person__AsForeign__address__AsForeign__zip
1329 And the processor would know to create this address, put the address id in
1330 person->address data slot, create the person and put the person id in the employee->person data slot and then create the employee with that data.
1332 Overriede make_element_foreign to change how you want a foreign param labeled.
1334 =head2 make_element_foreign
1336 $class->make_element_foreign($accessor, $element);
1338 Makes an HTML::Element type object foreign elemen representing the
1339 class's accessor. (IE this in an input element for $class->accessor :) )
1343 sub make_element_foreign {
1344 my ($self, $accssr, $element) = @_;
1345 $element->attr( name => $accssr . "__AsForeign__" . $element->attr('name'));
1350 sub _rename_foreign_input {
1351 my ($self, $accssr, $element) = @_;
1352 if ( ref $element ne 'HASH' ) {
1353 # my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
1354 $self->make_element_foreign($accssr, $element);
1357 $self->_rename_foreign_input($accssr, $element->{$_})
1358 foreach (keys %$element);
1363 This functions computes the dimensions of a textarea based on the value
1368 our ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1373 my @rows = split /^/, $text;
1374 my $cols = $min_cols;
1377 my $len = length $_;
1379 $cols = $len if $len > $cols;
1380 $cols = $max_cols if $cols > $max_cols;
1383 $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1384 $rows = $min_rows if $rows < $min_rows;
1385 $rows = $max_rows if $rows > $max_rows;
1388 else { ($min_rows, $min_cols) }
1403 Peter Speltz, Aaron Trevena
1405 =head1 AUTHORS EMERITUS
1407 Simon Cozens, Tony Bowden
1413 chekbox generalization
1414 radio generalization
1416 Make link_hidden use standard make_url stuff when it gets in Maypole
1417 How do you tell AF --" I want a has_many select box for this every time so,
1418 when you call "to_field($this_hasmany)" you get a select box
1420 =head1 BUGS and QUERIES
1422 Please direct all correspondence regarding this module to:
1425 =head1 COPYRIGHT AND LICENSE
1427 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1429 This library is free software; you can redistribute it and/or modify
1430 it under the same terms as Perl itself.
1434 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.