From ef5744f35f1e0f37a16d945b9ba8c0a5ed76d296 Mon Sep 17 00:00:00 2001 From: Aaron Trevena Date: Thu, 23 Feb 2006 13:01:22 +0000 Subject: [PATCH] peter speltz AsForm update git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@461 48953598-375a-da11-a14b-00016c27c3ee --- lib/Maypole/Model/CDBI/AsForm.pm | 450 +++++++++++++++++++------------ 1 file changed, 273 insertions(+), 177 deletions(-) diff --git a/lib/Maypole/Model/CDBI/AsForm.pm b/lib/Maypole/Model/CDBI/AsForm.pm index 3c35dfc..267cbea 100644 --- a/lib/Maypole/Model/CDBI/AsForm.pm +++ b/lib/Maypole/Model/CDBI/AsForm.pm @@ -12,19 +12,75 @@ use HTML::Element; our $OLD_STYLE = 0; # pjs -- Added new methods to @EXPORT -our @EXPORT = - qw( - to_cgi to_field _to_textarea _to_textfield _to_select +our @EXPORT = + qw( + to_cgi to_field make_element_foreign unselect_element + _field_from_how _field_from_relationship _field_from_column + _to_textarea _to_textfield _to_select _select_guts _to_foreign_inputs _to_enum_select _to_bool_select - _to_select_from_many _to_select_from_related _to_select_from_objs _to_hidden _to_link_hidden _rename_foreign_input _to_readonly _options_from_objects _options_from_arrays _options_from_hashes _options_from_scalars - _field_from_how _field_from_relationship _field_from_column - _select_guts unselect_element search_inputs make_param_foreign ); + +our @EXPORTOK = + qw( + + + ); + + + +our $VERSION = '.09'; +# Changes : +# 08-09-05 - fixed broken has_a select box +# - fiked some docs +# - _to_foreign_inputs now takes 3 positional parameters +# (accssr, fields, accssr_meta_info) + +# 10-18-05 - made _to_enum_select check column_default +# 10-19-05 - exported _to_select_from_objs +# - Now VERSION .06 +# 10-24-05 - _to_select_from_many Redesign. +# Now first arg is either a has_many accessor or a array ref of +# objects to select from and the options are in named list . +# selected : object or id +# name : the element name +# to_select_from_many ($accssr|$objs [, selected => $obj|$id, name => $elmnt_name]) +# +# - _to_hidden -- if object arg then name and value are from pk +# _ _rename_foreign_input -- took out useless assignment on new name +# - _to_select : put empty option if column is nullable +# 11-04-05 - _to_readonly with no args makes the calling object pk and id +# - _to_select : if object calls it without a column argument, it make# s a select box of the calling class rows and the object is pre selected. +# +# 11-05-05 - added _to_link_hidden to make a link to the hidden object +# - fixed _to_hidden when called with no args. Hides self obj. +# 11-04-05 - _to_textfield: tries to call "deflate4edit" if column is has_a +# 11-08-05 - Changed Version to .08 + + + +# 1-10-06 -- fixed bug in to_textfiled that was stringifyingf CDBI objects +# # +# +# 1-20-06 - to_select - call db_Main with has a class. +# 1-24-06 - to_select_from_many now named _to_select_from_many . Old deprecated +# - hasmany_class removed in favor of model's related_class method. +# - took out do_select. That is a model action. +# - use search_columns instead of search_fields now. +# - use to_field('column', 'select', {args}) instead of a_select_box. +# -- took out make_hidden_element.was my own personal hack +# -- added _box from DH's FormView to calculate decent textarea size +# -- Refactor to_field into _from_* method calls. +# +# 1-25-06 -- Added _to_checkbox and _to_radio from FView +# 1-27-06 -- Refactored into yet more exported methods +# 1-28-06 -- select constraints where, join order by +# 2-16-05 -- select box cols should only contain pks if you want them to +# be in he content string of the option. Went backt to old way. +# -our $VERSION = '2.11'; =head1 NAME @@ -51,12 +107,19 @@ Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns package BeerDB::Pint; __PACKAGE__->has_a('drinker', 'BeerDB::Drinker'); __PACKAGE__->has_a('beer', 'BeerDB::Beer'); + package BeerDB::Drinker; __PACKAGE__->has_many('pints', 'BeerDB::Pint'); - - # NEED to do mapping - my $sel = BeerDB::Drinker->to_field('pints', 'select') # multiple - my $sel = $Drunk->to_field('pints', 'select'); # Already had beers selected + + + # NOTE NEED to do mapping + + # Order a round -- multiple select of all pints if class method + my $sel = BeerDB::Drinker->to_field('pints', 'select') # + + # Take one down pass it around + my $choice = $Drunk->to_field('pints', 'select'); # Choose from what we already have + package Job; @@ -90,7 +153,8 @@ __PACKAGE__->has_many('contacts' => 'Contact', - # Random uses + # Random uses + =head1 DESCRIPTION @@ -108,46 +172,6 @@ The module is a mix-in which adds two additional methods to your C-derived class. -=head2 search_inputs - -Returns hashref of search inputs elements to use in cgi. - -Uses fields specified in search_fields, makes foreign inputs if necessary. - -=cut - -# TODO -- use search_columns - -sub search_inputs { - my ($class, $r) = @_; - warn "In model search_inputs " if $class->model_debug; - $class = ref $class || $class; - #my $accssr_class = { $class->accessor_classes }; - my %cgi; - my $sfs = [$class->search_columns]; - - foreach my $field ( @$sfs ) { - if ( ref $field eq "HASH" ) { # foreign search fields - my ($accssr, $cols) = each %$field; - unless ( @$cols ) { - # default to search fields for related - #$cols = $accssr_class->{$accssr}->search_columns; - die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'"); - } - my $fcgi = $class->_to_foreign_inputs($accssr, $cols); - # unset the default values for a select box - foreach (keys %$fcgi) { - $class->unselect_element($fcgi->{$_}); - } - $cgi{$accssr} = $fcgi; - } else { - $cgi{$field} = $class->to_field($field); - $class->unselect_element($cgi{$field}); - } - } - return \%cgi; -} - =head2 unselect_element @@ -169,12 +193,6 @@ sub unselect_element { } -=head2 a_select_box - - Returns a HTML::Element representing a select box, based on the arguments - -=cut - # make a select box from args sub a_select_box { my ($self, $name, $vals, $selected_val, $contents) = @_; @@ -197,18 +215,6 @@ sub a_select_box { -=head2 make_param_foreign - -Makes a new foreign parameter out of parameter and accessor -Just puts accssr__FOREIGN__ in front of param name - -=cut - -sub make_param_foreign { - my ($self, $r, $p, $accssr) = @_; - $r->params->{$accssr . '__FOREIGN__' . $p} = $r->params->{$p}; -} - =head2 to_cgi This returns a hash mapping all the column names of the class to @@ -253,7 +259,10 @@ of has-a relationships. sub to_field { my ($self, $field, @args) = @_; my $how = shift @args unless ref $args[0]; + my $args = shift @args; # argument hash ref + use Data::Dumper; + warn "args to_field are $field, " . Dumper(\@args); return $self->_field_from_how($field, $how, $args) || $self->_field_from_relationship($field, $args) || @@ -270,11 +279,12 @@ Override at will. sub _field_from_how { my ($self, $field, $how, $args) = @_; - if ($how) { - no strict 'refs'; - my $meth = "_to_$how"; - return $self->$meth($field, $args) if $self->can($meth); - } + $args ||= ''; + warn "field is $field. how is $how. args are $args"; + no strict 'refs'; + my $meth = $how ? "_to_$how" : '' ; + warn "Meth is $meth. field is $field"; + return $self->$meth($field, $args) if $meth and $self->can($meth); return; } @@ -283,30 +293,53 @@ sub _field_from_how { Returns an input based on the relationship associated with the field or nothing. Override at will. +For has_a it will give select box + =cut sub _field_from_relationship { my ($self, $field, $args) = @_; - my $meta = $self->meta_info; - my ($rel_type) = grep{ defined $meta->{$_}{$field} } keys %$meta; - $rel_type ||= ''; - my $fclass = $rel_type ? $meta->{$rel_type}{$field}{foreign_class} : ''; + my $rel_meta = $self->related_meta('r',$field) || return; + my $rel_name = $rel_meta->{name}; + #my $meta = $self->meta_info; + #grep{ defined $meta->{$_}{$field} } keys %$meta; + my $fclass = $rel_meta->foreign_class; $args->{class} = $fclass; my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0; # maybe has_a select - return $self->_to_select($field, $args) - if $rel_type eq 'has_a' and $fclass_is_cdbi; + warn "Dumper of relmeta. " . Dumper($rel_meta); + if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) { + # This condictions allows for trumping of the has_a args + if (not $rel_meta->{args}{no_select} and not $args->{no_select}) + { + return $self->_to_select($field, $args); + } + return; + } + + + #NOOO! maybe select from has_many +# if ($rel_type eq 'has_many' and ref $self) { +# $args->{items} ||= [$self->$field]; +# # arg name || fclass pk name || field +# if (not $args->{name}) { +# $args->{name} = eval{$fclass->primary_column->name} || $field; +# } +# return $self->_to_select($field, $args); +# } +# # maybe foreign inputs my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols - if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_type eq 'has_own')) + if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_name eq 'has_own')) { - return $self->_to_foreign_inputs($field, undef, $meta->{$rel_type}{$field}); + $args->{related_meta} = $rel_meta; # suspect faster to set these args + return $self->_to_foreign_inputs($field, $args); } return; } - + =head2 _field_from_column($field, $args) Returns an input based on the column's characteristics, namely type, or nothing. @@ -315,31 +348,32 @@ Override at will. =cut sub _field_from_column { - my ($self, $field, $args) = @_; - my $class = ref $self || $self; - # Get column type - unless ($args->{column_type}) { - if ($class->can('column_type')) { - $args->{column_type} = $class->column_type($field); - } else { - # Right, have some of this - eval "package $class; Class::DBI::Plugin::Type->import()"; - $args->{column_type} = $class->column_type($field); + my ($self, $field, $args) = @_; + my $class = ref $self || $self; + # Get column type + unless ($args->{column_type}) { + if ($class->can('column_type')) { + $args->{column_type} = $class->column_type($field); + } + else { + # Right, have some of this + eval "package $class; Class::DBI::Plugin::Type->import()"; + $args->{column_type} = $class->column_type($field); + } } - } - my $type = $args->{column_type}; - - return $self->_to_textfield($field) - if $type and $type =~ /(VAR)?CHAR/i; #common type - return $self->_to_textarea($field, $args) - if $type and $type =~ /^(TEXT|BLOB)$/i; - return $self->_to_enum_select($field, $args) - if $type and $type =~ /^ENUM\((.*?)\)$/i; - return $self->_to_bool_select($field, $args) - if $type and $type =~ /^BOOL/i; - return $self->_to_readonly($field, $args) - if $type and $type =~ /^readonly$/i; - return; + my $type = $args->{column_type}; + + return $self->_to_textfield($field) + if $type and $type =~ /(VAR)?CHAR/i; #common type + return $self->_to_textarea($field, $args) + if $type and $type =~ /^(TEXT|BLOB)$/i; + return $self->_to_enum_select($field, $args) + if $type and $type =~ /^ENUM\((.*?)\)$/i; + return $self->_to_bool_select($field, $args) + if $type and $type =~ /^BOOL/i; + return $self->_to_readonly($field, $args) + if $type and $type =~ /^readonly$/i; + return; } @@ -383,15 +417,21 @@ sub _to_textfield { $val = $self->$col; if (ref $val) { if (my $meta = $self->related_meta('',$col)) { + warn "Meta for $col"; if (my $code = $meta->{args}{deflate4edit} ) { $val = ref $code ? &$code($val) : $val->$code; } + elsif ( $val->isa('Class::DBI') ) { + $val = $val->id; + } else { - $val = $self->_attr($col); + warn "No deflate4edit code defined for $val of type " . + ref $val . ". Using the stringified value in textfield.."; } } else { - $val = $self->_attr($col); + warn "No meta for $col but ref $val.\n"; + $val = $val->id if $val->isa("Class::DBI"); } } @@ -506,26 +546,38 @@ sub _to_select { $col = $args->{class}->primary_column; } # Related Class maybe ? - elsif (my ($rel_type, $rel_meta) = $self->related_meta('r:)', $col) ) { + elsif (my $rel_meta = $self->related_meta('r:)', $col) ) { $args->{class} = $rel_meta->{foreign_class}; # related objects pre selected if object - $args->{selected} ||= [ $self->$col ] if ref $self; - # "Has many" -- we get multiple select - if ($rel_type =~ /has_many/i) { - $args->{attr}{multiple} = 'multiple'; - # TODO -- handle mapping + # "Has many" -- Issues: + # 1) want to select one from list if self is an object + # Thats about all we can do really, + # 2) except for mapping which is TODO and would + # do something like add to and take away from list of permissions for + # example. + + # Hasmany select one from list if ref self + if ($rel_meta->{name} =~ /has_many/i and ref $self) { + $args->{items} = [ $self->$col ]; + my $a = $self->_select_guts($col, $args); + $OLD_STYLE && return $a->as_HTML; + return $a; } - my $c = $rel_meta->{args}{constraint} || {}; - my $j = $rel_meta->{args}{join} || {}; - my @join ; - if (ref $self) { - @join = map { $_ ." = ". $self->_attr($_) } keys %$j; + else { + $args->{selected} ||= [ $self->$col ] if ref $self; + warn "selected is " . Dumper($args->{selected}); + my $c = $rel_meta->{args}{constraint} || {}; + my $j = $rel_meta->{args}{join} || {}; + my @join ; + if (ref $self) { + @join = map { $_ ." = ". $self->_attr($_) } keys %$j; + } + my @constr= map { "$_ = '$c->{$_}'"} keys %$c; + $args->{where} ||= join (' AND ', (@join, @constr)); + $args->{order_by} ||= $rel_meta->{args}{order_by}; + $args->{limit} ||= $rel_meta->{args}{limit}; } - my @constr= map { "$_ = '$c->{$_}'"} keys %$c; - $args->{where} ||= join (' AND ', (@join, @constr)); - $args->{order_by} ||= $rel_meta->{args}{order_by}; - $args->{limit} ||= $rel_meta->{args}{limit}; } # We could say :Col is name and we are selecting out of class arg. @@ -543,16 +595,30 @@ sub _to_select { # Get items to select from $args->{items} = _select_items($args); - # Make select HTML element - $a = $self->_select_guts($col, $args); + warn "Items selecting from are " . Dumper($args->{items}); +#use Data::Dumper; +#warn "Just got items. They are " . Dumper($args->{items}); - # Return + # Make select HTML element + $a = $self->_select_guts($col, $args); + + # Return $OLD_STYLE && return $a->as_HTML; $a; } - + +############## +# Function # +# ############# +# returns the intersection of list refs a and b +sub _list_intersect { + my ($a, $b) = @_; + my %isect; my %union; + foreach my $e (@$a, @$b) { $union{$e}++ && $isect{$e}++ } + return %isect; +} ############ # FUNCTION # ############ @@ -560,21 +626,23 @@ sub _to_select { sub _select_items { my $args = shift; my $fclass = $args->{class}; - my @select_box_cols; - @select_box_cols = $fclass->columns('SelectBox'); - @select_box_cols = $fclass->columns('Stringify') - unless @select_box_cols; - @select_box_cols = $fclass->_essential - unless @select_box_cols; - unshift @select_box_cols, $fclass->columns('Primary') - unless $select_box_cols[0] eq $fclass->columns('Primary'); - - my $sql = "SELECT " . join( ', ', @select_box_cols) . + my @disp_cols; + @disp_cols = $fclass->columns('SelectBox'); + @disp_cols = $fclass->columns('Stringify')unless @disp_cols; + @disp_cols = $fclass->_essential unless @disp_cols; + unshift @disp_cols, $fclass->columns('Primary'); + #my %isect = _list_intersect(\@pks, \@disp_cols); + #foreach (@pks) { push @sel_cols, $_ unless $isect{$_}; } + #push @sel_cols, @disp_cols; + + + my $sql = "SELECT " . join( ', ', @disp_cols) . " FROM " . $fclass->table; $sql .= " WHERE " . $args->{where} if $args->{where}; $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by}; $sql .= " LIMIT " . $args->{limit} if $args->{limit}; +warn "_select_items sql is : $sql"; return $fclass->db_Main->selectall_arrayref($sql); @@ -710,7 +778,8 @@ sub _to_link_hidden { my ($self, $accessor, $args) = @_; my $r = $args->{r} || ''; my $url = $args->{url} || ''; - + use Data::Dumper; + warn "$self Args are " . Dumper($args); $self->_croak("_to_link_hidden called without Maypole Request object (\$r) and url. Need one or other.") unless $r; my ($obj, $name); @@ -747,19 +816,22 @@ so it can use edit columns or search_columns NOTE , this names the foreign inputs is a particular way so they can be processed with a general routine and so there are not name clashes. +args - +related_meta -- if you have this, great, othervise it will determine or die +columns -- list of columns to make inputs for + =cut sub _to_foreign_inputs { - my ($self, $accssr, $fields, $accssr_meta) = @_; - if (!$accssr_meta) { - my $class_meta = $self->meta_info; - my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} } - keys %$class_meta; - $self->_croak( "No relationship for accessor $accssr") if not $rel_type; - $accssr_meta = $class_meta->{$rel_type}->{$accssr}; + my ($self, $accssr, $args) = @_; + my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr); + my $fields = $args->{columns}; + if (!$rel_meta) { + $self->_croak( "No relationship for accessor $accssr"); } - my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $accssr_meta->{foreign_class}; + my $rel_type = $rel_meta->{name}; + my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_meta->{foreign_class}; unless ($fields) { $fields = $classORobj->can('display_columns') ? @@ -767,8 +839,8 @@ sub _to_foreign_inputs { } # Ignore our fkey in them to prevent infinite recursion - my $me = eval {$accssr_meta->{args}{foreign_column}} || ''; - my $constrained = $accssr_meta->{args}{constraint}; + my $me = eval {$rel_meta->{args}{foreign_column}} || ''; + my $constrained = $rel_meta->{args}{constraint}; my %inputs; foreach ( @$fields ) { next if $constrained->{$_} || ($_ eq $me); # don't display constrained @@ -777,7 +849,7 @@ sub _to_foreign_inputs { # Make hidden inputs for constrained columns unless we are editing object # TODO -- is this right thing to do? - unless (ref $classORobj) { + unless (ref $classORobj || $args->{no_hidden_constraints}) { $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_}) foreach ( keys %$constrained ); } @@ -871,7 +943,7 @@ sub _select_guts { if ($args->{nullable}) { my $null_element = HTML::Element->new('option'); $null_element->attr(selected => 'selected') - if $args->{selected}{'null'}; + if ($args->{selected}{'null'}); $null_element->push_content('-- choose or type --'); $a->push_content($null_element); } @@ -881,7 +953,10 @@ sub _select_guts { my $type = ref $proto || ''; # Objects - if ($type and $type !~ /ARRAY|HASH/i) { + if (not $type) { + $a->push_content($self->_options_from_scalars($items, $args)); + } + elsif($type !~ /ARRAY|HASH/i) { # make select of objects $a->push_content($self->_options_from_objects($items, $args)); } @@ -892,7 +967,7 @@ sub _select_guts { $a->push_content($self->_options_from_hashes($items, $args)); } else { - $a->push_content($self->_options_from_scalars($items, $args)); + die "You passed a weird type of data structure to me. Here it is: $type"; } return $a; @@ -929,18 +1004,18 @@ sub _options_from_arrays { my ($self, $items, $args) = @_; my $selected = $args->{selected} || {}; my @res; - my $fclass = $args->{class} || ''; + my $class = $args->{class} || ''; my $stringify = $args->{stringify} || ''; - for (@$items) { - my $id = $_->[0]; + for my $item (@$items) { + my @pks; + push @pks, shift @$item foreach $class->columns('Primary'); + my $id = $pks[0] + 0; # In case zerofill is on . my $opt = HTML::Element->new("option", value => $id ); - #$opt->attr(selected => "selected") if $selected =~/^$id$/; $opt->attr(selected => "selected") if $selected->{$id}; - my $content = ($fclass and $stringify and $fclass->can($stringify)) ? - $fclass->$stringify($_) : - join('/', @{$_}); - + my $content = ($class and $stringify and $class->can($stringify)) ? + $class->$stringify($_) : + join( '/', map { $_ if $_; }@{$item} ); $opt->push_content( $content ); push @res, $opt; } @@ -968,15 +1043,17 @@ sub _options_from_hashes { my $fclass = $args->{class} || ''; my $stringify = $args->{stringify} || ''; my @res; - for my $item (@$items) { - my $val = $item->{$pk}; + for (@$items) { + my $val = $_->{$pk}; my $opt = HTML::Element->new("option", value => $val ); $opt->attr(selected => "selected") if $selected->{$val}; - my $content = ( $fclass && $stringify && $fclass->can($stringify)) ? $fclass->$stringify($item) : join(' ', @$item); + my $content = $fclass and $stringify and $fclass->can($stringify) ? + $fclass->$stringify($_) : + join(' ', @$_); $opt->push_content( $content ); - push @res, $opt; + push @res, $opt; } - return @res; + return @res; } # @@ -1029,14 +1106,15 @@ sub _to_radio { _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference -Recursively renames the foreign inputs made by to_foreign_inputs so they +Recursively renames the foreign inputs made by _to_foreign_inputs so they can be processed generically. The format is "accessor__AsForeign_colname". -So if an Employee is a Person who has own Address and you call +So if an Employee is a Person who has_own Address and you call Employee->to_field("person") -then you will get inputs for Address named like this: +then you will get inputs for the Person as well as their Address (by default, +override _field_from_relationship to change logic) named like this: person__AsForeign__address__AsForeign__street person__AsForeign__address__AsForeign__city @@ -1044,20 +1122,35 @@ then you will get inputs for Address named like this: person__AsForeign__address__AsForeign__zip And the processor would know to create this address, put the address id in -person address slot, create the person and put the address id in the employee -before creating the employee. +person->address data slot, create the person and put the person id in the employee->person data slot and then create the employee with that data. + +Overriede make_element_foreign to change how you want a foreign param labeled. + +=head2 make_element_foreign + + $class->make_element_foreign($accessor, $element); + +Makes an HTML::Element type object foreign elemen representing the +class's accessor. (IE this in an input element for $class->accessor :) ) =cut +sub make_element_foreign { + my ($self, $accssr, $element) = @_; + $element->attr( name => $accssr . "__AsForeign__" . $element->attr('name')); +} + + + sub _rename_foreign_input { - my ($self, $accssr, $input) = @_; - if ( ref $input ne 'HASH' ) { + my ($self, $accssr, $element) = @_; + if ( ref $element ne 'HASH' ) { # my $new_name = $accssr . "__AsForeign__" . $input->attr('name'); - $input->attr( name => $accssr . "__AsForeign__" . $input->attr('name')); + $self->make_element_foreign($accssr, $element); } else { - $self->_rename_foreign_input($accssr, $input->{$_}) - foreach (keys %$input); + $self->_rename_foreign_input($accssr, $element->{$_}) + foreach (keys %$element); } } =head2 _box($value) @@ -1133,3 +1226,6 @@ L, L, L. =cut + + + -- 2.39.2