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
27 our $VERSION = '2.11';
31 Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns
36 use Maypole::Model::CDBI::AsForm;
37 use base 'Class::DBI';
43 my %cgi_field = $self->to_cgi;
45 (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
50 . . . somewhere use to_field($col, $how, $args)
52 __PACKAGE__->has_a('drinker', 'BeerDB::Drinker');
53 __PACKAGE__->has_a('beer', 'BeerDB::Beer');
54 package BeerDB::Drinker;
55 __PACKAGE__->has_many('pints', 'BeerDB::Pint');
58 my $sel = BeerDB::Drinker->to_field('pints', 'select') # multiple
59 my $sel = $Drunk->to_field('pints', 'select'); # Already had beers selected
63 __PACKAGE__->has_a('employer' => 'Employer');
64 __PACKAGE__->has_a('contact' => 'Contact')
68 __PACKAGE__->has_a('employer_also' => 'Employer');
69 __PACKAGE__->has_many('jobs' => 'Job',
70 { join => { employer => 'employer_also' },
71 constraint => { 'finshed' => 0 },
72 order_by => "created ASC",
78 __PACKAGE__->has_many('jobs' => 'Job',);
79 __PACKAGE__->has_many('contacts' => 'Contact',
80 order_by => 'name DESC',
84 # Below gives select boxes with the multiple attribute.
85 my $select_jobs_for_new_contact =
86 Contact->to_field('jobs', 'select'); # Uses constraint and order by
88 my $edit_jobs_for_existing_contact =
89 $contact->to_field('jobs', 'select');
98 This module helps to generate HTML forms for creating new database rows
99 or editing existing rows. It maps column names in a database table to
100 HTML form elements which fit the schema. Large text fields are turned
101 into textareas, and fields with a has-a relationship to other
102 C<Class::DBI> tables are turned into select drop-downs populated with
103 objects from the joined class.
107 The module is a mix-in which adds two additional methods to your
108 C<Class::DBI>-derived class.
113 Returns hashref of search inputs elements to use in cgi.
115 Uses fields specified in search_fields, makes foreign inputs if necessary.
119 # TODO -- use search_columns
122 my ($class, $r) = @_;
123 warn "In model search_inputs " if $class->model_debug;
124 $class = ref $class || $class;
125 #my $accssr_class = { $class->accessor_classes };
127 my $sfs = [$class->search_columns];
129 foreach my $field ( @$sfs ) {
130 if ( ref $field eq "HASH" ) { # foreign search fields
131 my ($accssr, $cols) = each %$field;
133 # default to search fields for related
134 #$cols = $accssr_class->{$accssr}->search_columns;
135 die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
137 my $fcgi = $class->_to_foreign_inputs($accssr, $cols);
138 # unset the default values for a select box
139 foreach (keys %$fcgi) {
140 $class->unselect_element($fcgi->{$_});
142 $cgi{$accssr} = $fcgi;
144 $cgi{$field} = $class->to_field($field);
145 $class->unselect_element($cgi{$field});
153 =head2 unselect_element
155 Unselects all options in a HTML::Element of type select.
156 It does nothing if element is not a select element.
160 sub unselect_element {
161 my ($self, $el) = @_;
162 #unless (ref $el eq 'HTML::Element') {
163 #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
164 if ($el->tag eq 'select') {
165 foreach my $opt ($el->content_list) {
166 $opt->attr('selected', undef) if $opt->attr('selected');
174 Returns a HTML::Element representing a select box, based on the arguments
178 # make a select box from args
180 my ($self, $name, $vals, $selected_val, $contents) = @_;
181 die "Usage: Need a name and array ref of values to make a select boxes" unless ($name && $vals);
182 $selected_val ||= "";
183 $contents ||= $vals ;
185 my $a = HTML::Element->new('select', 'name' => $name);
188 foreach my $v ( @$vals ) {
189 my $opt = HTML::Element->new('option', 'value' => $v);
190 $opt->attr('selected' => 'selected') if $v eq $selected_val;
191 $c = $contents->[$i++] || $v;
192 $opt->push_content($c);
193 $a->push_content($opt);
200 =head2 make_param_foreign
202 Makes a new foreign parameter out of parameter and accessor
203 Just puts accssr__FOREIGN__ in front of param name
207 sub make_param_foreign {
208 my ($self, $r, $p, $accssr) = @_;
209 $r->params->{$accssr . '__FOREIGN__' . $p} = $r->params->{$p};
214 This returns a hash mapping all the column names of the class to
215 HTML::Element objects representing form widgets.
217 pjs -- added a columns list argument to specify which columns to make
223 my ($class, @columns) = @_; # pjs -- added columns arg
224 @columns = $class->columns unless (@columns);
225 map { $_ => $class->to_field($_) } @columns;
229 =head2 to_field($field [, $how])
231 This maps an individual column to a form element. The C<how> argument
232 can be used to force the field type into one of C<textfield>, C<textarea>
233 or C<select>; you can use this is you want to avoid the automatic detection
234 of has-a relationships.
237 -- added support for enum and bool. Note for enum and bool you need
238 a better column_type method than the Plugin::Type ' s as it won't work
239 if you are using MySQL. I have not tried others.
240 See those method's docs below.
241 -- Foreign inputs for might_have, must_have, has_own, and has_many(i think).
242 -- Really any relationship except has_a and is_a as has_a gets a select box
243 and is_a are not considered foreign.
244 -- Note a good column_type sub can be
245 used to get the correct type for is_a columns.
246 -- More efficient _to_select -- no object creation.
247 -- Attempts to set default value in field for you using a "column_default"
248 method you write yourself or your CDBI driver like mysql writes.
254 my ($self, $field, @args) = @_;
255 my $how = shift @args unless ref $args[0];
256 my $args = shift @args; # argument hash ref
258 return $self->_field_from_how($field, $how, $args) ||
259 $self->_field_from_relationship($field, $args) ||
260 $self->_field_from_column($field, $args) ||
261 $self->_to_textfield($field, $args);
264 =head2 _field_from_how($field, $how,$args)
266 Returns an input element based the "how" parameter or nothing at all.
271 sub _field_from_how {
272 my ($self, $field, $how, $args) = @_;
275 my $meth = "_to_$how";
276 return $self->$meth($field, $args) if $self->can($meth);
281 =head2 _field_from_relationship($field, $args)
283 Returns an input based on the relationship associated with the field or nothing.
288 sub _field_from_relationship {
289 my ($self, $field, $args) = @_;
290 my $meta = $self->meta_info;
291 my ($rel_type) = grep{ defined $meta->{$_}{$field} } keys %$meta;
293 my $fclass = $rel_type ? $meta->{$rel_type}{$field}{foreign_class} : '';
294 $args->{class} = $fclass;
295 my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
298 return $self->_to_select($field, $args)
299 if $rel_type eq 'has_a' and $fclass_is_cdbi;
301 # maybe foreign inputs
302 my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
303 if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_type eq 'has_own'))
305 return $self->_to_foreign_inputs($field, undef, $meta->{$rel_type}{$field});
310 =head2 _field_from_column($field, $args)
312 Returns an input based on the column's characteristics, namely type, or nothing.
317 sub _field_from_column {
318 my ($self, $field, $args) = @_;
319 my $class = ref $self || $self;
321 unless ($args->{column_type}) {
322 if ($class->can('column_type')) {
323 $args->{column_type} = $class->column_type($field);
325 # Right, have some of this
326 eval "package $class; Class::DBI::Plugin::Type->import()";
327 $args->{column_type} = $class->column_type($field);
330 my $type = $args->{column_type};
332 return $self->_to_textfield($field)
333 if $type and $type =~ /(VAR)?CHAR/i; #common type
334 return $self->_to_textarea($field, $args)
335 if $type and $type =~ /^(TEXT|BLOB)$/i;
336 return $self->_to_enum_select($field, $args)
337 if $type and $type =~ /^ENUM\((.*?)\)$/i;
338 return $self->_to_bool_select($field, $args)
339 if $type and $type =~ /^BOOL/i;
340 return $self->_to_readonly($field, $args)
341 if $type and $type =~ /^readonly$/i;
347 my ($self, $col, $args) = @_;
350 my $val = $args->{value};
352 unless (defined $val) {
357 $val = eval {$self->column_default($col);};
358 $val = '' unless defined $val;
361 my ($rows, $cols) = _box($val);
362 $rows = $args->{rows} if $args->{rows};
363 $cols = $args->{cols} if $args->{cols};;
364 my $name = $args->{name} || $col;
366 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
367 $a->push_content($val);
368 $OLD_STYLE && return $a->as_HTML;
373 my ($self, $col, $args ) = @_;
375 my $val = $args->{value};
376 my $name = $args->{name} || $col;
378 unless (defined $val) {
380 # Case where column inflates.
381 # Input would get stringification which could be not good.
382 # as in the case of Time::Piece objects
385 if (my $meta = $self->related_meta('',$col)) {
386 if (my $code = $meta->{args}{deflate4edit} ) {
387 $val = ref $code ? &$code($val) : $val->$code;
390 $val = $self->_attr($col);
394 $val = $self->_attr($col);
400 $val = eval {$self->column_default($col);};
401 $val = '' unless defined $val;
404 my $a = HTML::Element->new("input", type => "text", name => $name);
405 $a->attr("value" => $val);
406 $OLD_STYLE && return $a->as_HTML;
411 # Too expensive version -- TODO
413 # my ($self, $col, $hint) = @_;
414 # my $fclass = $hint || $self->__hasa_rels->{$col}->[0];
415 # my @objs = $fclass->retrieve_all;
416 # my $a = HTML::Element->new("select", name => $col);
418 # my $sel = HTML::Element->new("option", value => $_->id);
419 # $sel->attr("selected" => "selected")
421 # and eval { $_->id eq $self->$col->id };
422 # $sel->push_content($_->stringify_self);
423 # $a->push_content($sel);
425 # $OLD_STYLE && return $a->as_HTML;
432 # -- Rewrote this to be efficient -- no object creation.
433 # -- Added option for CDBI classes to specify a limiting clause
434 # via "has_a_select_limit".
435 # -- Added selected argument to set a selected
437 =head2 recognized arguments
439 selected => $object|$id,
442 where => SQL 'WHERE' clause,
443 order_by => SQL 'ORDER BY' clause,
444 limit => SQL 'LIMIT' clause,
445 items => [ @items_of_same_type_to_select_from ],
446 class => $class_we_are_selecting_from
447 stringify => $stringify_coderef|$method_name
452 # select box requirements
453 # 1. a select box for objecs of a has_a related class -- DONE
454 =head2 1. a select box out of a has_a or has_many related class.
455 # For has_a the default behavior is to make a select box of every element in
456 # related class and you choose one.
457 #Or explicitly you can create one and pass options like where and order
458 BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
460 # For has_many the default is to get a multiple select box with all objects.
461 # If called as an object method, the objects existing ones will be selected.
462 Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"});
465 =head2 2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun.
467 BeerDB::Beer->to_field('', 'select', $options)
469 BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
470 # with PK as ID, $Class->to_field() same.
471 BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
472 # specify exact where clause
474 =head2 3. If you already have a list of objects to select from --
476 BeerDB:;Beer->to_field($col, 'select' , {items => $objects});
478 # 3. a select box for arbitrary set of objects
479 # Pass array ref of objects as first arg rather than field
480 $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
486 my ($self, $col, $args) = @_;
488 # Do we have items already ? Go no further.
489 if ($args->{items}) {
490 my $a = $self->_select_guts($col, $args);
491 $OLD_STYLE && return $a->as_HTML;
495 # Else what are we making a select box out of ?
496 # No Column parameter -- means making a select box of args->class or self
497 # Using all rows from class's table
499 warn "No col. $self";
500 unless ($args->{class}) {
501 $args->{class} = ref $self || $self;
502 # object selected if called with one
503 $args->{selected} = { $self->id => 1}
504 if not $args->{selected} and ref $self;
506 $col = $args->{class}->primary_column;
508 # Related Class maybe ?
509 elsif (my ($rel_type, $rel_meta) = $self->related_meta('r:)', $col) ) {
510 $args->{class} = $rel_meta->{foreign_class};
511 # related objects pre selected if object
512 $args->{selected} ||= [ $self->$col ] if ref $self;
514 # "Has many" -- we get multiple select
515 if ($rel_type =~ /has_many/i) {
516 $args->{attr}{multiple} = 'multiple';
517 # TODO -- handle mapping
519 my $c = $rel_meta->{args}{constraint} || {};
520 my $j = $rel_meta->{args}{join} || {};
523 @join = map { $_ ." = ". $self->_attr($_) } keys %$j;
525 my @constr= map { "$_ = '$c->{$_}'"} keys %$c;
526 $args->{where} ||= join (' AND ', (@join, @constr));
527 $args->{order_by} ||= $rel_meta->{args}{order_by};
528 $args->{limit} ||= $rel_meta->{args}{limit};
531 # We could say :Col is name and we are selecting out of class arg.
534 #$args->{name} = $col;
535 die "Usage _to_select. $col not related to any class to select from. ";
540 if ( $self->can('column_nullable') ) {
541 $args->{nullable} ||= $self->column_nullable($col);
544 # Get items to select from
545 $args->{items} = _select_items($args);
547 warn "Just got items. They are " . Dumper($args->{items});
549 # Make select HTML element
550 $a = $self->_select_guts($col, $args);
553 $OLD_STYLE && return $a->as_HTML;
565 my $fclass = $args->{class};
567 @select_box_cols = $fclass->columns('SelectBox');
568 @select_box_cols = $fclass->columns('Stringify')
569 unless @select_box_cols;
570 @select_box_cols = $fclass->_essential
571 unless @select_box_cols;
572 unshift @select_box_cols, $fclass->columns('Primary')
573 unless $select_box_cols[0] eq $fclass->columns('Primary');
575 my $sql = "SELECT " . join( ', ', @select_box_cols) .
576 " FROM " . $fclass->table;
578 $sql .= " WHERE " . $args->{where} if $args->{where};
579 $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
580 $sql .= " LIMIT " . $args->{limit} if $args->{limit};
581 warn "_select_items sql is : $sql";
583 return $fclass->db_Main->selectall_arrayref($sql);
588 # Makes a readonly input box out of column's value
589 # No args makes object to readonly
591 my ($self, $col, $val) = @_;
592 if (! $col) { # object to readonly
594 $col = $self->primary_column;
596 unless (defined $val) {
597 $self->_croak("Cannot get value in _to_readonly .")
601 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
602 'name' => $col, 'value'=>$val);
603 $OLD_STYLE && return $a->as_HTML;
608 =head2 _to_enum_select
610 $sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");
612 Returns an enum select box given a column name and an enum string.
613 NOTE: The Plugin::Type does not return an enum string for mysql enum columns.
614 This will not work unless you write your own column_type method in your model.
618 sub _to_enum_select {
619 my ($self, $col, $type) = @_;
620 $type =~ /ENUM\((.*?)\)/i;
621 (my $enum = $1) =~ s/'//g;
622 my @enum_vals = split /\s*,\s*/, $enum;
624 # determine which is pre selected --
625 # if obj, the value is , otherwise use column_default which is the first
626 # value in the enum list unless it has been overridden
627 my $selected = eval { $self->$col };
628 $selected = eval{$self->column_default($col)} unless defined $selected;
629 $selected = $enum_vals[0] unless defined $selected;
632 my $a = HTML::Element->new("select", name => $col);
634 my $sel = HTML::Element->new("option", value => $_);
635 $sel->attr("selected" => "selected") if $_ eq $selected ;
636 $sel->push_content($_);
637 $a->push_content($sel);
639 $OLD_STYLE && return $a->as_HTML;
644 =head2 _to_bool_select
646 my $sel = $self->_to_bool_select($column, $bool_string);
648 This makes select input for boolean column. You can provide a
649 bool string of form: Bool('zero','one') and those are used for option
650 content. Onthervise No and Yes are used.
651 TODO -- test without bool string.
655 sub _to_bool_select {
656 my ($self, $col, $type) = @_;
657 my @bool_text = ('No', 'Yes');
658 if ($type =~ /BOOL\((.+?)\)/i) {
659 (my $bool = $1) =~ s/'//g;
660 @bool_text = split /,/, $bool;
662 my $one= ref $self ? eval {$self->$col;} : $self->column_default($col);
663 my $a = HTML::Element->new("select", name => $col);
664 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
665 HTML::Element->new("option", value => 1) );
666 $opt0->attr("selected" => "selected") if not $one;
667 $opt0->push_content($bool_text[0]);
668 $opt1->attr("selected" => "selected") if $one;
669 $opt1->push_content($bool_text[1]);
670 $a->push_content($opt0, $opt1);
671 $OLD_STYLE && return $a->as_HTML;
676 =head2 _to_hidden($col, $args)
678 This makes a hidden html element. Give it a name and value or if name is
679 a ref it will use the PK name and value of the object.
684 my ($self, $name, $val) = @_;
687 if (ref $name and $name->isa("Class::DBI")) {
689 $name= ($obj->primary_columns)[0]->name;
693 $val = $args->{value};
694 $name = $args->{name} if $args->{name};
696 elsif (not $name ) { # hidding object caller
697 $self->_croak("No object available in _to_hidden") unless ref $self;
698 $name = ($self->primary_column)[0]->name;
701 return HTML::Element->new('input', 'type' => 'hidden',
702 'name' => $name, 'value'=>$val
706 =head2 _to_link_hidden($col, $args)
708 Makes a link with a hidden input with the id of $obj as the value and name.
709 Name defaults to the objects primary key. The object defaults to self.
713 sub _to_link_hidden {
714 my ($self, $accessor, $args) = @_;
715 my $r = $args->{r} || '';
716 my $url = $args->{url} || '';
718 $self->_croak("_to_link_hidden called without Maypole Request object (\$r) and url. Need one or other.")
721 if (ref $self) { # hidding linking self
723 $name = $args->{name} || $obj->primary_column->name;
725 else { # hiding linking related object with id in args
726 $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
727 $name = $args->{name} || $obj->primary_column->name; # TODO make use meta data
729 $self->_croak("_to_link_hidden has no object") unless ref $obj;
730 my $href = $url || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
731 my $a = HTML::Element->new('a', 'href' => $href);
732 $a->push_content("$obj");
733 $a->push_content($self->_to_hidden($name, $obj->id));
734 $OLD_STYLE && return $a->as_HTML;
740 =head2 _to_foreign_inputs
742 $html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]);
744 Get inputs for the accessor's class. Pass an array ref of fields to get
745 inputs for only those fields. Otherwise display_columns or all columns is used.
746 If you have the meta info handy for the accessor you can pass that too.
748 TODO make AsForm know more about the request like what action we are doing
749 so it can use edit columns or search_columns
751 NOTE , this names the foreign inputs is a particular way so they can be
752 processed with a general routine and so there are not name clashes.
756 sub _to_foreign_inputs {
757 my ($self, $accssr, $fields, $accssr_meta) = @_;
759 my $class_meta = $self->meta_info;
760 my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
762 $self->_croak( "No relationship for accessor $accssr") if not $rel_type;
763 $accssr_meta = $class_meta->{$rel_type}->{$accssr};
766 my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $accssr_meta->{foreign_class};
769 $fields = $classORobj->can('display_columns') ?
770 [$classORobj->display_columns] : [$classORobj->columns];
773 # Ignore our fkey in them to prevent infinite recursion
774 my $me = eval {$accssr_meta->{args}{foreign_column}} || '';
775 my $constrained = $accssr_meta->{args}{constraint};
777 foreach ( @$fields ) {
778 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
779 $inputs{$_} = $classORobj->to_field($_);
782 # Make hidden inputs for constrained columns unless we are editing object
783 # TODO -- is this right thing to do?
784 unless (ref $classORobj) {
785 $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_})
786 foreach ( keys %$constrained );
788 $self->_rename_foreign_input($accssr, \%inputs);
793 =head2 _hash_selected
795 Method to make sense out of the "selected" argument which can be in a number
796 of formats perhaps. It returns a hashref with the the values of options to be
799 Below handles these formats for the "selected" slot in the arguments hash:
800 Object (with id method)
801 Scalar (assumes it is value)
802 Array ref *OF* objects, arrays of data (0 elmnt used), hashes of data
803 (id key used), and simple scalars.
813 my $selected = $args->{selected};
814 return $selected unless $selected and ref $selected ne 'HASH';
815 my $type = ref $selected;
817 if ($type and $type ne 'ARRAY') {
818 return {$selected->id => 1};
822 return { $selected => 1};
825 # Array of objs, arrays, hashes, or just scalalrs.
826 elsif ($type eq 'ARRAY') {
828 my $ltype = ref $selected->[0];
830 if ($ltype and $ltype ne 'ARRAY') {
831 %hashed = map { $_->id => 1 } @$selected;
833 # Arrays of data with id first
834 elsif ($ltype and $ltype eq 'ARRAY') {
835 %hashed = map { $_->[0] => 1 } @$selected;
837 # Hashes using pk or id key
838 elsif ($ltype and $ltype eq 'HASH') {
839 my $pk = $args->{class}->primary_column || 'id';
840 %hashed = map { $_->{$pk} => 1 } @$selected;
844 %hashed = map { $_ => 1 } @$selected;
848 else { warn "AsForm Could not hash the selected argument: $selected"; }
856 Internal api method to make the actual select box form elements.
858 3 types of lists making for --
859 Array of CDBI objects.
861 Array or Array refs with cols from class.
867 my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
869 $args->{stringify} ||= 'stringify_selectbox';
870 $args->{selected} = _hash_selected($args);
871 my $name = $args->{name} || $col;
872 my $a = HTML::Element->new('select', name => $name);
873 $a->attr( %{$args->{attr}} ) if $args->{attr};
875 if ($args->{nullable}) {
876 my $null_element = HTML::Element->new('option');
877 $null_element->attr(selected => 'selected')
878 if $args->{selected}{'null'};
879 $null_element->push_content('-- choose or type --');
880 $a->push_content($null_element);
883 my $items = $args->{items};
884 my $proto = $items->[0];
885 my $type = ref $proto || '';
888 if ($type and $type !~ /ARRAY|HASH/i) {
889 # make select of objects
890 $a->push_content($self->_options_from_objects($items, $args));
892 elsif ($type =~ /ARRAY/i) {
893 $a->push_content($self->_options_from_arrays($items, $args));
895 elsif ($type =~ /HASH/i) {
896 $a->push_content($self->_options_from_hashes($items, $args));
899 $a->push_content($self->_options_from_scalars($items, $args));
911 =head2 _options_from_objects ( $objects, $args);
913 Private method to makes a options out of objects. It attempts to call each
914 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
917 sub _options_from_objects {
918 my ($self, $items, $args) = @_;
919 my $selected = $args->{selected} || {};
920 my $stringify = $args->{stringify} || '';
923 my $opt = HTML::Element->new("option", value => $_->id);
924 $opt->attr(selected => "selected") if $selected->{$_->id};
925 my $content = $stringify ? $_->$stringify : "$_";
926 $opt->push_content($content);
932 sub _options_from_arrays {
933 my ($self, $items, $args) = @_;
934 my $selected = $args->{selected} || {};
936 my $fclass = $args->{class} || '';
937 my $stringify = $args->{stringify} || '';
940 my $opt = HTML::Element->new("option", value => $id );
941 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
942 $opt->attr(selected => "selected") if $selected->{$id};
944 my $content = ($fclass and $stringify and $fclass->can($stringify)) ?
945 $fclass->$stringify($_) :
948 warn "Content is $content";
949 $opt->push_content( $content );
955 sub _options_from_scalars {
956 my ($self, $items, $args) = @_;
957 my $selected = $args->{selected} || {};
960 my $opt = HTML::Element->new("option", value => $_ );
961 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
962 $opt->attr(selected => "selected") if $selected->{$_};
963 $opt->push_content( $_ );
969 sub _options_from_hashes {
970 my ($self, $items, $args) = @_;
971 my $selected = $args->{selected} || {};
972 my $pk = eval {$args->{class}->primary_column} || 'id';
973 my $fclass = $args->{class} || '';
974 my $stringify = $args->{stringify} || '';
976 for my $item (@$items) {
977 my $val = $item->{$pk};
978 my $opt = HTML::Element->new("option", value => $val );
979 $opt->attr(selected => "selected") if $selected->{$val};
980 my $content = ( $fclass && $stringify && $fclass->can($stringify)) ? $fclass->$stringify($item) : join(' ', @$item);
981 $opt->push_content( $content );
988 # checkboxes: if no data in hand (ie called as class method), replace
989 # with a radio button, in order to allow this field to be left
990 # unspecified in search / add forms.
993 # TODO -- make this general checkboxse
997 my ($self, $col, $args) = @_;
998 my $nullable = eval {self->column_nullable($col)} || 0;
1000 return $self->_to_radio($col) if !ref($self) || $nullable;
1001 my $value = $self->$col;
1002 my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1003 $a->attr("checked" => 'true') if $value eq 'Y';
1008 # TODO -- make this general radio butons
1011 my ($self, $col) = @_;
1012 my $value = ref $self && $self->$col || '';
1013 my $nullable = eval {self->column_nullable($col)} || 0;
1014 my $a = HTML::Element->new("span");
1015 my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1016 my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1017 my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1018 $ry->push_content('Yes'); $rn->push_content('No');
1019 $ru->push_content('n/a') if $nullable;
1020 if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1021 elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1022 elsif ($nullable) { $ru->attr("checked" => 'true') }
1023 $a->push_content($ry, $rn);
1024 $a->push_content($ru) if $nullable;
1030 ############################ HELPER METHODS ######################
1031 ##################################################################
1033 =head2 _rename_foreign_input
1035 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1037 Recursively renames the foreign inputs made by to_foreign_inputs so they
1038 can be processed generically. The format is "accessor__AsForeign_colname".
1040 So if an Employee is a Person who has own Address and you call
1042 Employee->to_field("person")
1044 then you will get inputs for Address named like this:
1046 person__AsForeign__address__AsForeign__street
1047 person__AsForeign__address__AsForeign__city
1048 person__AsForeign__address__AsForeign__state
1049 person__AsForeign__address__AsForeign__zip
1051 And the processor would know to create this address, put the address id in
1052 person address slot, create the person and put the address id in the employee
1053 before creating the employee.
1057 sub _rename_foreign_input {
1058 my ($self, $accssr, $input) = @_;
1059 if ( ref $input ne 'HASH' ) {
1060 # my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
1061 $input->attr( name => $accssr . "__AsForeign__" . $input->attr('name'));
1064 $self->_rename_foreign_input($accssr, $input->{$_})
1065 foreach (keys %$input);
1070 This functions computes the dimensions of a textarea based on the value
1075 our ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1080 my @rows = split /^/, $text;
1081 my $cols = $min_cols;
1084 my $len = length $_;
1086 $cols = $len if $len > $cols;
1087 $cols = $max_cols if $cols > $max_cols;
1090 $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1091 $rows = $min_rows if $rows < $min_rows;
1092 $rows = $max_rows if $rows > $max_rows;
1095 else { ($min_rows, $min_cols) }
1108 =head1 ORIGINAL AUTHOR
1110 Peter Speltz, Aaron Trevena
1116 chekbox generalization
1117 radio generalization
1119 Make link_hidden use standard make_url stuff when it gets in Maypole
1120 How do you tell AF --" I want a has_many select box for this every time so,
1121 when you call "to_field($this_hasmany)" you get a select box
1123 =head1 BUGS and QUERIES
1125 Please direct all correspondence regarding this module to:
1128 =head1 COPYRIGHT AND LICENSE
1130 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1132 This library is free software; you can redistribute it and/or modify
1133 it under the same terms as Perl itself.
1137 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.