X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole%2FModel%2FCDBI%2FAsForm.pm;h=48894f9534b7a8b726da80a21bde9b813624cd7b;hb=1f6513b996a1327e839df5d5583f724ce34a2b3e;hp=cd295f3e06335e502cbd720839ee3625f688608c;hpb=745badbb1417451398a0f983c450fd8725794f65;p=maypole.git diff --git a/lib/Maypole/Model/CDBI/AsForm.pm b/lib/Maypole/Model/CDBI/AsForm.pm index cd295f3..48894f9 100644 --- a/lib/Maypole/Model/CDBI/AsForm.pm +++ b/lib/Maypole/Model/CDBI/AsForm.pm @@ -7,8 +7,9 @@ package Maypole::Model::CDBI::AsForm; # -- $class->to_field($has_many_col); # foreign inputs # $class->search_inputs; / - +use Class::C3; use strict; + use warnings; use base 'Exporter'; @@ -18,7 +19,6 @@ use HTML::Element; use Carp qw/cluck/; our $OLD_STYLE = 0; -# pjs -- Added new methods to @EXPORT our @EXPORT = qw( to_cgi to_field foreign_input_delimiter search_inputs unselect_element @@ -30,7 +30,7 @@ our @EXPORT = _options_from_array _options_from_hash ); -our $VERSION = '.95'; +our $VERSION = '.96'; =head1 NAME @@ -326,26 +326,28 @@ See C. You can also pass this argument in $args->{how}. =cut sub to_field { - my ($self, $field, $how, $args) = @_; - if (ref $how) { $args = $how; $how = ''; } - unless ($how) { $how = $args->{how} || ''; } -#warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n"; - # Set sensible default value - if ($field and not defined $args->{default}) { - my $def = $self->column_default($field) ; - # exclude defaults we don't want actually put as value for input - if (defined $def) { - $def = $def =~ /(^0000-00-00.*$|^0[0]*$|^0\.00$|CURRENT_TIMESTAMP|NULL)/i ? '' : $def ; - $args->{default} = $def; - } - } - - + 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"; + # Set sensible default value + if ($field and not defined $args->{default}) { + my $def = $self->column_default($field) ; + # exclude defaults we don't want actually put as value for input + if (defined $def) { + $def = $def =~ /(^0000-00-00.*$|^0[0]*$|^0\.00$|CURRENT_TIMESTAMP|NULL)/i ? '' : $def ; + $args->{default} = $def; + } + } - return $self->_field_from_how($field, $how, $args) || - $self->_field_from_relationship($field, $args) || - $self->_field_from_column($field, $args) || - $self->_to_textfield($field, $args); + return $self->_field_from_how($field, $how, $args) || + $self->_field_from_relationship($field, $args) || + $self->_field_from_column($field, $args) || + $self->_to_textfield($field, $args); } @@ -375,65 +377,64 @@ Example: sub search_inputs { - my ($class, $args) = @_; - $class = ref $class || $class; - #my $accssr_class = { $class->accessor_classes }; - my %cgi; - - $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns]; - - foreach my $field ( @{ $args->{columns} } ) { - my $base_args = { - no_hidden_constraints => 1, - column_nullable => 1, # empty option on select boxes - value => '', - }; - if ( ref $field eq "HASH" ) { # foreign search fields - my ($accssr, $cols) = each %$field; - $base_args->{columns} = $cols; - unless ( @$cols ) { - # default to search fields for related - #$cols = $accssr_class->{$accssr}->search_columns; - die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'"); - } - my $fcgi = $class->to_field($accssr, 'foreign_inputs', $base_args); - - # unset the default values for a select box - foreach (keys %$fcgi) { - my $el = $fcgi->{$_}; - if ($el->tag eq 'select') { - - $class->unselect_element($el); - my ($first, @content) = $el->content_list; - my @fc = $first->content_list; - my $val = $first ? $first->attr('value') : undef; - if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or - - #(defined $first->attr('value') or $first->attr('value') ne '')) - # push an empty option on stactk - $el->unshift_content(HTML::Element->new('option')); - } - } + my ($class, $args) = @_; + $class = ref $class || $class; + #my $accssr_class = { $class->accessor_classes }; + my %cgi; + + $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns]; + + foreach my $field ( @{ $args->{columns} } ) { + my $base_args = { + no_hidden_constraints => 1, + column_nullable => 1, # empty option on select boxes + value => '', + }; + if ( ref $field eq "HASH" ) { # foreign search fields + my ($accssr, $cols) = each %$field; + $base_args->{columns} = $cols; + unless ( @$cols ) { + # default to search fields for related + #$cols = $accssr_class->{$accssr}->search_columns; + die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'"); + } + my $fcgi = $class->to_field($accssr, 'foreign_inputs', $base_args); + + # unset the default values for a select box + foreach (keys %$fcgi) { + my $el = $fcgi->{$_}; + if ($el->tag eq 'select') { + + $class->unselect_element($el); + my ($first, @content) = $el->content_list; + my @fc = $first->content_list; + my $val = $first ? $first->attr('value') : undef; + if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or + + #(defined $first->attr('value') or $first->attr('value') ne '')) + # push an empty option on stactk + $el->unshift_content(HTML::Element->new('option')); + } + } - } - $cgi{$accssr} = $fcgi; - delete $base_args->{columns}; - } - else { - $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} }); - my $el = $cgi{$field}; - if ($el->tag eq 'select') { - $class->unselect_element($el); - my ($first, @content) = $el->content_list; - if ($first and $first->content_list) { # something - #(defined $first->attr('value') or $first->attr('value') ne '')) - # push an empty option on stactk - $el->unshift_content(HTML::Element->new('option')); - } - } - } - } - return \%cgi; + } + $cgi{$accssr} = $fcgi; + delete $base_args->{columns}; + } else { + $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} }); + my $el = $cgi{$field}; + if ($el->tag eq 'select') { + $class->unselect_element($el); + my ($first, @content) = $el->content_list; + if ($first and $first->content_list) { # something + #(defined $first->attr('value') or $first->attr('value') ne '')) + # push an empty option on stactk + $el->unshift_content(HTML::Element->new('option')); + } + } + } + } + return \%cgi; } @@ -458,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 @@ -468,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) @@ -536,36 +536,35 @@ Override at will. =cut sub _field_from_column { - my ($self, $field, $args) = @_; - # this class and pk are default class and field at this point - my $class = $args->{class} || $self; - $class = ref $class || $class; - $field ||= ($class->primary_columns)[0]; # TODO - - # Get column type - unless ($args->{column_type}) { - if ($class->can('column_type')) { - $args->{column_type} = $class->column_type($field); - } - else { - # Right, have some of this - eval "package $class; Class::DBI::Plugin::Type->import()"; - $args->{column_type} = $class->column_type($field); - } - } - my $type = $args->{column_type}; - - return $self->_to_textfield($field, $args) - if $type and $type =~ /^(VAR)?CHAR/i; #common type - return $self->_to_textarea($field, $args) - if $type and $type =~ /^(TEXT|BLOB)$/i; - return $self->_to_enum_select($field, $args) - if $type and $type =~ /^ENUM\((.*?)\)$/i; - return $self->_to_bool_select($field, $args) - if $type and $type =~ /^BOOL/i; - return $self->_to_readonly($field, $args) - if $type and $type =~ /^readonly$/i; - return; + my ($self, $field, $args) = @_; + # this class and pk are default class and field at this point + my $class = $args->{class} || $self; + $class = ref $class || $class; + $field ||= ($class->primary_columns)[0]; # TODO + + # Get column type + unless ($args->{column_type}) { + if ($class->can('column_type')) { + $args->{column_type} = $class->column_type($field); + } else { + # Right, have some of this + eval "package $class; Class::DBI::Plugin::Type->import()"; + $args->{column_type} = $class->column_type($field); + } + } + my $type = $args->{column_type}; + + return $self->_to_textfield($field, $args) + if $type and $type =~ /^(VAR)?CHAR/i; #common type + return $self->_to_textarea($field, $args) + if $type and $type =~ /^(TEXT|BLOB)$/i; + return $self->_to_enum_select($field, $args) + if $type and $type =~ /^ENUM\((.*?)\)$/i; + return $self->_to_bool_select($field, $args) + if $type and $type =~ /^BOOL/i; + return $self->_to_readonly($field, $args) + if $type and $type =~ /^readonly$/i; + return; } @@ -717,100 +716,102 @@ 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) = @_; + + $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; - } + # 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 + # 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}); + # 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; + } - # Make select HTML element - $a = $self->_select_guts($col, $args); + # Make select HTML element + $a = $self->_select_guts($col, $args); - if ($args->{multiple}) {$a->attr('multiple', 'multiple');} + if ($args->{multiple}) { + $a->attr('multiple', 'multiple'); + } - # Return - $OLD_STYLE && return $a->as_HTML; - $a; + # Return + $OLD_STYLE && return $a->as_HTML; + $a; } @@ -1158,64 +1159,63 @@ 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') { + $a->push_content($self->_options_from_hash($items, $args)); + } + # Single Array + elsif ( $type eq 'ARRAY' and not ref $items->[0] ) { + $a->push_content($self->_options_from_array($items, $args)); + } + # Array of Objects + elsif ( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) { + # make select of objects + $a->push_content($self->_options_from_objects($items, $args)); + } + # Array of Arrays + elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) { + $a->push_content($self->_options_from_arrays($items, $args)); + } + # Array of Hashes + elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) { + $a->push_content($self->_options_from_hashes($items, $args)); + } else { + die "You passed a weird type of data structure to me. Here it is: " . + Dumper($items ); + } - return $a; + return $a; } @@ -1229,20 +1229,21 @@ 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; + + 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 { @@ -1250,7 +1251,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'); @@ -1305,23 +1306,28 @@ 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) = @_; + 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