X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole%2FModel%2FCDBI%2FAsForm.pm;h=7956bbbedda71ef0f069242641415246bd835186;hb=b9aff7e76eab19b36abd670e6fc75a8a3d821324;hp=a5296cd2bbe9be9e8f8057c3d4424e2003c2b06f;hpb=2c41363d0f5abf35c8d642db4b837f52f5954b2c;p=maypole.git diff --git a/lib/Maypole/Model/CDBI/AsForm.pm b/lib/Maypole/Model/CDBI/AsForm.pm index a5296cd..7956bbb 100644 --- a/lib/Maypole/Model/CDBI/AsForm.pm +++ b/lib/Maypole/Model/CDBI/AsForm.pm @@ -31,9 +31,9 @@ our @EXPORT = _to_foreign_inputs _to_enum_select _to_bool_select _to_hidden _to_link_hidden _rename_foreign_input _to_readonly _options_from_objects _options_from_arrays _options_from_hashes - _options_from_array _options_from_hash _to_select_or_create + _options_from_array _options_from_hash ); - + our $VERSION = '.10'; =head1 NAME @@ -383,8 +383,6 @@ Override at will. sub _field_from_how { my ($self, $field, $how, $args) = @_; - #if (ref $how) { $args = $how; $how = undef; } -#warn "In filed from how . filed is $field how is $how. args ar e" . Dumper($args) . " \n"; return unless $how; $args ||= {}; no strict 'refs'; @@ -408,7 +406,6 @@ For has_a it will give select box sub _field_from_relationship { my ($self, $field, $args) = @_; -#warn "In filed from rel . filed is $field \n"; return unless $field; my $rel_meta = $self->related_meta('r',$field) || return; my $rel_name = $rel_meta->{name}; @@ -418,7 +415,6 @@ sub _field_from_relationship { my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0; # maybe has_a select - #warn "Dumper of relmeta. " . Dumper($rel_meta); 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}) @@ -434,7 +430,8 @@ sub _field_from_relationship { if (not $rel_meta->{args}{no_select} and not $args->{no_select}) { $args->{class} = $fclass; - $args->{items} = $self->$field; + my @itms = $self->$field; # need list not iterator + $args->{items} = \@itms; return $self->_to_select($field, $args); } return; @@ -473,10 +470,8 @@ sub _field_from_column { my ($self, $field, $args) = @_; return unless $field; my $class = ref $self || $self; - #warn "Class is $class\n"; # Get column type unless ($args->{column_type}) { - $args->{column_type} = $class->column_type($field); if ($class->can('column_type')) { $args->{column_type} = $class->column_type($field); } @@ -489,7 +484,7 @@ sub _field_from_column { my $type = $args->{column_type}; return $self->_to_textfield($field, $args) - if $type and $type =~ /(VAR)?CHAR/i; #common type + 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) @@ -530,6 +525,8 @@ sub _to_textarea { 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; @@ -542,7 +539,6 @@ sub _to_textfield { $val = $self->can($col) ? $self->$col : ''; # in case it is a virtual column if (ref $val) { if (my $meta = $self->related_meta('',$col)) { - #warn "Meta for $col"; if (my $code = $meta->{args}{deflate4edit} || $meta->{args}{deflate} ) { $val = ref $code ? &$code($val) : $val->$code; } @@ -555,7 +551,6 @@ sub _to_textfield { } } else { - #warn "No meta for $col but ref $val.\n"; $val = $val->id if $val->isa("Class::DBI"); } } @@ -566,9 +561,11 @@ sub _to_textfield { $val = '' unless defined $val; } } - my $a = HTML::Element->new("input", type => "text", name => $name, value => - $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; } @@ -651,7 +648,7 @@ sub _to_textfield { sub _to_select { my ($self, $col, $args) = @_; $args ||= {}; -# Do we have items already ? Go no further. + # 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; @@ -659,7 +656,7 @@ sub _to_select { return $a; } -# Else what are we making a select box out of ? + # 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) { @@ -677,7 +674,7 @@ sub _to_select { # related objects pre selected if object # "Has many" -- Issues: - # 1) want to select one from list if self is an object + # 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 @@ -685,7 +682,8 @@ sub _to_select { # Hasmany select one from list if ref self if ($rel_meta->{name} =~ /has_many/i and ref $self) { - $args->{items} = [ $self->$col ]; + 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; @@ -722,9 +720,8 @@ sub _to_select { # Get items to select from $args->{items} = _select_items($args); - #warn "Items selecting from are " . Dumper($args->{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); @@ -776,7 +773,7 @@ sub _select_items { $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"; + #warn "_select_items sql is : $sql"; return $fclass->db_Main->selectall_arrayref($sql); @@ -786,19 +783,16 @@ sub _select_items { # Makes a readonly input box out of column's value # No args makes object to readonly sub _to_readonly { - my ($self, $col, $val) = @_; - if (! $col) { # object 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; } - 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; + $OLD_STYLE && return $a->as_HTML; $a; } @@ -853,7 +847,6 @@ TODO -- test without bool string. # TCODO fix this mess with args sub _to_bool_select { my ($self, $col, $args) = @_; - #warn "In to_bool select\n"; my $type = $args->{column_type}; my @bool_text = ('No', 'Yes'); if ($type =~ /BOOL\((.+?)\)/i) { @@ -1033,12 +1026,15 @@ Below handles these formats for the "selected" slot in the arguments hash: sub _hash_selected { my ($args) = shift; my $selected = $args->{value} || $args->{selected}; - return $selected unless $selected and ref $selected ne 'HASH'; - #warn "Selected dump : " . Dumper($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') { - return {$selected->id => 1}; + my $id = $selected->id; + $id =~ s/^0*//; + return {$id => 1}; } # Single Scalar id elsif (not $type) { @@ -1094,6 +1090,7 @@ 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); @@ -1157,6 +1154,8 @@ sub _select_guts { 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. +*Note only single primary keys supported + =cut sub _options_from_objects { my ($self, $items, $args) = @_; @@ -1164,8 +1163,10 @@ sub _options_from_objects { my $stringify = $args->{stringify} || ''; my @res; for (@$items) { - my $opt = HTML::Element->new("option", value => $_->id); - $opt->attr(selected => "selected") if $selected->{$_->id}; + 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; @@ -1183,8 +1184,9 @@ sub _options_from_arrays { 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 $opt = HTML::Element->new("option", value => $id ); + $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)) ? @@ -1202,7 +1204,8 @@ sub _options_from_array { my $selected = $args->{selected} || {}; my @res; for (@$items) { - my $opt = HTML::Element->new("option", value => $_ ); + 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( $_ ); @@ -1219,7 +1222,8 @@ sub _options_from_hash { my @values = values %$items; # hash Key is the option content and the hash value is option value for (sort keys %$items) { - my $opt = HTML::Element->new("option", value => $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( $_ ); @@ -1237,8 +1241,8 @@ sub _options_from_hashes { my $stringify = $args->{stringify} || ''; my @res; for (@$items) { - my $val = $_->{$pk}; - my $opt = HTML::Element->new("option", value => $val ); + my $val = defined $_->{$pk} ? $_->{$pk} : ''; + my $opt = HTML::Element->new("option", value => $val); $opt->attr(selected => "selected") if $selected->{$val}; my $content = ($fclass and $stringify and $fclass->can($stringify)) ? $fclass->$stringify($_) : @@ -1249,16 +1253,17 @@ sub _options_from_hashes { return @res; } -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); -} +# 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); +#} # # checkboxes: if no data in hand (ie called as class method), replace