X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole%2FModel%2FCDBI%2FAsForm.pm;h=8a7f06c95e3f8237aad4d82009b0eba928353060;hb=ee812d68b34c0e43d89551e39ebf5b7d247ac5b6;hp=7956bbbedda71ef0f069242641415246bd835186;hpb=b9aff7e76eab19b36abd670e6fc75a8a3d821324;p=maypole.git diff --git a/lib/Maypole/Model/CDBI/AsForm.pm b/lib/Maypole/Model/CDBI/AsForm.pm index 7956bbb..8a7f06c 100644 --- a/lib/Maypole/Model/CDBI/AsForm.pm +++ b/lib/Maypole/Model/CDBI/AsForm.pm @@ -1,18 +1,6 @@ package Maypole::Model::CDBI::AsForm; - -#TODO -- -# lots of doc -# _to_select_or_create -- select input stays -# _to_create_or_select -- create input trumps -# - -# TESTED and Works -- -# has_many select -- $obj->to_field($has_many_col); # select one form many -# -- $class->to_field($has_many_col); # foreign inputs -# $class->search_inputs; / - - use strict; + use warnings; use base 'Exporter'; @@ -22,10 +10,9 @@ use HTML::Element; use Carp qw/cluck/; our $OLD_STYLE = 0; -# pjs -- Added new methods to @EXPORT our @EXPORT = qw( - to_cgi to_field make_element_foreign search_inputs unselect_element + to_cgi to_field foreign_input_delimiter search_inputs 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 @@ -34,7 +21,7 @@ our @EXPORT = _options_from_array _options_from_hash ); -our $VERSION = '.10'; +our $VERSION = '.97'; =head1 NAME @@ -57,34 +44,107 @@ Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns end_form; } -# Example of has_many select -package Job; -__PACKAGE__->has_a('job_employer' => 'Employer'); -__PACKAGE__->has_a('contact' => 'Contact') -package Contact; -__PACKAGE__->has_a('cont_employer' => 'Employer'); -__PACKAGE__->has_many('jobs' => 'Job', - { join => { job_employer => 'cont_employer' }, - constraint => { 'finshed' => 0 }, - order_by => "created ASC", - } -); + . . . + + # Somewhere else in a Maypole application about beer... + + + + + $beer->to_field('brewery', 'textfield', { + name => 'brewery_id', value => $beer->brewery, + # however, no need to set value since $beer is object + }); + + # Rate a beer + $beer->to_field(rating => select => { + items => [1 , 2, 3, 4, 5], + }); + + # Select a Brewery to visit in the UK + Brewery->to_field(brewery_id => { + items => [ Brewery->search_like(location => 'UK') ], + }); + + # Make a select for a boolean field + $Pub->to_field('open' , { items => [ {'Open' => 1, 'Closed' => 0 } ] }); + + $beer->to_field('brewery', { + selected => $beer->brewery, # again not necessary since caller is obj. + }); + + + $beer->to_field('brewery', 'link_hidden', {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery}); + # an html link that is also a hidden input to the object. R is required to + # make the uri unless you pass a uri + + + + ##################################################### + # Templates Usage + +
+ + ... + + + + . . . + + -package Employer; -__PACKAGE__->has_many('jobs' => 'Job',); -__PACKAGE__->has_many('contacts' => 'Contact', - order_by => 'name DESC', -); + . . . + +
+ + + ##################################################### + # Advanced Usage + + # has_many select + package Job; + __PACKAGE__->has_a('job_employer' => 'Employer'); + __PACKAGE__->has_a('contact' => 'Contact') + + package Contact; + __PACKAGE__->has_a('cont_employer' => 'Employer'); + __PACKAGE__->has_many('jobs' => 'Job', + { join => { job_employer => 'cont_employer' }, + constraint => { 'finshed' => 0 }, + order_by => "created ASC", + } + ); + + package Employer; + __PACKAGE__->has_many('jobs' => 'Job',); + __PACKAGE__->has_many('contacts' => 'Contact', + order_by => 'name DESC', + ); # Choose some jobs to add to a contact (has multiple attribute). my $job_sel = Contact->to_field('jobs'); # Uses constraint and order by - + # Choose a job from $contact->jobs my $job_sel = $contact->to_field('jobs'); - + + 1; + + =head1 DESCRIPTION @@ -108,22 +168,22 @@ example usages. $beer->to_field($col, $args); Not all _to_* methods pay attention to all arguments. For example, '_to_textfield' does not look in $args->{'items'} at all. - + =over =item name -- the name the element will have , this trumps the derived name. $beer->to_field('brewery', 'readonly', { - name => 'brewery_id' + name => 'brewery_id' }); - + =item value -- the initial value the element will have, trumps derived value $beer->to_field('brewery', 'textfield', { name => 'brewery_id', value => $beer->brewery, # however, no need to set value since $beer is object }); - + =item items -- array of items generally used to make select box options Can be array of objects, hashes, arrays, or strings, or just a hash. @@ -132,7 +192,7 @@ Can be array of objects, hashes, arrays, or strings, or just a hash. $beer->to_field(rating => select => { items => [1 , 2, 3, 4, 5], }); - + # Select a Brewery to visit in the UK Brewery->to_field(brewery_id => { items => [ Brewery->search_like(location => 'UK') ], @@ -154,11 +214,11 @@ Can be an simple scalar id, an object, or an array of either This in almost always derived in cases where it may be difficult to derive, -- # Select beers to serve on handpump Pub->to_field(handpumps => select => { - class => 'Beer', order_by => 'name ASC', multiple => 1, + class => 'Beer', order_by => 'name ASC', multiple => 1, }); =item column_type -- a string representing column type - + $pub->to_field('open', 'bool_select', { column_type => "bool('Closed', 'Open'), }); @@ -168,15 +228,15 @@ This in almost always derived in cases where it may be difficult to derive, -- Generally this can be set to get or not get a null/empty option added to a select box. AsForm attempts to call "$class->column_nullable" to set this and it defaults to true if there is no shuch method. - + $beer->to_field('brewery', { column_nullable => 1 }); -=item r or request -- the mapyole request object +=item r or request -- the Mapyole request object =item uri -- uri for a link , used in methods such as _to_link_hidden $beer->to_field('brewery', 'link_hidden', - {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery}); + {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery}); # an html link that is also a hidden input to the object. R is required to # make the uri unless you pass a uri @@ -185,18 +245,20 @@ and it defaults to true if there is no shuch method. These are used in making select boxes. order_by is a simple order by clause and constraint and join are hashes used to limit the rows selected. The difference is that join uses methods of the object and constraint uses -static values. You can also specify these in the relationship arguments. +static values. You can also specify these in the relationship definitions. +See the relationships documentation of how to set arbitrayr meta info. BeerDB::LondonBeer->has_a('brewery', 'BeerDB::Brewery', - order_by => 'brewery_name ASC', + order_by => 'brewery_name ASC', constraint => {location => 'London'}, 'join' => {'brewery_tablecolumn => 'beer_obj_column'}, ); - + =item no_hidden_constraints -- Tell AsForm not to make hidden inputs for relationship constraints. It does -this sometimes when making foreign inputs . +this sometimes when making foreign inputs. However, i think it should not +do this and that the FromCGI 's _create_related method should do it. =back @@ -214,34 +276,39 @@ columns and a hashref of hashes of arguments for each column. If called with an # and dont want to call to_field a bunch of times just to tweak one or # two of them. $self->to_cgi(@cols, {brewery => { - how => 'textfield' # too big for select + how => 'textfield' # too big for select }, - style => { - column_nullable => 0, - how => 'select', - items => ['Ale', 'Lager'] + style => { + column_nullable => 0, + how => 'select', + items => ['Ale', 'Lager'] } - } + }); =cut sub to_cgi { - my ($class, @columns) = @_; # pjs -- added columns arg - my $args = {}; - if (not @columns) { - @columns = $class->columns; - } - else { - if ( ref $columns[-1] eq 'HASH' ) { $args = pop @columns; } - } - map { $_ => $class->to_field($_, $args->{$_}) } @columns; + my ($class, @columns) = @_; + my $args = {}; + if (not @columns) { + @columns = $class->columns; + # Eventually after stabalization, we could add display_columns + #keys map { $_ => 1 } ($class->display_columns, $class->columns); + } else { + if ( ref $columns[-1] eq 'HASH' ) { + $args = pop @columns; + } + } + map { $_ => $class->to_field($_, $args->{$_}) } @columns; } =head2 to_field($field [, $how][, $args]) This maps an individual column to a form element. The C argument -can be used to force the field type into any you want. It tells AsForm how -to make the input ie-- forces it to use the method "_to_$how". +can be used to force the field type into any you want. All that you need +is a method named "_to_$how" in your class. Your class inherits many from +AsForm already. + If C is specified but the class cannot call the method it maps to, then AsForm will issue a warning and the default input will be made. You can write your own "_to_$how" methods and AsForm comes with many. @@ -251,23 +318,27 @@ See C. You can also pass this argument in $args->{how}. =cut sub to_field { - my ($self, $field, $how, $args) = @_; - if (ref $how) { $args = $how; $how = ''; } - unless ($how) { $how = $args->{how} || ''; } -#warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n"; - - #if (ref $field) { $args = $field; $field = '' } - - #use Data::Dumper; - #warn "args to_field are $field, . " . Dumper($how) . " , " . Dumper($args); - + my ($self, $field, $how, $args) = @_; + if (ref $how) { $args = $how; $how = ''; } + unless ($how) { $how = $args->{how} || ''; } + #warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n"; + # Set sensible default value + if ($field and not defined $args->{default}) { + my $def = $self->column_default($field) ; + # exclude defaults we don't want actually put as value for input + if (defined $def) { + $def = $def =~ /(^0000-00-00.*$|^0[0]*$|^0\.00$|CURRENT_TIMESTAMP|NULL)/i ? '' : $def ; + $args->{default} = $def; + } + } - return $self->_field_from_how($field, $how, $args) || - $self->_field_from_relationship($field, $args) || - $self->_field_from_column($field, $args) || - $self->_to_textfield($field, $args); + return $self->_field_from_how($field, $how, $args) || + $self->_field_from_relationship($field, $args) || + $self->_field_from_column($field, $args) || + $self->_to_textfield($field, $args); } + =head2 search_inputs my $cgi = $class->search_inputs ([$args]); # optional $args @@ -284,7 +355,7 @@ the value is a list ref of columns to search on in the related class. Example: sub BeerDB::Beer::search_columns { - return ( 'name' , 'rating', { brewery => [ 'name', 'location'] } ); + return ( 'name' , 'rating', { brewery => [ 'name', 'location'] } ); } # Now foreign inputs are made for Brewery name and location and the @@ -294,65 +365,63 @@ Example: sub search_inputs { - my ($class, $args) = @_; - $class = ref $class || $class; - #my $accssr_class = { $class->accessor_classes }; - my %cgi; - - $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns]; - - foreach my $field ( @{ $args->{columns} } ) { - my $base_args = { - no_hidden_constraints => 1, - column_nullable => 1, # empty option on select boxes - value => '', - }; - if ( ref $field eq "HASH" ) { # foreign search fields - my ($accssr, $cols) = each %$field; - $base_args->{columns} = $cols; - 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_field($accssr, 'foreign_inputs', $base_args); - - # unset the default values for a select box - foreach (keys %$fcgi) { - my $el = $fcgi->{$_}; - if ($el->tag eq 'select') { - - $class->unselect_element($el); - my ($first, @content) = $el->content_list; - my @fc = $first->content_list; - my $val = $first ? $first->attr('value') : undef; - if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or - - #(defined $first->attr('value') or $first->attr('value') ne '')) - # push an empty option on stactk - $el->unshift_content(HTML::Element->new('option')); - } - } - - } - $cgi{$accssr} = $fcgi; - delete $base_args->{columns}; - } - else { - $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} }); - my $el = $cgi{$field}; - if ($el->tag eq 'select') { - $class->unselect_element($el); - my ($first, @content) = $el->content_list; - if ($first and $first->content_list) { # something - #(defined $first->attr('value') or $first->attr('value') ne '')) - # push an empty option on stactk - $el->unshift_content(HTML::Element->new('option')); - } - } - } + my ($class, $args) = @_; + $class = ref $class || $class; + #my $accssr_class = { $class->accessor_classes }; + my %cgi; + + $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns]; + + foreach my $field ( @{ $args->{columns} } ) { + my $base_args = { + no_hidden_constraints => 1, + column_nullable => 1, # empty option on select boxes + value => '', + }; + if ( ref $field eq "HASH" ) { # foreign search fields + my ($accssr, $cols) = each %$field; + $base_args->{columns} = $cols; + 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_field($accssr, 'foreign_inputs', $base_args); + + # unset the default values for a select box + foreach (keys %$fcgi) { + my $el = $fcgi->{$_}; + if ($el->tag eq 'select') { + + $class->unselect_element($el); + my ($first, @content) = $el->content_list; + my @fc = $first->content_list; + my $val = $first ? $first->attr('value') : undef; + if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or + + # push an empty option on stactk + $el->unshift_content(HTML::Element->new('option')); + } + } + + } + $cgi{$accssr} = $fcgi; + delete $base_args->{columns}; + } else { + $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} }); + my $el = $cgi{$field}; + if ($el->tag eq 'select') { + $class->unselect_element($el); + my ($first, @content) = $el->content_list; + if ($first and $first->content_list) { # something + #(defined $first->attr('value') or $first->attr('value') ne '')) + # push an empty option on stactk + $el->unshift_content(HTML::Element->new('option')); + } + } } - return \%cgi; + } + return \%cgi; } @@ -364,35 +433,32 @@ sub search_inputs { =cut sub unselect_element { - my ($self, $el) = @_; - #unless (ref $el eq 'HTML::Element') { - #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); } - if ($el->tag eq 'select') { - foreach my $opt ($el->content_list) { - $opt->attr('selected', undef) if $opt->attr('selected'); - } - } + my ($self, $el) = @_; + if (ref $el && $el->can('tag') && $el->tag eq 'select') { + foreach my $opt ($el->content_list) { + $opt->attr('selected', undef) if $opt->attr('selected'); + } + } } =head2 _field_from_how($field, $how,$args) Returns an input element based the "how" parameter or nothing at all. -Override at will. +Override at will. =cut sub _field_from_how { - my ($self, $field, $how, $args) = @_; - return unless $how; - $args ||= {}; - no strict 'refs'; - my $meth = "_to_$how"; - if (not $self->can($meth)) { - warn "Class can not $meth"; - return; - } - return $self->$meth($field, $args); - return; + my ($self, $field, $how, $args) = @_; + return unless $how; + $args ||= {}; + no strict 'refs'; + my $meth = "_to_$how"; + if (not $self->can($meth)) { + warn "Class can not $meth"; + return; + } + return $self->$meth($field, $args); } =head2 _field_from_relationship($field, $args) @@ -405,60 +471,43 @@ For has_a it will give select box =cut sub _field_from_relationship { - my ($self, $field, $args) = @_; - return unless $field; - 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; - my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0; - - # maybe has_a select - 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}) - { - $args->{class} = $fclass; - return $self->_to_select($field, $args); - } - return; - } - # maybe has many select - if ($rel_meta->{name} eq 'has_many' and $fclass_is_cdbi and ref $self) { - # This condictions allows for trumping of the has_a args - if (not $rel_meta->{args}{no_select} and not $args->{no_select}) - { - $args->{class} = $fclass; - my @itms = $self->$field; # need list not iterator - $args->{items} = \@itms; - return $self->_to_select($field, $args); - } - return; - } + my ($self, $field, $args) = @_; + return unless $field; + my $rel_meta = $self->related_meta('r',$field) || return; + my $rel_name = $rel_meta->{name}; + my $fclass = $rel_meta->foreign_class; + my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0; + + # maybe has_a select + 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}) { + $args->{class} = $fclass; + return $self->_to_select($field, $args); + } + return; + } + # maybe has many select + if ($rel_meta->{name} eq 'has_many' and $fclass_is_cdbi and ref $self) { + # This condictions allows for trumping of the has_a args + if (not $rel_meta->{args}{no_select} and not $args->{no_select}) { + $args->{class} = $fclass; + my @itms = $self->$field; # need list not iterator + $args->{items} = \@itms; + 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_name eq 'has_own')) - { - $args->{related_meta} = $rel_meta; # suspect faster to set these args - return $self->_to_foreign_inputs($field, $args); - } - return; + # 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_name eq 'has_own')) { + $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. @@ -467,170 +516,140 @@ Override at will. =cut sub _field_from_column { - my ($self, $field, $args) = @_; - return unless $field; - 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) = @_; + # this class and pk are default class and field at this point + my $class = $args->{class} || $self; + $class = ref $class || $class; + $field ||= ($class->primary_columns)[0]; # TODO + + # 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, $args) - 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, $args) + 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; } sub _to_textarea { - my ($self, $col, $args) = @_; - # pjs added default - $args ||= {}; - my $val = $args->{value}; - - unless (defined $val) { - if (ref $self) { - $val = $self->$col; - } - else { - $val = eval {$self->column_default($col);}; - $val = '' unless defined $val; - } - } - my ($rows, $cols) = _box($val); - $rows = $args->{rows} if $args->{rows}; - $cols = $args->{cols} if $args->{cols};; - my $name = $args->{name} || $col; - my $a = - HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols); - $a->push_content($val); - $OLD_STYLE && return $a->as_HTML; - $a; + my ($self, $col, $args) = @_; + my $class = $args->{class} || $self; + $class = ref $class || $class; + $col ||= ($class->primary_columns)[0]; # TODO + # pjs added default + $args ||= {}; + my $val = $args->{value}; + + unless (defined $val) { + if (ref $self) { + $val = $self->$col; + } else { + $val = $args->{default}; + $val = '' unless defined $val; + } + } + my ($rows, $cols) = _box($val); + $rows = $args->{rows} if $args->{rows}; + $cols = $args->{cols} if $args->{cols};; + my $name = $args->{name} || $col; + my $a = + HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols); + $a->push_content($val); + $OLD_STYLE && return $a->as_HTML; + $a; } sub _to_textfield { - my ($self, $col, $args ) = @_; - use Carp qw/confess/; - confess "No col passed to _to_textfield" unless $col; - $args ||= {}; - my $val = $args->{value}; - my $name = $args->{name} || $col; - - unless (defined $val) { - if (ref $self) { - # Case where column inflates. - # Input would get stringification which could be not good. - # as in the case of Time::Piece objects - $val = $self->can($col) ? $self->$col : ''; # in case it is a virtual column - if (ref $val) { - if (my $meta = $self->related_meta('',$col)) { - if (my $code = $meta->{args}{deflate4edit} || $meta->{args}{deflate} ) { - $val = ref $code ? &$code($val) : $val->$code; - } - elsif ( $val->isa('Class::DBI') ) { - $val = $val->id; - } - else { - #warn "No deflate4edit code defined for $val of type " . - #ref $val . ". Using the stringified value in textfield.."; - } - } - else { - $val = $val->id if $val->isa("Class::DBI"); - } - } - - } - else { - $val = eval {$self->column_default($col);}; - $val = '' unless defined $val; - } + my ($self, $col, $args ) = @_; + use Carp qw/confess/; + confess "No col passed to _to_textfield" unless $col; + $args ||= {}; + my $val = $args->{value}; + my $name = $args->{name} || $col; + + unless (defined $val) { + if (ref $self) { + # Case where column inflates. + # Input would get stringification which could be not good. + # as in the case of Time::Piece objects + $val = $self->can($col) ? $self->$col : ''; # in case it is a virtual column + if (ref $val) { + if (my $meta = $self->related_meta('',$col)) { + if (my $code = $meta->{args}{deflate4edit} || $meta->{args}{deflate} ) { + $val = ref $code ? &$code($val) : $val->$code; + } elsif ( $val->isa('Class::DBI') ) { + $val = $val->id; + } else { + #warn "No deflate4edit code defined for $val of type " . + #ref $val . ". Using the stringified value in textfield.."; + } + } else { + $val = $val->id if $val->isa("Class::DBI"); + } + } + + } else { + $val = $args->{default}; + $val = '' unless defined $val; } - my $a; - # THIS If section is neccessary or you end up with "value" for a vaiue - # if val is - $val = '' unless defined $val; - $a = HTML::Element->new("input", type => "text", name => $name, value =>$val); - $OLD_STYLE && return $a->as_HTML; - $a; + } + my $a; + # THIS If section is neccessary or you end up with "value" for a vaiue + # if val is + $val = '' unless defined $val; + $a = HTML::Element->new("input", type => "text", name => $name, value =>$val); + $OLD_STYLE && return $a->as_HTML; + $a; } - -# Too expensive version -- TODO -#sub _to_select { -# my ($self, $col, $hint) = @_; -# my $fclass = $hint || $self->__hasa_rels->{$col}->[0]; -# my @objs = $fclass->retrieve_all; -# my $a = HTML::Element->new("select", name => $col); -# for (@objs) { -# my $sel = HTML::Element->new("option", value => $_->id); -# $sel->attr("selected" => "selected") -# if ref $self -# and eval { $_->id eq $self->$col->id }; -# $sel->push_content($_->stringify_self); -# $a->push_content($sel); -# } -# $OLD_STYLE && return $a->as_HTML; -# $a; -#} - - - -# pjs -# -- Rewrote this to be efficient -- no object creation. -# -- Added option for CDBI classes to specify a limiting clause -# via "has_a_select_limit". -# -- Added selected argument to set a selected - =head2 recognized arguments - + selected => $object|$id, name => $name, value => $value, where => SQL 'WHERE' clause, order_by => SQL 'ORDER BY' clause, + constraint => hash of constraints to search limit => SQL 'LIMIT' clause, items => [ @items_of_same_type_to_select_from ], class => $class_we_are_selecting_from stringify => $stringify_coderef|$method_name - - -# select box requirements -# 1. a select box for objecs of a has_a related class -- DONE =head2 1. a select box out of a has_a or has_many related class. # For has_a the default behavior is to make a select box of every element in # related class and you choose one. #Or explicitly you can create one and pass options like where and order BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'"); - + # For has_many the default is to get a multiple select box with all objects. # If called as an object method, the objects existing ones will be selected. Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"}); - + =head2 2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun. # general BeerDB::Beer->to_field('', 'select', $options) BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class - # with PK as ID, $Class->to_field() same. + # with PK as ID, $Class->to_field() same. BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10}); # specify exact where clause @@ -641,96 +660,99 @@ sub _to_textfield { # 3. a select box for arbitrary set of objects # Pass array ref of objects as first arg rather than field $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',); - + =cut sub _to_select { - my ($self, $col, $args) = @_; - $args ||= {}; - # Do we have items already ? Go no further. - if ($args->{items} and ref $args->{items}) { - my $a = $self->_select_guts($col, $args); - $OLD_STYLE && return $a->as_HTML; - if ($args->{multiple}) { $a->attr('multiple', 'multiple');} - return $a; - } + my ($self, $col, $args) = @_; - # Else what are we making a select box out of ? - # No Column parameter -- means making a select box of args->class or self - # Using all rows from class's table - if (not $col) { - unless ($args->{class}) { - $args->{class} = ref $self || $self; - # object selected if called with one - $args->{selected} = { $self->id => 1} - if not $args->{selected} and ref $self; - } - $col = $args->{class}->primary_column; + $args ||= {}; + # Do we have items already ? Go no further. + if ($args->{items} and ref $args->{items}) { + my $a = $self->_select_guts($col, $args); + $OLD_STYLE && return $a->as_HTML; + if ($args->{multiple}) { + $a->attr('multiple', 'multiple'); } - # Related Class maybe ? - elsif (my $rel_meta = $self->related_meta('r:)', $col) ) { - $args->{class} = $rel_meta->{foreign_class}; - # related objects pre selected if object - - # "Has many" -- Issues: - # 1) want to select one or many 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) { - my @itms = $self->$col; # need list not iterator - $args->{items} = \@itms; - my $a = $self->_select_guts($col, $args); - $OLD_STYLE && return $a->as_HTML; - return $a; - } - 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}; - } - + return $a; + } + + # Proceed with work + + my $rel_meta; + if (not $col) { + unless ($args->{class}) { + $args->{class} = ref $self || $self; + # object selected if called with one + $args->{selected} = { $self->id => 1} + if not $args->{selected} and ref $self; } - # We could say :Col is name and we are selecting out of class arg. - # DIE for now - else { - #$args->{name} = $col; - die "Usage _to_select. $col not related to any class to select from. "; - + $col = $args->{class}->primary_column; + $args->{name} ||= $col; + } + # Related Class maybe ? + elsif ($rel_meta = $self->related_meta('r:)', $col) ) { + $args->{class} = $rel_meta->{foreign_class}; + # related objects pre selected if object + # "Has many" -- Issues: + # 1) want to select one or many 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) { + my @itms = $self->$col; # need list not iterator + $args->{items} = \@itms; + my $a = $self->_select_guts($col, $args); + $OLD_STYLE && return $a->as_HTML; + return $a; + } 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}; } - - # Set arguments - unless ( defined $args->{column_nullable} ) { - $args->{column_nullable} = $self->can('column_nullable') ? - $self->column_nullable($col) : 1; - } + } + + # Set arguments + unless ( defined $args->{column_nullable} ) { + $args->{column_nullable} = $self->can('column_nullable') ? + $self->column_nullable($col) : 1; + } - # Get items to select from - $args->{items} = _select_items($args); - #use Data::Dumper; - #warn "Just got items. They are " . Dumper($args->{items}); + # Get items to select from + my $items = _select_items($args); # array of hashrefs - # Make select HTML element - $a = $self->_select_guts($col, $args); + # Turn items into objects if related + if ($rel_meta and not $args->{no_construct}) { + my @objs = (); + push @objs, $rel_meta->{foreign_class}->construct($_) foreach @$items; + $args->{items} = \@objs; + } else { + $args->{items} = $items; + } - if ($args->{multiple}) {$a->attr('multiple', 'multiple');} + # Make select HTML element + $a = $self->_select_guts($col, $args); - # Return - $OLD_STYLE && return $a->as_HTML; - $a; + if ($args->{multiple}) { + $a->attr('multiple', 'multiple'); + } + + # Return + $OLD_STYLE && return $a->as_HTML; + $a; } @@ -740,176 +762,168 @@ sub _to_select { # ############# # 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; + my ($a, $b) = @_; + my %isect; my %union; + foreach my $e (@$a, @$b) { + $union{$e}++ && $isect{$e}++; + } + return %isect; } + ############ # FUNCTION # ############ -# Get Items +# Get Items returns array of hashrefs sub _select_items { - my $args = shift; - my $fclass = $args->{class}; - my @disp_cols = @{$args->{columns} || []}; - @disp_cols = $fclass->columns('SelectBox') unless @disp_cols; - @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; - - #warn "in select items. args are : " . Dumper($args); - my $distinct = ''; - if ($args->{'distinct'}) { - $distinct = 'DISTINCT '; - } - - my $sql = "SELECT $distinct" . join( ', ', @disp_cols) . - " FROM " . $fclass->table; + my $args = shift; + my $fclass = $args->{class}; + my @disp_cols = @{$args->{columns} || []}; + @disp_cols = $fclass->columns('SelectBox') unless @disp_cols; + @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; + + #warn "in select items. args are : " . Dumper($args); + my $distinct = ''; + if ($args->{'distinct'}) { + $distinct = 'DISTINCT '; + } - $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"; + my $sql = "SELECT $distinct" . join( ', ', @disp_cols) . + " FROM " . $fclass->table; - return $fclass->db_Main->selectall_arrayref($sql); + $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"; + my $sth = $fclass->db_Main->prepare($sql); + $sth->execute; + my @data; + while ( my $d = $sth->fetchrow_hashref ) { + push @data, $d; + } + return \@data; } # Makes a readonly input box out of column's value # No args makes object to readonly sub _to_readonly { - my ($self, $col, $args) = @_; - my $val = $args->{value}; - if (not defined $val ) { # object to readonly - $self->_croak("AsForm: To readonly field called as class method without a value") unless ref $self; - $val = $self->id; - $col = $self->primary_column; - } - my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1', - 'name' => $col, 'value'=>$val); - $OLD_STYLE && return $a->as_HTML; - $a; + my ($self, $col, $args) = @_; + my $val = $args->{value}; + if (not defined $val ) { # object to readonly + $self->_croak("AsForm: To readonly field called as class method without a value") unless ref $self; + $val = $self->id; + $col = $self->primary_column; + } + my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1', + 'name' => $col, 'value'=>$val); + $OLD_STYLE && return $a->as_HTML; + $a; } =head2 _to_enum_select -$sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')"); - -Returns an enum select box given a column name and an enum string. -NOTE: The Plugin::Type does not return an enum string for mysql enum columns. -This will not work unless you write your own column_type method in your model. +Returns a select box for the an enum column type. =cut sub _to_enum_select { - my ($self, $col, $args) = @_; - my $type = $args->{column_type}; - $type =~ /ENUM\((.*?)\)/i; - (my $enum = $1) =~ s/'//g; - my @enum_vals = split /\s*,\s*/, $enum; - - # determine which is pre selected -- - # if obj, the value is , otherwise use column_default which is the first - # value in the enum list unless it has been overridden - my $selected = eval { $self->$col }; - $selected = eval{$self->column_default($col)} unless defined $selected; - $selected = $enum_vals[0] unless defined $selected; - - my $a = HTML::Element->new("select", name => $col); - for ( @enum_vals ) { - my $sel = HTML::Element->new("option", value => $_); - $sel->attr("selected" => "selected") if $_ eq $selected ; - $sel->push_content($_); - $a->push_content($sel); - } - $OLD_STYLE && return $a->as_HTML; - $a; + my ($self, $col, $args) = @_; + my $type = $args->{column_type}; + $type =~ /ENUM\((.*?)\)/i; + (my $enum = $1) =~ s/'//g; + my @enum_vals = split /\s*,\s*/, $enum; + + # determine which is pre selected + my $selected = eval { $self->$col }; + $selected = $args->{default} unless defined $selected; + $selected = $enum_vals[0] unless defined $selected; + + my $a = HTML::Element->new("select", name => $col); + for ( @enum_vals ) { + my $sel = HTML::Element->new("option", value => $_); + $sel->attr("selected" => "selected") if $_ eq $selected ; + $sel->push_content($_); + $a->push_content($sel); + } + $OLD_STYLE && return $a->as_HTML; + $a; } =head2 _to_bool_select - my $sel = $self->_to_bool_select($column, $bool_string); - -This makes select input for boolean column. You can provide a -bool string of form: Bool('zero','one') and those are used for option -content. Onthervise No and Yes are used. -TODO -- test without bool string. +Returns a "No/Yes" select box for a boolean column type. =cut -# TCODO fix this mess with args +# TODO fix this mess with args sub _to_bool_select { - my ($self, $col, $args) = @_; - my $type = $args->{column_type}; - my @bool_text = ('No', 'Yes'); - if ($type =~ /BOOL\((.+?)\)/i) { - (my $bool = $1) =~ s/'//g; - @bool_text = split /,/, $bool; - } + my ($self, $col, $args) = @_; + my $type = $args->{column_type}; + my @bool_text = ('No', 'Yes'); + if ($type =~ /BOOL\((.+?)\)/i) { + (my $bool = $1) =~ s/'//g; + @bool_text = split /,/, $bool; + } - # get selectedod - - my $selected = $args->{value} if defined $args->{value}; - $selected = $args->{selected} unless defined $selected; - $selected = ref $self ? eval {$self->$col;} : $self->column_default($col) - unless (defined $selected); - - my $a = HTML::Element->new("select", name => $col); - if ($args->{column_nullable} || $args->{value} eq '') { - my $null = HTML::Element->new("option"); - $null->attr('selected', 'selected') if $args->{value} eq ''; - $a->push_content( $null ); - } - - my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0), - HTML::Element->new("option", value => 1) ); - $opt0->push_content($bool_text[0]); - $opt1->push_content($bool_text[1]); - unless ($selected eq '') { - $opt0->attr("selected" => "selected") if not $selected; - $opt1->attr("selected" => "selected") if $selected; - } - $a->push_content($opt0, $opt1); - $OLD_STYLE && return $a->as_HTML; - $a; -} + # get selected + my $selected = $args->{value} if defined $args->{value}; + $selected = $args->{selected} unless defined $selected; + $selected = ref $self ? eval {$self->$col;} : $args->{default} + unless (defined $selected); + + my $a = HTML::Element->new("select", name => $col); + if ($args->{column_nullable} || !defined $args->{value} ) { + my $null = HTML::Element->new("option"); + $null->attr('selected', 'selected') if (!defined $args->{value}); + $a->push_content( $null ); + } + my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0), + HTML::Element->new("option", value => 1) ); + $opt0->push_content($bool_text[0]); + $opt1->push_content($bool_text[1]); + unless ($selected eq '') { + $opt0->attr("selected" => "selected") if not $selected; + $opt1->attr("selected" => "selected") if $selected; + } + $a->push_content($opt0, $opt1); + $OLD_STYLE && return $a->as_HTML; + $a; +} -=head2 _to_hidden($col, $args) +=head2 _to_hidden($field, $args) -This makes a hidden html element. Give it a name and value or if name is -a ref it will use the PK name and value of the object. +This makes a hidden html element input. It uses the "name" and "value" +arguments. If one or both are not there, it will look for an object in +"items->[0]" or the caller. Then it will use $field or the primary key for +name and the value of the column by the derived name. =cut sub _to_hidden { - my ($self, $name, $val) = @_; - my $args = {}; - my $obj; - if (ref $name and $name->isa("Class::DBI")) { - $obj = $name; - $name= ($obj->primary_columns)[0]->name; - } - if (ref $val) { - $args = $val; - $val = $args->{value}; - $name = $args->{name} if $args->{name}; - } - elsif (not $name ) { # hidding object caller - $self->_croak("No object available in _to_hidden") unless ref $self; - $name = ($self->primary_column)[0]->name; - $val = $self->id; + my ($self, $field, $args) = @_; + $args ||= {}; + my ($name, $value) = ($args->{'name'}, $args->{value}); + $name = $field unless defined $name; + if (! defined $name and !defined $value) { # check for objects + my $obj = $args->{items}->[0] || $self; + unless (ref $obj) { + die "_to_hidden cannot determine a value. It was passed a value argument or items object or called with an object."; } - return HTML::Element->new('input', 'type' => 'hidden', - 'name' => $name, 'value'=>$val - ); + $name = $obj->primary_column->name unless $name; + $value = $obj->$name unless $value; + } + + return HTML::Element->new('input', 'type' => 'hidden', + 'name' => $name, 'value'=>$value); } =head2 _to_link_hidden($col, $args) @@ -920,162 +934,164 @@ Name defaults to the objects primary key. The object defaults to self. =cut sub _to_link_hidden { - my ($self, $accessor, $args) = @_; - my $r = eval {$self->controller} || $args->{r} || ''; - my $uri = $args->{uri} || ''; - use Data::Dumper; - $self->_croak("_to_link_hidden cant get uri. No Maypole Request class (\$r) or uri arg. Need one or other.") - unless $r; - my ($obj, $name); - if (ref $self) { # hidding linking self - $obj = $self; - $name = $args->{name} || $obj->primary_column->name; - } - elsif ($obj = $args->{items}->[0]) { - $name = $args->{name} || $accessor || $obj->primary_column->name; - # TODO use meta data above maybe - } - else { # hiding linking related object with id in args - $obj = $self->related_class($r, $accessor)->retrieve($args->{id}); - $name = $args->{name} || $accessor ; #$obj->primary_column->name; - # TODO use meta data above maybe - } - $self->_croak("_to_link_hidden has no object") unless ref $obj; - my $href = $uri || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id; - my $a = HTML::Element->new('a', 'href' => $href); - $a->push_content("$obj"); - $a->push_content($self->_to_hidden($name, $obj->id)); - $OLD_STYLE && return $a->as_HTML; - $a; + my ($self, $accessor, $args) = @_; + my $r = eval {$self->controller} || $args->{r} || ''; + my $uri = $args->{uri} || ''; + $self->_croak("_to_link_hidden cant get uri. No Maypole Request class (\$r) or uri arg. Need one or other.") + unless $r; + my ($obj, $name); + if (ref $self) { # hidding linking self + $obj = $self; + $name = $args->{name} || $obj->primary_column->name; + } elsif ($obj = $args->{items}->[0]) { + $name = $args->{name} || $accessor || $obj->primary_column->name; + # TODO use meta data above maybe + } else { # hiding linking related object with id in args + $obj = $self->related_class($r, $accessor)->retrieve($args->{id}); + $name = $args->{name} || $accessor ; #$obj->primary_column->name; + # TODO use meta data above maybe + } + $self->_croak("_to_link_hidden has no object") unless ref $obj; + my $href = $uri || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id; + my $a = HTML::Element->new('a', 'href' => $href); + $a->push_content("$obj"); + $a->push_content($self->to_field('blahfooey', 'hidden', {name => $name, value => $obj->id} )); + + $OLD_STYLE && return $a->as_HTML; + return $a; } =head2 _to_foreign_inputs -$html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]); - -Get inputs for the accessor's class. Pass an array ref of fields to get -inputs for only those fields. Otherwise display_columns or all columns is used. -If you have the meta info handy for the accessor you can pass that too. +Creates inputs for a foreign class, usually related to the calling class or +object. In names them so they do not clash with other names and so they +can be processed generically. See _rename_foreign_inputs below and +Maypole::Model::CDBI::FromCGI::classify_foreign_inputs. -TODO make AsForm know more about the request like what action we are doing -so it can use edit columns or search_columns +Arguments this recognizes are : -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 + related_meta -- if you have this, great, othervise it will determine or die + columns -- list of columns to make inputs for + request (r) -- TODO the Maypole request so we can see what action =cut sub _to_foreign_inputs { - 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 ($self, $accssr, $args) = @_; + my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr); + my $fields = $args->{columns}; + if (!$rel_meta) { + $self->_carp( "[_to_foreign_inputs] No relationship for accessor $accssr"); + return; + } - my $rel_type = $rel_meta->{name}; - my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_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') ? - [$classORobj->display_columns] : [$classORobj->columns]; - } + unless ($fields) { + $fields = $classORobj->can('display_columns') ? + [$classORobj->display_columns] : [$classORobj->columns]; + } - # Ignore our fkey in them to prevent infinite recursion - 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 - $inputs{$_} = $classORobj->to_field($_); - } + # Ignore our fkey in them to prevent infinite recursion + my $me = eval {$rel_meta->{args}{foreign_key}} || + eval {$rel_meta->{args}{foreign_column}} + || ''; # what uses foreign_column has_many or might_have + my $constrained = $rel_meta->{args}{constraint}; + my %inputs; + foreach ( @$fields ) { + next if $constrained->{$_} || ($_ eq $me); # don't display constrained + $inputs{$_} = $classORobj->to_field($_); + } - # Make hidden inputs for constrained columns unless we are editing object - # TODO -- is this right thing to do? - unless (ref $classORobj || $args->{no_hidden_constraints}) { - $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_}) - foreach ( keys %$constrained ); - } - $self->_rename_foreign_input($accssr, \%inputs); - return \%inputs; + # Make hidden inputs for constrained columns unless we are editing object + # TODO -- is this right thing to do? + unless (ref $classORobj || $args->{no_hidden_constraints}) { + foreach ( keys %$constrained ) { + $inputs{$_} = $classORobj->to_field('blahfooey', 'hidden', + { name => $_, value => $constrained->{$_}} ); + } + } + $self->_rename_foreign_input($accssr, \%inputs); + return \%inputs; } =head2 _hash_selected -Method to make sense out of the "selected" argument which can be in a number -of formats perhaps. It returns a hashref with the the values of options to be -as the keys. +*Function* to make sense out of the "selected" argument which has values of the +options that should be selected by default when making a select box. It +can be in a number formats. This method returns a map of which options to +select with the values being the keys in the map ( {val1 => 1, val2 = 1} ). -Below handles these formats for the "selected" slot in the arguments hash: - Object (with id method) - Scalar (assumes it is value) - Array ref *OF* objects, arrays of data (0 elmnt used), hashes of data - (id key used), and simple scalars. - +Currently this method handles the following formats for the "selected" argument +and in the following ways + + Object -- uses the id method to get the value + Scalar -- assumes it *is* the value + Array ref of objects -- same as Object + Arrays of data -- uses the 0th element in each + Hashes of data -- uses key named 'id' + +=cut -=cut - ############ # FUNCTION # ############ + sub _hash_selected { - my ($args) = shift; - my $selected = $args->{value} || $args->{selected}; - #warn "**** SELECTED is $selected ****"; - my $type = ref $selected; - return $selected unless $selected and $type ne 'HASH'; - #warn "Selected dump : " . Dumper($selected); - # Single Object - if ($type and $type ne 'ARRAY') { - my $id = $selected->id; - $id =~ s/^0*//; - return {$id => 1}; - } - # Single Scalar id - elsif (not $type) { - return { $selected => 1}; - } - + my ($args) = shift; + my $selected = $args->{value} || $args->{selected}; + my $type = ref $selected; + return $selected unless $selected and $type ne 'HASH'; + + # Single Object + if ($type and $type ne 'ARRAY') { + my $id = $selected->id; + $id =~ s/^0*//; + return {$id => 1}; + } + # Single Scalar id + elsif (not $type) { + return { $selected => 1}; + } - # Array of objs, arrays, hashes, or just scalalrs. - elsif ($type eq 'ARRAY') { - my %hashed; - my $ltype = ref $selected->[0]; - # Objects - if ($ltype and $ltype ne 'ARRAY') { - %hashed = map { $_->id => 1 } @$selected; - } - # Arrays of data with id first - elsif ($ltype and $ltype eq 'ARRAY') { - %hashed = map { $_->[0] => 1 } @$selected; - } - # Hashes using pk or id key - elsif ($ltype and $ltype eq 'HASH') { - my $pk = $args->{class}->primary_column || 'id'; - %hashed = map { $_->{$pk} => 1 } @$selected; - } - # Just Scalars - else { - %hashed = map { $_ => 1 } @$selected; - } - return \%hashed; - } - else { warn "AsForm Could not hash the selected argument: $selected"; } -} - + # Array of objs, arrays, hashes, or just scalalrs. + elsif ($type eq 'ARRAY') { + my %hashed; + my $ltype = ref $selected->[0]; + # Objects + if ($ltype and $ltype ne 'ARRAY') { + %hashed = map { $_->id => 1 } @$selected; + } + # Arrays of data with id first + elsif ($ltype and $ltype eq 'ARRAY') { + %hashed = map { $_->[0] => 1 } @$selected; + } + # Hashes using pk or id key + elsif ($ltype and $ltype eq 'HASH') { + my $pk = $args->{class}->primary_column || 'id'; + %hashed = map { $_->{$pk} => 1 } @$selected; + } + # Just Scalars + else { + %hashed = map { $_ => 1 } @$selected; + } + return \%hashed; + } else { + warn "AsForm Could not hash the selected argument: $selected"; + } + return; +} =head2 _select_guts -Internal api method to make the actual select box form elements. +Internal api method to make the actual select box form elements. +the data. -3 types of lists making for -- +Items to make options out of can be Hash, Array, Array of CDBI objects. Array of scalars , @@ -1084,67 +1100,63 @@ Internal api method to make the actual select box form elements. =cut - - sub _select_guts { - my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_; + my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_; - #$args->{stringify} ||= 'stringify_selectbox'; - - $args->{selected} = _hash_selected($args) if defined $args->{selected}; - my $name = $args->{name} || $col; - my $a = HTML::Element->new('select', name => $name); - $a->attr( %{$args->{attr}} ) if $args->{attr}; + $args->{selected} = _hash_selected($args) if defined $args->{selected}; + my $name = $args->{name} || $col; + my $a = HTML::Element->new('select', name => $name); + $a->attr( %{$args->{attr}} ) if $args->{attr}; - if ($args->{column_nullable}) { - my $null_element = HTML::Element->new('option', value => ''); - $null_element->attr(selected => 'selected') - if ($args->{selected}{'null'}); - $a->push_content($null_element); - } + if ($args->{column_nullable}) { + my $null_element = HTML::Element->new('option', value => ''); + $null_element->attr(selected => 'selected') + if ($args->{selected}{'null'}); + $a->push_content($null_element); + } - my $items = $args->{items}; - my $type = ref $items; - my $proto = eval { ref $items->[0]; } || ""; - my $optgroups = $args->{optgroups} || ''; - - # Array of hashes, one for each optgroup - if ($optgroups) { - my $i = 0; - foreach (@$optgroups) { - my $ogrp= HTML::Element->new('optgroup', label => $_); - $ogrp->push_content($self->_options_from_hash($items->[$i], $args)); - $a->push_content($ogrp); - $i++; - } - } - # Single Hash - elsif ($type eq 'HASH') { - $a->push_content($self->_options_from_hash($items, $args)); - } - # Single Array - elsif ( $type eq 'ARRAY' and not ref $items->[0] ) { - $a->push_content($self->_options_from_array($items, $args)); - } - # Array of Objects - elsif( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) { - # make select of objects - $a->push_content($self->_options_from_objects($items, $args)); - } - # Array of Arrays - elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) { - $a->push_content($self->_options_from_arrays($items, $args)); - } - # Array of Hashes - elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) { - $a->push_content($self->_options_from_hashes($items, $args)); - } - else { - die "You passed a weird type of data structure to me. Here it is: " . - Dumper($items ); + my $items = $args->{items}; + my $type = ref $items; + my $proto = eval { ref $items->[0]; } || ""; + my $optgroups = $args->{optgroups} || ''; + + # Array of hashes, one for each optgroup + if ($optgroups) { + my $i = 0; + foreach (@$optgroups) { + my $ogrp= HTML::Element->new('optgroup', label => $_); + $ogrp->push_content($self->_options_from_hash($items->[$i], $args)); + $a->push_content($ogrp); + $i++; } + } - return $a; + # Single Hash + elsif ($type eq 'HASH') { + $a->push_content($self->_options_from_hash($items, $args)); + } + # Single Array + elsif ( $type eq 'ARRAY' and not ref $items->[0] ) { + $a->push_content($self->_options_from_array($items, $args)); + } + # Array of Objects + elsif ( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) { + # make select of objects + $a->push_content($self->_options_from_objects($items, $args)); + } + # Array of Arrays + elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) { + $a->push_content($self->_options_from_arrays($items, $args)); + } + # Array of Hashes + elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) { + $a->push_content($self->_options_from_hashes($items, $args)); + } else { + die "You passed a weird type of data structure to me. Here it is: " . + Dumper($items ); + } + + return $a; } @@ -1158,113 +1170,117 @@ objects stringify method specified in $args->{stringify} as the content. Otherwi =cut sub _options_from_objects { - my ($self, $items, $args) = @_; - my $selected = $args->{selected} || {}; - my $stringify = $args->{stringify} || ''; - my @res; - for (@$items) { - my $id = $_->id; - my $opt = HTML::Element->new("option", value => $id); - $id =~ s/^0*//; # leading zeros no good in hash key - $opt->attr(selected => "selected") if $selected->{$id}; - my $content = $stringify ? $_->stringify : "$_"; - $opt->push_content($content); - push @res, $opt; - } - return @res; + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + + my @res; + for my $object (@$items) { + my $stringify = $args->{stringify}; + if ($object->can('stringify_column') ) { + $stringify ||= $object->stringify_column if ($object->stringify_column && $object->can($object->stringify_column)); + } + my $id = $object->id; + my $opt = HTML::Element->new("option", value => $id); + $id =~ s/^0*//; # leading zeros no good in hash key + $opt->attr(selected => "selected") if $selected->{$id}; + my $content = $stringify ? $object->$stringify : "$object"; + $opt->push_content($content); + push @res, $opt; + } + return @res; } sub _options_from_arrays { - my ($self, $items, $args) = @_; - my $selected = $args->{selected} || {}; - my @res; - my $class = $args->{class} || ''; - my $stringify = $args->{stringify} || ''; - for my $item (@$items) { - my @pks; # for future multiple key support - push @pks, shift @$item foreach $class->columns('Primary'); - my $id = $pks[0]; - $id =~ s/^0+//; # In case zerofill is on . - my $val = defined $id ? $id : ''; - my $opt = HTML::Element->new("option", value =>$val); - $opt->attr(selected => "selected") if $selected->{$id}; - - my $content = ($class and $stringify and $class->can($stringify)) ? - $class->$stringify($_) : - join( '/', map { $_ if $_; }@{$item} ); - $opt->push_content( $content ); - push @res, $opt; - } - return @res; + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + my @res; + my $class = $args->{class} || ''; + my $stringify = $args->{stringify}; + $stringify ||= $self->stringify_column if ($self->can('stringify_column')); + for my $item (@$items) { + my @pks; # for future multiple key support + push @pks, shift @$item foreach $class->columns('Primary'); + my $id = $pks[0]; + $id =~ s/^0+//; # In case zerofill is on . + my $val = defined $id ? $id : ''; + my $opt = HTML::Element->new("option", value =>$val); + $opt->attr(selected => "selected") if $selected->{$id}; + my $content = ($class and $stringify and $class->can($stringify)) ? + $class->$stringify($_) : + join( '/', map { $_ if $_; }@{$item} ); + $opt->push_content( $content ); + push @res, $opt; + } + return @res; } sub _options_from_array { - my ($self, $items, $args) = @_; - my $selected = $args->{selected} || {}; - my @res; - for (@$items) { - my $val = defined $_ ? $_ : ''; - my $opt = HTML::Element->new("option", value => $val); - #$opt->attr(selected => "selected") if $selected =~/^$id$/; - $opt->attr(selected => "selected") if $selected->{$_}; - $opt->push_content( $_ ); - push @res, $opt; - } - return @res; + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + my @res; + for (@$items) { + my $val = defined $_ ? $_ : ''; + my $opt = HTML::Element->new("option", value => $val); + #$opt->attr(selected => "selected") if $selected =~/^$id$/; + $opt->attr(selected => "selected") if $selected->{$_}; + $opt->push_content( $_ ); + push @res, $opt; + } + return @res; } sub _options_from_hash { - my ($self, $items, $args) = @_; - my $selected = $args->{selected} || {}; - my @res; - - my @values = values %$items; - # hash Key is the option content and the hash value is option value - for (sort keys %$items) { - my $val = defined $items->{$_} ? $items->{$_} : ''; - my $opt = HTML::Element->new("option", value => $val); - #$opt->attr(selected => "selected") if $selected =~/^$id$/; - $opt->attr(selected => "selected") if $selected->{$items->{$_}}; - $opt->push_content( $_ ); - push @res, $opt; - } - return @res; + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + my @res; + + my @values = values %$items; + # hash Key is the option content and the hash value is option value + for (sort keys %$items) { + my $val = defined $items->{$_} ? $items->{$_} : ''; + my $opt = HTML::Element->new("option", value => $val); + $opt->attr(selected => "selected") if $selected->{$items->{$_}}; + $opt->push_content( $_ ); + push @res, $opt; + } + return @res; } sub _options_from_hashes { - my ($self, $items, $args) = @_; - my $selected = $args->{selected} || {}; - my $pk = eval {$args->{class}->primary_column} || 'id'; - my $fclass = $args->{class} || ''; - my $stringify = $args->{stringify} || ''; - my @res; - for (@$items) { - my $val = defined $_->{$pk} ? $_->{$pk} : ''; - my $opt = HTML::Element->new("option", value => $val); - $opt->attr(selected => "selected") if $selected->{$val}; - my $content = ($fclass and $stringify and $fclass->can($stringify)) ? - $fclass->$stringify($_) : - join(' ', @$_); - $opt->push_content( $content ); - push @res, $opt; + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + my $pk = eval {$args->{class}->primary_column} || 'id'; + my $fclass = $args->{class} || ''; + my $stringify = $args->{stringify}; + $stringify ||= $self->stringify_column if ( $self->can('stringify_column') ); + my @res; + for my $item (@$items) { + my $val = defined $item->{$pk} ? $item->{$pk} : ''; + my $opt = HTML::Element->new("option", value => $val); + $opt->attr(selected => "selected") if $selected->{$val}; + my $content; + if ($fclass and $stringify and $fclass->can($stringify)) { + $content = bless ($item,$fclass)->$stringify(); + } elsif ( $stringify ) { + $content = $item->{$stringify}; + } else { + $content = join(' ', map {$item->{$_} } keys %$item); } - return @res; + + $opt->push_content( $content ); + push @res, $opt; + } + return @res; } -# TODO -- Maybe -#sub _to_select_or_create { -# my ($self, $col, $args) = @_; -# $args->{name} ||= $col; -# my $select = $self->to_field($col, 'select', $args); -# $args->{name} = "create_" . $args->{name}; -# my $create = $self->to_field($col, 'foreign_inputs', $args); -# $create->{'__select_or_create__'} = -# $self->to_field('__select_or_create__',{ name => '__select_or_create__' , value => 1 } ); -# return ($select, $create); -#} - + +=head2 _to_checkbox + +Makes a checkbox element -- TODO + +=cut # # checkboxes: if no data in hand (ie called as class method), replace # with a radio button, in order to allow this field to be left @@ -1284,25 +1300,33 @@ sub _to_checkbox { return $a; } +=head2 _to_radio + +Makes a radio button element -- TODO +=cut # TODO -- make this general radio butons # sub _to_radio { - my ($self, $col) = @_; - my $value = ref $self && $self->$col || ''; - my $nullable = eval {self->column_nullable($col)} || 0; - my $a = HTML::Element->new("span"); - my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' ); - my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' ); - my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable; - $ry->push_content('Yes'); $rn->push_content('No'); - $ru->push_content('n/a') if $nullable; - if ($value eq 'Y') { $ry->attr("checked" => 'true') } - elsif ($value eq 'N') { $rn->attr("checked" => 'true') } - elsif ($nullable) { $ru->attr("checked" => 'true') } - $a->push_content($ry, $rn); - $a->push_content($ru) if $nullable; - return $a; + my ($self, $col) = @_; + my $value = ref $self && $self->$col || ''; + my $nullable = eval {self->column_nullable($col)} || 0; + my $a = HTML::Element->new("span"); + my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' ); + my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' ); + my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable; + $ry->push_content('Yes'); $rn->push_content('No'); + $ru->push_content('n/a') if $nullable; + if ($value eq 'Y') { + $ry->attr("checked" => 'true'); + } elsif ($value eq 'N') { + $rn->attr("checked" => 'true'); + } elsif ($nullable) { + $ru->attr("checked" => 'true'); + } + $a->push_content($ry, $rn); + $a->push_content($ru) if $nullable; + return $a; } @@ -1315,52 +1339,48 @@ 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 -can be processed generically. The format is "accessor__AsForeign_colname". +can be processed generically. It uses foreign_input_delimiter. -So if an Employee is a Person who has_own Address and you call +So if an Employee is a Person who has_many Addresses and you call and the +method 'foreign_input_delimiter' returns '__AF__' then - Employee->to_field("person") + Employee->to_field("person"); -then you will get inputs for the Person as well as their Address (by default, +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 - person__AsForeign__address__AsForeign__state - person__AsForeign__address__AsForeign__zip + person__AF__address__AF__street + person__AF__address__AF__city + person__AF__address__AF__state + person__AF__address__AF__zip And the processor would know to create this address, put the address id in -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 :) ) +person->{address} data slot, insert the person and put the person id in the employee->{person} data slot and then insert the employee with that data. =cut -sub make_element_foreign { - my ($self, $accssr, $element) = @_; - $element->attr( name => $accssr . "__AsForeign__" . $element->attr('name')); +sub _rename_foreign_input { + my ($self, $accssr, $element) = @_; + my $del = $self->foreign_input_delimiter; + + if ( ref $element ne 'HASH' ) { + # my $new_name = $accssr . "__AF__" . $input->attr('name'); + $element->attr( name => $accssr . $del . $element->attr('name')); + } else { + $self->_rename_foreign_input($accssr, $element->{$_}) + foreach (keys %$element); + } } +=head2 foreign_input_delimiter +This tells AsForm what to use to delmit forieign input names. This is important +to avoid name clashes as well as automating processing of forms. + +=cut + +sub foreign_input_delimiter { '__AF__' }; -sub _rename_foreign_input { - my ($self, $accssr, $element) = @_; - if ( ref $element ne 'HASH' ) { - # my $new_name = $accssr . "__AsForeign__" . $input->attr('name'); - $self->make_element_foreign($accssr, $element); - } - else { - $self->_rename_foreign_input($accssr, $element->{$_}) - foreach (keys %$element); - } -} =head2 _box($value) This functions computes the dimensions of a textarea based on the value @@ -1368,27 +1388,27 @@ or the defaults. =cut -our ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100); -sub _box -{ - my $text = shift; - if ($text) { - my @rows = split /^/, $text; - my $cols = $min_cols; - my $chars = 0; - for (@rows) { - my $len = length $_; - $chars += $len; - $cols = $len if $len > $cols; - $cols = $max_cols if $cols > $max_cols; - } - my $rows = @rows; - $rows = int($chars/$cols) + 1 if $chars/$cols > $rows; - $rows = $min_rows if $rows < $min_rows; - $rows = $max_rows if $rows > $max_rows; - ($rows, $cols) +sub _box { + my ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100); + my $text = shift; + if ($text) { + my @rows = split /^/, $text; + my $cols = $min_cols; + my $chars = 0; + for (@rows) { + my $len = length $_; + $chars += $len; + $cols = $len if $len > $cols; + $cols = $max_cols if $cols > $max_cols; } - else { ($min_rows, $min_cols) } + my $rows = @rows; + $rows = int($chars/$cols) + 1 if $chars/$cols > $rows; + $rows = $min_rows if $rows < $min_rows; + $rows = $max_rows if $rows > $max_rows; + ($rows, $cols) + } else { + ($min_rows, $min_cols); + } } @@ -1397,6 +1417,8 @@ sub _box =head1 CHANGES +1.0 +15-07-2004 -- Initial version =head1 MAINTAINER Maypole Developers @@ -1411,11 +1433,9 @@ Simon Cozens, Tony Bowden =head1 TODO - Documenting Testing - lots - chekbox generalization + checkbox generalization radio generalization - select work Make link_hidden use standard make_url stuff when it gets in Maypole How do you tell AF --" I want a has_many select box for this every time so, when you call "to_field($this_hasmany)" you get a select box @@ -1423,7 +1443,7 @@ Simon Cozens, Tony Bowden =head1 BUGS and QUERIES Please direct all correspondence regarding this module to: - Maypole list. + Maypole list. =head1 COPYRIGHT AND LICENSE