From 28823167d12d4cd1419cc6a58900c0fc5819e1af Mon Sep 17 00:00:00 2001 From: Aaron Trevena Date: Sat, 4 Feb 2006 17:56:18 +0000 Subject: [PATCH] applied Peter J Speltz model/asform fixes git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@452 48953598-375a-da11-a14b-00016c27c3ee --- lib/Maypole/Model/CDBI.pm | 26 +- lib/Maypole/Model/CDBI/AsForm.pm | 1097 ++++++++++++++++++++---------- lib/Maypole/View/TT.pm | 3 + 3 files changed, 757 insertions(+), 369 deletions(-) diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index a5c65f6..4423b69 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -371,17 +371,36 @@ sub related_class { } } +=head2 related_meta + + $class->related_meta($col); + +Given a column associated with a relationship it will return the relatation +ship type and the meta info for the relationship on the column. + +=cut + +sub related_meta { + my ($self,$r, $accssr) = @_; + $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr; + my $class_meta = $self->meta_info; + if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} } + keys %$class_meta) + { return $rel_type, $class_meta->{$rel_type}->{$accssr} }; +} + + =head2 isa_class -Returns class of a column inherited by is_a, assumes something can be more than one thing (have * is_a rels) +Returns class of a column inherited by is_a. =cut +# Maybe put this in IsA? sub isa_class { my ($class, $col) = @_; $class->_croak( "Need a column for isa_class." ) unless $col; my $isaclass; - # class col is first found in is returned my $isa = $class->meta_info("is_a") || {}; foreach ( keys %$isa ) { $isaclass = $isa->{$_}->foreign_class; @@ -395,7 +414,8 @@ sub isa_class { Returns hash ref of classes for accessors. This is an attempt at a more efficient method than calling "related_class()" -a bunch of times when you need it for many relations. +a bunch of times when you need it for many relations. +It may be good to call at startup and store in a global config. =cut diff --git a/lib/Maypole/Model/CDBI/AsForm.pm b/lib/Maypole/Model/CDBI/AsForm.pm index da29578..39cda98 100644 --- a/lib/Maypole/Model/CDBI/AsForm.pm +++ b/lib/Maypole/Model/CDBI/AsForm.pm @@ -12,22 +12,43 @@ 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 - type_of _to_foreign_inputs _to_enum_select _to_bool_select - to_select_from_many _to_select_from_related hasmany_class - _to_hidden _rename_foreign_input _to_readonly - make_param_foreign make_hidden_elmnt make_hidden_elmnt - a_select_box unselect_element do_select search_inputs); - - - -our $VERSION = '2.41'; -# PJS VERSION .05 -# 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) +our @EXPORT = + qw( + to_cgi to_field _to_textarea _to_textfield _to_select + _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 $VERSION = '.09'; + +# 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 =head1 NAME @@ -43,22 +64,60 @@ Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns ... sub create_or_edit { - my $class = shift; - my %cgi_field = $class->to_cgi; + my $self = shift; + my %cgi_field = $self->to_cgi; return start_form, (map { "$_: ". $cgi_field{$_}->as_HTML."
" } $class->Columns), end_form; } - #
- # Title:
- # Artist: - # ... - #
+ . . . somewhere use to_field($col, $how, $args) + 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 + +package Job; + +__PACKAGE__->has_a('employer' => 'Employer'); +__PACKAGE__->has_a('contact' => 'Contact') + +package Contact; + +__PACKAGE__->has_a('employer_also' => 'Employer'); +__PACKAGE__->has_many('jobs' => 'Job', + { join => { employer => 'employer_also' }, + constraint => { 'finshed' => 0 }, + order_by => "created ASC", + } +); + +package Employer; + +__PACKAGE__->has_many('jobs' => 'Job',); +__PACKAGE__->has_many('contacts' => 'Contact', + order_by => 'name DESC', +); + + + # Below gives select boxes with the multiple attribute. + my $select_jobs_for_new_contact = + Contact->to_field('jobs', 'select'); # Uses constraint and order by + + my $edit_jobs_for_existing_contact = + $contact->to_field('jobs', 'select'); + + + + # Random uses + + =head1 DESCRIPTION @@ -83,20 +142,21 @@ 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_fields; + 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_fields; + #$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); @@ -105,7 +165,6 @@ sub search_inputs { $class->unselect_element($fcgi->{$_}); } $cgi{$accssr} = $fcgi; - #warn "Searchy inputs for field $field is " . Dumper($cgi{$accssr}); } else { $cgi{$field} = $class->to_field($field); $class->unselect_element($cgi{$field}); @@ -115,21 +174,6 @@ sub search_inputs { } -=head2 do_select - -Retrieves object selected from a select box and puts in $r->objects[0]. -The select box input must be named the same as the primary key. - -NOTE only works with tables with single primary key for now. - -=cut - -sub do_select { - my ($self, $r) = @_; - $r->objects([ $self->retrieve($r->params->{$self->primary_column}) ]); - $r->template('view'); -} - =head2 unselect_element @@ -171,22 +215,6 @@ sub a_select_box { } -=head2 make_hidden_elmnt - -Makes a hidden HTML::Element and puts it in template_args{hidden_elements} -$model->make_hidden_elmnt($name, $val); - -=cut - -sub make_hidden_elmnt { - my ($self, $r, $col, $val) = @_; - my $elmnt = HTML::Element->new('input', 'type'=>'hidden', 'name'=>$col, 'value'=>$val); - - $r->{template_args}{hidden_elements} ||= []; - push @{ $r->{template_args}{hidden_elements} }, $elmnt; -} - - =head2 make_param_foreign @@ -242,23 +270,52 @@ of has-a relationships. =cut sub to_field { - my ($self, $field, $how) = @_; - my $class = ref $self || $self; - if ($how and $how =~ /^(text(area|field)|select)$/) { + my ($self, $field, @args) = @_; + my $how = shift @args unless ref $args[0]; + my $args = shift @args; # argument hash ref + + 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 _field_from_how($field, $how,$args) + +Returns an input element based the "how" parameter or nothing at all. +Override at will. + +=cut + +sub _field_from_how { + my ($self, $field, $how, $args) = @_; + if ($how) { no strict 'refs'; my $meth = "_to_$how"; - return $self->$meth($field); + return $self->$meth($field, $args) if $self->can($meth); } + return; +} + +=head2 _field_from_relationship($field, $args) + +Returns an input based on the relationship associated with the field or nothing. +Override at will. + +=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 $fclass = $rel_type ? $meta->{$rel_type}{$field}{foreign_class} : ''; + $args->{class} = $fclass; my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0; # maybe has_a select - return $self->_to_select($field, $fclass) if $rel_type eq 'has_a' and - $fclass_is_cdbi; + return $self->_to_select($field, $args) + if $rel_type eq 'has_a' and $fclass_is_cdbi; # maybe foreign inputs my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols @@ -266,133 +323,308 @@ sub to_field { { return $self->_to_foreign_inputs($field, undef, $meta->{$rel_type}{$field}); } - - # the rest - my $type; - if ($class->can('column_type')) { - $type = $class->column_type($field); - } - else { - # Right, have some of this - eval "package $class; Class::DBI::Plugin::Type->import()"; - $type = $class->column_type($field); - } + return; +} + +=head2 _field_from_column($field, $args) + +Returns an input based on the column's characteristics, namely type, or nothing. +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 $type = $args->{column_type}; - #return $self->_to_textfield($field) - # if $type and $type =~ /(var)?char/i; #common type - return $self->_to_textarea($field) + 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, $type) + return $self->_to_enum_select($field, $args) if $type and $type =~ /^ENUM\((.*?)\)$/i; - return $self->_to_bool_select($field, $type) + return $self->_to_bool_select($field, $args) if $type and $type =~ /^BOOL/i; - return $self->_to_readonly($field) + return $self->_to_readonly($field, $args) if $type and $type =~ /^readonly$/i; - return $self->_to_textfield($field); + return; } + sub _to_textarea { - my ($self, $col) = @_; + my ($self, $col, $args) = @_; # pjs added default - my $a = - HTML::Element->new("textarea", name => $col, rows => "3", cols => "22"); - my $val; - if (ref $self) { - $val = $self->$col; - } - else { - $val = eval {$self->column_default($col);}; - $val = '' unless defined $val; + $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; } sub _to_textfield { - my ($self, $col) = @_; - # pjs added default - my $val; - if (ref $self) { - $val = $self->$col; - } - else { - $val = eval {$self->column_default($col);}; - $val = '' unless defined $val; - } - - my $a = HTML::Element->new("input", type => "text", name => $col); - $a->attr("value" => $val); - $OLD_STYLE && return $a->as_HTML; - $a; + my ($self, $col, $args ) = @_; + $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->$col; + if (ref $val) { + if (my $meta = $self->related_meta('',$col)) { + if (my $code = $meta->{args}{deflate4edit} ) { + $val = ref $code ? &$code($val) : $val->$code; + } + else { + $val = $self->_attr($col); + } + } + else { + $val = $self->_attr($col); + } + } + + } + else { + $val = eval {$self->column_default($col);}; + $val = '' unless defined $val; + } + } + my $a = HTML::Element->new("input", type => "text", name => $name); + $a->attr("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, + 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. + 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 + +=head2 3. If you already have a list of objects to select from -- + + BeerDB:;Beer->to_field($col, 'select' , {items => $objects}); + +# 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, $hint, $selected) = @_; - my $has_a_class; - if (not $col) { # class is making select box of self - $has_a_class = ref $self || $self; - $col = $self->primary_column; + my ($self, $col, $args) = @_; + $args ||= {}; +# Do we have items already ? Go no further. + if ($args->{items}) { + my $a = $self->_select_guts($col, $args); + $OLD_STYLE && return $a->as_HTML; + return $a; } + +# 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) { + warn "No col. $self"; + 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; + } + # Related Class maybe ? + elsif (my ($rel_type, $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 + } + 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}; + + } + # We could say :Col is name and we are selecting out of class arg. + # DIE for now else { - $has_a_class = $hint || $self->__hasa_rels->{$col}->[0]; + #$args->{name} = $col; + die "Usage _to_select. $col not related to any class to select from. "; + + } + + # Set arguments + if ( $self->can('column_nullable') ) { + $args->{nullable} ||= $self->column_nullable($col); } - $selected ||= {}; - if (ref $self and my $id = eval { $self->$col->id }) { - $selected->{$id} = 1; - } - #pjs Possible sql limiting clause ("WHERE acol = 'X' " or "LIMIT 10", etc) - my $select_box_limit = eval { $self->has_a_select_limit->{$col} } || '' ; - - # Get columns to appear in select box options on forms. - # TODO -- there is maybe a good idiom for this. - my @select_box_cols; - @select_box_cols = $has_a_class->columns('SelectBox'); - @select_box_cols = $has_a_class->columns('Stringify') - unless @select_box_cols; - @select_box_cols = $has_a_class->_essential - unless @select_box_cols; - unshift @select_box_cols, $has_a_class->columns('Primary'); - my $sql = "SELECT " . join( ', ', @select_box_cols) . " FROM " . - $has_a_class->table . " " . $select_box_limit; - my $opts_data = $self->db_Main->selectall_arrayref($sql); - - my $a = HTML::Element->new("select", name => $col); - for (@$opts_data) { - my $id = shift @$_; - my $opt = HTML::Element->new("option", value => $id ); - $opt->attr("selected" => "selected") if $selected->{$id}; - my $content = eval {$has_a_class->stringify_selectbox($_);} || - join(' ', @$_); - $opt->push_content( $content ); - $a->push_content($opt); - } + # Get items to select from + $args->{items} = _select_items($args); +use Data::Dumper; +warn "Just got items. They are " . Dumper($args->{items}); + + # Make select HTML element + $a = $self->_select_guts($col, $args); + + # Return $OLD_STYLE && return $a->as_HTML; $a; + +} + + +############ +# FUNCTION # +############ +# Get Items +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) . + " 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); + } + # Makes a readonly input box out of column's value -# Currently object method only +# No args makes object to readonly sub _to_readonly { - my ($self, $col, $val) = @_; - unless (defined $val) { - $self->_croak("Cannot call _to_readonly on class without value arg.") - unless ref $self; - $val = $self->$col; - } - my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1', - 'name' => $col, 'value'=>$val); - $OLD_STYLE && return $a->as_HTML; - $a; + my ($self, $col, $val) = @_; + if (! $col) { # object to readonly + $val = $self->id; + $col = $self->primary_column; + } + unless (defined $val) { + $self->_croak("Cannot get value in _to_readonly .") + unless ref $self; + $val = $self->$col; + } + 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')"); @@ -405,16 +637,23 @@ This will not work unless you write your own column_type method in your model. sub _to_enum_select { my ($self, $col, $type) = @_; - $type =~ /ENUM\((.*?)\)/i; - (my $enum = $1) =~ s/'//g; - my @enum_vals = split /\s*,\s*/, $enum; + $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 ref $self - and eval { $self->$col eq $_ }; - $sel->push_content($_); + 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; @@ -454,16 +693,66 @@ sub _to_bool_select { } -=head2 _to_hidden($name, $value) +=head2 _to_hidden($col, $args) -This makes a hidden html element. Give it a name and value. +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. =cut + sub _to_hidden { my ($self, $name, $val) = @_; - return HTML::Element->new('input', 'type' => 'hidden', - 'name' => $name, 'value'=>$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; + } + return HTML::Element->new('input', 'type' => 'hidden', + 'name' => $name, 'value'=>$val + ); +} + +=head2 _to_link_hidden($col, $args) + +Makes a link with a hidden input with the id of $obj as the value and name. +Name defaults to the objects primary key. The object defaults to self. + +=cut + +sub _to_link_hidden { + my ($self, $accessor, $args) = @_; + my $r = $args->{r} || ''; + my $url = $args->{url} || ''; + + $self->_croak("_to_link_hidden called without Maypole Request object (\$r) and url. Need one or other.") + unless $r; + my ($obj, $name); + if (ref $self) { # hidding linking self + $obj = $self; + $name = $args->{name} || $obj->primary_column->name; + } + else { # hiding linking related object with id in args + $obj = $self->related_class($r, $accessor)->retrieve($args->{id}); + $name = $args->{name} || $obj->primary_column->name; # TODO make use meta data + } + $self->_croak("_to_link_hidden has no object") unless ref $obj; + my $href = $url || $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; } @@ -520,269 +809,343 @@ sub _to_foreign_inputs { return \%inputs; } -=head2 _rename_foreign_input - -_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". - -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: - person__AsForeign__address__AsForeign__street - person__AsForeign__address__AsForeign__city - person__AsForeign__address__AsForeign__state - person__AsForeign__address__AsForeign__zip +=head2 _hash_selected -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. +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. -=cut +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. + -sub _rename_foreign_input { - my ($self, $accssr, $input) = @_; - if ( ref $input ne 'HASH' ) { - my $new_name = $accssr . "__AsForeign__" . $input->attr('name'); - $input->attr( name => $new_name ); - } - else { - $self->_rename_foreign_input($accssr, $input->{$_}) - foreach (keys %$input); +=cut + +############ +# FUNCTION # +############ +sub _hash_selected { + my ($args) = shift; + my $selected = $args->{selected}; + return $selected unless $selected and ref $selected ne 'HASH'; + my $type = ref $selected; + # Single Object + if ($type and $type ne 'ARRAY') { + return {$selected->id => 1}; + } + # Single Scalar id + elsif (not $type) { + return { $selected => 1}; } -} - -# pjs - -=head2 to_select_from_many + # 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"; } +} + -Usage: $object->to_select_from_many($accessor|$objects_to_select_from, [$element_name], [$options]); -CD->has_many( 'songs' => "Songs" ); -... in some nearby piece of code: -my $cd = CD->retrieve($id); -my $select_song_html = $cd->to_select_from_many('songs'); -print "

Choose your Favorite song from $cd

"; -print $select_song_html.as_XML; -return; +=head2 _select_guts -# OR if you only want to select from a group of objects +Internal api method to make the actual select box form elements. -my @favorites = $cd->favorite_songs; -my $select_from_favorites = $cd->to_select_from_many(\@favorites); +3 types of lists making for -- + Array of CDBI objects. + Array of scalars , + Array or Array refs with cols from class. +=cut -This an object method that makes a select box out of the objects related to this object by a has_many relationship. The select box only allows one selection. -The multiple attribute can easily be added if needed to the element returned : -$this_element->attr('multiple', 'multiple'); -You can pass an array ref of objects to select from instead of the class accessor name if you already have the objects to select from. -Also, you can pass the name you want the element to have as a second argument. -The default is the primary key name (as returned by primary_column) of the firstobject that is being selected from. +sub _select_guts { + my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_; -If related class has a multi column pk, this dies for now.#strange things may happen as primary_column method is used. + $args->{stringify} ||= 'stringify_selectbox'; + $args->{selected} = _hash_selected($args); + my $name = $args->{name} || $col; + my $a = HTML::Element->new('select', name => $name); + $a->attr( %{$args->{attr}} ) if $args->{attr}; + + if ($args->{nullable}) { + my $null_element = HTML::Element->new('option'); + $null_element->attr(selected => 'selected') + if $args->{selected}{'null'}; + $null_element->push_content('-- choose or type --'); + $a->push_content($null_element); + } -=cut + my $items = $args->{items}; + my $proto = $items->[0]; + my $type = ref $proto || ''; + + # Objects + if ($type and $type !~ /ARRAY|HASH/i) { + # make select of objects + $a->push_content($self->_options_from_objects($items, $args)); + } + elsif ($type =~ /ARRAY/i) { + $a->push_content($self->_options_from_arrays($items, $args)); + } + elsif ($type =~ /HASH/i) { + $a->push_content($self->_options_from_hashes($items, $args)); + } + else { + $a->push_content($self->_options_from_scalars($items, $args)); + } + return $a; +} -sub to_select_from_many { - my ($self, $accessor, $elmnt_name) = @_; - my $objs = ref $accessor eq "ARRAY" ? $accessor : [$self->$accessor]; - my $rel_class = ( @$objs ) ? ref $objs->[0] : - eval{$self->hasmany_class($accessor)}; + + + - $elmnt_name = eval {$rel_class->primary_column} || "__AF_TSFM_OBJS__" - unless $elmnt_name; - return _to_select_from_objs($objs, $elmnt_name); - -} -=head2 _to_select_from_objs($objects, $name, $selected); +=head2 _options_from_objects ( $objects, $args); -Private method to makes a select box of objects passed with name passed. -Assumes they are same type +Private method to makes a options out of objects. It attempts to call each +objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails. =cut -sub _to_select_from_objs { - my ($objs, $elmnt_name) = @_; - CGI::Carp::croak("Usage: element name required") unless ($elmnt_name); -# $elmnt_name ||= eval {$objs->[0]->primary_column}; -# unless ($elmnt_name) { -# my $num = @$objs; -# $self->_carp ("Element name arg. not passed and couldn't get element name from object 0. Number of objects in arg are: $num"); -# return; -# } - - my $a = HTML::Element->new("select", name => $elmnt_name); - for (@$objs) { +sub _options_from_objects { + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + my $stringify = $args->{stringify} || ''; + my @res; + for (@$items) { my $opt = HTML::Element->new("option", value => $_->id); - $opt->push_content($_->stringify_self); - $a->push_content($opt); + $opt->attr(selected => "selected") if $selected->{$_->id}; + my $content = $stringify ? $_->$stringify : "$_"; + $opt->push_content($content); + push @res, $opt; } - $OLD_STYLE && return $a->as_HTML; - $a; + return @res; } - - -# pjs EXPERIMENTAL -# TODO this is crap. I think this will just be a public sub to select many objects from a class. Then you can do thingks like add them to has_many and stuff. -# -# not finished -# usage: CD->has_many('songs', 'Song', 'cd_id'); -# my $song_sel_element = $class->_to_select_many('songs', @options); -# @options have same form as a SQL::Abstract options with exception of -# -HINT element which is the class name if you want to give it. -# { '-HINT' => $classname, # so you can cheat, or be efficient -# 'logic'=> 'OR', # default is OR -# $limiting_col => $limit_val, -# $limiting_col2=> $limit_val2, -# . . . } -# -# -# make select box for has many. This is a multiple select box (select many) -# element. If you want to choose between on of the has_many's an object has ( -# ie -- a cd has many songs and you want to choose one of the songs from it) -# then pass an additional hash ref of limiting cols and vals. -# $cd->_to_many_select('songs', {'cd_id' => $cd->id, . . .} -sub _to_select_many { - my ($self, $accessor, $hint, $where, $order ) = @_; - my $has_many_class = $hint || $self->hasmany_class($accessor); - my %selected = (); - %selected = map { $_->id => 1} $self->$accessor if ref $self; - - my $pk = $has_many_class->primary_column; - my $a = $self->_to_select($pk, $has_many_class, \%selected, $where, $order); - $a->attr('multiple', 'multiple'); - $OLD_STYLE && return $a->as_HTML; - $a; +sub _options_from_arrays { + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + my @res; + my $fclass = $args->{class} || ''; + my $stringify = $args->{stringify} || ''; + for (@$items) { + my $id = $_->[0]; + 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('/', @{$_}); +use Data::Dumper; +warn "Content is $content"; + $opt->push_content( $content ); + push @res, $opt; + } + return @res; } - - - -sub _to_select_old_version { - my ($self, $col, $hint) = @_; - my $has_a_class = $hint || $self->__hasa_rels->{$col}->[0]; - my @objs = $has_a_class->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; +sub _options_from_scalars { + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + my @res; + for (@$items) { + my $opt = HTML::Element->new("option", value => $_ ); + #$opt->attr(selected => "selected") if $selected =~/^$id$/; + $opt->attr(selected => "selected") if $selected->{$_}; + $opt->push_content( $_ ); + push @res, $opt; + } + return @res; } - - -############################ HELPER METHODS ###################### -################################################################## - -# hasmany_class($accessor) -- stole code from Maypole::Model::CDBI -# Returns class of has_many relationship when given the accessor -sub hasmany_class { - my ( $self, $accessor ) = @_; - $self->_croak("No accessor (2nd arg) passed to hasmany_class") - unless $accessor; - my $rel_meta = $self->meta_info('has_many' => $accessor); +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 = $_->{$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; + } + return @res; +} - my $mapping; - if ( $mapping = $rel_meta->{args}->{mapping} and @$mapping ) { - return $rel_meta->{foreign_class}->meta_info('has_a')->{ $$mapping[0] }->{foreign_class}; - } - else { - return $rel_meta->{foreign_class}; - } +# +# 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 +# unspecified in search / add forms. +# +# Not tested +# TODO -- make this general checkboxse +# +# +sub _to_checkbox { + my ($self, $col, $args) = @_; + my $nullable = eval {self->column_nullable($col)} || 0; + + return $self->_to_radio($col) if !ref($self) || $nullable; + my $value = $self->$col; + my $a = HTML::Element->new("input", type=> "checkbox", name => $col); + $a->attr("checked" => 'true') if $value eq 'Y'; + return $a; } -1; - -=head1 ***NEW PJS Stuff**** GETTING SPECIFIC IN MODEL CLASS +# 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; +} -You can tell AsForm some things in your model classes to get custom results. In particular you can have: -=head2 Custom column_type methods -Since much of this modules functionality relies on the subroutine C -returning the type string from the database table definition Model classes can -benefit a great deal by writing their own. See example. This version tries to -call column_type with the model class first. IF your model's column_type returns -undef or it has no such method it falls back on -C<&Class::DBI::Plugin::Type::column_type> which is database independent but not -fully functional yet. For full functionality make a custom C method -in your base model class and override it in subclasses at will. Some \ -Class::DBI::* drivers such as Class::DBI::mysql have mostly functional ones. +############################ HELPER METHODS ###################### +################################################################## -With a column_type sub you can set bool options for users , make select boxes -for ordinary columns (by lying and returning an enum('blah', 'blh') string for a -column, get correct types for is_a inherited columns, optimize , and maybe more. +=head2 _rename_foreign_input -=head2 Appropriate elements for columns inherited from an is_a relationship +_rename_foreign_input($html_el_or_hash_of_them); # changes made by reference -At least you have the power to get them by making column_type work. +Recursively renames the foreign inputs made by to_foreign_inputs so they +can be processed generically. The format is "accessor__AsForeign_colname". -=head2 Select box specifications for has_a columns. +So if an Employee is a Person who has own Address and you call -You can specify columns to be selected for a select box's options - for a class by : + Employee->to_field("person") + +then you will get inputs for Address named like this: - __Package__->columns('SelectBox' => qw/col1 col2/); + person__AsForeign__address__AsForeign__street + person__AsForeign__address__AsForeign__city + person__AsForeign__address__AsForeign__state + person__AsForeign__address__AsForeign__zip -If you don't, 'Stringify' columns are used if they exist and lastly 'Essential' -columns. The 'Primary' column is always the option value. This means don't -include it in the 'SelectBox' columns unless you want it in the option content. +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. -You can limit rows selected for the select box with a has_a_select_limit sub like so: +=cut - Customer->has_a(pay_plan => "PayPlan"); - Customer->has_a(pick_fromTopFive => "Movie"); - sub has_a_select_limit { { - pay_plan => "WHERE is_available = 1", - pick_fromTopFive => "ORDER BY rank ASC LIMIT 5" } +sub _rename_foreign_input { + my ($self, $accssr, $input) = @_; + if ( ref $input ne 'HASH' ) { + # my $new_name = $accssr . "__AsForeign__" . $input->attr('name'); + $input->attr( name => $accssr . "__AsForeign__" . $input->attr('name')); + } + else { + $self->_rename_foreign_input($accssr, $input->{$_}) + foreach (keys %$input); } +} +=head2 _box($value) -If you need complex stringification make a C sub which -takes an arrayref. Elements are in order specified in columns('SelectBox') -or whatever columns list was used. Otherwise, the array is joined on ' '. +This functions computes the dimensions of a textarea based on the value +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) + } + else { ($min_rows, $min_cols) } +} -=head1 CHANGES -Many by Peter Speltz +1; -Version 1.x of this module returned raw HTML instead of -C objects, which made it harder to manipulate the -HTML before sending it out. If you depend on the old behaviour, set -C<$Class::DBI::AsForm::OLD_STYLE> to a true value. +=head1 CHANGES =head1 MAINTAINER -Tony Bowden +Maypole Developers =head1 ORIGINAL AUTHOR -Simon Cozens +Peter Speltz, Aaron Trevena + +=head1 TODO + + Documenting + Testing - lots + chekbox 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 =head1 BUGS and QUERIES Please direct all correspondence regarding this module to: - bug-Class-DBI-AsForm@rt.cpan.org + Maypole list. =head1 COPYRIGHT AND LICENSE @@ -798,3 +1161,5 @@ L, L, L. =cut + + diff --git a/lib/Maypole/View/TT.pm b/lib/Maypole/View/TT.pm index fd71b48..7106b7a 100644 --- a/lib/Maypole/View/TT.pm +++ b/lib/Maypole/View/TT.pm @@ -141,6 +141,9 @@ or CALL a method or operation which will also not return anything. You can specify expressions using the logical (and, or, not, ?:) and mathematic operators (+ - * / % mod div). +Results of TT commands are interpolated in the place of the template tags, unless +using SET or CALL, i.e. [% SET foo = 1 %], [% GET foo.bar('quz'); %] + =over 4 [% template.title or default.title %] -- 2.39.2