From 70a0d09c3f228f792775b4ac03894d0d37b5c444 Mon Sep 17 00:00:00 2001 From: Aaron Trevena Date: Tue, 24 Oct 2006 10:54:11 +0000 Subject: [PATCH] lots of debug warnings, fixes to AsForm select handling git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@536 48953598-375a-da11-a14b-00016c27c3ee --- Changes | 2 + lib/Maypole.pm | 15 +- lib/Maypole/Model/CDBI/AsForm.pm | 376 +++++++++++++++++-------------- lib/Maypole/View/Base.pm | 2 +- 4 files changed, 217 insertions(+), 178 deletions(-) diff --git a/Changes b/Changes index ff41b68..9ac3c6e 100644 --- a/Changes +++ b/Changes @@ -13,6 +13,8 @@ For information about current developments and future releases, see: Model inheritance re-organised New config method : additional, for stashing additional info, especially from additional_data method new warn method in maypole/request class/object, over-ridden by Apache::MVC, etc or own driver + AsForm fixes + new build_form_elements attribute for Maypole request, set it to 0 to avoid building cgi form if you don't need it 2.11 Mon 31 July 2006 diff --git a/lib/Maypole.pm b/lib/Maypole.pm index b9a6085..b08edbd 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -184,7 +184,7 @@ __PACKAGE__->mk_classdata($_) for qw( config init_done view_object model_classes __PACKAGE__->mk_accessors( qw( params query objects model_class template_args output path args action template error document_encoding content_type table - headers_in headers_out stash status parent) + headers_in headers_out stash status parent build_form_elements) ); __PACKAGE__->config( Maypole::Config->new() ); @@ -536,15 +536,13 @@ sub __call_hook This is the main request handling method and calls various methods to handle the request/response and defines the workflow within Maypole. -B. - =cut # The root of all evil sub handler_guts { my ($self) = @_; - + $self->build_form_elements(1); $self->__load_request_model; my $applicable = $self->is_model_applicable == OK; @@ -691,6 +689,15 @@ want to use something like Log::Log4perl instead. sub warn { } +=head2 build_form_elements + +$r->build_form_elements(0); + +Specify whether to build HTML form elements and populate +the cgi element of classmetadata. + +=cut + =item get_request You should only need to define this method if you are writing a new diff --git a/lib/Maypole/Model/CDBI/AsForm.pm b/lib/Maypole/Model/CDBI/AsForm.pm index f176f3e..e0499c6 100644 --- a/lib/Maypole/Model/CDBI/AsForm.pm +++ b/lib/Maypole/Model/CDBI/AsForm.pm @@ -327,6 +327,10 @@ 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"; @@ -455,7 +459,7 @@ sub unselect_element { =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 @@ -465,12 +469,11 @@ sub _field_from_how { $args ||= {}; no strict 'refs'; my $meth = "_to_$how"; - if (not $self->can($meth)) { - warn "Class can not $meth"; - return; + if (not $self->can($meth)) { + warn "Class can not $meth"; + return; } - return $self->$meth($field, $args); - return; + return $self->$meth($field, $args); } =head2 _field_from_relationship($field, $args) @@ -713,100 +716,111 @@ sub _to_textfield { =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; - } - - # 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; - } - $col = $args->{class}->primary_column; - $args->{name} ||= $col; + my ($self, $col, $args) = @_; + warn "\n---\n[_to_select] col : $col\n"; + warn "[_to_select] self : $self\n"; + warn "[_to_select] args : ",Dumper($args), "\n"; + warn "[_to_select] caller : ",caller(),"\n"; + + $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 ($rel_meta = $self->related_meta('r:)', $col) ) { - $args->{class} = $rel_meta->{foreign_class}; - # related objects pre selected if object + 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; + } + $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}; - } - + # "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}; } - # 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. "; + + } + # 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') ? - $self->column_nullable($col) : 1; - } - - # Get items to select from - my $items = _select_items($args); # array of hashrefs + # Set arguments + unless ( defined $args->{column_nullable} ) { + $args->{column_nullable} = $self->can('column_nullable') ? + $self->column_nullable($col) : 1; + } - # 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; } + # Get items to select from + my $items = _select_items($args); # array of hashrefs + + # 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; + } - #use Data::Dumper; - #warn "Just got items. They are " . Dumper($args->{items}); + use Data::Dumper; + warn "Just got items. They are " . Dumper($args->{items}); - # Make select HTML element - $a = $self->_select_guts($col, $args); + warn "col : $col\n"; - 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; } @@ -1154,64 +1168,68 @@ Items to make options out of can be sub _select_guts { - my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_; + my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_; - #$args->{stringify} ||= 'stringify_selectbox'; + #$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} || ''; + 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 ); + # 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') { + warn "making select of single hash"; + $a->push_content($self->_options_from_hash($items, $args)); + } + # Single Array + elsif ( $type eq 'ARRAY' and not ref $items->[0] ) { + warn "making select of single array"; + $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 + warn "making select of objects\n"; + $a->push_content($self->_options_from_objects($items, $args)); + } + # Array of Arrays + elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) { + warn "making select of array of arrays\n"; + $a->push_content($self->_options_from_arrays($items, $args)); + } + # Array of Hashes + elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) { + warn "making select of array of \n"; + $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; + return $a; } @@ -1225,20 +1243,26 @@ 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 $stringify = $args->{stringify} || $self->stringify_column; + + warn "self : $self\n"; + warn "stringify : $stringify\n"; + warn "stringify column : ", $self->stringify_column, "\n"; + warn "stringify in args : ", $args->{stringify}, "\n"; + + 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; } sub _options_from_arrays { @@ -1246,7 +1270,7 @@ sub _options_from_arrays { my $selected = $args->{selected} || {}; my @res; my $class = $args->{class} || ''; - my $stringify = $args->{stringify} || ''; + 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'); @@ -1301,23 +1325,29 @@ sub _options_from_hash { 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 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 = ($fclass and $stringify and $fclass->can($stringify)) ? - $fclass->$stringify($_) : - join(' ', map {$item->{$_} } keys %$item); - $opt->push_content( $content ); - push @res, $opt; - } - return @res; + my ($self, $items, $args) = @_; + warn "_options_from_hashes called with $self,", Dumper($items), Dumper($args), "\n"; + my $selected = $args->{selected} || {}; + my $pk = eval {$args->{class}->primary_column} || 'id'; + my $fclass = $args->{class} || ''; + my $stringify = $args->{stringify} || $self->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); + } + $opt->push_content( $content ); + push @res, $opt; + } + return @res; } # TODO -- Maybe diff --git a/lib/Maypole/View/Base.pm b/lib/Maypole/View/Base.pm index 277a0c9..f21e771 100644 --- a/lib/Maypole/View/Base.pm +++ b/lib/Maypole/View/Base.pm @@ -57,7 +57,7 @@ sub vars { $classmeta->{related_accessors} ||= [ $class->related($r) ]; $classmeta->{moniker} ||= $class->moniker; $classmeta->{plural} ||= $class->plural_moniker; - $classmeta->{cgi} ||= { $class->to_cgi }; + $classmeta->{cgi} ||= { $class->to_cgi } if ($r->build_form_elements); $classmeta->{stringify_column} ||= $class->stringify_column; # User-friendliness facility for custom template writers. -- 2.39.5