1 package Maypole::Model::CDBI::AsForm;
10 use Class::DBI::Plugin::Type ();
14 # pjs -- Added new methods to @EXPORT
17 to_cgi to_field _to_textarea _to_textfield _to_select
18 _to_foreign_inputs _to_enum_select _to_bool_select
19 _to_select_from_many _to_select_from_related _to_select_from_objs
20 _to_hidden _to_link_hidden _rename_foreign_input _to_readonly
21 _options_from_objects _options_from_arrays _options_from_hashes
23 _field_from_how _field_from_relationship _field_from_column
24 _select_guts unselect_element search_inputs make_param_foreign
29 # 11-05-05 - added _to_link_hidden to make a link to the hidden object
30 # - fixed _to_hidden when called with no args. Hides self obj.
31 # 11-04-05 - _to_textfield: tries to call "deflate4edit" if column is has_a
32 # 11-08-05 - Changed Version to .08
36 # 1-10-06 -- fixed bug in to_textfiled that was stringifyingf CDBI objects
39 # 1-20-06 - to_select - call db_Main with has a class.
40 # 1-24-06 - to_select_from_many now named _to_select_from_many . Old deprecated
41 # - hasmany_class removed in favor of model's related_class method.
42 # - took out do_select. That is a model action.
43 # - use search_columns instead of search_fields now.
44 # - use to_field('column', 'select', {args}) instead of a_select_box.
45 # -- took out make_hidden_element.was my own personal hack
46 # -- added _box from DH's FormView to calculate decent textarea size
47 # -- Refactor to_field into _from_* method calls.
49 # 1-25-06 -- Added _to_checkbox and _to_radio from FView
50 # 1-27-06 -- Refactored into yet more exported methods
51 # 1-28-06 -- select constraints where, join order by
56 Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns
61 use Maypole::Model::CDBI::AsForm;
62 use base 'Class::DBI';
68 my %cgi_field = $self->to_cgi;
70 (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
75 . . . somewhere use to_field($col, $how, $args)
77 __PACKAGE__->has_a('drinker', 'BeerDB::Drinker');
78 __PACKAGE__->has_a('beer', 'BeerDB::Beer');
79 package BeerDB::Drinker;
80 __PACKAGE__->has_many('pints', 'BeerDB::Pint');
83 my $sel = BeerDB::Drinker->to_field('pints', 'select') # multiple
84 my $sel = $Drunk->to_field('pints', 'select'); # Already had beers selected
88 __PACKAGE__->has_a('employer' => 'Employer');
89 __PACKAGE__->has_a('contact' => 'Contact')
93 __PACKAGE__->has_a('employer_also' => 'Employer');
94 __PACKAGE__->has_many('jobs' => 'Job',
95 { join => { employer => 'employer_also' },
96 constraint => { 'finshed' => 0 },
97 order_by => "created ASC",
103 __PACKAGE__->has_many('jobs' => 'Job',);
104 __PACKAGE__->has_many('contacts' => 'Contact',
105 order_by => 'name DESC',
109 # Below gives select boxes with the multiple attribute.
110 my $select_jobs_for_new_contact =
111 Contact->to_field('jobs', 'select'); # Uses constraint and order by
113 my $edit_jobs_for_existing_contact =
114 $contact->to_field('jobs', 'select');
124 This module helps to generate HTML forms for creating new database rows
125 or editing existing rows. It maps column names in a database table to
126 HTML form elements which fit the schema. Large text fields are turned
127 into textareas, and fields with a has-a relationship to other
128 C<Class::DBI> tables are turned into select drop-downs populated with
129 objects from the joined class.
133 The module is a mix-in which adds two additional methods to your
134 C<Class::DBI>-derived class.
139 Returns hashref of search inputs elements to use in cgi.
141 Uses fields specified in search_fields, makes foreign inputs if necessary.
145 # TODO -- use search_columns
147 my ($class, $r) = @_;
148 warn "In model search_inputs " if $class->model_debug;
149 $class = ref $class || $class;
150 #my $accssr_class = { $class->accessor_classes };
152 my $sfs = [$class->search_columns];
154 foreach my $field ( @$sfs ) {
155 if ( ref $field eq "HASH" ) { # foreign search fields
156 my ($accssr, $cols) = each %$field;
158 # default to search fields for related
159 #$cols = $accssr_class->{$accssr}->search_columns;
160 die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
162 my $fcgi = $class->_to_foreign_inputs($accssr, $cols);
163 # unset the default values for a select box
164 foreach (keys %$fcgi) {
165 $class->unselect_element($fcgi->{$_});
167 $cgi{$accssr} = $fcgi;
169 $cgi{$field} = $class->to_field($field);
170 $class->unselect_element($cgi{$field});
178 =head2 unselect_element
180 Unselects all options in a HTML::Element of type select.
181 It does nothing if element is not a select element.
185 sub unselect_element {
186 my ($self, $el) = @_;
187 #unless (ref $el eq 'HTML::Element') {
188 #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
189 if ($el->tag eq 'select') {
190 foreach my $opt ($el->content_list) {
191 $opt->attr('selected', undef) if $opt->attr('selected');
197 # make a select box from args
199 my ($self, $name, $vals, $selected_val, $contents) = @_;
200 die "Usage: Need a name and array ref of values to make a select boxes" unless ($name && $vals);
201 $selected_val ||= "";
202 $contents ||= $vals ;
204 my $a = HTML::Element->new('select', 'name' => $name);
207 foreach my $v ( @$vals ) {
208 my $opt = HTML::Element->new('option', 'value' => $v);
209 $opt->attr('selected' => 'selected') if $v eq $selected_val;
210 $c = $contents->[$i++] || $v;
211 $opt->push_content($c);
212 $a->push_content($opt);
219 =head2 make_param_foreign
221 Makes a new foreign parameter out of parameter and accessor
222 Just puts accssr__FOREIGN__ in front of param name
226 sub make_param_foreign {
227 my ($self, $r, $p, $accssr) = @_;
228 $r->params->{$accssr . '__FOREIGN__' . $p} = $r->params->{$p};
233 This returns a hash mapping all the column names of the class to
234 HTML::Element objects representing form widgets.
236 pjs -- added a columns list argument to specify which columns to make
242 my ($class, @columns) = @_; # pjs -- added columns arg
243 @columns = $class->columns unless (@columns);
244 map { $_ => $class->to_field($_) } @columns;
248 =head2 to_field($field [, $how])
250 This maps an individual column to a form element. The C<how> argument
251 can be used to force the field type into one of C<textfield>, C<textarea>
252 or C<select>; you can use this is you want to avoid the automatic detection
253 of has-a relationships.
256 -- added support for enum and bool. Note for enum and bool you need
257 a better column_type method than the Plugin::Type ' s as it won't work
258 if you are using MySQL. I have not tried others.
259 See those method's docs below.
260 -- Foreign inputs for might_have, must_have, has_own, and has_many(i think).
261 -- Really any relationship except has_a and is_a as has_a gets a select box
262 and is_a are not considered foreign.
263 -- Note a good column_type sub can be
264 used to get the correct type for is_a columns.
265 -- More efficient _to_select -- no object creation.
266 -- Attempts to set default value in field for you using a "column_default"
267 method you write yourself or your CDBI driver like mysql writes.
273 my ($self, $field, @args) = @_;
274 my $how = shift @args unless ref $args[0];
275 my $args = shift @args; # argument hash ref
277 return $self->_field_from_how($field, $how, $args) ||
278 $self->_field_from_relationship($field, $args) ||
279 $self->_field_from_column($field, $args) ||
280 $self->_to_textfield($field, $args);
283 =head2 _field_from_how($field, $how,$args)
285 Returns an input element based the "how" parameter or nothing at all.
290 sub _field_from_how {
291 my ($self, $field, $how, $args) = @_;
294 my $meth = "_to_$how";
295 return $self->$meth($field, $args) if $self->can($meth);
300 =head2 _field_from_relationship($field, $args)
302 Returns an input based on the relationship associated with the field or nothing.
307 sub _field_from_relationship {
308 my ($self, $field, $args) = @_;
309 my $meta = $self->meta_info;
310 my ($rel_type) = grep{ defined $meta->{$_}{$field} } keys %$meta;
312 my $fclass = $rel_type ? $meta->{$rel_type}{$field}{foreign_class} : '';
313 $args->{class} = $fclass;
314 my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
317 return $self->_to_select($field, $args)
318 if $rel_type eq 'has_a' and $fclass_is_cdbi;
320 # maybe foreign inputs
321 my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
322 if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_type eq 'has_own'))
324 return $self->_to_foreign_inputs($field, undef, $meta->{$rel_type}{$field});
329 =head2 _field_from_column($field, $args)
331 Returns an input based on the column's characteristics, namely type, or nothing.
336 sub _field_from_column {
337 my ($self, $field, $args) = @_;
338 my $class = ref $self || $self;
340 unless ($args->{column_type}) {
341 if ($class->can('column_type')) {
342 $args->{column_type} = $class->column_type($field);
345 # Right, have some of this
346 eval "package $class; Class::DBI::Plugin::Type->import()";
347 $args->{column_type} = $class->column_type($field);
350 my $type = $args->{column_type};
352 return $self->_to_textfield($field)
353 if $type and $type =~ /(VAR)?CHAR/i; #common type
354 return $self->_to_textarea($field, $args)
355 if $type and $type =~ /^(TEXT|BLOB)$/i;
356 return $self->_to_enum_select($field, $args)
357 if $type and $type =~ /^ENUM\((.*?)\)$/i;
358 return $self->_to_bool_select($field, $args)
359 if $type and $type =~ /^BOOL/i;
360 return $self->_to_readonly($field, $args)
361 if $type and $type =~ /^readonly$/i;
367 my ($self, $col, $args) = @_;
370 my $val = $args->{value};
372 unless (defined $val) {
377 $val = eval {$self->column_default($col);};
378 $val = '' unless defined $val;
381 my ($rows, $cols) = _box($val);
382 $rows = $args->{rows} if $args->{rows};
383 $cols = $args->{cols} if $args->{cols};;
384 my $name = $args->{name} || $col;
386 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
387 $a->push_content($val);
388 $OLD_STYLE && return $a->as_HTML;
393 my ($self, $col, $args ) = @_;
395 my $val = $args->{value};
396 my $name = $args->{name} || $col;
398 unless (defined $val) {
400 # Case where column inflates.
401 # Input would get stringification which could be not good.
402 # as in the case of Time::Piece objects
405 if (my $meta = $self->related_meta('',$col)) {
406 if (my $code = $meta->{args}{deflate4edit} ) {
407 $val = ref $code ? &$code($val) : $val->$code;
410 $val = $self->_attr($col);
414 $val = $self->_attr($col);
420 $val = eval {$self->column_default($col);};
421 $val = '' unless defined $val;
424 my $a = HTML::Element->new("input", type => "text", name => $name);
425 $a->attr("value" => $val);
426 $OLD_STYLE && return $a->as_HTML;
431 # Too expensive version -- TODO
433 # my ($self, $col, $hint) = @_;
434 # my $fclass = $hint || $self->__hasa_rels->{$col}->[0];
435 # my @objs = $fclass->retrieve_all;
436 # my $a = HTML::Element->new("select", name => $col);
438 # my $sel = HTML::Element->new("option", value => $_->id);
439 # $sel->attr("selected" => "selected")
441 # and eval { $_->id eq $self->$col->id };
442 # $sel->push_content($_->stringify_self);
443 # $a->push_content($sel);
445 # $OLD_STYLE && return $a->as_HTML;
452 # -- Rewrote this to be efficient -- no object creation.
453 # -- Added option for CDBI classes to specify a limiting clause
454 # via "has_a_select_limit".
455 # -- Added selected argument to set a selected
457 =head2 recognized arguments
459 selected => $object|$id,
462 where => SQL 'WHERE' clause,
463 order_by => SQL 'ORDER BY' clause,
464 limit => SQL 'LIMIT' clause,
465 items => [ @items_of_same_type_to_select_from ],
466 class => $class_we_are_selecting_from
467 stringify => $stringify_coderef|$method_name
472 # select box requirements
473 # 1. a select box for objecs of a has_a related class -- DONE
474 =head2 1. a select box out of a has_a or has_many related class.
475 # For has_a the default behavior is to make a select box of every element in
476 # related class and you choose one.
477 #Or explicitly you can create one and pass options like where and order
478 BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
480 # For has_many the default is to get a multiple select box with all objects.
481 # If called as an object method, the objects existing ones will be selected.
482 Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"});
485 =head2 2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun.
487 BeerDB::Beer->to_field('', 'select', $options)
489 BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
490 # with PK as ID, $Class->to_field() same.
491 BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
492 # specify exact where clause
494 =head2 3. If you already have a list of objects to select from --
496 BeerDB:;Beer->to_field($col, 'select' , {items => $objects});
498 # 3. a select box for arbitrary set of objects
499 # Pass array ref of objects as first arg rather than field
500 $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
506 my ($self, $col, $args) = @_;
508 # Do we have items already ? Go no further.
509 if ($args->{items}) {
510 my $a = $self->_select_guts($col, $args);
511 $OLD_STYLE && return $a->as_HTML;
515 # Else what are we making a select box out of ?
516 # No Column parameter -- means making a select box of args->class or self
517 # Using all rows from class's table
519 warn "No col. $self";
520 unless ($args->{class}) {
521 $args->{class} = ref $self || $self;
522 # object selected if called with one
523 $args->{selected} = { $self->id => 1}
524 if not $args->{selected} and ref $self;
526 $col = $args->{class}->primary_column;
528 # Related Class maybe ?
529 elsif (my ($rel_type, $rel_meta) = $self->related_meta('r:)', $col) ) {
530 $args->{class} = $rel_meta->{foreign_class};
531 # related objects pre selected if object
532 $args->{selected} ||= [ $self->$col ] if ref $self;
534 # "Has many" -- we get multiple select
535 if ($rel_type =~ /has_many/i) {
536 $args->{attr}{multiple} = 'multiple';
537 # TODO -- handle mapping
539 my $c = $rel_meta->{args}{constraint} || {};
540 my $j = $rel_meta->{args}{join} || {};
543 @join = map { $_ ." = ". $self->_attr($_) } keys %$j;
545 my @constr= map { "$_ = '$c->{$_}'"} keys %$c;
546 $args->{where} ||= join (' AND ', (@join, @constr));
547 $args->{order_by} ||= $rel_meta->{args}{order_by};
548 $args->{limit} ||= $rel_meta->{args}{limit};
551 # We could say :Col is name and we are selecting out of class arg.
554 #$args->{name} = $col;
555 die "Usage _to_select. $col not related to any class to select from. ";
560 if ( $self->can('column_nullable') ) {
561 $args->{nullable} ||= $self->column_nullable($col);
564 # Get items to select from
565 $args->{items} = _select_items($args);
567 warn "Just got items. They are " . Dumper($args->{items});
569 # Make select HTML element
570 $a = $self->_select_guts($col, $args);
573 $OLD_STYLE && return $a->as_HTML;
585 my $fclass = $args->{class};
587 @select_box_cols = $fclass->columns('SelectBox');
588 @select_box_cols = $fclass->columns('Stringify')
589 unless @select_box_cols;
590 @select_box_cols = $fclass->_essential
591 unless @select_box_cols;
592 unshift @select_box_cols, $fclass->columns('Primary')
593 unless $select_box_cols[0] eq $fclass->columns('Primary');
595 my $sql = "SELECT " . join( ', ', @select_box_cols) .
596 " FROM " . $fclass->table;
598 $sql .= " WHERE " . $args->{where} if $args->{where};
599 $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
600 $sql .= " LIMIT " . $args->{limit} if $args->{limit};
601 warn "_select_items sql is : $sql";
603 return $fclass->db_Main->selectall_arrayref($sql);
608 # Makes a readonly input box out of column's value
609 # No args makes object to readonly
611 my ($self, $col, $val) = @_;
612 if (! $col) { # object to readonly
614 $col = $self->primary_column;
616 unless (defined $val) {
617 $self->_croak("Cannot get value in _to_readonly .")
621 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
622 'name' => $col, 'value'=>$val);
623 $OLD_STYLE && return $a->as_HTML;
628 =head2 _to_enum_select
630 $sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");
632 Returns an enum select box given a column name and an enum string.
633 NOTE: The Plugin::Type does not return an enum string for mysql enum columns.
634 This will not work unless you write your own column_type method in your model.
638 sub _to_enum_select {
639 my ($self, $col, $type) = @_;
640 $type =~ /ENUM\((.*?)\)/i;
641 (my $enum = $1) =~ s/'//g;
642 my @enum_vals = split /\s*,\s*/, $enum;
644 # determine which is pre selected --
645 # if obj, the value is , otherwise use column_default which is the first
646 # value in the enum list unless it has been overridden
647 my $selected = eval { $self->$col };
648 $selected = eval{$self->column_default($col)} unless defined $selected;
649 $selected = $enum_vals[0] unless defined $selected;
652 my $a = HTML::Element->new("select", name => $col);
654 my $sel = HTML::Element->new("option", value => $_);
655 $sel->attr("selected" => "selected") if $_ eq $selected ;
656 $sel->push_content($_);
657 $a->push_content($sel);
659 $OLD_STYLE && return $a->as_HTML;
664 =head2 _to_bool_select
666 my $sel = $self->_to_bool_select($column, $bool_string);
668 This makes select input for boolean column. You can provide a
669 bool string of form: Bool('zero','one') and those are used for option
670 content. Onthervise No and Yes are used.
671 TODO -- test without bool string.
675 sub _to_bool_select {
676 my ($self, $col, $type) = @_;
677 my @bool_text = ('No', 'Yes');
678 if ($type =~ /BOOL\((.+?)\)/i) {
679 (my $bool = $1) =~ s/'//g;
680 @bool_text = split /,/, $bool;
682 my $one= ref $self ? eval {$self->$col;} : $self->column_default($col);
683 my $a = HTML::Element->new("select", name => $col);
684 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
685 HTML::Element->new("option", value => 1) );
686 $opt0->attr("selected" => "selected") if not $one;
687 $opt0->push_content($bool_text[0]);
688 $opt1->attr("selected" => "selected") if $one;
689 $opt1->push_content($bool_text[1]);
690 $a->push_content($opt0, $opt1);
691 $OLD_STYLE && return $a->as_HTML;
696 =head2 _to_hidden($col, $args)
698 This makes a hidden html element. Give it a name and value or if name is
699 a ref it will use the PK name and value of the object.
704 my ($self, $name, $val) = @_;
707 if (ref $name and $name->isa("Class::DBI")) {
709 $name= ($obj->primary_columns)[0]->name;
713 $val = $args->{value};
714 $name = $args->{name} if $args->{name};
716 elsif (not $name ) { # hidding object caller
717 $self->_croak("No object available in _to_hidden") unless ref $self;
718 $name = ($self->primary_column)[0]->name;
721 return HTML::Element->new('input', 'type' => 'hidden',
722 'name' => $name, 'value'=>$val
726 =head2 _to_link_hidden($col, $args)
728 Makes a link with a hidden input with the id of $obj as the value and name.
729 Name defaults to the objects primary key. The object defaults to self.
733 sub _to_link_hidden {
734 my ($self, $accessor, $args) = @_;
735 my $r = $args->{r} || '';
736 my $url = $args->{url} || '';
738 $self->_croak("_to_link_hidden called without Maypole Request object (\$r) and url. Need one or other.")
741 if (ref $self) { # hidding linking self
743 $name = $args->{name} || $obj->primary_column->name;
745 else { # hiding linking related object with id in args
746 $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
747 $name = $args->{name} || $obj->primary_column->name; # TODO make use meta data
749 $self->_croak("_to_link_hidden has no object") unless ref $obj;
750 my $href = $url || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
751 my $a = HTML::Element->new('a', 'href' => $href);
752 $a->push_content("$obj");
753 $a->push_content($self->_to_hidden($name, $obj->id));
754 $OLD_STYLE && return $a->as_HTML;
760 =head2 _to_foreign_inputs
762 $html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]);
764 Get inputs for the accessor's class. Pass an array ref of fields to get
765 inputs for only those fields. Otherwise display_columns or all columns is used.
766 If you have the meta info handy for the accessor you can pass that too.
768 TODO make AsForm know more about the request like what action we are doing
769 so it can use edit columns or search_columns
771 NOTE , this names the foreign inputs is a particular way so they can be
772 processed with a general routine and so there are not name clashes.
776 sub _to_foreign_inputs {
777 my ($self, $accssr, $fields, $accssr_meta) = @_;
779 my $class_meta = $self->meta_info;
780 my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
782 $self->_croak( "No relationship for accessor $accssr") if not $rel_type;
783 $accssr_meta = $class_meta->{$rel_type}->{$accssr};
786 my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $accssr_meta->{foreign_class};
789 $fields = $classORobj->can('display_columns') ?
790 [$classORobj->display_columns] : [$classORobj->columns];
793 # Ignore our fkey in them to prevent infinite recursion
794 my $me = eval {$accssr_meta->{args}{foreign_column}} || '';
795 my $constrained = $accssr_meta->{args}{constraint};
797 foreach ( @$fields ) {
798 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
799 $inputs{$_} = $classORobj->to_field($_);
802 # Make hidden inputs for constrained columns unless we are editing object
803 # TODO -- is this right thing to do?
804 unless (ref $classORobj) {
805 $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_})
806 foreach ( keys %$constrained );
808 $self->_rename_foreign_input($accssr, \%inputs);
813 =head2 _hash_selected
815 Method to make sense out of the "selected" argument which can be in a number
816 of formats perhaps. It returns a hashref with the the values of options to be
819 Below handles these formats for the "selected" slot in the arguments hash:
820 Object (with id method)
821 Scalar (assumes it is value)
822 Array ref *OF* objects, arrays of data (0 elmnt used), hashes of data
823 (id key used), and simple scalars.
833 my $selected = $args->{selected};
834 return $selected unless $selected and ref $selected ne 'HASH';
835 my $type = ref $selected;
837 if ($type and $type ne 'ARRAY') {
838 return {$selected->id => 1};
842 return { $selected => 1};
845 # Array of objs, arrays, hashes, or just scalalrs.
846 elsif ($type eq 'ARRAY') {
848 my $ltype = ref $selected->[0];
850 if ($ltype and $ltype ne 'ARRAY') {
851 %hashed = map { $_->id => 1 } @$selected;
853 # Arrays of data with id first
854 elsif ($ltype and $ltype eq 'ARRAY') {
855 %hashed = map { $_->[0] => 1 } @$selected;
857 # Hashes using pk or id key
858 elsif ($ltype and $ltype eq 'HASH') {
859 my $pk = $args->{class}->primary_column || 'id';
860 %hashed = map { $_->{$pk} => 1 } @$selected;
864 %hashed = map { $_ => 1 } @$selected;
868 else { warn "AsForm Could not hash the selected argument: $selected"; }
876 Internal api method to make the actual select box form elements.
878 3 types of lists making for --
879 Array of CDBI objects.
881 Array or Array refs with cols from class.
887 my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
889 $args->{stringify} ||= 'stringify_selectbox';
890 $args->{selected} = _hash_selected($args);
891 my $name = $args->{name} || $col;
892 my $a = HTML::Element->new('select', name => $name);
893 $a->attr( %{$args->{attr}} ) if $args->{attr};
895 if ($args->{nullable}) {
896 my $null_element = HTML::Element->new('option');
897 $null_element->attr(selected => 'selected')
898 if $args->{selected}{'null'};
899 $null_element->push_content('-- choose or type --');
900 $a->push_content($null_element);
903 my $items = $args->{items};
904 my $proto = $items->[0];
905 my $type = ref $proto || '';
908 if ($type and $type !~ /ARRAY|HASH/i) {
909 # make select of objects
910 $a->push_content($self->_options_from_objects($items, $args));
912 elsif ($type =~ /ARRAY/i) {
913 $a->push_content($self->_options_from_arrays($items, $args));
915 elsif ($type =~ /HASH/i) {
916 $a->push_content($self->_options_from_hashes($items, $args));
919 $a->push_content($self->_options_from_scalars($items, $args));
931 =head2 _options_from_objects ( $objects, $args);
933 Private method to makes a options out of objects. It attempts to call each
934 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
937 sub _options_from_objects {
938 my ($self, $items, $args) = @_;
939 my $selected = $args->{selected} || {};
940 my $stringify = $args->{stringify} || '';
943 my $opt = HTML::Element->new("option", value => $_->id);
944 $opt->attr(selected => "selected") if $selected->{$_->id};
945 my $content = $stringify ? $_->$stringify : "$_";
946 $opt->push_content($content);
952 sub _options_from_arrays {
953 my ($self, $items, $args) = @_;
954 my $selected = $args->{selected} || {};
956 my $fclass = $args->{class} || '';
957 my $stringify = $args->{stringify} || '';
960 my $opt = HTML::Element->new("option", value => $id );
961 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
962 $opt->attr(selected => "selected") if $selected->{$id};
964 my $content = ($fclass and $stringify and $fclass->can($stringify)) ?
965 $fclass->$stringify($_) :
968 warn "Content is $content";
969 $opt->push_content( $content );
975 sub _options_from_scalars {
976 my ($self, $items, $args) = @_;
977 my $selected = $args->{selected} || {};
980 my $opt = HTML::Element->new("option", value => $_ );
981 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
982 $opt->attr(selected => "selected") if $selected->{$_};
983 $opt->push_content( $_ );
989 sub _options_from_hashes {
990 my ($self, $items, $args) = @_;
991 my $selected = $args->{selected} || {};
992 my $pk = eval {$args->{class}->primary_column} || 'id';
993 my $fclass = $args->{class} || '';
994 my $stringify = $args->{stringify} || '';
998 my $opt = HTML::Element->new("option", value => $val );
999 $opt->attr(selected => "selected") if $selected->{$val};
1000 my $content = $fclass and $stringify and $fclass->can($stringify) ?
1001 $fclass->$stringify($_) :
1003 $opt->push_content( $content );
1010 # checkboxes: if no data in hand (ie called as class method), replace
1011 # with a radio button, in order to allow this field to be left
1012 # unspecified in search / add forms.
1015 # TODO -- make this general checkboxse
1019 my ($self, $col, $args) = @_;
1020 my $nullable = eval {self->column_nullable($col)} || 0;
1022 return $self->_to_radio($col) if !ref($self) || $nullable;
1023 my $value = $self->$col;
1024 my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1025 $a->attr("checked" => 'true') if $value eq 'Y';
1030 # TODO -- make this general radio butons
1033 my ($self, $col) = @_;
1034 my $value = ref $self && $self->$col || '';
1035 my $nullable = eval {self->column_nullable($col)} || 0;
1036 my $a = HTML::Element->new("span");
1037 my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1038 my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1039 my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1040 $ry->push_content('Yes'); $rn->push_content('No');
1041 $ru->push_content('n/a') if $nullable;
1042 if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1043 elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1044 elsif ($nullable) { $ru->attr("checked" => 'true') }
1045 $a->push_content($ry, $rn);
1046 $a->push_content($ru) if $nullable;
1052 ############################ HELPER METHODS ######################
1053 ##################################################################
1055 =head2 _rename_foreign_input
1057 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1059 Recursively renames the foreign inputs made by to_foreign_inputs so they
1060 can be processed generically. The format is "accessor__AsForeign_colname".
1062 So if an Employee is a Person who has own Address and you call
1064 Employee->to_field("person")
1066 then you will get inputs for Address named like this:
1068 person__AsForeign__address__AsForeign__street
1069 person__AsForeign__address__AsForeign__city
1070 person__AsForeign__address__AsForeign__state
1071 person__AsForeign__address__AsForeign__zip
1073 And the processor would know to create this address, put the address id in
1074 person address slot, create the person and put the address id in the employee
1075 before creating the employee.
1079 sub _rename_foreign_input {
1080 my ($self, $accssr, $input) = @_;
1081 if ( ref $input ne 'HASH' ) {
1082 # my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
1083 $input->attr( name => $accssr . "__AsForeign__" . $input->attr('name'));
1086 $self->_rename_foreign_input($accssr, $input->{$_})
1087 foreach (keys %$input);
1092 This functions computes the dimensions of a textarea based on the value
1097 our ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1102 my @rows = split /^/, $text;
1103 my $cols = $min_cols;
1106 my $len = length $_;
1108 $cols = $len if $len > $cols;
1109 $cols = $max_cols if $cols > $max_cols;
1112 $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1113 $rows = $min_rows if $rows < $min_rows;
1114 $rows = $max_rows if $rows > $max_rows;
1117 else { ($min_rows, $min_cols) }
1130 =head1 ORIGINAL AUTHOR
1132 Peter Speltz, Aaron Trevena
1138 chekbox generalization
1139 radio generalization
1141 Make link_hidden use standard make_url stuff when it gets in Maypole
1142 How do you tell AF --" I want a has_many select box for this every time so,
1143 when you call "to_field($this_hasmany)" you get a select box
1145 =head1 BUGS and QUERIES
1147 Please direct all correspondence regarding this module to:
1150 =head1 COPYRIGHT AND LICENSE
1152 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1154 This library is free software; you can redistribute it and/or modify
1155 it under the same terms as Perl itself.
1159 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.