1 package Maypole::Model::CDBI::AsForm;
6 # has_many select -- $obj->to_field($has_many_col); # select one form many
7 # -- $class->to_field($has_many_col); # foreign inputs
8 # $class->search_inputs; /
16 use Class::DBI::Plugin::Type ();
21 # pjs -- Added new methods to @EXPORT
24 to_cgi to_field foreign_input_delimiter search_inputs unselect_element
25 _field_from_how _field_from_relationship _field_from_column
26 _to_textarea _to_textfield _to_select _select_guts
27 _to_foreign_inputs _to_enum_select _to_bool_select
28 _to_hidden _to_link_hidden _rename_foreign_input _to_readonly
29 _options_from_objects _options_from_arrays _options_from_hashes
30 _options_from_array _options_from_hash
37 Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns
42 use Maypole::Model::CDBI::AsForm;
43 use base 'Class::DBI';
49 my %cgi_field = $self->to_cgi;
51 (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
56 # Example of has_many select
58 __PACKAGE__->has_a('job_employer' => 'Employer');
59 __PACKAGE__->has_a('contact' => 'Contact')
62 __PACKAGE__->has_a('cont_employer' => 'Employer');
63 __PACKAGE__->has_many('jobs' => 'Job',
64 { join => { job_employer => 'cont_employer' },
65 constraint => { 'finshed' => 0 },
66 order_by => "created ASC",
71 __PACKAGE__->has_many('jobs' => 'Job',);
72 __PACKAGE__->has_many('contacts' => 'Contact',
73 order_by => 'name DESC',
77 # Choose some jobs to add to a contact (has multiple attribute).
78 my $job_sel = Contact->to_field('jobs'); # Uses constraint and order by
81 # Choose a job from $contact->jobs
82 my $job_sel = $contact->to_field('jobs');
88 This module helps to generate HTML forms for creating new database rows
89 or editing existing rows. It maps column names in a database table to
90 HTML form elements which fit the schema. Large text fields are turned
91 into textareas, and fields with a has-a relationship to other
92 C<Class::DBI> tables are turned into select drop-downs populated with
93 objects from the joined class.
98 This provides a convenient way to tweak AsForm's behavior in exceptional or
99 not so exceptional instances. Below describes the arguments hash and
103 $beer->to_field($col, $how, $args);
104 $beer->to_field($col, $args);
106 Not all _to_* methods pay attention to all arguments. For example, '_to_textfield' does not look in $args->{'items'} at all.
110 =item name -- the name the element will have , this trumps the derived name.
112 $beer->to_field('brewery', 'readonly', {
116 =item value -- the initial value the element will have, trumps derived value
118 $beer->to_field('brewery', 'textfield', {
119 name => 'brewery_id', value => $beer->brewery,
120 # however, no need to set value since $beer is object
123 =item items -- array of items generally used to make select box options
125 Can be array of objects, hashes, arrays, or strings, or just a hash.
128 $beer->to_field(rating => select => {
129 items => [1 , 2, 3, 4, 5],
132 # Select a Brewery to visit in the UK
133 Brewery->to_field(brewery_id => {
134 items => [ Brewery->search_like(location => 'UK') ],
137 # Make a select for a boolean field
138 $Pub->to_field('open' , { items => [ {'Open' => 1, 'Closed' => 0 } ] });
140 =item selected -- something representing which item is selected in a select box
142 $beer->to_field('brewery', {
143 selected => $beer->brewery, # again not necessary since caller is obj.
146 Can be an simple scalar id, an object, or an array of either
148 =item class -- the class for which the input being made for field pertains to.
150 This in almost always derived in cases where it may be difficult to derive, --
151 # Select beers to serve on handpump
152 Pub->to_field(handpumps => select => {
153 class => 'Beer', order_by => 'name ASC', multiple => 1,
156 =item column_type -- a string representing column type
158 $pub->to_field('open', 'bool_select', {
159 column_type => "bool('Closed', 'Open'),
162 =item column_nullable -- flag saying if column is nullable or not
164 Generally this can be set to get or not get a null/empty option added to
165 a select box. AsForm attempts to call "$class->column_nullable" to set this
166 and it defaults to true if there is no shuch method.
168 $beer->to_field('brewery', { column_nullable => 1 });
170 =item r or request -- the Mapyole request object
172 =item uri -- uri for a link , used in methods such as _to_link_hidden
174 $beer->to_field('brewery', 'link_hidden',
175 {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery});
176 # an html link that is also a hidden input to the object. R is required to
177 # make the uri unless you pass a uri
179 =item order_by, constraint, join
181 These are used in making select boxes. order_by is a simple order by clause
182 and constraint and join are hashes used to limit the rows selected. The
183 difference is that join uses methods of the object and constraint uses
184 static values. You can also specify these in the relationship definitions.
185 See the relationships documentation of how to set arbitrayr meta info.
187 BeerDB::LondonBeer->has_a('brewery', 'BeerDB::Brewery',
188 order_by => 'brewery_name ASC',
189 constraint => {location => 'London'},
190 'join' => {'brewery_tablecolumn => 'beer_obj_column'},
193 =item no_hidden_constraints --
195 Tell AsForm not to make hidden inputs for relationship constraints. It does
196 this sometimes when making foreign inputs. However, i think it should not
197 do this and that the FromCGI 's _create_related method should do it.
203 $self->to_cgi([@columns, $args]);
205 This returns a hash mapping all the column names to HTML::Element objects
206 representing form widgets. It takes two opitonal arguments -- a list of
207 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.
209 $self->to_cgi(); # uses $self->columns; # most used
210 $self->to_cgi(qw/brewery style rating/); # sometimes
211 # and on rare occassions this is desireable if you have a lot of fields
212 # and dont want to call to_field a bunch of times just to tweak one or
214 $self->to_cgi(@cols, {brewery => {
215 how => 'textfield' # too big for select
218 column_nullable => 0,
220 items => ['Ale', 'Lager']
227 my ($class, @columns) = @_; # pjs -- added columns arg
230 @columns = $class->columns;
231 # Eventually after stabalization, we could add display_columns
232 #keys map { $_ => 1 } ($class->display_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. All that you need
244 is a method named "_to_$how" in your class. Your class inherits many from
245 AsForm already. Override them at will.
247 If C<how> is specified but the class cannot call the method it maps to,
248 then AsForm will issue a warning and the default input will be made.
249 You can write your own "_to_$how" methods and AsForm comes with many.
250 See C<HOW Methods>. You can also pass this argument in $args->{how}.
256 my ($self, $field, $how, $args) = @_;
257 if (ref $how) { $args = $how; $how = ''; }
258 unless ($how) { $how = $args->{how} || ''; }
259 #warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n";
260 # Set sensible default value
261 unless ($args->{default}) {
262 my $def = $self->column_default($field);
263 # exclude defaults we don't want actually put as value for input
265 $def = $def =~ /(^0000-00-00.*$|^0[0]*$|^0\.00$|CURRENT_TIMESTAMP|NULL)/i ? '' : $def ;
266 $args->{default} = $def;
272 return $self->_field_from_how($field, $how, $args) ||
273 $self->_field_from_relationship($field, $args) ||
274 $self->_field_from_column($field, $args) ||
275 $self->_to_textfield($field, $args);
281 my $cgi = $class->search_inputs ([$args]); # optional $args
283 Returns hash or hashref of search inputs elements for a class making sure the
284 inputs are empty of any initial values.
285 You can specify what columns you want inputs for in
287 by the method "search_columns". The default is "display_columns".
288 If you want to te search on columns in related classes you can do that by
289 specifying a one element hashref in place of the column name where
290 the key is the related "column" (has_a or has_many method for example) and
291 the value is a list ref of columns to search on in the related class.
294 sub BeerDB::Beer::search_columns {
295 return ( 'name' , 'rating', { brewery => [ 'name', 'location'] } );
298 # Now foreign inputs are made for Brewery name and location and the
299 # there will be no name clashing and processing can be automated.
305 my ($class, $args) = @_;
306 $class = ref $class || $class;
307 #my $accssr_class = { $class->accessor_classes };
310 $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns];
312 foreach my $field ( @{ $args->{columns} } ) {
314 no_hidden_constraints => 1,
315 column_nullable => 1, # empty option on select boxes
318 if ( ref $field eq "HASH" ) { # foreign search fields
319 my ($accssr, $cols) = each %$field;
320 $base_args->{columns} = $cols;
322 # default to search fields for related
323 #$cols = $accssr_class->{$accssr}->search_columns;
324 die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
326 my $fcgi = $class->to_field($accssr, 'foreign_inputs', $base_args);
328 # unset the default values for a select box
329 foreach (keys %$fcgi) {
330 my $el = $fcgi->{$_};
331 if ($el->tag eq 'select') {
333 $class->unselect_element($el);
334 my ($first, @content) = $el->content_list;
335 my @fc = $first->content_list;
336 my $val = $first ? $first->attr('value') : undef;
337 if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or
339 #(defined $first->attr('value') or $first->attr('value') ne ''))
340 # push an empty option on stactk
341 $el->unshift_content(HTML::Element->new('option'));
346 $cgi{$accssr} = $fcgi;
347 delete $base_args->{columns};
350 $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} });
351 my $el = $cgi{$field};
352 if ($el->tag eq 'select') {
353 $class->unselect_element($el);
354 my ($first, @content) = $el->content_list;
355 if ($first and $first->content_list) { # something
356 #(defined $first->attr('value') or $first->attr('value') ne ''))
357 # push an empty option on stactk
358 $el->unshift_content(HTML::Element->new('option'));
369 =head2 unselect_element
371 unselect any selected elements in a HTML::Element select list widget
374 sub unselect_element {
375 my ($self, $el) = @_;
376 #unless (ref $el eq 'HTML::Element') {
377 #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
378 if ($el->tag eq 'select') {
379 foreach my $opt ($el->content_list) {
380 $opt->attr('selected', undef) if $opt->attr('selected');
385 =head2 _field_from_how($field, $how,$args)
387 Returns an input element based the "how" parameter or nothing at all.
392 sub _field_from_how {
393 my ($self, $field, $how, $args) = @_;
397 my $meth = "_to_$how";
398 if (not $self->can($meth)) {
399 warn "Class can not $meth";
402 return $self->$meth($field, $args);
406 =head2 _field_from_relationship($field, $args)
408 Returns an input based on the relationship associated with the field or nothing.
411 For has_a it will give select box
415 sub _field_from_relationship {
416 my ($self, $field, $args) = @_;
417 return unless $field;
418 my $rel_meta = $self->related_meta('r',$field) || return;
419 my $rel_name = $rel_meta->{name};
420 #my $meta = $self->meta_info;
421 #grep{ defined $meta->{$_}{$field} } keys %$meta;
422 my $fclass = $rel_meta->foreign_class;
423 my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
426 if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) {
427 # This condictions allows for trumping of the has_a args
428 if (not $rel_meta->{args}{no_select} and not $args->{no_select})
430 $args->{class} = $fclass;
431 return $self->_to_select($field, $args);
435 # maybe has many select
436 if ($rel_meta->{name} eq 'has_many' and $fclass_is_cdbi and ref $self) {
437 # This condictions allows for trumping of the has_a args
438 if (not $rel_meta->{args}{no_select} and not $args->{no_select})
440 $args->{class} = $fclass;
441 my @itms = $self->$field; # need list not iterator
442 $args->{items} = \@itms;
443 return $self->_to_select($field, $args);
450 #NOOO! maybe select from has_many
451 # if ($rel_type eq 'has_many' and ref $self) {
452 # $args->{items} ||= [$self->$field];
453 # # arg name || fclass pk name || field
454 # if (not $args->{name}) {
455 # $args->{name} = eval{$fclass->primary_column->name} || $field;
457 # return $self->_to_select($field, $args);
460 # maybe foreign inputs
461 my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
462 if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_name eq 'has_own'))
464 $args->{related_meta} = $rel_meta; # suspect faster to set these args
465 return $self->_to_foreign_inputs($field, $args);
470 =head2 _field_from_column($field, $args)
472 Returns an input based on the column's characteristics, namely type, or nothing.
477 sub _field_from_column {
478 my ($self, $field, $args) = @_;
479 return unless $field;
480 my $class = ref $self || $self;
482 unless ($args->{column_type}) {
483 if ($class->can('column_type')) {
484 $args->{column_type} = $class->column_type($field);
487 # Right, have some of this
488 eval "package $class; Class::DBI::Plugin::Type->import()";
489 $args->{column_type} = $class->column_type($field);
492 my $type = $args->{column_type};
494 return $self->_to_textfield($field, $args)
495 if $type and $type =~ /^(VAR)?CHAR/i; #common type
496 return $self->_to_textarea($field, $args)
497 if $type and $type =~ /^(TEXT|BLOB)$/i;
498 return $self->_to_enum_select($field, $args)
499 if $type and $type =~ /^ENUM\((.*?)\)$/i;
500 return $self->_to_bool_select($field, $args)
501 if $type and $type =~ /^BOOL/i;
502 return $self->_to_readonly($field, $args)
503 if $type and $type =~ /^readonly$/i;
509 my ($self, $col, $args) = @_;
512 my $val = $args->{value};
514 unless (defined $val) {
519 $val = $args->{default};
520 $val = '' unless defined $val;
523 my ($rows, $cols) = _box($val);
524 $rows = $args->{rows} if $args->{rows};
525 $cols = $args->{cols} if $args->{cols};;
526 my $name = $args->{name} || $col;
528 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
529 $a->push_content($val);
530 $OLD_STYLE && return $a->as_HTML;
535 my ($self, $col, $args ) = @_;
536 use Carp qw/confess/;
537 confess "No col passed to _to_textfield" unless $col;
539 my $val = $args->{value};
540 my $name = $args->{name} || $col;
542 unless (defined $val) {
544 # Case where column inflates.
545 # Input would get stringification which could be not good.
546 # as in the case of Time::Piece objects
547 $val = $self->can($col) ? $self->$col : ''; # in case it is a virtual column
549 if (my $meta = $self->related_meta('',$col)) {
550 if (my $code = $meta->{args}{deflate4edit} || $meta->{args}{deflate} ) {
551 $val = ref $code ? &$code($val) : $val->$code;
553 elsif ( $val->isa('Class::DBI') ) {
557 #warn "No deflate4edit code defined for $val of type " .
558 #ref $val . ". Using the stringified value in textfield..";
562 $val = $val->id if $val->isa("Class::DBI");
568 $val = $args->{default};
569 $val = '' unless defined $val;
573 # THIS If section is neccessary or you end up with "value" for a vaiue
575 $val = '' unless defined $val;
576 $a = HTML::Element->new("input", type => "text", name => $name, value =>$val);
577 $OLD_STYLE && return $a->as_HTML;
584 # my ($self, $col, $hint) = @_;
585 # my $fclass = $hint || $self->__hasa_rels->{$col}->[0];
586 # my @objs = $fclass->retrieve_all;
587 # my $a = HTML::Element->new("select", name => $col);
589 # my $sel = HTML::Element->new("option", value => $_->id);
590 # $sel->attr("selected" => "selected")
592 # and eval { $_->id eq $self->$col->id };
593 # $sel->push_content($_->stringify_self);
594 # $a->push_content($sel);
596 # $OLD_STYLE && return $a->as_HTML;
603 =head2 recognized arguments
605 selected => $object|$id,
608 where => SQL 'WHERE' clause,
609 order_by => SQL 'ORDER BY' clause,
610 constraint => hash of constraints to search
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');}
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 ($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 my $items = _select_items($args); # array of hashrefs
728 # Turn items into objects if related
729 if ($rel_meta and not $args->{no_construct}) {
731 push @objs, $rel_meta->{foreign_class}->construct($_) foreach @$items;
732 $args->{items} = \@objs;
734 else { $args->{items} = $items; }
737 #warn "Just got items. They are " . Dumper($args->{items});
739 # Make select HTML element
740 $a = $self->_select_guts($col, $args);
742 if ($args->{multiple}) {$a->attr('multiple', 'multiple');}
745 $OLD_STYLE && return $a->as_HTML;
754 # returns the intersection of list refs a and b
755 sub _list_intersect {
757 my %isect; my %union;
758 foreach my $e (@$a, @$b) { $union{$e}++ && $isect{$e}++ }
764 # Get Items returns array of hashrefs
767 my $fclass = $args->{class};
768 my @disp_cols = @{$args->{columns} || []};
769 @disp_cols = $fclass->columns('SelectBox') unless @disp_cols;
770 @disp_cols = $fclass->columns('Stringify')unless @disp_cols;
771 @disp_cols = $fclass->_essential unless @disp_cols;
772 unshift @disp_cols, $fclass->columns('Primary');
773 #my %isect = _list_intersect(\@pks, \@disp_cols);
774 #foreach (@pks) { push @sel_cols, $_ unless $isect{$_}; }
775 #push @sel_cols, @disp_cols;
777 #warn "in select items. args are : " . Dumper($args);
779 if ($args->{'distinct'}) {
780 $distinct = 'DISTINCT ';
783 my $sql = "SELECT $distinct" . join( ', ', @disp_cols) .
784 " FROM " . $fclass->table;
786 $sql .= " WHERE " . $args->{where} if $args->{where};
787 $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
788 $sql .= " LIMIT " . $args->{limit} if $args->{limit};
789 #warn "_select_items sql is : $sql";
791 my $sth = $fclass->db_Main->prepare($sql);
794 while ( my $d = $sth->fetchrow_hashref ) {push @data, $d};
800 # Makes a readonly input box out of column's value
801 # No args makes object to readonly
803 my ($self, $col, $args) = @_;
804 my $val = $args->{value};
805 if (not defined $val ) { # object to readonly
806 $self->_croak("AsForm: To readonly field called as class method without a value") unless ref $self;
808 $col = $self->primary_column;
810 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
811 'name' => $col, 'value'=>$val);
812 $OLD_STYLE && return $a->as_HTML;
817 =head2 _to_enum_select
819 Returns a select box for the an enum column type.
823 sub _to_enum_select {
824 my ($self, $col, $args) = @_;
825 my $type = $args->{column_type};
826 $type =~ /ENUM\((.*?)\)/i;
827 (my $enum = $1) =~ s/'//g;
828 my @enum_vals = split /\s*,\s*/, $enum;
830 # determine which is pre selected --
831 my $selected = eval { $self->$col };
832 $selected = $args->{default} unless defined $selected;
833 $selected = $enum_vals[0] unless defined $selected;
835 my $a = HTML::Element->new("select", name => $col);
837 my $sel = HTML::Element->new("option", value => $_);
838 $sel->attr("selected" => "selected") if $_ eq $selected ;
839 $sel->push_content($_);
840 $a->push_content($sel);
842 $OLD_STYLE && return $a->as_HTML;
847 =head2 _to_bool_select
849 Returns a "No/Yes" select box for a boolean column type.
852 # TCODO fix this mess with args
853 sub _to_bool_select {
854 my ($self, $col, $args) = @_;
855 my $type = $args->{column_type};
856 my @bool_text = ('No', 'Yes');
857 if ($type =~ /BOOL\((.+?)\)/i) {
858 (my $bool = $1) =~ s/'//g;
859 @bool_text = split /,/, $bool;
864 my $selected = $args->{value} if defined $args->{value};
865 $selected = $args->{selected} unless defined $selected;
866 $selected = ref $self ? eval {$self->$col;} : $args->{default}
867 unless (defined $selected);
869 my $a = HTML::Element->new("select", name => $col);
870 if ($args->{column_nullable} || $args->{value} eq '') {
871 my $null = HTML::Element->new("option");
872 $null->attr('selected', 'selected') if $args->{value} eq '';
873 $a->push_content( $null );
876 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
877 HTML::Element->new("option", value => 1) );
878 $opt0->push_content($bool_text[0]);
879 $opt1->push_content($bool_text[1]);
880 unless ($selected eq '') {
881 $opt0->attr("selected" => "selected") if not $selected;
882 $opt1->attr("selected" => "selected") if $selected;
884 $a->push_content($opt0, $opt1);
885 $OLD_STYLE && return $a->as_HTML;
890 =head2 _to_hidden($field, $args)
892 This makes a hidden html element input. It uses the "name" and "value"
893 arguments. If one or both are not there, it will look for an object in
894 "items->[0]" or the caller. Then it will use $field or the primary key for
895 name and the value of the column by the derived name.
900 my ($self, $field, $args) = @_;
902 my ($name, $value) = ($args->{'name'}, $args->{value});
903 $name = $field unless defined $name;
904 if (! defined $name and !defined $value) { # check for objects
905 my $obj = $args->{items}->[0] || $self;
906 unless (ref $obj) { die "_to_hidden cannot determine a value. It was passed a value argument or items object or called with an object."; }
907 $name = $obj->primary_column->name unless $name;
908 $value = $obj->$name unless $value;
911 return HTML::Element->new('input', 'type' => 'hidden',
912 'name' => $name, 'value'=>$value);
916 =head2 _to_link_hidden($col, $args)
918 Makes a link with a hidden input with the id of $obj as the value and name.
919 Name defaults to the objects primary key. The object defaults to self.
923 sub _to_link_hidden {
924 my ($self, $accessor, $args) = @_;
925 my $r = eval {$self->controller} || $args->{r} || '';
926 my $uri = $args->{uri} || '';
928 $self->_croak("_to_link_hidden cant get uri. No Maypole Request class (\$r) or uri arg. Need one or other.")
931 if (ref $self) { # hidding linking self
933 $name = $args->{name} || $obj->primary_column->name;
935 elsif ($obj = $args->{items}->[0]) {
936 $name = $args->{name} || $accessor || $obj->primary_column->name;
937 # TODO use meta data above maybe
939 else { # hiding linking related object with id in args
940 $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
941 $name = $args->{name} || $accessor ; #$obj->primary_column->name;
942 # TODO use meta data above maybe
944 $self->_croak("_to_link_hidden has no object") unless ref $obj;
945 my $href = $uri || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
946 my $a = HTML::Element->new('a', 'href' => $href);
947 $a->push_content("$obj");
948 $a->push_content($self->to_field('blahfooey', 'hidden', {name => $name, value => $obj->id} ));
950 $OLD_STYLE && return $a->as_HTML;
954 =head2 _to_foreign_inputs
956 Creates inputs for a foreign class, usually related to the calling class or
957 object. In names them so they do not clash with other names and so they
958 can be processed generically. See _rename_foreign_inputs below and
959 Maypole::Model::CDBI::FromCGI::classify_foreign_inputs.
961 Arguments this recognizes are :
963 related_meta -- if you have this, great, othervise it will determine or die
964 columns -- list of columns to make inputs for
965 request (r) -- TODO the Maypole request so we can see what action
969 sub _to_foreign_inputs {
970 my ($self, $accssr, $args) = @_;
971 my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr);
972 my $fields = $args->{columns};
974 $self->_croak( "No relationship for accessor $accssr");
977 my $rel_type = $rel_meta->{name};
978 my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_meta->{foreign_class};
981 $fields = $classORobj->can('display_columns') ?
982 [$classORobj->display_columns] : [$classORobj->columns];
985 # Ignore our fkey in them to prevent infinite recursion
986 my $me = eval {$rel_meta->{args}{foreign_column}} || '';
987 my $constrained = $rel_meta->{args}{constraint};
989 foreach ( @$fields ) {
990 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
991 $inputs{$_} = $classORobj->to_field($_);
994 # Make hidden inputs for constrained columns unless we are editing object
995 # TODO -- is this right thing to do?
996 unless (ref $classORobj || $args->{no_hidden_constraints}) {
997 $inputs{$_} = $classORobj->to_field('blahfooey', 'hidden',
998 {name => $_, value => $constrained->{$_}} )
999 foreach ( keys %$constrained );
1001 $self->_rename_foreign_input($accssr, \%inputs);
1006 =head2 _hash_selected
1008 *Function* to make sense out of the "selected" argument which has values of the
1009 options that should be selected by default when making a select box. It
1010 can be in a number formats. This method returns a map of which options to
1011 select with the values being the keys in the map ( {val1 => 1, val2 = 1} ).
1013 Currently this method handles the following formats for the "selected" argument
1014 and in the following ways
1016 Object -- uses the id method to get the value
1017 Scalar -- assumes it *is* the value
1018 Array ref of objects -- same as Object
1019 Arrays of data -- uses the 0th element in each
1020 Hashes of data -- uses key named 'id'
1027 sub _hash_selected {
1029 my $selected = $args->{value} || $args->{selected};
1030 #warn "**** SELECTED is $selected ****";
1031 my $type = ref $selected;
1032 return $selected unless $selected and $type ne 'HASH';
1033 #warn "Selected dump : " . Dumper($selected);
1035 if ($type and $type ne 'ARRAY') {
1036 my $id = $selected->id;
1042 return { $selected => 1};
1046 # Array of objs, arrays, hashes, or just scalalrs.
1047 elsif ($type eq 'ARRAY') {
1049 my $ltype = ref $selected->[0];
1051 if ($ltype and $ltype ne 'ARRAY') {
1052 %hashed = map { $_->id => 1 } @$selected;
1054 # Arrays of data with id first
1055 elsif ($ltype and $ltype eq 'ARRAY') {
1056 %hashed = map { $_->[0] => 1 } @$selected;
1058 # Hashes using pk or id key
1059 elsif ($ltype and $ltype eq 'HASH') {
1060 my $pk = $args->{class}->primary_column || 'id';
1061 %hashed = map { $_->{$pk} => 1 } @$selected;
1065 %hashed = map { $_ => 1 } @$selected;
1069 else { warn "AsForm Could not hash the selected argument: $selected"; }
1077 Internal api method to make the actual select box form elements.
1080 Items to make options out of can be
1082 Array of CDBI objects.
1084 Array or Array refs with cols from class,
1092 my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
1094 #$args->{stringify} ||= 'stringify_selectbox';
1096 $args->{selected} = _hash_selected($args) if defined $args->{selected};
1097 my $name = $args->{name} || $col;
1098 my $a = HTML::Element->new('select', name => $name);
1099 $a->attr( %{$args->{attr}} ) if $args->{attr};
1101 if ($args->{column_nullable}) {
1102 my $null_element = HTML::Element->new('option', value => '');
1103 $null_element->attr(selected => 'selected')
1104 if ($args->{selected}{'null'});
1105 $a->push_content($null_element);
1108 my $items = $args->{items};
1109 my $type = ref $items;
1110 my $proto = eval { ref $items->[0]; } || "";
1111 my $optgroups = $args->{optgroups} || '';
1113 # Array of hashes, one for each optgroup
1116 foreach (@$optgroups) {
1117 my $ogrp= HTML::Element->new('optgroup', label => $_);
1118 $ogrp->push_content($self->_options_from_hash($items->[$i], $args));
1119 $a->push_content($ogrp);
1124 elsif ($type eq 'HASH') {
1125 $a->push_content($self->_options_from_hash($items, $args));
1128 elsif ( $type eq 'ARRAY' and not ref $items->[0] ) {
1129 $a->push_content($self->_options_from_array($items, $args));
1132 elsif( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) {
1133 # make select of objects
1134 $a->push_content($self->_options_from_objects($items, $args));
1137 elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) {
1138 $a->push_content($self->_options_from_arrays($items, $args));
1141 elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) {
1142 $a->push_content($self->_options_from_hashes($items, $args));
1145 die "You passed a weird type of data structure to me. Here it is: " .
1154 =head2 _options_from_objects ( $objects, $args);
1156 Private method to makes a options out of objects. It attempts to call each
1157 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
1159 *Note only single primary keys supported
1162 sub _options_from_objects {
1163 my ($self, $items, $args) = @_;
1164 my $selected = $args->{selected} || {};
1165 my $stringify = $args->{stringify} || '';
1169 my $opt = HTML::Element->new("option", value => $id);
1170 $id =~ s/^0*//; # leading zeros no good in hash key
1171 $opt->attr(selected => "selected") if $selected->{$id};
1172 my $content = $stringify ? $_->stringify : "$_";
1173 $opt->push_content($content);
1179 sub _options_from_arrays {
1180 my ($self, $items, $args) = @_;
1181 my $selected = $args->{selected} || {};
1183 my $class = $args->{class} || '';
1184 my $stringify = $args->{stringify} || '';
1185 for my $item (@$items) {
1186 my @pks; # for future multiple key support
1187 push @pks, shift @$item foreach $class->columns('Primary');
1189 $id =~ s/^0+//; # In case zerofill is on .
1190 my $val = defined $id ? $id : '';
1191 my $opt = HTML::Element->new("option", value =>$val);
1192 $opt->attr(selected => "selected") if $selected->{$id};
1194 my $content = ($class and $stringify and $class->can($stringify)) ?
1195 $class->$stringify($_) :
1196 join( '/', map { $_ if $_; }@{$item} );
1197 $opt->push_content( $content );
1204 sub _options_from_array {
1205 my ($self, $items, $args) = @_;
1206 my $selected = $args->{selected} || {};
1209 my $val = defined $_ ? $_ : '';
1210 my $opt = HTML::Element->new("option", value => $val);
1211 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1212 $opt->attr(selected => "selected") if $selected->{$_};
1213 $opt->push_content( $_ );
1219 sub _options_from_hash {
1220 my ($self, $items, $args) = @_;
1221 my $selected = $args->{selected} || {};
1224 my @values = values %$items;
1225 # hash Key is the option content and the hash value is option value
1226 for (sort keys %$items) {
1227 my $val = defined $items->{$_} ? $items->{$_} : '';
1228 my $opt = HTML::Element->new("option", value => $val);
1229 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1230 $opt->attr(selected => "selected") if $selected->{$items->{$_}};
1231 $opt->push_content( $_ );
1238 sub _options_from_hashes {
1239 my ($self, $items, $args) = @_;
1240 my $selected = $args->{selected} || {};
1241 my $pk = eval {$args->{class}->primary_column} || 'id';
1242 my $fclass = $args->{class} || '';
1243 my $stringify = $args->{stringify} || '';
1246 my $val = defined $_->{$pk} ? $_->{$pk} : '';
1247 my $opt = HTML::Element->new("option", value => $val);
1248 $opt->attr(selected => "selected") if $selected->{$val};
1249 my $content = ($fclass and $stringify and $fclass->can($stringify)) ?
1250 $fclass->$stringify($_) :
1251 join(' ', keys %$_);
1252 $opt->push_content( $content );
1259 #sub _to_select_or_create {
1260 # my ($self, $col, $args) = @_;
1261 # $args->{name} ||= $col;
1262 # my $select = $self->to_field($col, 'select', $args);
1263 # $args->{name} = "create_" . $args->{name};
1264 # my $create = $self->to_field($col, 'foreign_inputs', $args);
1265 # $create->{'__select_or_create__'} =
1266 # $self->to_field('__select_or_create__',{ name => '__select_or_create__' , value => 1 } );
1267 # return ($select, $create);
1273 Makes a checkbox element -- TODO
1277 # checkboxes: if no data in hand (ie called as class method), replace
1278 # with a radio button, in order to allow this field to be left
1279 # unspecified in search / add forms.
1282 # TODO -- make this general checkboxse
1286 my ($self, $col, $args) = @_;
1287 my $nullable = eval {self->column_nullable($col)} || 0;
1288 return $self->_to_radio($col) if !ref($self) || $nullable;
1289 my $value = $self->$col;
1290 my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1291 $a->attr("checked" => 'true') if $value eq 'Y';
1297 Makes a radio button element -- TODO
1300 # TODO -- make this general radio butons
1303 my ($self, $col) = @_;
1304 my $value = ref $self && $self->$col || '';
1305 my $nullable = eval {self->column_nullable($col)} || 0;
1306 my $a = HTML::Element->new("span");
1307 my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1308 my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1309 my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1310 $ry->push_content('Yes'); $rn->push_content('No');
1311 $ru->push_content('n/a') if $nullable;
1312 if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1313 elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1314 elsif ($nullable) { $ru->attr("checked" => 'true') }
1315 $a->push_content($ry, $rn);
1316 $a->push_content($ru) if $nullable;
1322 ############################ HELPER METHODS ######################
1323 ##################################################################
1325 =head2 _rename_foreign_input
1327 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1329 Recursively renames the foreign inputs made by _to_foreign_inputs so they
1330 can be processed generically. It uses foreign_input_delimiter.
1332 So if an Employee is a Person who has_many Addresses and you call and the
1333 method 'foreign_input_delimiter' returns '__AF__' then
1335 Employee->to_field("person");
1337 will get inputs for the Person as well as their Address (by default,
1338 override _field_from_relationship to change logic) named like this:
1340 person__AF__address__AF__street
1341 person__AF__address__AF__city
1342 person__AF__address__AF__state
1343 person__AF__address__AF__zip
1345 And the processor would know to create this address, put the address id in
1346 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.
1350 sub _rename_foreign_input {
1351 my ($self, $accssr, $element) = @_;
1352 my $del = $self->foreign_input_delimiter;
1354 if ( ref $element ne 'HASH' ) {
1355 # my $new_name = $accssr . "__AF__" . $input->attr('name');
1356 $element->attr( name => $accssr . $del . $element->attr('name'));
1359 $self->_rename_foreign_input($accssr, $element->{$_})
1360 foreach (keys %$element);
1364 =head2 foreign_input_delimiter
1366 This tells AsForm what to use to delmit forieign input names. This is important
1367 to avoid name clashes as well as automating processing of forms.
1371 sub foreign_input_delimiter { '__AF__' };
1375 This functions computes the dimensions of a textarea based on the value
1383 my ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1386 my @rows = split /^/, $text;
1387 my $cols = $min_cols;
1390 my $len = length $_;
1392 $cols = $len if $len > $cols;
1393 $cols = $max_cols if $cols > $max_cols;
1396 $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1397 $rows = $min_rows if $rows < $min_rows;
1398 $rows = $max_rows if $rows > $max_rows;
1401 else { ($min_rows, $min_cols) }
1411 15-07-2004 -- Initial version
1418 Peter Speltz, Aaron Trevena
1420 =head1 AUTHORS EMERITUS
1422 Simon Cozens, Tony Bowden
1428 chekbox generalization
1429 radio generalization
1431 Make link_hidden use standard make_url stuff when it gets in Maypole
1432 How do you tell AF --" I want a has_many select box for this every time so,
1433 when you call "to_field($this_hasmany)" you get a select box
1435 =head1 BUGS and QUERIES
1437 Please direct all correspondence regarding this module to:
1440 =head1 COPYRIGHT AND LICENSE
1442 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1444 This library is free software; you can redistribute it and/or modify
1445 it under the same terms as Perl itself.
1449 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.