# -- $class->to_field($has_many_col); # foreign inputs
# $class->search_inputs; /
-
+use Class::C3;
use strict;
+
use warnings;
use base 'Exporter';
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
_options_from_array _options_from_hash
);
-our $VERSION = '.95';
+our $VERSION = '.96';
=head1 NAME
=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);
}
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;
}
=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
$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)
=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;
}
=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;
}
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;
}
=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 {
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');
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
projects / maypole.git / blobdiff