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');
99 This module helps to generate HTML forms for creating new database rows
100 or editing existing rows. It maps column names in a database table to
101 HTML form elements which fit the schema. Large text fields are turned
102 into textareas, and fields with a has-a relationship to other
103 C<Class::DBI> tables are turned into select drop-downs populated with
104 objects from the joined class.
108 The module is a mix-in which adds two additional methods to your
109 C<Class::DBI>-derived class.
114 Returns hashref of search inputs elements to use in cgi.
116 Uses fields specified in search_fields, makes foreign inputs if necessary.
120 # 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');
172 # make a select box from args
174 my ($self, $name, $vals, $selected_val, $contents) = @_;
175 die "Usage: Need a name and array ref of values to make a select boxes" unless ($name && $vals);
176 $selected_val ||= "";
177 $contents ||= $vals ;
179 my $a = HTML::Element->new('select', 'name' => $name);
182 foreach my $v ( @$vals ) {
183 my $opt = HTML::Element->new('option', 'value' => $v);
184 $opt->attr('selected' => 'selected') if $v eq $selected_val;
185 $c = $contents->[$i++] || $v;
186 $opt->push_content($c);
187 $a->push_content($opt);
194 =head2 make_param_foreign
196 Makes a new foreign parameter out of parameter and accessor
197 Just puts accssr__FOREIGN__ in front of param name
201 sub make_param_foreign {
202 my ($self, $r, $p, $accssr) = @_;
203 $r->params->{$accssr . '__FOREIGN__' . $p} = $r->params->{$p};
208 This returns a hash mapping all the column names of the class to
209 HTML::Element objects representing form widgets.
211 pjs -- added a columns list argument to specify which columns to make
217 my ($class, @columns) = @_; # pjs -- added columns arg
218 @columns = $class->columns unless (@columns);
219 map { $_ => $class->to_field($_) } @columns;
223 =head2 to_field($field [, $how])
225 This maps an individual column to a form element. The C<how> argument
226 can be used to force the field type into one of C<textfield>, C<textarea>
227 or C<select>; you can use this is you want to avoid the automatic detection
228 of has-a relationships.
231 -- added support for enum and bool. Note for enum and bool you need
232 a better column_type method than the Plugin::Type ' s as it won't work
233 if you are using MySQL. I have not tried others.
234 See those method's docs below.
235 -- Foreign inputs for might_have, must_have, has_own, and has_many(i think).
236 -- Really any relationship except has_a and is_a as has_a gets a select box
237 and is_a are not considered foreign.
238 -- Note a good column_type sub can be
239 used to get the correct type for is_a columns.
240 -- More efficient _to_select -- no object creation.
241 -- Attempts to set default value in field for you using a "column_default"
242 method you write yourself or your CDBI driver like mysql writes.
248 my ($self, $field, @args) = @_;
249 my $how = shift @args unless ref $args[0];
250 my $args = shift @args; # argument hash ref
252 return $self->_field_from_how($field, $how, $args) ||
253 $self->_field_from_relationship($field, $args) ||
254 $self->_field_from_column($field, $args) ||
255 $self->_to_textfield($field, $args);
258 =head2 _field_from_how($field, $how,$args)
260 Returns an input element based the "how" parameter or nothing at all.
265 sub _field_from_how {
266 my ($self, $field, $how, $args) = @_;
269 my $meth = "_to_$how";
270 return $self->$meth($field, $args) if $self->can($meth);
275 =head2 _field_from_relationship($field, $args)
277 Returns an input based on the relationship associated with the field or nothing.
282 sub _field_from_relationship {
283 my ($self, $field, $args) = @_;
284 my $meta = $self->meta_info;
285 my ($rel_type) = grep{ defined $meta->{$_}{$field} } keys %$meta;
287 my $fclass = $rel_type ? $meta->{$rel_type}{$field}{foreign_class} : '';
288 $args->{class} = $fclass;
289 my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
292 return $self->_to_select($field, $args)
293 if $rel_type eq 'has_a' and $fclass_is_cdbi;
295 # maybe foreign inputs
296 my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
297 if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_type eq 'has_own'))
299 return $self->_to_foreign_inputs($field, undef, $meta->{$rel_type}{$field});
304 =head2 _field_from_column($field, $args)
306 Returns an input based on the column's characteristics, namely type, or nothing.
311 sub _field_from_column {
312 my ($self, $field, $args) = @_;
313 my $class = ref $self || $self;
315 unless ($args->{column_type}) {
316 if ($class->can('column_type')) {
317 $args->{column_type} = $class->column_type($field);
319 # Right, have some of this
320 eval "package $class; Class::DBI::Plugin::Type->import()";
321 $args->{column_type} = $class->column_type($field);
324 my $type = $args->{column_type};
326 return $self->_to_textfield($field)
327 if $type and $type =~ /(VAR)?CHAR/i; #common type
328 return $self->_to_textarea($field, $args)
329 if $type and $type =~ /^(TEXT|BLOB)$/i;
330 return $self->_to_enum_select($field, $args)
331 if $type and $type =~ /^ENUM\((.*?)\)$/i;
332 return $self->_to_bool_select($field, $args)
333 if $type and $type =~ /^BOOL/i;
334 return $self->_to_readonly($field, $args)
335 if $type and $type =~ /^readonly$/i;
341 my ($self, $col, $args) = @_;
344 my $val = $args->{value};
346 unless (defined $val) {
351 $val = eval {$self->column_default($col);};
352 $val = '' unless defined $val;
355 my ($rows, $cols) = _box($val);
356 $rows = $args->{rows} if $args->{rows};
357 $cols = $args->{cols} if $args->{cols};;
358 my $name = $args->{name} || $col;
360 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
361 $a->push_content($val);
362 $OLD_STYLE && return $a->as_HTML;
367 my ($self, $col, $args ) = @_;
369 my $val = $args->{value};
370 my $name = $args->{name} || $col;
372 unless (defined $val) {
374 # Case where column inflates.
375 # Input would get stringification which could be not good.
376 # as in the case of Time::Piece objects
379 if (my $meta = $self->related_meta('',$col)) {
380 if (my $code = $meta->{args}{deflate4edit} ) {
381 $val = ref $code ? &$code($val) : $val->$code;
384 $val = $self->_attr($col);
388 $val = $self->_attr($col);
394 $val = eval {$self->column_default($col);};
395 $val = '' unless defined $val;
398 my $a = HTML::Element->new("input", type => "text", name => $name);
399 $a->attr("value" => $val);
400 $OLD_STYLE && return $a->as_HTML;
405 # Too expensive version -- TODO
407 # my ($self, $col, $hint) = @_;
408 # my $fclass = $hint || $self->__hasa_rels->{$col}->[0];
409 # my @objs = $fclass->retrieve_all;
410 # my $a = HTML::Element->new("select", name => $col);
412 # my $sel = HTML::Element->new("option", value => $_->id);
413 # $sel->attr("selected" => "selected")
415 # and eval { $_->id eq $self->$col->id };
416 # $sel->push_content($_->stringify_self);
417 # $a->push_content($sel);
419 # $OLD_STYLE && return $a->as_HTML;
426 # -- Rewrote this to be efficient -- no object creation.
427 # -- Added option for CDBI classes to specify a limiting clause
428 # via "has_a_select_limit".
429 # -- Added selected argument to set a selected
431 =head2 recognized arguments
433 selected => $object|$id,
436 where => SQL 'WHERE' clause,
437 order_by => SQL 'ORDER BY' clause,
438 limit => SQL 'LIMIT' clause,
439 items => [ @items_of_same_type_to_select_from ],
440 class => $class_we_are_selecting_from
441 stringify => $stringify_coderef|$method_name
446 # select box requirements
447 # 1. a select box for objecs of a has_a related class -- DONE
448 =head2 1. a select box out of a has_a or has_many related class.
449 # For has_a the default behavior is to make a select box of every element in
450 # related class and you choose one.
451 #Or explicitly you can create one and pass options like where and order
452 BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
454 # For has_many the default is to get a multiple select box with all objects.
455 # If called as an object method, the objects existing ones will be selected.
456 Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"});
459 =head2 2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun.
461 BeerDB::Beer->to_field('', 'select', $options)
463 BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
464 # with PK as ID, $Class->to_field() same.
465 BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
466 # specify exact where clause
468 =head2 3. If you already have a list of objects to select from --
470 BeerDB:;Beer->to_field($col, 'select' , {items => $objects});
472 # 3. a select box for arbitrary set of objects
473 # Pass array ref of objects as first arg rather than field
474 $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
480 my ($self, $col, $args) = @_;
482 # Do we have items already ? Go no further.
483 if ($args->{items}) {
484 my $a = $self->_select_guts($col, $args);
485 $OLD_STYLE && return $a->as_HTML;
489 # Else what are we making a select box out of ?
490 # No Column parameter -- means making a select box of args->class or self
491 # Using all rows from class's table
493 warn "No col. $self";
494 unless ($args->{class}) {
495 $args->{class} = ref $self || $self;
496 # object selected if called with one
497 $args->{selected} = { $self->id => 1}
498 if not $args->{selected} and ref $self;
500 $col = $args->{class}->primary_column;
502 # Related Class maybe ?
503 elsif (my ($rel_type, $rel_meta) = $self->related_meta('r:)', $col) ) {
504 $args->{class} = $rel_meta->{foreign_class};
505 # related objects pre selected if object
506 $args->{selected} ||= [ $self->$col ] if ref $self;
508 # "Has many" -- we get multiple select
509 if ($rel_type =~ /has_many/i) {
510 $args->{attr}{multiple} = 'multiple';
511 # TODO -- handle mapping
513 my $c = $rel_meta->{args}{constraint} || {};
514 my $j = $rel_meta->{args}{join} || {};
517 @join = map { $_ ." = ". $self->_attr($_) } keys %$j;
519 my @constr= map { "$_ = '$c->{$_}'"} keys %$c;
520 $args->{where} ||= join (' AND ', (@join, @constr));
521 $args->{order_by} ||= $rel_meta->{args}{order_by};
522 $args->{limit} ||= $rel_meta->{args}{limit};
525 # We could say :Col is name and we are selecting out of class arg.
528 #$args->{name} = $col;
529 die "Usage _to_select. $col not related to any class to select from. ";
534 if ( $self->can('column_nullable') ) {
535 $args->{nullable} ||= $self->column_nullable($col);
538 # Get items to select from
539 $args->{items} = _select_items($args);
541 warn "Just got items. They are " . Dumper($args->{items});
543 # Make select HTML element
544 $a = $self->_select_guts($col, $args);
547 $OLD_STYLE && return $a->as_HTML;
559 my $fclass = $args->{class};
561 @select_box_cols = $fclass->columns('SelectBox');
562 @select_box_cols = $fclass->columns('Stringify')
563 unless @select_box_cols;
564 @select_box_cols = $fclass->_essential
565 unless @select_box_cols;
566 unshift @select_box_cols, $fclass->columns('Primary')
567 unless $select_box_cols[0] eq $fclass->columns('Primary');
569 my $sql = "SELECT " . join( ', ', @select_box_cols) .
570 " FROM " . $fclass->table;
572 $sql .= " WHERE " . $args->{where} if $args->{where};
573 $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
574 $sql .= " LIMIT " . $args->{limit} if $args->{limit};
575 warn "_select_items sql is : $sql";
577 return $fclass->db_Main->selectall_arrayref($sql);
582 # Makes a readonly input box out of column's value
583 # No args makes object to readonly
585 my ($self, $col, $val) = @_;
586 if (! $col) { # object to readonly
588 $col = $self->primary_column;
590 unless (defined $val) {
591 $self->_croak("Cannot get value in _to_readonly .")
595 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
596 'name' => $col, 'value'=>$val);
597 $OLD_STYLE && return $a->as_HTML;
602 =head2 _to_enum_select
604 $sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");
606 Returns an enum select box given a column name and an enum string.
607 NOTE: The Plugin::Type does not return an enum string for mysql enum columns.
608 This will not work unless you write your own column_type method in your model.
612 sub _to_enum_select {
613 my ($self, $col, $type) = @_;
614 $type =~ /ENUM\((.*?)\)/i;
615 (my $enum = $1) =~ s/'//g;
616 my @enum_vals = split /\s*,\s*/, $enum;
618 # determine which is pre selected --
619 # if obj, the value is , otherwise use column_default which is the first
620 # value in the enum list unless it has been overridden
621 my $selected = eval { $self->$col };
622 $selected = eval{$self->column_default($col)} unless defined $selected;
623 $selected = $enum_vals[0] unless defined $selected;
626 my $a = HTML::Element->new("select", name => $col);
628 my $sel = HTML::Element->new("option", value => $_);
629 $sel->attr("selected" => "selected") if $_ eq $selected ;
630 $sel->push_content($_);
631 $a->push_content($sel);
633 $OLD_STYLE && return $a->as_HTML;
638 =head2 _to_bool_select
640 my $sel = $self->_to_bool_select($column, $bool_string);
642 This makes select input for boolean column. You can provide a
643 bool string of form: Bool('zero','one') and those are used for option
644 content. Onthervise No and Yes are used.
645 TODO -- test without bool string.
649 sub _to_bool_select {
650 my ($self, $col, $type) = @_;
651 my @bool_text = ('No', 'Yes');
652 if ($type =~ /BOOL\((.+?)\)/i) {
653 (my $bool = $1) =~ s/'//g;
654 @bool_text = split /,/, $bool;
656 my $one= ref $self ? eval {$self->$col;} : $self->column_default($col);
657 my $a = HTML::Element->new("select", name => $col);
658 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
659 HTML::Element->new("option", value => 1) );
660 $opt0->attr("selected" => "selected") if not $one;
661 $opt0->push_content($bool_text[0]);
662 $opt1->attr("selected" => "selected") if $one;
663 $opt1->push_content($bool_text[1]);
664 $a->push_content($opt0, $opt1);
665 $OLD_STYLE && return $a->as_HTML;
670 =head2 _to_hidden($col, $args)
672 This makes a hidden html element. Give it a name and value or if name is
673 a ref it will use the PK name and value of the object.
678 my ($self, $name, $val) = @_;
681 if (ref $name and $name->isa("Class::DBI")) {
683 $name= ($obj->primary_columns)[0]->name;
687 $val = $args->{value};
688 $name = $args->{name} if $args->{name};
690 elsif (not $name ) { # hidding object caller
691 $self->_croak("No object available in _to_hidden") unless ref $self;
692 $name = ($self->primary_column)[0]->name;
695 return HTML::Element->new('input', 'type' => 'hidden',
696 'name' => $name, 'value'=>$val
700 =head2 _to_link_hidden($col, $args)
702 Makes a link with a hidden input with the id of $obj as the value and name.
703 Name defaults to the objects primary key. The object defaults to self.
707 sub _to_link_hidden {
708 my ($self, $accessor, $args) = @_;
709 my $r = $args->{r} || '';
710 my $url = $args->{url} || '';
712 $self->_croak("_to_link_hidden called without Maypole Request object (\$r) and url. Need one or other.")
715 if (ref $self) { # hidding linking self
717 $name = $args->{name} || $obj->primary_column->name;
719 else { # hiding linking related object with id in args
720 $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
721 $name = $args->{name} || $obj->primary_column->name; # TODO make use meta data
723 $self->_croak("_to_link_hidden has no object") unless ref $obj;
724 my $href = $url || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
725 my $a = HTML::Element->new('a', 'href' => $href);
726 $a->push_content("$obj");
727 $a->push_content($self->_to_hidden($name, $obj->id));
728 $OLD_STYLE && return $a->as_HTML;
734 =head2 _to_foreign_inputs
736 $html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]);
738 Get inputs for the accessor's class. Pass an array ref of fields to get
739 inputs for only those fields. Otherwise display_columns or all columns is used.
740 If you have the meta info handy for the accessor you can pass that too.
742 TODO make AsForm know more about the request like what action we are doing
743 so it can use edit columns or search_columns
745 NOTE , this names the foreign inputs is a particular way so they can be
746 processed with a general routine and so there are not name clashes.
750 sub _to_foreign_inputs {
751 my ($self, $accssr, $fields, $accssr_meta) = @_;
753 my $class_meta = $self->meta_info;
754 my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
756 $self->_croak( "No relationship for accessor $accssr") if not $rel_type;
757 $accssr_meta = $class_meta->{$rel_type}->{$accssr};
760 my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $accssr_meta->{foreign_class};
763 $fields = $classORobj->can('display_columns') ?
764 [$classORobj->display_columns] : [$classORobj->columns];
767 # Ignore our fkey in them to prevent infinite recursion
768 my $me = eval {$accssr_meta->{args}{foreign_column}} || '';
769 my $constrained = $accssr_meta->{args}{constraint};
771 foreach ( @$fields ) {
772 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
773 $inputs{$_} = $classORobj->to_field($_);
776 # Make hidden inputs for constrained columns unless we are editing object
777 # TODO -- is this right thing to do?
778 unless (ref $classORobj) {
779 $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_})
780 foreach ( keys %$constrained );
782 $self->_rename_foreign_input($accssr, \%inputs);
787 =head2 _hash_selected
789 Method to make sense out of the "selected" argument which can be in a number
790 of formats perhaps. It returns a hashref with the the values of options to be
793 Below handles these formats for the "selected" slot in the arguments hash:
794 Object (with id method)
795 Scalar (assumes it is value)
796 Array ref *OF* objects, arrays of data (0 elmnt used), hashes of data
797 (id key used), and simple scalars.
807 my $selected = $args->{selected};
808 return $selected unless $selected and ref $selected ne 'HASH';
809 my $type = ref $selected;
811 if ($type and $type ne 'ARRAY') {
812 return {$selected->id => 1};
816 return { $selected => 1};
819 # Array of objs, arrays, hashes, or just scalalrs.
820 elsif ($type eq 'ARRAY') {
822 my $ltype = ref $selected->[0];
824 if ($ltype and $ltype ne 'ARRAY') {
825 %hashed = map { $_->id => 1 } @$selected;
827 # Arrays of data with id first
828 elsif ($ltype and $ltype eq 'ARRAY') {
829 %hashed = map { $_->[0] => 1 } @$selected;
831 # Hashes using pk or id key
832 elsif ($ltype and $ltype eq 'HASH') {
833 my $pk = $args->{class}->primary_column || 'id';
834 %hashed = map { $_->{$pk} => 1 } @$selected;
838 %hashed = map { $_ => 1 } @$selected;
842 else { warn "AsForm Could not hash the selected argument: $selected"; }
850 Internal api method to make the actual select box form elements.
852 3 types of lists making for --
853 Array of CDBI objects.
855 Array or Array refs with cols from class.
861 my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
863 $args->{stringify} ||= 'stringify_selectbox';
864 $args->{selected} = _hash_selected($args);
865 my $name = $args->{name} || $col;
866 my $a = HTML::Element->new('select', name => $name);
867 $a->attr( %{$args->{attr}} ) if $args->{attr};
869 if ($args->{nullable}) {
870 my $null_element = HTML::Element->new('option');
871 $null_element->attr(selected => 'selected')
872 if $args->{selected}{'null'};
873 $null_element->push_content('-- choose or type --');
874 $a->push_content($null_element);
877 my $items = $args->{items};
878 my $proto = $items->[0];
879 my $type = ref $proto || '';
882 if ($type and $type !~ /ARRAY|HASH/i) {
883 # make select of objects
884 $a->push_content($self->_options_from_objects($items, $args));
886 elsif ($type =~ /ARRAY/i) {
887 $a->push_content($self->_options_from_arrays($items, $args));
889 elsif ($type =~ /HASH/i) {
890 $a->push_content($self->_options_from_hashes($items, $args));
893 $a->push_content($self->_options_from_scalars($items, $args));
905 =head2 _options_from_objects ( $objects, $args);
907 Private method to makes a options out of objects. It attempts to call each
908 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
911 sub _options_from_objects {
912 my ($self, $items, $args) = @_;
913 my $selected = $args->{selected} || {};
914 my $stringify = $args->{stringify} || '';
917 my $opt = HTML::Element->new("option", value => $_->id);
918 $opt->attr(selected => "selected") if $selected->{$_->id};
919 my $content = $stringify ? $_->$stringify : "$_";
920 $opt->push_content($content);
926 sub _options_from_arrays {
927 my ($self, $items, $args) = @_;
928 my $selected = $args->{selected} || {};
930 my $fclass = $args->{class} || '';
931 my $stringify = $args->{stringify} || '';
934 my $opt = HTML::Element->new("option", value => $id );
935 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
936 $opt->attr(selected => "selected") if $selected->{$id};
938 my $content = ($fclass and $stringify and $fclass->can($stringify)) ?
939 $fclass->$stringify($_) :
942 warn "Content is $content";
943 $opt->push_content( $content );
949 sub _options_from_scalars {
950 my ($self, $items, $args) = @_;
951 my $selected = $args->{selected} || {};
954 my $opt = HTML::Element->new("option", value => $_ );
955 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
956 $opt->attr(selected => "selected") if $selected->{$_};
957 $opt->push_content( $_ );
963 sub _options_from_hashes {
964 my ($self, $items, $args) = @_;
965 my $selected = $args->{selected} || {};
966 my $pk = eval {$args->{class}->primary_column} || 'id';
967 my $fclass = $args->{class} || '';
968 my $stringify = $args->{stringify} || '';
970 for my $item (@$items) {
971 my $val = $item->{$pk};
972 my $opt = HTML::Element->new("option", value => $val );
973 $opt->attr(selected => "selected") if $selected->{$val};
974 my $content = ( $fclass && $stringify && $fclass->can($stringify)) ? $fclass->$stringify($item) : join(' ', @$item);
975 $opt->push_content( $content );
982 # checkboxes: if no data in hand (ie called as class method), replace
983 # with a radio button, in order to allow this field to be left
984 # unspecified in search / add forms.
987 # TODO -- make this general checkboxse
991 my ($self, $col, $args) = @_;
992 my $nullable = eval {self->column_nullable($col)} || 0;
994 return $self->_to_radio($col) if !ref($self) || $nullable;
995 my $value = $self->$col;
996 my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
997 $a->attr("checked" => 'true') if $value eq 'Y';
1002 # TODO -- make this general radio butons
1005 my ($self, $col) = @_;
1006 my $value = ref $self && $self->$col || '';
1007 my $nullable = eval {self->column_nullable($col)} || 0;
1008 my $a = HTML::Element->new("span");
1009 my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1010 my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1011 my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1012 $ry->push_content('Yes'); $rn->push_content('No');
1013 $ru->push_content('n/a') if $nullable;
1014 if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1015 elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1016 elsif ($nullable) { $ru->attr("checked" => 'true') }
1017 $a->push_content($ry, $rn);
1018 $a->push_content($ru) if $nullable;
1024 ############################ HELPER METHODS ######################
1025 ##################################################################
1027 =head2 _rename_foreign_input
1029 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1031 Recursively renames the foreign inputs made by to_foreign_inputs so they
1032 can be processed generically. The format is "accessor__AsForeign_colname".
1034 So if an Employee is a Person who has own Address and you call
1036 Employee->to_field("person")
1038 then you will get inputs for Address named like this:
1040 person__AsForeign__address__AsForeign__street
1041 person__AsForeign__address__AsForeign__city
1042 person__AsForeign__address__AsForeign__state
1043 person__AsForeign__address__AsForeign__zip
1045 And the processor would know to create this address, put the address id in
1046 person address slot, create the person and put the address id in the employee
1047 before creating the employee.
1051 sub _rename_foreign_input {
1052 my ($self, $accssr, $input) = @_;
1053 if ( ref $input ne 'HASH' ) {
1054 # my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
1055 $input->attr( name => $accssr . "__AsForeign__" . $input->attr('name'));
1058 $self->_rename_foreign_input($accssr, $input->{$_})
1059 foreach (keys %$input);
1064 This functions computes the dimensions of a textarea based on the value
1069 our ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1074 my @rows = split /^/, $text;
1075 my $cols = $min_cols;
1078 my $len = length $_;
1080 $cols = $len if $len > $cols;
1081 $cols = $max_cols if $cols > $max_cols;
1084 $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1085 $rows = $min_rows if $rows < $min_rows;
1086 $rows = $max_rows if $rows > $max_rows;
1089 else { ($min_rows, $min_cols) }
1102 =head1 ORIGINAL AUTHOR
1104 Peter Speltz, Aaron Trevena
1110 chekbox generalization
1111 radio generalization
1113 Make link_hidden use standard make_url stuff when it gets in Maypole
1114 How do you tell AF --" I want a has_many select box for this every time so,
1115 when you call "to_field($this_hasmany)" you get a select box
1117 =head1 BUGS and QUERIES
1119 Please direct all correspondence regarding this module to:
1122 =head1 COPYRIGHT AND LICENSE
1124 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1126 This library is free software; you can redistribute it and/or modify
1127 it under the same terms as Perl itself.
1131 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.