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 make_element_foreign 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 _to_select_or_create
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;
235 if ( ref $columns[-1] eq 'HASH' ) { $args = pop @columns; }
237 map { $_ => $class->to_field($_, $args->{$_}) } @columns;
240 =head2 to_field($field [, $how][, $args])
242 This maps an individual column to a form element. The C<how> argument
243 can be used to force the field type into any you want. It tells AsForm how
244 to make the input ie-- forces it to use the method "_to_$how".
245 If C<how> is specified but the class cannot call the method it maps to,
246 then AsForm will issue a warning and the default input will be made.
247 You can write your own "_to_$how" methods and AsForm comes with many.
248 See C<HOW Methods>. You can also pass this argument in $args->{how}.
254 my ($self, $field, $how, $args) = @_;
255 if (ref $how) { $args = $how; $how = ''; }
256 unless ($how) { $how = $args->{how} || ''; }
257 #warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n";
259 #if (ref $field) { $args = $field; $field = '' }
262 #warn "args to_field are $field, . " . Dumper($how) . " , " . Dumper($args);
265 return $self->_field_from_how($field, $how, $args) ||
266 $self->_field_from_relationship($field, $args) ||
267 $self->_field_from_column($field, $args) ||
268 $self->_to_textfield($field, $args);
273 my $cgi = $class->search_inputs ([$args]); # optional $args
275 Returns hash or hashref of search inputs elements for a class making sure the
276 inputs are empty of any initial values.
277 You can specify what columns you want inputs for in
279 by the method "search_columns". The default is "display_columns".
280 If you want to te search on columns in related classes you can do that by
281 specifying a one element hashref in place of the column name where
282 the key is the related "column" (has_a or has_many method for example) and
283 the value is a list ref of columns to search on in the related class.
286 sub BeerDB::Beer::search_columns {
287 return ( 'name' , 'rating', { brewery => [ 'name', 'location'] } );
290 # Now foreign inputs are made for Brewery name and location and the
291 # there will be no name clashing and processing can be automated.
297 my ($class, $args) = @_;
298 $class = ref $class || $class;
299 #my $accssr_class = { $class->accessor_classes };
302 $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns];
304 foreach my $field ( @{ $args->{columns} } ) {
306 no_hidden_constraints => 1,
307 column_nullable => 1, # empty option on select boxes
310 if ( ref $field eq "HASH" ) { # foreign search fields
311 my ($accssr, $cols) = each %$field;
312 $base_args->{columns} = $cols;
314 # default to search fields for related
315 #$cols = $accssr_class->{$accssr}->search_columns;
316 die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
318 my $fcgi = $class->to_field($accssr, 'foreign_inputs', $base_args);
320 # unset the default values for a select box
321 foreach (keys %$fcgi) {
322 my $el = $fcgi->{$_};
323 if ($el->tag eq 'select') {
325 $class->unselect_element($el);
326 my ($first, @content) = $el->content_list;
327 my @fc = $first->content_list;
328 my $val = $first ? $first->attr('value') : undef;
329 if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or
331 #(defined $first->attr('value') or $first->attr('value') ne ''))
332 # push an empty option on stactk
333 $el->unshift_content(HTML::Element->new('option'));
338 $cgi{$accssr} = $fcgi;
339 delete $base_args->{columns};
342 $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} });
343 my $el = $cgi{$field};
344 if ($el->tag eq 'select') {
345 $class->unselect_element($el);
346 my ($first, @content) = $el->content_list;
347 if ($first and $first->content_list) { # something
348 #(defined $first->attr('value') or $first->attr('value') ne ''))
349 # push an empty option on stactk
350 $el->unshift_content(HTML::Element->new('option'));
361 =head2 unselect_element
363 unselect any selected elements in a HTML::Element select list widget
366 sub unselect_element {
367 my ($self, $el) = @_;
368 #unless (ref $el eq 'HTML::Element') {
369 #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
370 if ($el->tag eq 'select') {
371 foreach my $opt ($el->content_list) {
372 $opt->attr('selected', undef) if $opt->attr('selected');
377 =head2 _field_from_how($field, $how,$args)
379 Returns an input element based the "how" parameter or nothing at all.
384 sub _field_from_how {
385 my ($self, $field, $how, $args) = @_;
386 #if (ref $how) { $args = $how; $how = undef; }
387 #warn "In filed from how . filed is $field how is $how. args ar e" . Dumper($args) . " \n";
391 my $meth = "_to_$how";
392 if (not $self->can($meth)) {
393 warn "Class can not $meth";
396 return $self->$meth($field, $args);
400 =head2 _field_from_relationship($field, $args)
402 Returns an input based on the relationship associated with the field or nothing.
405 For has_a it will give select box
409 sub _field_from_relationship {
410 my ($self, $field, $args) = @_;
411 #warn "In filed from rel . filed is $field \n";
412 return unless $field;
413 my $rel_meta = $self->related_meta('r',$field) || return;
414 my $rel_name = $rel_meta->{name};
415 #my $meta = $self->meta_info;
416 #grep{ defined $meta->{$_}{$field} } keys %$meta;
417 my $fclass = $rel_meta->foreign_class;
418 my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
421 #warn "Dumper of relmeta. " . Dumper($rel_meta);
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 $args->{items} = $self->$field;
438 return $self->_to_select($field, $args);
445 #NOOO! maybe select from has_many
446 # if ($rel_type eq 'has_many' and ref $self) {
447 # $args->{items} ||= [$self->$field];
448 # # arg name || fclass pk name || field
449 # if (not $args->{name}) {
450 # $args->{name} = eval{$fclass->primary_column->name} || $field;
452 # return $self->_to_select($field, $args);
455 # maybe foreign inputs
456 my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
457 if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_name eq 'has_own'))
459 $args->{related_meta} = $rel_meta; # suspect faster to set these args
460 return $self->_to_foreign_inputs($field, $args);
465 =head2 _field_from_column($field, $args)
467 Returns an input based on the column's characteristics, namely type, or nothing.
472 sub _field_from_column {
473 my ($self, $field, $args) = @_;
474 return unless $field;
475 my $class = ref $self || $self;
476 #warn "Class is $class\n";
478 unless ($args->{column_type}) {
479 $args->{column_type} = $class->column_type($field);
480 if ($class->can('column_type')) {
481 $args->{column_type} = $class->column_type($field);
484 # Right, have some of this
485 eval "package $class; Class::DBI::Plugin::Type->import()";
486 $args->{column_type} = $class->column_type($field);
489 my $type = $args->{column_type};
491 return $self->_to_textfield($field, $args)
492 if $type and $type =~ /(VAR)?CHAR/i; #common type
493 return $self->_to_textarea($field, $args)
494 if $type and $type =~ /^(TEXT|BLOB)$/i;
495 return $self->_to_enum_select($field, $args)
496 if $type and $type =~ /^ENUM\((.*?)\)$/i;
497 return $self->_to_bool_select($field, $args)
498 if $type and $type =~ /^BOOL/i;
499 return $self->_to_readonly($field, $args)
500 if $type and $type =~ /^readonly$/i;
506 my ($self, $col, $args) = @_;
509 my $val = $args->{value};
511 unless (defined $val) {
516 $val = eval {$self->column_default($col);};
517 $val = '' unless defined $val;
520 my ($rows, $cols) = _box($val);
521 $rows = $args->{rows} if $args->{rows};
522 $cols = $args->{cols} if $args->{cols};;
523 my $name = $args->{name} || $col;
525 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
526 $a->push_content($val);
527 $OLD_STYLE && return $a->as_HTML;
532 my ($self, $col, $args ) = @_;
534 my $val = $args->{value};
535 my $name = $args->{name} || $col;
537 unless (defined $val) {
539 # Case where column inflates.
540 # Input would get stringification which could be not good.
541 # as in the case of Time::Piece objects
542 $val = $self->can($col) ? $self->$col : ''; # in case it is a virtual column
544 if (my $meta = $self->related_meta('',$col)) {
545 #warn "Meta for $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 #warn "No meta for $col but ref $val.\n";
559 $val = $val->id if $val->isa("Class::DBI");
565 $val = eval {$self->column_default($col);};
566 $val = '' unless defined $val;
569 my $a = HTML::Element->new("input", type => "text", name => $name, value =>
572 $OLD_STYLE && return $a->as_HTML;
577 # Too expensive version -- TODO
579 # my ($self, $col, $hint) = @_;
580 # my $fclass = $hint || $self->__hasa_rels->{$col}->[0];
581 # my @objs = $fclass->retrieve_all;
582 # my $a = HTML::Element->new("select", name => $col);
584 # my $sel = HTML::Element->new("option", value => $_->id);
585 # $sel->attr("selected" => "selected")
587 # and eval { $_->id eq $self->$col->id };
588 # $sel->push_content($_->stringify_self);
589 # $a->push_content($sel);
591 # $OLD_STYLE && return $a->as_HTML;
598 # -- Rewrote this to be efficient -- no object creation.
599 # -- Added option for CDBI classes to specify a limiting clause
600 # via "has_a_select_limit".
601 # -- Added selected argument to set a selected
603 =head2 recognized arguments
605 selected => $object|$id,
608 where => SQL 'WHERE' clause,
609 order_by => SQL 'ORDER BY' clause,
610 limit => SQL 'LIMIT' clause,
611 items => [ @items_of_same_type_to_select_from ],
612 class => $class_we_are_selecting_from
613 stringify => $stringify_coderef|$method_name
618 # select box requirements
619 # 1. a select box for objecs of a has_a related class -- DONE
620 =head2 1. a select box out of a has_a or has_many related class.
621 # For has_a the default behavior is to make a select box of every element in
622 # related class and you choose one.
623 #Or explicitly you can create one and pass options like where and order
624 BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
626 # For has_many the default is to get a multiple select box with all objects.
627 # If called as an object method, the objects existing ones will be selected.
628 Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"});
631 =head2 2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun.
633 BeerDB::Beer->to_field('', 'select', $options)
635 BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
636 # with PK as ID, $Class->to_field() same.
637 BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
638 # specify exact where clause
640 =head2 3. If you already have a list of objects to select from --
642 BeerDB:;Beer->to_field($col, 'select' , {items => $objects});
644 # 3. a select box for arbitrary set of objects
645 # Pass array ref of objects as first arg rather than field
646 $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
652 my ($self, $col, $args) = @_;
654 # Do we have items already ? Go no further.
655 if ($args->{items} and ref $args->{items}) {
656 my $a = $self->_select_guts($col, $args);
657 $OLD_STYLE && return $a->as_HTML;
658 if ($args->{multiple}) { $a->attr('multiple', 'multiple');}
662 # Else what are we making a select box out of ?
663 # No Column parameter -- means making a select box of args->class or self
664 # Using all rows from class's table
666 unless ($args->{class}) {
667 $args->{class} = ref $self || $self;
668 # object selected if called with one
669 $args->{selected} = { $self->id => 1}
670 if not $args->{selected} and ref $self;
672 $col = $args->{class}->primary_column;
674 # Related Class maybe ?
675 elsif (my $rel_meta = $self->related_meta('r:)', $col) ) {
676 $args->{class} = $rel_meta->{foreign_class};
677 # related objects pre selected if object
679 # "Has many" -- Issues:
680 # 1) want to select one from list if self is an object
681 # Thats about all we can do really,
682 # 2) except for mapping which is TODO and would
683 # do something like add to and take away from list of permissions for
686 # Hasmany select one from list if ref self
687 if ($rel_meta->{name} =~ /has_many/i and ref $self) {
688 $args->{items} = [ $self->$col ];
689 my $a = $self->_select_guts($col, $args);
690 $OLD_STYLE && return $a->as_HTML;
694 $args->{selected} ||= [ $self->$col ] if ref $self;
695 #warn "selected is " . Dumper($args->{selected});
696 my $c = $rel_meta->{args}{constraint} || {};
697 my $j = $rel_meta->{args}{join} || {};
700 @join = map { $_ ." = ". $self->_attr($_) } keys %$j;
702 my @constr= map { "$_ = '$c->{$_}'"} keys %$c;
703 $args->{where} ||= join (' AND ', (@join, @constr));
704 $args->{order_by} ||= $rel_meta->{args}{order_by};
705 $args->{limit} ||= $rel_meta->{args}{limit};
709 # We could say :Col is name and we are selecting out of class arg.
712 #$args->{name} = $col;
713 die "Usage _to_select. $col not related to any class to select from. ";
718 unless ( defined $args->{column_nullable} ) {
719 $args->{column_nullable} = $self->can('column_nullable') ?
720 $self->column_nullable($col) : 1;
723 # Get items to select from
724 $args->{items} = _select_items($args);
725 #warn "Items selecting from are " . Dumper($args->{items});
727 #warn "Just got items. They are " . Dumper($args->{items});
729 # Make select HTML element
730 $a = $self->_select_guts($col, $args);
732 if ($args->{multiple}) {$a->attr('multiple', 'multiple');}
735 $OLD_STYLE && return $a->as_HTML;
744 # returns the intersection of list refs a and b
745 sub _list_intersect {
747 my %isect; my %union;
748 foreach my $e (@$a, @$b) { $union{$e}++ && $isect{$e}++ }
757 my $fclass = $args->{class};
758 my @disp_cols = @{$args->{columns} || []};
759 @disp_cols = $fclass->columns('SelectBox') unless @disp_cols;
760 @disp_cols = $fclass->columns('Stringify')unless @disp_cols;
761 @disp_cols = $fclass->_essential unless @disp_cols;
762 unshift @disp_cols, $fclass->columns('Primary');
763 #my %isect = _list_intersect(\@pks, \@disp_cols);
764 #foreach (@pks) { push @sel_cols, $_ unless $isect{$_}; }
765 #push @sel_cols, @disp_cols;
767 #warn "in select items. args are : " . Dumper($args);
769 if ($args->{'distinct'}) {
770 $distinct = 'DISTINCT ';
773 my $sql = "SELECT $distinct" . join( ', ', @disp_cols) .
774 " FROM " . $fclass->table;
776 $sql .= " WHERE " . $args->{where} if $args->{where};
777 $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
778 $sql .= " LIMIT " . $args->{limit} if $args->{limit};
779 #warn "_select_items sql is : $sql";
781 return $fclass->db_Main->selectall_arrayref($sql);
786 # Makes a readonly input box out of column's value
787 # No args makes object to readonly
789 my ($self, $col, $val) = @_;
790 if (! $col) { # object to readonly
792 $col = $self->primary_column;
794 unless (defined $val) {
795 $self->_croak("Cannot get value in _to_readonly .")
799 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
800 'name' => $col, 'value'=>$val);
801 $OLD_STYLE && return $a->as_HTML;
806 =head2 _to_enum_select
808 $sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");
810 Returns an enum select box given a column name and an enum string.
811 NOTE: The Plugin::Type does not return an enum string for mysql enum columns.
812 This will not work unless you write your own column_type method in your model.
816 sub _to_enum_select {
817 my ($self, $col, $args) = @_;
818 my $type = $args->{column_type};
819 $type =~ /ENUM\((.*?)\)/i;
820 (my $enum = $1) =~ s/'//g;
821 my @enum_vals = split /\s*,\s*/, $enum;
823 # determine which is pre selected --
824 # if obj, the value is , otherwise use column_default which is the first
825 # value in the enum list unless it has been overridden
826 my $selected = eval { $self->$col };
827 $selected = eval{$self->column_default($col)} unless defined $selected;
828 $selected = $enum_vals[0] unless defined $selected;
830 my $a = HTML::Element->new("select", name => $col);
832 my $sel = HTML::Element->new("option", value => $_);
833 $sel->attr("selected" => "selected") if $_ eq $selected ;
834 $sel->push_content($_);
835 $a->push_content($sel);
837 $OLD_STYLE && return $a->as_HTML;
842 =head2 _to_bool_select
844 my $sel = $self->_to_bool_select($column, $bool_string);
846 This makes select input for boolean column. You can provide a
847 bool string of form: Bool('zero','one') and those are used for option
848 content. Onthervise No and Yes are used.
849 TODO -- test without bool string.
853 # TCODO fix this mess with args
854 sub _to_bool_select {
855 my ($self, $col, $args) = @_;
856 #warn "In to_bool select\n";
857 my $type = $args->{column_type};
858 my @bool_text = ('No', 'Yes');
859 if ($type =~ /BOOL\((.+?)\)/i) {
860 (my $bool = $1) =~ s/'//g;
861 @bool_text = split /,/, $bool;
866 my $selected = $args->{value} if defined $args->{value};
867 $selected = $args->{selected} unless defined $selected;
868 $selected = ref $self ? eval {$self->$col;} : $self->column_default($col)
869 unless (defined $selected);
871 my $a = HTML::Element->new("select", name => $col);
872 if ($args->{column_nullable} || $args->{value} eq '') {
873 my $null = HTML::Element->new("option");
874 $null->attr('selected', 'selected') if $args->{value} eq '';
875 $a->push_content( $null );
878 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
879 HTML::Element->new("option", value => 1) );
880 $opt0->push_content($bool_text[0]);
881 $opt1->push_content($bool_text[1]);
882 unless ($selected eq '') {
883 $opt0->attr("selected" => "selected") if not $selected;
884 $opt1->attr("selected" => "selected") if $selected;
886 $a->push_content($opt0, $opt1);
887 $OLD_STYLE && return $a->as_HTML;
892 =head2 _to_hidden($col, $args)
894 This makes a hidden html element. Give it a name and value or if name is
895 a ref it will use the PK name and value of the object.
900 my ($self, $name, $val) = @_;
903 if (ref $name and $name->isa("Class::DBI")) {
905 $name= ($obj->primary_columns)[0]->name;
909 $val = $args->{value};
910 $name = $args->{name} if $args->{name};
912 elsif (not $name ) { # hidding object caller
913 $self->_croak("No object available in _to_hidden") unless ref $self;
914 $name = ($self->primary_column)[0]->name;
917 return HTML::Element->new('input', 'type' => 'hidden',
918 'name' => $name, 'value'=>$val
922 =head2 _to_link_hidden($col, $args)
924 Makes a link with a hidden input with the id of $obj as the value and name.
925 Name defaults to the objects primary key. The object defaults to self.
929 sub _to_link_hidden {
930 my ($self, $accessor, $args) = @_;
931 my $r = eval {$self->controller} || $args->{r} || '';
932 my $uri = $args->{uri} || '';
934 $self->_croak("_to_link_hidden cant get uri. No Maypole Request class (\$r) or uri arg. Need one or other.")
937 if (ref $self) { # hidding linking self
939 $name = $args->{name} || $obj->primary_column->name;
941 elsif ($obj = $args->{items}->[0]) {
942 $name = $args->{name} || $accessor || $obj->primary_column->name;
943 # TODO use meta data above maybe
945 else { # hiding linking related object with id in args
946 $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
947 $name = $args->{name} || $accessor ; #$obj->primary_column->name;
948 # TODO use meta data above maybe
950 $self->_croak("_to_link_hidden has no object") unless ref $obj;
951 my $href = $uri || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
952 my $a = HTML::Element->new('a', 'href' => $href);
953 $a->push_content("$obj");
954 $a->push_content($self->_to_hidden($name, $obj->id));
955 $OLD_STYLE && return $a->as_HTML;
959 =head2 _to_foreign_inputs
961 $html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]);
963 Get inputs for the accessor's class. Pass an array ref of fields to get
964 inputs for only those fields. Otherwise display_columns or all columns is used.
965 If you have the meta info handy for the accessor you can pass that too.
967 TODO make AsForm know more about the request like what action we are doing
968 so it can use edit columns or search_columns
970 NOTE , this names the foreign inputs is a particular way so they can be
971 processed with a general routine and so there are not name clashes.
974 related_meta -- if you have this, great, othervise it will determine or die
975 columns -- list of columns to make inputs for
979 sub _to_foreign_inputs {
980 my ($self, $accssr, $args) = @_;
981 my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr);
982 my $fields = $args->{columns};
984 $self->_croak( "No relationship for accessor $accssr");
987 my $rel_type = $rel_meta->{name};
988 my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_meta->{foreign_class};
991 $fields = $classORobj->can('display_columns') ?
992 [$classORobj->display_columns] : [$classORobj->columns];
995 # Ignore our fkey in them to prevent infinite recursion
996 my $me = eval {$rel_meta->{args}{foreign_column}} || '';
997 my $constrained = $rel_meta->{args}{constraint};
999 foreach ( @$fields ) {
1000 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
1001 $inputs{$_} = $classORobj->to_field($_);
1004 # Make hidden inputs for constrained columns unless we are editing object
1005 # TODO -- is this right thing to do?
1006 unless (ref $classORobj || $args->{no_hidden_constraints}) {
1007 $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_})
1008 foreach ( keys %$constrained );
1010 $self->_rename_foreign_input($accssr, \%inputs);
1015 =head2 _hash_selected
1017 Method to make sense out of the "selected" argument which can be in a number
1018 of formats perhaps. It returns a hashref with the the values of options to be
1021 Below handles these formats for the "selected" slot in the arguments hash:
1022 Object (with id method)
1023 Scalar (assumes it is value)
1024 Array ref *OF* objects, arrays of data (0 elmnt used), hashes of data
1025 (id key used), and simple scalars.
1033 sub _hash_selected {
1035 my $selected = $args->{value} || $args->{selected};
1036 return $selected unless $selected and ref $selected ne 'HASH';
1037 #warn "Selected dump : " . Dumper($selected);
1038 my $type = ref $selected;
1040 if ($type and $type ne 'ARRAY') {
1041 return {$selected->id => 1};
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';
1097 $args->{selected} = _hash_selected($args) if defined $args->{selected};
1098 my $name = $args->{name} || $col;
1099 my $a = HTML::Element->new('select', name => $name);
1100 $a->attr( %{$args->{attr}} ) if $args->{attr};
1102 if ($args->{column_nullable}) {
1103 my $null_element = HTML::Element->new('option', value => '');
1104 $null_element->attr(selected => 'selected')
1105 if ($args->{selected}{'null'});
1106 $a->push_content($null_element);
1109 my $items = $args->{items};
1110 my $type = ref $items;
1111 my $proto = eval { ref $items->[0]; } || "";
1112 my $optgroups = $args->{optgroups} || '';
1114 # Array of hashes, one for each optgroup
1117 foreach (@$optgroups) {
1118 my $ogrp= HTML::Element->new('optgroup', label => $_);
1119 $ogrp->push_content($self->_options_from_hash($items->[$i], $args));
1120 $a->push_content($ogrp);
1125 elsif ($type eq 'HASH') {
1126 $a->push_content($self->_options_from_hash($items, $args));
1129 elsif ( $type eq 'ARRAY' and not ref $items->[0] ) {
1130 $a->push_content($self->_options_from_array($items, $args));
1133 elsif( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) {
1134 # make select of objects
1135 $a->push_content($self->_options_from_objects($items, $args));
1138 elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) {
1139 $a->push_content($self->_options_from_arrays($items, $args));
1142 elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) {
1143 $a->push_content($self->_options_from_hashes($items, $args));
1146 die "You passed a weird type of data structure to me. Here it is: " .
1155 =head2 _options_from_objects ( $objects, $args);
1157 Private method to makes a options out of objects. It attempts to call each
1158 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
1161 sub _options_from_objects {
1162 my ($self, $items, $args) = @_;
1163 my $selected = $args->{selected} || {};
1164 my $stringify = $args->{stringify} || '';
1167 my $opt = HTML::Element->new("option", value => $_->id);
1168 $opt->attr(selected => "selected") if $selected->{$_->id};
1169 my $content = $stringify ? $_->stringify : "$_";
1170 $opt->push_content($content);
1176 sub _options_from_arrays {
1177 my ($self, $items, $args) = @_;
1178 my $selected = $args->{selected} || {};
1180 my $class = $args->{class} || '';
1181 my $stringify = $args->{stringify} || '';
1182 for my $item (@$items) {
1183 my @pks; # for future multiple key support
1184 push @pks, shift @$item foreach $class->columns('Primary');
1186 $id =~ ~ s/^0+//; # In case zerofill is on .
1187 my $opt = HTML::Element->new("option", value => $id );
1188 $opt->attr(selected => "selected") if $selected->{$id};
1190 my $content = ($class and $stringify and $class->can($stringify)) ?
1191 $class->$stringify($_) :
1192 join( '/', map { $_ if $_; }@{$item} );
1193 $opt->push_content( $content );
1200 sub _options_from_array {
1201 my ($self, $items, $args) = @_;
1202 my $selected = $args->{selected} || {};
1205 my $opt = HTML::Element->new("option", value => $_ );
1206 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1207 $opt->attr(selected => "selected") if $selected->{$_};
1208 $opt->push_content( $_ );
1214 sub _options_from_hash {
1215 my ($self, $items, $args) = @_;
1216 my $selected = $args->{selected} || {};
1219 my @values = values %$items;
1220 # hash Key is the option content and the hash value is option value
1221 for (sort keys %$items) {
1222 my $opt = HTML::Element->new("option", value => $items->{$_} );
1223 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1224 $opt->attr(selected => "selected") if $selected->{$items->{$_}};
1225 $opt->push_content( $_ );
1232 sub _options_from_hashes {
1233 my ($self, $items, $args) = @_;
1234 my $selected = $args->{selected} || {};
1235 my $pk = eval {$args->{class}->primary_column} || 'id';
1236 my $fclass = $args->{class} || '';
1237 my $stringify = $args->{stringify} || '';
1240 my $val = $_->{$pk};
1241 my $opt = HTML::Element->new("option", value => $val );
1242 $opt->attr(selected => "selected") if $selected->{$val};
1243 my $content = ($fclass and $stringify and $fclass->can($stringify)) ?
1244 $fclass->$stringify($_) :
1246 $opt->push_content( $content );
1252 sub _to_select_or_create {
1253 my ($self, $col, $args) = @_;
1254 $args->{name} ||= $col;
1255 my $select = $self->to_field($col, 'select', $args);
1256 $args->{name} = "create_" . $args->{name};
1257 my $create = $self->to_field($col, 'foreign_inputs', $args);
1258 $create->{'__select_or_create__'} =
1259 $self->to_field('__select_or_create__',{ name => '__select_or_create__' , value => 1 } );
1260 return ($select, $create);
1264 # checkboxes: if no data in hand (ie called as class method), replace
1265 # with a radio button, in order to allow this field to be left
1266 # unspecified in search / add forms.
1269 # TODO -- make this general checkboxse
1273 my ($self, $col, $args) = @_;
1274 my $nullable = eval {self->column_nullable($col)} || 0;
1275 return $self->_to_radio($col) if !ref($self) || $nullable;
1276 my $value = $self->$col;
1277 my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1278 $a->attr("checked" => 'true') if $value eq 'Y';
1283 # TODO -- make this general radio butons
1286 my ($self, $col) = @_;
1287 my $value = ref $self && $self->$col || '';
1288 my $nullable = eval {self->column_nullable($col)} || 0;
1289 my $a = HTML::Element->new("span");
1290 my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1291 my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1292 my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1293 $ry->push_content('Yes'); $rn->push_content('No');
1294 $ru->push_content('n/a') if $nullable;
1295 if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1296 elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1297 elsif ($nullable) { $ru->attr("checked" => 'true') }
1298 $a->push_content($ry, $rn);
1299 $a->push_content($ru) if $nullable;
1305 ############################ HELPER METHODS ######################
1306 ##################################################################
1308 =head2 _rename_foreign_input
1310 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1312 Recursively renames the foreign inputs made by _to_foreign_inputs so they
1313 can be processed generically. The format is "accessor__AsForeign_colname".
1315 So if an Employee is a Person who has_own Address and you call
1317 Employee->to_field("person")
1319 then you will get inputs for the Person as well as their Address (by default,
1320 override _field_from_relationship to change logic) named like this:
1322 person__AsForeign__address__AsForeign__street
1323 person__AsForeign__address__AsForeign__city
1324 person__AsForeign__address__AsForeign__state
1325 person__AsForeign__address__AsForeign__zip
1327 And the processor would know to create this address, put the address id in
1328 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.
1330 Overriede make_element_foreign to change how you want a foreign param labeled.
1332 =head2 make_element_foreign
1334 $class->make_element_foreign($accessor, $element);
1336 Makes an HTML::Element type object foreign elemen representing the
1337 class's accessor. (IE this in an input element for $class->accessor :) )
1341 sub make_element_foreign {
1342 my ($self, $accssr, $element) = @_;
1343 $element->attr( name => $accssr . "__AsForeign__" . $element->attr('name'));
1348 sub _rename_foreign_input {
1349 my ($self, $accssr, $element) = @_;
1350 if ( ref $element ne 'HASH' ) {
1351 # my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
1352 $self->make_element_foreign($accssr, $element);
1355 $self->_rename_foreign_input($accssr, $element->{$_})
1356 foreach (keys %$element);
1361 This functions computes the dimensions of a textarea based on the value
1366 our ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1371 my @rows = split /^/, $text;
1372 my $cols = $min_cols;
1375 my $len = length $_;
1377 $cols = $len if $len > $cols;
1378 $cols = $max_cols if $cols > $max_cols;
1381 $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1382 $rows = $min_rows if $rows < $min_rows;
1383 $rows = $max_rows if $rows > $max_rows;
1386 else { ($min_rows, $min_cols) }
1401 Peter Speltz, Aaron Trevena
1403 =head1 AUTHORS EMERITUS
1405 Simon Cozens, Tony Bowden
1411 chekbox generalization
1412 radio generalization
1414 Make link_hidden use standard make_url stuff when it gets in Maypole
1415 How do you tell AF --" I want a has_many select box for this every time so,
1416 when you call "to_field($this_hasmany)" you get a select box
1418 =head1 BUGS and QUERIES
1420 Please direct all correspondence regarding this module to:
1423 =head1 COPYRIGHT AND LICENSE
1425 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1427 This library is free software; you can redistribute it and/or modify
1428 it under the same terms as Perl itself.
1432 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.