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);
546 # Make select HTML element
547 $a = $self->_select_guts($col, $args);
550 $OLD_STYLE && return $a->as_HTML;
562 my $fclass = $args->{class};
564 @select_box_cols = $fclass->columns('SelectBox');
565 @select_box_cols = $fclass->columns('Stringify')
566 unless @select_box_cols;
567 @select_box_cols = $fclass->_essential
568 unless @select_box_cols;
569 unshift @select_box_cols, $fclass->columns('Primary')
570 unless $select_box_cols[0] eq $fclass->columns('Primary');
572 my $sql = "SELECT " . join( ', ', @select_box_cols) .
573 " FROM " . $fclass->table;
575 $sql .= " WHERE " . $args->{where} if $args->{where};
576 $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
577 $sql .= " LIMIT " . $args->{limit} if $args->{limit};
579 return $fclass->db_Main->selectall_arrayref($sql);
584 # Makes a readonly input box out of column's value
585 # No args makes object to readonly
587 my ($self, $col, $val) = @_;
588 if (! $col) { # object to readonly
590 $col = $self->primary_column;
592 unless (defined $val) {
593 $self->_croak("Cannot get value in _to_readonly .")
597 my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
598 'name' => $col, 'value'=>$val);
599 $OLD_STYLE && return $a->as_HTML;
604 =head2 _to_enum_select
606 $sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");
608 Returns an enum select box given a column name and an enum string.
609 NOTE: The Plugin::Type does not return an enum string for mysql enum columns.
610 This will not work unless you write your own column_type method in your model.
614 sub _to_enum_select {
615 my ($self, $col, $type) = @_;
616 $type =~ /ENUM\((.*?)\)/i;
617 (my $enum = $1) =~ s/'//g;
618 my @enum_vals = split /\s*,\s*/, $enum;
620 # determine which is pre selected --
621 # if obj, the value is , otherwise use column_default which is the first
622 # value in the enum list unless it has been overridden
623 my $selected = eval { $self->$col };
624 $selected = eval{$self->column_default($col)} unless defined $selected;
625 $selected = $enum_vals[0] unless defined $selected;
628 my $a = HTML::Element->new("select", name => $col);
630 my $sel = HTML::Element->new("option", value => $_);
631 $sel->attr("selected" => "selected") if $_ eq $selected ;
632 $sel->push_content($_);
633 $a->push_content($sel);
635 $OLD_STYLE && return $a->as_HTML;
640 =head2 _to_bool_select
642 my $sel = $self->_to_bool_select($column, $bool_string);
644 This makes select input for boolean column. You can provide a
645 bool string of form: Bool('zero','one') and those are used for option
646 content. Onthervise No and Yes are used.
647 TODO -- test without bool string.
651 sub _to_bool_select {
652 my ($self, $col, $type) = @_;
653 my @bool_text = ('No', 'Yes');
654 if ($type =~ /BOOL\((.+?)\)/i) {
655 (my $bool = $1) =~ s/'//g;
656 @bool_text = split /,/, $bool;
658 my $one= ref $self ? eval {$self->$col;} : $self->column_default($col);
659 my $a = HTML::Element->new("select", name => $col);
660 my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
661 HTML::Element->new("option", value => 1) );
662 $opt0->attr("selected" => "selected") if not $one;
663 $opt0->push_content($bool_text[0]);
664 $opt1->attr("selected" => "selected") if $one;
665 $opt1->push_content($bool_text[1]);
666 $a->push_content($opt0, $opt1);
667 $OLD_STYLE && return $a->as_HTML;
672 =head2 _to_hidden($col, $args)
674 This makes a hidden html element. Give it a name and value or if name is
675 a ref it will use the PK name and value of the object.
680 my ($self, $name, $val) = @_;
683 if (ref $name and $name->isa("Class::DBI")) {
685 $name= ($obj->primary_columns)[0]->name;
689 $val = $args->{value};
690 $name = $args->{name} if $args->{name};
692 elsif (not $name ) { # hidding object caller
693 $self->_croak("No object available in _to_hidden") unless ref $self;
694 $name = ($self->primary_column)[0]->name;
697 return HTML::Element->new('input', 'type' => 'hidden',
698 'name' => $name, 'value'=>$val
702 =head2 _to_link_hidden($col, $args)
704 Makes a link with a hidden input with the id of $obj as the value and name.
705 Name defaults to the objects primary key. The object defaults to self.
709 sub _to_link_hidden {
710 my ($self, $accessor, $args) = @_;
711 my $r = $args->{r} || '';
712 my $url = $args->{url} || '';
714 $self->_croak("_to_link_hidden called without Maypole Request object (\$r) and url. Need one or other.")
717 if (ref $self) { # hidding linking self
719 $name = $args->{name} || $obj->primary_column->name;
721 else { # hiding linking related object with id in args
722 $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
723 $name = $args->{name} || $obj->primary_column->name; # TODO make use meta data
725 $self->_croak("_to_link_hidden has no object") unless ref $obj;
726 my $href = $url || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
727 my $a = HTML::Element->new('a', 'href' => $href);
728 $a->push_content("$obj");
729 $a->push_content($self->_to_hidden($name, $obj->id));
730 $OLD_STYLE && return $a->as_HTML;
736 =head2 _to_foreign_inputs
738 $html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]);
740 Get inputs for the accessor's class. Pass an array ref of fields to get
741 inputs for only those fields. Otherwise display_columns or all columns is used.
742 If you have the meta info handy for the accessor you can pass that too.
744 TODO make AsForm know more about the request like what action we are doing
745 so it can use edit columns or search_columns
747 NOTE , this names the foreign inputs is a particular way so they can be
748 processed with a general routine and so there are not name clashes.
752 sub _to_foreign_inputs {
753 my ($self, $accssr, $fields, $accssr_meta) = @_;
755 my $class_meta = $self->meta_info;
756 my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
758 $self->_croak( "No relationship for accessor $accssr") if not $rel_type;
759 $accssr_meta = $class_meta->{$rel_type}->{$accssr};
762 my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $accssr_meta->{foreign_class};
765 $fields = $classORobj->can('display_columns') ?
766 [$classORobj->display_columns] : [$classORobj->columns];
769 # Ignore our fkey in them to prevent infinite recursion
770 my $me = eval {$accssr_meta->{args}{foreign_column}} || '';
771 my $constrained = $accssr_meta->{args}{constraint};
773 foreach ( @$fields ) {
774 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
775 $inputs{$_} = $classORobj->to_field($_);
778 # Make hidden inputs for constrained columns unless we are editing object
779 # TODO -- is this right thing to do?
780 unless (ref $classORobj) {
781 $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_})
782 foreach ( keys %$constrained );
784 $self->_rename_foreign_input($accssr, \%inputs);
789 =head2 _hash_selected
791 Method to make sense out of the "selected" argument which can be in a number
792 of formats perhaps. It returns a hashref with the the values of options to be
795 Below handles these formats for the "selected" slot in the arguments hash:
796 Object (with id method)
797 Scalar (assumes it is value)
798 Array ref *OF* objects, arrays of data (0 elmnt used), hashes of data
799 (id key used), and simple scalars.
809 my $selected = $args->{selected};
810 return $selected unless $selected and ref $selected ne 'HASH';
811 my $type = ref $selected;
813 if ($type and $type ne 'ARRAY') {
814 return {$selected->id => 1};
818 return { $selected => 1};
821 # Array of objs, arrays, hashes, or just scalalrs.
822 elsif ($type eq 'ARRAY') {
824 my $ltype = ref $selected->[0];
826 if ($ltype and $ltype ne 'ARRAY') {
827 %hashed = map { $_->id => 1 } @$selected;
829 # Arrays of data with id first
830 elsif ($ltype and $ltype eq 'ARRAY') {
831 %hashed = map { $_->[0] => 1 } @$selected;
833 # Hashes using pk or id key
834 elsif ($ltype and $ltype eq 'HASH') {
835 my $pk = $args->{class}->primary_column || 'id';
836 %hashed = map { $_->{$pk} => 1 } @$selected;
840 %hashed = map { $_ => 1 } @$selected;
844 else { warn "AsForm Could not hash the selected argument: $selected"; }
852 Internal api method to make the actual select box form elements.
854 3 types of lists making for --
855 Array of CDBI objects.
857 Array or Array refs with cols from class.
863 my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
865 $args->{stringify} ||= 'stringify_selectbox';
866 $args->{selected} = _hash_selected($args);
867 my $name = $args->{name} || $col;
868 my $a = HTML::Element->new('select', name => $name);
869 $a->attr( %{$args->{attr}} ) if $args->{attr};
871 if ($args->{nullable}) {
872 my $null_element = HTML::Element->new('option');
873 $null_element->attr(selected => 'selected')
874 if $args->{selected}{'null'};
875 $null_element->push_content('-- choose or type --');
876 $a->push_content($null_element);
879 my $items = $args->{items};
880 my $proto = $items->[0];
881 my $type = ref $proto || '';
884 if ($type and $type !~ /ARRAY|HASH/i) {
885 # make select of objects
886 $a->push_content($self->_options_from_objects($items, $args));
888 elsif ($type =~ /ARRAY/i) {
889 $a->push_content($self->_options_from_arrays($items, $args));
891 elsif ($type =~ /HASH/i) {
892 $a->push_content($self->_options_from_hashes($items, $args));
895 $a->push_content($self->_options_from_scalars($items, $args));
907 =head2 _options_from_objects ( $objects, $args);
909 Private method to makes a options out of objects. It attempts to call each
910 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
913 sub _options_from_objects {
914 my ($self, $items, $args) = @_;
915 my $selected = $args->{selected} || {};
916 my $stringify = $args->{stringify} || '';
919 my $opt = HTML::Element->new("option", value => $_->id);
920 $opt->attr(selected => "selected") if $selected->{$_->id};
921 my $content = $stringify ? $_->$stringify : "$_";
922 $opt->push_content($content);
928 sub _options_from_arrays {
929 my ($self, $items, $args) = @_;
930 my $selected = $args->{selected} || {};
932 my $fclass = $args->{class} || '';
933 my $stringify = $args->{stringify} || '';
936 my $opt = HTML::Element->new("option", value => $id );
937 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
938 $opt->attr(selected => "selected") if $selected->{$id};
940 my $content = ($fclass and $stringify and $fclass->can($stringify)) ?
941 $fclass->$stringify($_) :
944 $opt->push_content( $content );
950 sub _options_from_scalars {
951 my ($self, $items, $args) = @_;
952 my $selected = $args->{selected} || {};
955 my $opt = HTML::Element->new("option", value => $_ );
956 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
957 $opt->attr(selected => "selected") if $selected->{$_};
958 $opt->push_content( $_ );
964 sub _options_from_hashes {
965 my ($self, $items, $args) = @_;
966 my $selected = $args->{selected} || {};
967 my $pk = eval {$args->{class}->primary_column} || 'id';
968 my $fclass = $args->{class} || '';
969 my $stringify = $args->{stringify} || '';
971 for my $item (@$items) {
972 my $val = $item->{$pk};
973 my $opt = HTML::Element->new("option", value => $val );
974 $opt->attr(selected => "selected") if $selected->{$val};
975 my $content = ( $fclass && $stringify && $fclass->can($stringify)) ? $fclass->$stringify($item) : join(' ', @$item);
976 $opt->push_content( $content );
983 # checkboxes: if no data in hand (ie called as class method), replace
984 # with a radio button, in order to allow this field to be left
985 # unspecified in search / add forms.
988 # TODO -- make this general checkboxse
992 my ($self, $col, $args) = @_;
993 my $nullable = eval {self->column_nullable($col)} || 0;
995 return $self->_to_radio($col) if !ref($self) || $nullable;
996 my $value = $self->$col;
997 my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
998 $a->attr("checked" => 'true') if $value eq 'Y';
1003 # TODO -- make this general radio butons
1006 my ($self, $col) = @_;
1007 my $value = ref $self && $self->$col || '';
1008 my $nullable = eval {self->column_nullable($col)} || 0;
1009 my $a = HTML::Element->new("span");
1010 my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1011 my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1012 my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1013 $ry->push_content('Yes'); $rn->push_content('No');
1014 $ru->push_content('n/a') if $nullable;
1015 if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1016 elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1017 elsif ($nullable) { $ru->attr("checked" => 'true') }
1018 $a->push_content($ry, $rn);
1019 $a->push_content($ru) if $nullable;
1025 ############################ HELPER METHODS ######################
1026 ##################################################################
1028 =head2 _rename_foreign_input
1030 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1032 Recursively renames the foreign inputs made by to_foreign_inputs so they
1033 can be processed generically. The format is "accessor__AsForeign_colname".
1035 So if an Employee is a Person who has own Address and you call
1037 Employee->to_field("person")
1039 then you will get inputs for Address named like this:
1041 person__AsForeign__address__AsForeign__street
1042 person__AsForeign__address__AsForeign__city
1043 person__AsForeign__address__AsForeign__state
1044 person__AsForeign__address__AsForeign__zip
1046 And the processor would know to create this address, put the address id in
1047 person address slot, create the person and put the address id in the employee
1048 before creating the employee.
1052 sub _rename_foreign_input {
1053 my ($self, $accssr, $input) = @_;
1054 if ( ref $input ne 'HASH' ) {
1055 # my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
1056 $input->attr( name => $accssr . "__AsForeign__" . $input->attr('name'));
1059 $self->_rename_foreign_input($accssr, $input->{$_})
1060 foreach (keys %$input);
1065 This functions computes the dimensions of a textarea based on the value
1070 our ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1075 my @rows = split /^/, $text;
1076 my $cols = $min_cols;
1079 my $len = length $_;
1081 $cols = $len if $len > $cols;
1082 $cols = $max_cols if $cols > $max_cols;
1085 $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1086 $rows = $min_rows if $rows < $min_rows;
1087 $rows = $max_rows if $rows > $max_rows;
1090 else { ($min_rows, $min_cols) }
1103 =head1 ORIGINAL AUTHOR
1105 Peter Speltz, Aaron Trevena
1111 chekbox generalization
1112 radio generalization
1114 Make link_hidden use standard make_url stuff when it gets in Maypole
1115 How do you tell AF --" I want a has_many select box for this every time so,
1116 when you call "to_field($this_hasmany)" you get a select box
1118 =head1 BUGS and QUERIES
1120 Please direct all correspondence regarding this module to:
1123 =head1 COPYRIGHT AND LICENSE
1125 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1127 This library is free software; you can redistribute it and/or modify
1128 it under the same terms as Perl itself.
1132 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.