1 package Maypole::Model::CDBI::AsForm;
10 use Class::DBI::Plugin::Type ();
14 # pjs -- Added new methods to @EXPORT
17 to_cgi to_field make_element_foreign unselect_element
18 _field_from_how _field_from_relationship _field_from_column
19 _to_textarea _to_textfield _to_select _select_guts
20 _to_foreign_inputs _to_enum_select _to_bool_select
21 _to_hidden _to_link_hidden _rename_foreign_input _to_readonly
22 _options_from_objects _options_from_arrays _options_from_hashes
36 # 08-09-05 - fixed broken has_a select box
38 # - _to_foreign_inputs now takes 3 positional parameters
39 # (accssr, fields, accssr_meta_info)
41 # 10-18-05 - made _to_enum_select check column_default
42 # 10-19-05 - exported _to_select_from_objs
44 # 10-24-05 - _to_select_from_many Redesign.
45 # Now first arg is either a has_many accessor or a array ref of
46 # objects to select from and the options are in named list .
47 # selected : object or id
48 # name : the element name
49 # to_select_from_many ($accssr|$objs [, selected => $obj|$id, name => $elmnt_name])
51 # - _to_hidden -- if object arg then name and value are from pk
52 # _ _rename_foreign_input -- took out useless assignment on new name
53 # - _to_select : put empty option if column is nullable
54 # 11-04-05 - _to_readonly with no args makes the calling object pk and id
55 # - _to_select : if object calls it without a column argument, it make# s a select box of the calling class rows and the object is pre selected.
57 # 11-05-05 - added _to_link_hidden to make a link to the hidden object
58 # - fixed _to_hidden when called with no args. Hides self obj.
59 # 11-04-05 - _to_textfield: tries to call "deflate4edit" if column is has_a
60 # 11-08-05 - Changed Version to .08
64 # 1-10-06 -- fixed bug in to_textfiled that was stringifyingf CDBI objects
67 # 1-20-06 - to_select - call db_Main with has a class.
68 # 1-24-06 - to_select_from_many now named _to_select_from_many . Old deprecated
69 # - hasmany_class removed in favor of model's related_class method.
70 # - took out do_select. That is a model action.
71 # - use search_columns instead of search_fields now.
72 # - use to_field('column', 'select', {args}) instead of a_select_box.
73 # -- took out make_hidden_element.was my own personal hack
74 # -- added _box from DH's FormView to calculate decent textarea size
75 # -- Refactor to_field into _from_* method calls.
77 # 1-25-06 -- Added _to_checkbox and _to_radio from FView
78 # 1-27-06 -- Refactored into yet more exported methods
79 # 1-28-06 -- select constraints where, join order by
80 # 2-16-05 -- select box cols should only contain pks if you want them to
81 # be in he content string of the option. Went backt to old way.
87 Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns
92 use Maypole::Model::CDBI::AsForm;
93 use base 'Class::DBI';
99 my %cgi_field = $self->to_cgi;
101 (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
106 . . . somewhere use to_field($col, $how, $args)
107 package BeerDB::Pint;
108 __PACKAGE__->has_a('drinker', 'BeerDB::Drinker');
109 __PACKAGE__->has_a('beer', 'BeerDB::Beer');
111 package BeerDB::Drinker;
112 __PACKAGE__->has_many('pints', 'BeerDB::Pint');
115 # NOTE NEED to do mapping
117 # Order a round -- multiple select of all pints if class method
118 my $sel = BeerDB::Drinker->to_field('pints', 'select') #
120 # Take one down pass it around
121 my $choice = $Drunk->to_field('pints', 'select'); # Choose from what we already have
126 __PACKAGE__->has_a('employer' => 'Employer');
127 __PACKAGE__->has_a('contact' => 'Contact')
131 __PACKAGE__->has_a('employer_also' => 'Employer');
132 __PACKAGE__->has_many('jobs' => 'Job',
133 { join => { employer => 'employer_also' },
134 constraint => { 'finshed' => 0 },
135 order_by => "created ASC",
141 __PACKAGE__->has_many('jobs' => 'Job',);
142 __PACKAGE__->has_many('contacts' => 'Contact',
143 order_by => 'name DESC',
147 # Below gives select boxes with the multiple attribute.
148 my $select_jobs_for_new_contact =
149 Contact->to_field('jobs', 'select'); # Uses constraint and order by
151 my $edit_jobs_for_existing_contact =
152 $contact->to_field('jobs', 'select');
162 This module helps to generate HTML forms for creating new database rows
163 or editing existing rows. It maps column names in a database table to
164 HTML form elements which fit the schema. Large text fields are turned
165 into textareas, and fields with a has-a relationship to other
166 C<Class::DBI> tables are turned into select drop-downs populated with
167 objects from the joined class.
171 The module is a mix-in which adds two additional methods to your
172 C<Class::DBI>-derived class.
177 =head2 unselect_element
179 Unselects all options in a HTML::Element of type select.
180 It does nothing if element is not a select element.
184 sub unselect_element {
185 my ($self, $el) = @_;
186 #unless (ref $el eq 'HTML::Element') {
187 #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
188 if ($el->tag eq 'select') {
189 foreach my $opt ($el->content_list) {
190 $opt->attr('selected', undef) if $opt->attr('selected');
198 Returns a HTML::Element representing a select box, based on the arguments
202 # make a select box from args
204 my ($self, $name, $vals, $selected_val, $contents) = @_;
205 die "Usage: Need a name and array ref of values to make a select boxes" unless ($name && $vals);
206 $selected_val ||= "";
207 $contents ||= $vals ;
209 my $a = HTML::Element->new('select', 'name' => $name);
212 foreach my $v ( @$vals ) {
213 my $opt = HTML::Element->new('option', 'value' => $v);
214 $opt->attr('selected' => 'selected') if $v eq $selected_val;
215 $c = $contents->[$i++] || $v;
216 $opt->push_content($c);
217 $a->push_content($opt);
226 This returns a hash mapping all the column names of the class to
227 HTML::Element objects representing form widgets.
229 pjs -- added a columns list argument to specify which columns to make
235 my ($class, @columns) = @_; # pjs -- added columns arg
236 @columns = $class->columns unless (@columns);
237 map { $_ => $class->to_field($_) } @columns;
241 =head2 to_field($field [, $how])
243 This maps an individual column to a form element. The C<how> argument
244 can be used to force the field type into one of C<textfield>, C<textarea>
245 or C<select>; you can use this is you want to avoid the automatic detection
246 of has-a relationships.
249 -- added support for enum and bool. Note for enum and bool you need
250 a better column_type method than the Plugin::Type ' s as it won't work
251 if you are using MySQL. I have not tried others.
252 See those method's docs below.
253 -- Foreign inputs for might_have, must_have, has_own, and has_many(i think).
254 -- Really any relationship except has_a and is_a as has_a gets a select box
255 and is_a are not considered foreign.
256 -- Note a good column_type sub can be
257 used to get the correct type for is_a columns.
258 -- More efficient _to_select -- no object creation.
259 -- Attempts to set default value in field for you using a "column_default"
260 method you write yourself or your CDBI driver like mysql writes.
266 my ($self, $field, @args) = @_;
267 my $how = shift @args unless ref $args[0];
269 my $args = shift @args; # argument hash ref
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);
278 =head2 _field_from_how($field, $how,$args)
280 Returns an input element based the "how" parameter or nothing at all.
285 sub _field_from_how {
286 my ($self, $field, $how, $args) = @_;
288 # warn "field is $field. how is $how. args are $args";
290 my $meth = $how ? "_to_$how" : '' ;
291 # warn "Meth is $meth. field is $field";
292 return $self->$meth($field, $args) if $meth and $self->can($meth);
296 =head2 _field_from_relationship($field, $args)
298 Returns an input based on the relationship associated with the field or nothing.
301 For has_a it will give select box
305 sub _field_from_relationship {
306 my ($self, $field, $args) = @_;
307 my $rel_meta = $self->related_meta('r',$field) || return;
308 my $rel_name = $rel_meta->{name};
309 #my $meta = $self->meta_info;
310 #grep{ defined $meta->{$_}{$field} } keys %$meta;
311 my $fclass = $rel_meta->foreign_class;
312 $args->{class} = $fclass;
313 my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
316 # warn "Dumper of relmeta. " . Dumper($rel_meta);
317 if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) {
318 # This condictions allows for trumping of the has_a args
319 if (not $rel_meta->{args}{no_select} and not $args->{no_select})
321 return $self->_to_select($field, $args);
328 #NOOO! maybe select from has_many
329 # if ($rel_type eq 'has_many' and ref $self) {
330 # $args->{items} ||= [$self->$field];
331 # # arg name || fclass pk name || field
332 # if (not $args->{name}) {
333 # $args->{name} = eval{$fclass->primary_column->name} || $field;
335 # return $self->_to_select($field, $args);
338 # maybe foreign inputs
339 my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
340 if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_name eq 'has_own'))
342 $args->{related_meta} = $rel_meta; # suspect faster to set these args
343 return $self->_to_foreign_inputs($field, $args);
348 =head2 _field_from_column($field, $args)
350 Returns an input based on the column's characteristics, namely type, or nothing.
355 sub _field_from_column {
356 my ($self, $field, $args) = @_;
357 my $class = ref $self || $self;
359 unless ($args->{column_type}) {
360 if ($class->can('column_type')) {
361 $args->{column_type} = $class->column_type($field);
364 # Right, have some of this
365 eval "package $class; Class::DBI::Plugin::Type->import()";
366 $args->{column_type} = $class->column_type($field);
369 my $type = $args->{column_type};
371 return $self->_to_textfield($field)
372 if $type and $type =~ /(VAR)?CHAR/i; #common type
373 return $self->_to_textarea($field, $args)
374 if $type and $type =~ /^(TEXT|BLOB)$/i;
375 return $self->_to_enum_select($field, $args)
376 if $type and $type =~ /^ENUM\((.*?)\)$/i;
377 return $self->_to_bool_select($field, $args)
378 if $type and $type =~ /^BOOL/i;
379 return $self->_to_readonly($field, $args)
380 if $type and $type =~ /^readonly$/i;
386 my ($self, $col, $args) = @_;
389 my $val = $args->{value};
391 unless (defined $val) {
396 $val = eval {$self->column_default($col);};
397 $val = '' unless defined $val;
400 my ($rows, $cols) = _box($val);
401 $rows = $args->{rows} if $args->{rows};
402 $cols = $args->{cols} if $args->{cols};;
403 my $name = $args->{name} || $col;
405 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
406 $a->push_content($val);
407 $OLD_STYLE && return $a->as_HTML;
412 my ($self, $col, $args ) = @_;
414 my $val = $args->{value};
415 my $name = $args->{name} || $col;
417 unless (defined $val) {
419 # Case where column inflates.
420 # Input would get stringification which could be not good.
421 # as in the case of Time::Piece objects
424 if (my $meta = $self->related_meta('',$col)) {
425 # warn "Meta for $col";
426 if (my $code = $meta->{args}{deflate4edit} ) {
427 $val = ref $code ? &$code($val) : $val->$code;
429 elsif ( $val->isa('Class::DBI') ) {
433 warn "No deflate4edit code defined for $val of type " .
434 ref $val . ". Using the stringified value in textfield..";
438 warn "No meta for $col but ref $val.\n";
439 $val = $val->id if $val->isa("Class::DBI");
445 $val = eval {$self->column_default($col);};
446 $val = '' unless defined $val;
449 my $a = HTML::Element->new("input", type => "text", name => $name);
450 $a->attr("value" => $val);
451 $OLD_STYLE && return $a->as_HTML;
456 # Too expensive version -- TODO
458 # my ($self, $col, $hint) = @_;
459 # my $fclass = $hint || $self->__hasa_rels->{$col}->[0];
460 # my @objs = $fclass->retrieve_all;
461 # my $a = HTML::Element->new("select", name => $col);
463 # my $sel = HTML::Element->new("option", value => $_->id);
464 # $sel->attr("selected" => "selected")
466 # and eval { $_->id eq $self->$col->id };
467 # $sel->push_content($_->stringify_self);
468 # $a->push_content($sel);
470 # $OLD_STYLE && return $a->as_HTML;
477 # -- Rewrote this to be efficient -- no object creation.
478 # -- Added option for CDBI classes to specify a limiting clause
479 # via "has_a_select_limit".
480 # -- Added selected argument to set a selected
482 =head2 recognized arguments
484 selected => $object|$id,
487 where => SQL 'WHERE' clause,
488 order_by => SQL 'ORDER BY' clause,
489 limit => SQL 'LIMIT' clause,
490 items => [ @items_of_same_type_to_select_from ],
491 class => $class_we_are_selecting_from
492 stringify => $stringify_coderef|$method_name
497 # select box requirements
498 # 1. a select box for objecs of a has_a related class -- DONE
499 =head2 1. a select box out of a has_a or has_many related class.
500 # For has_a the default behavior is to make a select box of every element in
501 # related class and you choose one.
502 #Or explicitly you can create one and pass options like where and order
503 BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
505 # For has_many the default is to get a multiple select box with all objects.
506 # If called as an object method, the objects existing ones will be selected.
507 Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"});
510 =head2 2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun.
512 BeerDB::Beer->to_field('', 'select', $options)
514 BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
515 # with PK as ID, $Class->to_field() same.
516 BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
517 # specify exact where clause
519 =head2 3. If you already have a list of objects to select from --
521 BeerDB:;Beer->to_field($col, 'select' , {items => $objects});
523 # 3. a select box for arbitrary set of objects
524 # Pass array ref of objects as first arg rather than field
525 $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
531 my ($self, $col, $args) = @_;
533 # Do we have items already ? Go no further.
534 if ($args->{items}) {
535 my $a = $self->_select_guts($col, $args);
536 $OLD_STYLE && return $a->as_HTML;
540 # Else what are we making a select box out of ?
541 # No Column parameter -- means making a select box of args->class or self
542 # Using all rows from class's table
544 warn "No col. $self";
545 unless ($args->{class}) {
546 $args->{class} = ref $self || $self;
547 # object selected if called with one
548 $args->{selected} = { $self->id => 1}
549 if not $args->{selected} and ref $self;
551 $col = $args->{class}->primary_column;
553 # Related Class maybe ?
554 elsif (my $rel_meta = $self->related_meta('r:)', $col) ) {
555 $args->{class} = $rel_meta->{foreign_class};
556 # related objects pre selected if object
558 # "Has many" -- Issues:
559 # 1) want to select one from list if self is an object
560 # Thats about all we can do really,
561 # 2) except for mapping which is TODO and would
562 # do something like add to and take away from list of permissions for
565 # Hasmany select one from list if ref self
566 if ($rel_meta->{name} =~ /has_many/i and ref $self) {
567 $args->{items} = [ $self->$col ];
568 my $a = $self->_select_guts($col, $args);
569 $OLD_STYLE && return $a->as_HTML;
573 $args->{selected} ||= [ $self->$col ] if ref $self;
574 # warn "selected is " . Dumper($args->{selected});
575 my $c = $rel_meta->{args}{constraint} || {};
576 my $j = $rel_meta->{args}{join} || {};
579 @join = map { $_ ." = ". $self->_attr($_) } keys %$j;
581 my @constr= map { "$_ = '$c->{$_}'"} keys %$c;
582 $args->{where} ||= join (' AND ', (@join, @constr));
583 $args->{order_by} ||= $rel_meta->{args}{order_by};
584 $args->{limit} ||= $rel_meta->{args}{limit};
588 # We could say :Col is name and we are selecting out of class arg.
591 #$args->{name} = $col;
592 die "Usage _to_select. $col not related to any class to select from. ";
597 if ( $self->can('column_nullable') ) {
598 $args->{nullable} ||= $self->column_nullable($col);
601 # Get items to select from
602 $args->{items} = _select_items($args);
603 # warn "Items selecting from are " . Dumper($args->{items});
605 #warn "Just got items. They are " . Dumper($args->{items});
607 # Make select HTML element
608 $a = $self->_select_guts($col, $args);
611 $OLD_STYLE && return $a->as_HTML;
620 # returns the intersection of list refs a and b
621 sub _list_intersect {
623 my %isect; my %union;
624 foreach my $e (@$a, @$b) { $union{$e}++ && $isect{$e}++ }
633 my $fclass = $args->{class};
635 @disp_cols = $fclass->columns('SelectBox');
636 @disp_cols = $fclass->columns('Stringify')unless @disp_cols;
637 @disp_cols = $fclass->_essential unless @disp_cols;
638 unshift @disp_cols, $fclass->columns('Primary');
639 #my %isect = _list_intersect(\@pks, \@disp_cols);
640 #foreach (@pks) { push @sel_cols, $_ unless $isect{$_}; }
641 #push @sel_cols, @disp_cols;
644 my $sql = "SELECT " . join( ', ', @disp_cols) .
645 " FROM " . $fclass->table;
647 $sql .= " WHERE " . $args->{where} if $args->{where};
648 $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
649 $sql .= " LIMIT " . $args->{limit} if $args->{limit};
650 #warn "_select_items sql is : $sql";
652 return $fclass->db_Main->selectall_arrayref($sql);
657 # Makes a readonly input box out of column's value
658 # No args makes object to readonly
660 my ($self, $col, $val) = @_;
661 if (! $col) { # object to readonly
663 $col = $self->primary_column;
665 unless (defined $val) {
666 $self->_croak("Cannot get value in _to_readonly .")
670 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
671 'name' => $col, 'value'=>$val);
672 $OLD_STYLE && return $a->as_HTML;
677 =head2 _to_enum_select
679 $sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");
681 Returns an enum select box given a column name and an enum string.
682 NOTE: The Plugin::Type does not return an enum string for mysql enum columns.
683 This will not work unless you write your own column_type method in your model.
687 sub _to_enum_select {
688 my ($self, $col, $type) = @_;
689 $type =~ /ENUM\((.*?)\)/i;
690 (my $enum = $1) =~ s/'//g;
691 my @enum_vals = split /\s*,\s*/, $enum;
693 # determine which is pre selected --
694 # if obj, the value is , otherwise use column_default which is the first
695 # value in the enum list unless it has been overridden
696 my $selected = eval { $self->$col };
697 $selected = eval{$self->column_default($col)} unless defined $selected;
698 $selected = $enum_vals[0] unless defined $selected;
701 my $a = HTML::Element->new("select", name => $col);
703 my $sel = HTML::Element->new("option", value => $_);
704 $sel->attr("selected" => "selected") if $_ eq $selected ;
705 $sel->push_content($_);
706 $a->push_content($sel);
708 $OLD_STYLE && return $a->as_HTML;
713 =head2 _to_bool_select
715 my $sel = $self->_to_bool_select($column, $bool_string);
717 This makes select input for boolean column. You can provide a
718 bool string of form: Bool('zero','one') and those are used for option
719 content. Onthervise No and Yes are used.
720 TODO -- test without bool string.
724 sub _to_bool_select {
725 my ($self, $col, $type) = @_;
726 my @bool_text = ('No', 'Yes');
727 if ($type =~ /BOOL\((.+?)\)/i) {
728 (my $bool = $1) =~ s/'//g;
729 @bool_text = split /,/, $bool;
731 my $one= ref $self ? eval {$self->$col;} : $self->column_default($col);
732 my $a = HTML::Element->new("select", name => $col);
733 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
734 HTML::Element->new("option", value => 1) );
735 $opt0->attr("selected" => "selected") if not $one;
736 $opt0->push_content($bool_text[0]);
737 $opt1->attr("selected" => "selected") if $one;
738 $opt1->push_content($bool_text[1]);
739 $a->push_content($opt0, $opt1);
740 $OLD_STYLE && return $a->as_HTML;
745 =head2 _to_hidden($col, $args)
747 This makes a hidden html element. Give it a name and value or if name is
748 a ref it will use the PK name and value of the object.
753 my ($self, $name, $val) = @_;
756 if (ref $name and $name->isa("Class::DBI")) {
758 $name= ($obj->primary_columns)[0]->name;
762 $val = $args->{value};
763 $name = $args->{name} if $args->{name};
765 elsif (not $name ) { # hidding object caller
766 $self->_croak("No object available in _to_hidden") unless ref $self;
767 $name = ($self->primary_column)[0]->name;
770 return HTML::Element->new('input', 'type' => 'hidden',
771 'name' => $name, 'value'=>$val
775 =head2 _to_link_hidden($col, $args)
777 Makes a link with a hidden input with the id of $obj as the value and name.
778 Name defaults to the objects primary key. The object defaults to self.
782 sub _to_link_hidden {
783 my ($self, $accessor, $args) = @_;
784 my $r = $args->{r} || '';
785 my $url = $args->{url} || '';
787 # warn "$self Args are " . Dumper($args);
788 $self->_croak("_to_link_hidden called without Maypole Request object (\$r) and url. Need one or other.")
791 if (ref $self) { # hidding linking self
793 $name = $args->{name} || $obj->primary_column->name;
795 else { # hiding linking related object with id in args
796 $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
797 $name = $args->{name} || $obj->primary_column->name; # TODO make use meta data
799 $self->_croak("_to_link_hidden has no object") unless ref $obj;
800 my $href = $url || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
801 my $a = HTML::Element->new('a', 'href' => $href);
802 $a->push_content("$obj");
803 $a->push_content($self->_to_hidden($name, $obj->id));
804 $OLD_STYLE && return $a->as_HTML;
810 =head2 _to_foreign_inputs
812 $html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]);
814 Get inputs for the accessor's class. Pass an array ref of fields to get
815 inputs for only those fields. Otherwise display_columns or all columns is used.
816 If you have the meta info handy for the accessor you can pass that too.
818 TODO make AsForm know more about the request like what action we are doing
819 so it can use edit columns or search_columns
821 NOTE , this names the foreign inputs is a particular way so they can be
822 processed with a general routine and so there are not name clashes.
825 related_meta -- if you have this, great, othervise it will determine or die
826 columns -- list of columns to make inputs for
830 sub _to_foreign_inputs {
831 my ($self, $accssr, $args) = @_;
832 my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr);
833 my $fields = $args->{columns};
835 $self->_croak( "No relationship for accessor $accssr");
838 my $rel_type = $rel_meta->{name};
839 my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_meta->{foreign_class};
842 $fields = $classORobj->can('display_columns') ?
843 [$classORobj->display_columns] : [$classORobj->columns];
846 # Ignore our fkey in them to prevent infinite recursion
847 my $me = eval {$rel_meta->{args}{foreign_column}} || '';
848 my $constrained = $rel_meta->{args}{constraint};
850 foreach ( @$fields ) {
851 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
852 $inputs{$_} = $classORobj->to_field($_);
855 # Make hidden inputs for constrained columns unless we are editing object
856 # TODO -- is this right thing to do?
857 unless (ref $classORobj || $args->{no_hidden_constraints}) {
858 $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_})
859 foreach ( keys %$constrained );
861 $self->_rename_foreign_input($accssr, \%inputs);
866 =head2 _hash_selected
868 Method to make sense out of the "selected" argument which can be in a number
869 of formats perhaps. It returns a hashref with the the values of options to be
872 Below handles these formats for the "selected" slot in the arguments hash:
873 Object (with id method)
874 Scalar (assumes it is value)
875 Array ref *OF* objects, arrays of data (0 elmnt used), hashes of data
876 (id key used), and simple scalars.
886 my $selected = $args->{selected};
887 return $selected unless $selected and ref $selected ne 'HASH';
888 my $type = ref $selected;
890 if ($type and $type ne 'ARRAY') {
891 return {$selected->id => 1};
895 return { $selected => 1};
898 # Array of objs, arrays, hashes, or just scalalrs.
899 elsif ($type eq 'ARRAY') {
901 my $ltype = ref $selected->[0];
903 if ($ltype and $ltype ne 'ARRAY') {
904 %hashed = map { $_->id => 1 } @$selected;
906 # Arrays of data with id first
907 elsif ($ltype and $ltype eq 'ARRAY') {
908 %hashed = map { $_->[0] => 1 } @$selected;
910 # Hashes using pk or id key
911 elsif ($ltype and $ltype eq 'HASH') {
912 my $pk = $args->{class}->primary_column || 'id';
913 %hashed = map { $_->{$pk} => 1 } @$selected;
917 %hashed = map { $_ => 1 } @$selected;
921 else { warn "AsForm Could not hash the selected argument: $selected"; }
927 Internal api method to make the actual select box form elements.
929 3 types of lists making for --
930 Array of CDBI objects.
932 Array or Array refs with cols from class.
938 my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
940 $args->{stringify} ||= 'stringify_selectbox';
941 $args->{selected} = _hash_selected($args);
942 my $name = $args->{name} || $col;
943 my $a = HTML::Element->new('select', name => $name);
944 $a->attr( %{$args->{attr}} ) if $args->{attr};
946 if ($args->{nullable}) {
947 my $null_element = HTML::Element->new('option');
948 $null_element->attr(selected => 'selected')
949 if ($args->{selected}{'null'});
950 $null_element->push_content('-- choose or type --');
951 $a->push_content($null_element);
954 my $items = $args->{items};
955 my $proto = $items->[0];
956 my $type = ref $proto || '';
960 $a->push_content($self->_options_from_scalars($items, $args));
962 elsif($type !~ /ARRAY|HASH/i) {
963 # make select of objects
964 $a->push_content($self->_options_from_objects($items, $args));
966 elsif ($type =~ /ARRAY/i) {
967 $a->push_content($self->_options_from_arrays($items, $args));
969 elsif ($type =~ /HASH/i) {
970 $a->push_content($self->_options_from_hashes($items, $args));
973 die "You passed a weird type of data structure to me. Here it is: $type";
985 =head2 _options_from_objects ( $objects, $args);
987 Private method to makes a options out of objects. It attempts to call each
988 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
991 sub _options_from_objects {
992 my ($self, $items, $args) = @_;
993 my $selected = $args->{selected} || {};
994 my $stringify = $args->{stringify} || '';
997 my $opt = HTML::Element->new("option", value => $_->id);
998 $opt->attr(selected => "selected") if $selected->{$_->id};
999 my $content = $stringify ? $_->$stringify : "$_";
1000 $opt->push_content($content);
1006 sub _options_from_arrays {
1007 my ($self, $items, $args) = @_;
1008 my $selected = $args->{selected} || {};
1010 my $class = $args->{class} || '';
1011 my $stringify = $args->{stringify} || '';
1012 for my $item (@$items) {
1014 push @pks, shift @$item foreach $class->columns('Primary');
1015 my $id = $pks[0] + 0; # In case zerofill is on .
1016 my $opt = HTML::Element->new("option", value => $id );
1017 $opt->attr(selected => "selected") if $selected->{$id};
1019 my $content = ($class and $stringify and $class->can($stringify)) ?
1020 $class->$stringify($_) :
1021 join( '/', map { $_ if $_; }@{$item} );
1022 $opt->push_content( $content );
1028 sub _options_from_scalars {
1029 my ($self, $items, $args) = @_;
1030 my $selected = $args->{selected} || {};
1033 my $opt = HTML::Element->new("option", value => $_ );
1034 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1035 $opt->attr(selected => "selected") if $selected->{$_};
1036 $opt->push_content( $_ );
1042 sub _options_from_hashes {
1043 my ($self, $items, $args) = @_;
1044 my $selected = $args->{selected} || {};
1045 my $pk = eval {$args->{class}->primary_column} || 'id';
1046 my $fclass = $args->{class} || '';
1047 my $stringify = $args->{stringify} || '';
1050 my $val = $_->{$pk};
1051 my $opt = HTML::Element->new("option", value => $val );
1052 $opt->attr(selected => "selected") if $selected->{$val};
1053 my $content = ($fclass && $stringify && $fclass->can($stringify)) ?
1054 $fclass->$stringify($_) :
1056 $opt->push_content( $content );
1063 # checkboxes: if no data in hand (ie called as class method), replace
1064 # with a radio button, in order to allow this field to be left
1065 # unspecified in search / add forms.
1068 # TODO -- make this general checkboxse
1072 my ($self, $col, $args) = @_;
1073 my $nullable = eval {self->column_nullable($col)} || 0;
1075 return $self->_to_radio($col) if !ref($self) || $nullable;
1076 my $value = $self->$col;
1077 my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1078 $a->attr("checked" => 'true') if $value eq 'Y';
1083 # TODO -- make this general radio butons
1086 my ($self, $col) = @_;
1087 my $value = ref $self && $self->$col || '';
1088 my $nullable = eval {self->column_nullable($col)} || 0;
1089 my $a = HTML::Element->new("span");
1090 my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1091 my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1092 my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1093 $ry->push_content('Yes'); $rn->push_content('No');
1094 $ru->push_content('n/a') if $nullable;
1095 if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1096 elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1097 elsif ($nullable) { $ru->attr("checked" => 'true') }
1098 $a->push_content($ry, $rn);
1099 $a->push_content($ru) if $nullable;
1105 ############################ HELPER METHODS ######################
1106 ##################################################################
1108 =head2 _rename_foreign_input
1110 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1112 Recursively renames the foreign inputs made by _to_foreign_inputs so they
1113 can be processed generically. The format is "accessor__AsForeign_colname".
1115 So if an Employee is a Person who has_own Address and you call
1117 Employee->to_field("person")
1119 then you will get inputs for the Person as well as their Address (by default,
1120 override _field_from_relationship to change logic) named like this:
1122 person__AsForeign__address__AsForeign__street
1123 person__AsForeign__address__AsForeign__city
1124 person__AsForeign__address__AsForeign__state
1125 person__AsForeign__address__AsForeign__zip
1127 And the processor would know to create this address, put the address id in
1128 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.
1130 Overriede make_element_foreign to change how you want a foreign param labeled.
1132 =head2 make_element_foreign
1134 $class->make_element_foreign($accessor, $element);
1136 Makes an HTML::Element type object foreign elemen representing the
1137 class's accessor. (IE this in an input element for $class->accessor :) )
1141 sub make_element_foreign {
1142 my ($self, $accssr, $element) = @_;
1143 $element->attr( name => $accssr . "__AsForeign__" . $element->attr('name'));
1148 sub _rename_foreign_input {
1149 my ($self, $accssr, $element) = @_;
1150 if ( ref $element ne 'HASH' ) {
1151 # my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
1152 $self->make_element_foreign($accssr, $element);
1155 $self->_rename_foreign_input($accssr, $element->{$_})
1156 foreach (keys %$element);
1161 This functions computes the dimensions of a textarea based on the value
1166 our ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1171 my @rows = split /^/, $text;
1172 my $cols = $min_cols;
1175 my $len = length $_;
1177 $cols = $len if $len > $cols;
1178 $cols = $max_cols if $cols > $max_cols;
1181 $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1182 $rows = $min_rows if $rows < $min_rows;
1183 $rows = $max_rows if $rows > $max_rows;
1186 else { ($min_rows, $min_cols) }
1199 =head1 ORIGINAL AUTHOR
1201 Peter Speltz, Aaron Trevena
1207 chekbox generalization
1208 radio generalization
1210 Make link_hidden use standard make_url stuff when it gets in Maypole
1211 How do you tell AF --" I want a has_many select box for this every time so,
1212 when you call "to_field($this_hasmany)" you get a select box
1214 =head1 BUGS and QUERIES
1216 Please direct all correspondence regarding this module to:
1219 =head1 COPYRIGHT AND LICENSE
1221 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1223 This library is free software; you can redistribute it and/or modify
1224 it under the same terms as Perl itself.
1228 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.