From 4f4bbd04570ff3c5f59f99c5cbf868d9b1a3da49 Mon Sep 17 00:00:00 2001 From: Aaron Trevena Date: Wed, 25 Oct 2006 15:36:30 +0000 Subject: [PATCH] some more cleaning up and fixing for AsForm, changed CDBI::Base model to not always populate cgi classmetadata git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@538 48953598-375a-da11-a14b-00016c27c3ee --- lib/Maypole/Model/CDBI/AsForm.pm | 979 ++++++++++++++----------------- lib/Maypole/Model/CDBI/Base.pm | 16 +- 2 files changed, 469 insertions(+), 526 deletions(-) diff --git a/lib/Maypole/Model/CDBI/AsForm.pm b/lib/Maypole/Model/CDBI/AsForm.pm index 48894f9..76003ff 100644 --- a/lib/Maypole/Model/CDBI/AsForm.pm +++ b/lib/Maypole/Model/CDBI/AsForm.pm @@ -1,12 +1,5 @@ package Maypole::Model::CDBI::AsForm; -#TODO -- - -# 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 Class::C3; use strict; @@ -30,7 +23,7 @@ our @EXPORT = _options_from_array _options_from_hash ); -our $VERSION = '.96'; +our $VERSION = '.97'; =head1 NAME @@ -297,17 +290,18 @@ columns and a hashref of hashes of arguments for each column. If called with an =cut sub to_cgi { - my ($class, @columns) = @_; # pjs -- added columns arg - 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; + 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]) @@ -327,10 +321,6 @@ See C. You can also pass this argument in $args->{how}. sub to_field { my ($self, $field, $how, $args) = @_; - print STDERR "---------------------------------\n"; - print STDERR "[to_field] self : $self\n"; - print STDERR "[to_field] args : field : $field , how : $how , args : $args\n"; - print STDERR "[to_field] caller : ", join(' ',caller), "\n"; 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"; @@ -381,9 +371,9 @@ sub search_inputs { $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, @@ -411,7 +401,6 @@ sub search_inputs { 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')); } @@ -446,14 +435,12 @@ 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) @@ -464,16 +451,16 @@ 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); + 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) @@ -486,46 +473,41 @@ 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; - } - - # 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; + 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; + } + + # 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) @@ -569,102 +551,75 @@ sub _field_from_column { sub _to_textarea { - 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; + 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 = $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; -} - - -# Old version -#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; -#} - - + 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; +} =head2 recognized arguments @@ -680,10 +635,6 @@ sub _to_textfield { 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. @@ -746,7 +697,6 @@ sub _to_select { 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, @@ -775,15 +725,8 @@ sub _to_select { $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 { - # die "Usage _to_select. $col not related to any class to select from. "; - - #} - + # Set arguments unless ( defined $args->{column_nullable} ) { $args->{column_nullable} = $self->can('column_nullable') ? @@ -821,64 +764,68 @@ 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 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; - my $sth = $fclass->db_Main->prepare($sql); - $sth->execute; - my @data; - while ( my $d = $sth->fetchrow_hashref ) {push @data, $d}; - return \@data; + $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; } @@ -889,26 +836,26 @@ 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 -- - 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; + 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; } @@ -917,43 +864,42 @@ sub _to_enum_select { 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 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} || $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} || $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; +} =head2 _to_hidden($field, $args) @@ -965,20 +911,21 @@ name and the value of the column by the derived name. =cut sub _to_hidden { - 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."; } - $name = $obj->primary_column->name unless $name; - $value = $obj->$name unless $value; - } + 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."; + } + $name = $obj->primary_column->name unless $name; + $value = $obj->$name unless $value; + } - return HTML::Element->new('input', 'type' => 'hidden', - 'name' => $name, 'value'=>$value); - + return HTML::Element->new('input', 'type' => 'hidden', + 'name' => $name, 'value'=>$value); } =head2 _to_link_hidden($col, $args) @@ -989,34 +936,31 @@ 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_field('blahfooey', 'hidden', {name => $name, value => $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 @@ -1035,41 +979,42 @@ Arguments this recognizes are : =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->_croak( "No relationship for accessor $accssr"); + } - 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_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($_); - } + # 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_field('blahfooey', 'hidden', - {name => $_, value => $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; } @@ -1088,57 +1033,57 @@ and in the following ways 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; +} @@ -1156,13 +1101,9 @@ Items to make options out of can be =cut - - sub _select_guts { 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); @@ -1179,7 +1120,7 @@ sub _select_guts { 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; @@ -1189,7 +1130,8 @@ sub _select_guts { $a->push_content($ogrp); $i++; } - } + } + # Single Hash elsif ($type eq 'HASH') { $a->push_content($self->_options_from_hash($items, $args)); @@ -1231,15 +1173,16 @@ objects stringify method specified in $args->{stringify} as the content. Otherwi sub _options_from_objects { my ($self, $items, $args) = @_; my $selected = $args->{selected} || {}; - my $stringify = $args->{stringify} || $self->stringify_column; + my $stringify = $args->{stringify}; my @res; - for (@$items) { - my $id = $_->id; + for my $object (@$items) { + $stringify ||= $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 ? $_->$stringify : "$_"; + my $content = $stringify ? $object->$stringify : "$object"; $opt->push_content($content); push @res, $opt; } @@ -1247,61 +1190,59 @@ sub _options_from_objects { } sub _options_from_arrays { - my ($self, $items, $args) = @_; - my $selected = $args->{selected} || {}; - my @res; - my $class = $args->{class} || ''; - my $stringify = $args->{stringify} || $self->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; + my ($self, $items, $args) = @_; + my $selected = $args->{selected} || {}; + my @res; + my $class = $args->{class} || ''; + my $stringify = $args->{stringify} || $self->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; } @@ -1330,18 +1271,6 @@ sub _options_from_hashes { 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 @@ -1375,21 +1304,25 @@ Makes a radio button element -- TODO # 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; } @@ -1423,17 +1356,16 @@ person->{address} data slot, insert the person and put the person id in the empl =cut 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); - } + 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 @@ -1452,28 +1384,27 @@ or the defaults. =cut -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; - } - 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); + } } @@ -1498,11 +1429,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 @@ -1510,7 +1439,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 diff --git a/lib/Maypole/Model/CDBI/Base.pm b/lib/Maypole/Model/CDBI/Base.pm index a7e7d97..118062f 100644 --- a/lib/Maypole/Model/CDBI/Base.pm +++ b/lib/Maypole/Model/CDBI/Base.pm @@ -145,6 +145,19 @@ sub _do_update_or_create { return $obj, $fatal, $creating; } +=head2 view + +This command shows the object using the view factory template. + +=cut + +sub view : Exported { + my ($self, $r) = @_; + $r->build_form_elements(0); + return; +} + + =head2 delete Deprecated method that calls do_delete or a given classes delete method, please @@ -166,11 +179,12 @@ sub delete : Exported { if ($1 ne "Maypole::Model::Base" && $2 ne "delete") { $self->SUPER::delete(@_); } else { - warn "Maypole::Model::CDBI delete method is deprecated\n"; + warn "Maypole::Model::CDBI::Base delete method is deprecated\n"; $self->do_delete(@_); } } + sub do_delete { my ( $self, $r ) = @_; # FIXME: handle fatal error with exception -- 2.39.5