our $OLD_STYLE = 0;
# pjs -- Added new methods to @EXPORT
-our @EXPORT = qw( to_cgi to_field _to_textarea _to_textfield _to_select
- type_of _to_foreign_inputs _to_enum_select _to_bool_select
- to_select_from_many _to_select_from_related hasmany_class
- _to_hidden _rename_foreign_input _to_readonly
- make_param_foreign make_hidden_elmnt make_hidden_elmnt
- a_select_box unselect_element do_select search_inputs);
-
-
-
-our $VERSION = '2.41';
-# PJS VERSION .05
-# Changes :
-# 08-09-05 - fixed broken has_a select box
-# - fiked some docs
-# - _to_foreign_inputs now takes 3 positional parameters
-# (accssr, fields, accssr_meta_info)
+our @EXPORT =
+ qw(
+ to_cgi to_field _to_textarea _to_textfield _to_select
+ _to_foreign_inputs _to_enum_select _to_bool_select
+ _to_select_from_many _to_select_from_related _to_select_from_objs
+ _to_hidden _to_link_hidden _rename_foreign_input _to_readonly
+ _options_from_objects _options_from_arrays _options_from_hashes
+ _options_from_scalars
+ _field_from_how _field_from_relationship _field_from_column
+ _select_guts unselect_element search_inputs make_param_foreign
+ );
+
+our $VERSION = '.09';
+
+# 11-05-05 - added _to_link_hidden to make a link to the hidden object
+# - fixed _to_hidden when called with no args. Hides self obj.
+# 11-04-05 - _to_textfield: tries to call "deflate4edit" if column is has_a
+# 11-08-05 - Changed Version to .08
+
+
+
+# 1-10-06 -- fixed bug in to_textfiled that was stringifyingf CDBI objects
+# #
+#
+# 1-20-06 - to_select - call db_Main with has a class.
+# 1-24-06 - to_select_from_many now named _to_select_from_many . Old deprecated
+# - hasmany_class removed in favor of model's related_class method.
+# - took out do_select. That is a model action.
+# - use search_columns instead of search_fields now.
+# - use to_field('column', 'select', {args}) instead of a_select_box.
+# -- took out make_hidden_element.was my own personal hack
+# -- added _box from DH's FormView to calculate decent textarea size
+# -- Refactor to_field into _from_* method calls.
+#
+# 1-25-06 -- Added _to_checkbox and _to_radio from FView
+# 1-27-06 -- Refactored into yet more exported methods
+# 1-28-06 -- select constraints where, join order by
=head1 NAME
...
sub create_or_edit {
- my $class = shift;
- my %cgi_field = $class->to_cgi;
+ my $self = shift;
+ my %cgi_field = $self->to_cgi;
return start_form,
(map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
$class->Columns),
end_form;
}
- # <form method="post"...>
- # Title: <input type="text" name="Title" /> <br>
- # Artist: <select name="Artist">
- # <option value=1>Grateful Dead</option>
- # ...
- # </select>
- # ...
- # </form>
+ . . . somewhere use to_field($col, $how, $args)
+ package BeerDB::Pint;
+ __PACKAGE__->has_a('drinker', 'BeerDB::Drinker');
+ __PACKAGE__->has_a('beer', 'BeerDB::Beer');
+ package BeerDB::Drinker;
+ __PACKAGE__->has_many('pints', 'BeerDB::Pint');
+
+ # NEED to do mapping
+ my $sel = BeerDB::Drinker->to_field('pints', 'select') # multiple
+ my $sel = $Drunk->to_field('pints', 'select'); # Already had beers selected
+
+package Job;
+
+__PACKAGE__->has_a('employer' => 'Employer');
+__PACKAGE__->has_a('contact' => 'Contact')
+
+package Contact;
+
+__PACKAGE__->has_a('employer_also' => 'Employer');
+__PACKAGE__->has_many('jobs' => 'Job',
+ { join => { employer => 'employer_also' },
+ constraint => { 'finshed' => 0 },
+ order_by => "created ASC",
+ }
+);
+
+package Employer;
+
+__PACKAGE__->has_many('jobs' => 'Job',);
+__PACKAGE__->has_many('contacts' => 'Contact',
+ order_by => 'name DESC',
+);
+
+
+ # Below gives select boxes with the multiple attribute.
+ my $select_jobs_for_new_contact =
+ Contact->to_field('jobs', 'select'); # Uses constraint and order by
+
+ my $edit_jobs_for_existing_contact =
+ $contact->to_field('jobs', 'select');
+
+
+
+ # Random uses
+
+
=head1 DESCRIPTION
=cut
+# TODO -- use search_columns
sub search_inputs {
my ($class, $r) = @_;
warn "In model search_inputs " if $class->model_debug;
$class = ref $class || $class;
#my $accssr_class = { $class->accessor_classes };
my %cgi;
- my $sfs = $class->search_fields;
+ my $sfs = [$class->search_columns];
foreach my $field ( @$sfs ) {
if ( ref $field eq "HASH" ) { # foreign search fields
my ($accssr, $cols) = each %$field;
unless ( @$cols ) {
# default to search fields for related
- #$cols = $accssr_class->{$accssr}->search_fields;
+ #$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_foreign_inputs($accssr, $cols);
$class->unselect_element($fcgi->{$_});
}
$cgi{$accssr} = $fcgi;
- #warn "Searchy inputs for field $field is " . Dumper($cgi{$accssr});
} else {
$cgi{$field} = $class->to_field($field);
$class->unselect_element($cgi{$field});
}
-=head2 do_select
-
-Retrieves object selected from a select box and puts in $r->objects[0].
-The select box input must be named the same as the primary key.
-
-NOTE only works with tables with single primary key for now.
-
-=cut
-
-sub do_select {
- my ($self, $r) = @_;
- $r->objects([ $self->retrieve($r->params->{$self->primary_column}) ]);
- $r->template('view');
-}
-
=head2 unselect_element
}
-=head2 make_hidden_elmnt
-
-Makes a hidden HTML::Element and puts it in template_args{hidden_elements}
-$model->make_hidden_elmnt($name, $val);
-
-=cut
-
-sub make_hidden_elmnt {
- my ($self, $r, $col, $val) = @_;
- my $elmnt = HTML::Element->new('input', 'type'=>'hidden', 'name'=>$col, 'value'=>$val);
-
- $r->{template_args}{hidden_elements} ||= [];
- push @{ $r->{template_args}{hidden_elements} }, $elmnt;
-}
-
-
=head2 make_param_foreign
=cut
sub to_field {
- my ($self, $field, $how) = @_;
- my $class = ref $self || $self;
- if ($how and $how =~ /^(text(area|field)|select)$/) {
+ my ($self, $field, @args) = @_;
+ my $how = shift @args unless ref $args[0];
+ my $args = shift @args; # argument hash ref
+
+ 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);
+}
+
+=head2 _field_from_how($field, $how,$args)
+
+Returns an input element based the "how" parameter or nothing at all.
+Override at will.
+
+=cut
+
+sub _field_from_how {
+ my ($self, $field, $how, $args) = @_;
+ if ($how) {
no strict 'refs';
my $meth = "_to_$how";
- return $self->$meth($field);
+ return $self->$meth($field, $args) if $self->can($meth);
}
+ return;
+}
+
+=head2 _field_from_relationship($field, $args)
+
+Returns an input based on the relationship associated with the field or nothing.
+Override at will.
+
+=cut
+sub _field_from_relationship {
+ my ($self, $field, $args) = @_;
my $meta = $self->meta_info;
my ($rel_type) = grep{ defined $meta->{$_}{$field} } keys %$meta;
$rel_type ||= '';
- my $fclass = $rel_type ? $meta->{$rel_type}{$field}{foreign_class} : '';
+ my $fclass = $rel_type ? $meta->{$rel_type}{$field}{foreign_class} : '';
+ $args->{class} = $fclass;
my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
# maybe has_a select
- return $self->_to_select($field, $fclass) if $rel_type eq 'has_a' and
- $fclass_is_cdbi;
+ return $self->_to_select($field, $args)
+ if $rel_type eq 'has_a' and $fclass_is_cdbi;
# maybe foreign inputs
my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
{
return $self->_to_foreign_inputs($field, undef, $meta->{$rel_type}{$field});
}
-
- # the rest
- my $type;
- if ($class->can('column_type')) {
- $type = $class->column_type($field);
- }
- else {
- # Right, have some of this
- eval "package $class; Class::DBI::Plugin::Type->import()";
- $type = $class->column_type($field);
- }
+ return;
+}
+
+=head2 _field_from_column($field, $args)
+
+Returns an input based on the column's characteristics, namely type, or nothing.
+Override at will.
+
+=cut
+
+sub _field_from_column {
+ my ($self, $field, $args) = @_;
+ my $class = ref $self || $self;
+ # 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)
- # if $type and $type =~ /(var)?char/i; #common type
- return $self->_to_textarea($field)
+ return $self->_to_textfield($field)
+ 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, $type)
+ return $self->_to_enum_select($field, $args)
if $type and $type =~ /^ENUM\((.*?)\)$/i;
- return $self->_to_bool_select($field, $type)
+ return $self->_to_bool_select($field, $args)
if $type and $type =~ /^BOOL/i;
- return $self->_to_readonly($field)
+ return $self->_to_readonly($field, $args)
if $type and $type =~ /^readonly$/i;
- return $self->_to_textfield($field);
+ return;
}
+
sub _to_textarea {
- my ($self, $col) = @_;
+ my ($self, $col, $args) = @_;
# pjs added default
- my $a =
- HTML::Element->new("textarea", name => $col, rows => "3", cols => "22");
- my $val;
- if (ref $self) {
- $val = $self->$col;
- }
- else {
- $val = eval {$self->column_default($col);};
- $val = '' unless defined $val;
+ $args ||= {};
+ my $val = $args->{value};
+
+ unless (defined $val) {
+ if (ref $self) {
+ $val = $self->$col;
+ }
+ else {
+ $val = eval {$self->column_default($col);};
+ $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) = @_;
- # pjs added default
- my $val;
- if (ref $self) {
- $val = $self->$col;
- }
- else {
- $val = eval {$self->column_default($col);};
- $val = '' unless defined $val;
- }
-
- my $a = HTML::Element->new("input", type => "text", name => $col);
- $a->attr("value" => $val);
- $OLD_STYLE && return $a->as_HTML;
- $a;
+ my ($self, $col, $args ) = @_;
+ $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->$col;
+ if (ref $val) {
+ if (my $meta = $self->related_meta('',$col)) {
+ if (my $code = $meta->{args}{deflate4edit} ) {
+ $val = ref $code ? &$code($val) : $val->$code;
+ }
+ else {
+ $val = $self->_attr($col);
+ }
+ }
+ else {
+ $val = $self->_attr($col);
+ }
+ }
+
+ }
+ else {
+ $val = eval {$self->column_default($col);};
+ $val = '' unless defined $val;
+ }
+ }
+ my $a = HTML::Element->new("input", type => "text", name => $name);
+ $a->attr("value" => $val);
+ $OLD_STYLE && return $a->as_HTML;
+ $a;
}
+
+# Too expensive version -- TODO
+#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;
+#}
+
+
+
# pjs
# -- Rewrote this to be efficient -- no object creation.
# -- Added option for CDBI classes to specify a limiting clause
# via "has_a_select_limit".
# -- Added selected argument to set a selected
+=head2 recognized arguments
+
+ selected => $object|$id,
+ name => $name,
+ value => $value,
+ where => SQL 'WHERE' clause,
+ order_by => SQL 'ORDER BY' clause,
+ limit => SQL 'LIMIT' clause,
+ items => [ @items_of_same_type_to_select_from ],
+ class => $class_we_are_selecting_from
+ 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.
+ #Or explicitly you can create one and pass options like where and order
+ BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
+
+ # For has_many the default is to get a multiple select box with all objects.
+ # If called as an object method, the objects existing ones will be selected.
+ Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"});
+
+
+=head2 2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun.
+ # general
+ BeerDB::Beer->to_field('', 'select', $options)
+
+ BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
+ # with PK as ID, $Class->to_field() same.
+ BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
+ # specify exact where clause
+
+=head2 3. If you already have a list of objects to select from --
+
+ BeerDB:;Beer->to_field($col, 'select' , {items => $objects});
+
+# 3. a select box for arbitrary set of objects
+ # Pass array ref of objects as first arg rather than field
+ $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
+
+
+=cut
+
sub _to_select {
- my ($self, $col, $hint, $selected) = @_;
- my $has_a_class;
- if (not $col) { # class is making select box of self
- $has_a_class = ref $self || $self;
- $col = $self->primary_column;
+ my ($self, $col, $args) = @_;
+ $args ||= {};
+# Do we have items already ? Go no further.
+ if ($args->{items}) {
+ my $a = $self->_select_guts($col, $args);
+ $OLD_STYLE && return $a->as_HTML;
+ return $a;
}
+
+# 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) {
+ warn "No col. $self";
+ 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;
+ }
+ # Related Class maybe ?
+ elsif (my ($rel_type, $rel_meta) = $self->related_meta('r:)', $col) ) {
+ $args->{class} = $rel_meta->{foreign_class};
+ # related objects pre selected if object
+ $args->{selected} ||= [ $self->$col ] if ref $self;
+
+ # "Has many" -- we get multiple select
+ if ($rel_type =~ /has_many/i) {
+ $args->{attr}{multiple} = 'multiple';
+ # TODO -- handle mapping
+ }
+ 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 {
- $has_a_class = $hint || $self->__hasa_rels->{$col}->[0];
+ #$args->{name} = $col;
+ die "Usage _to_select. $col not related to any class to select from. ";
+
+ }
+
+ # Set arguments
+ if ( $self->can('column_nullable') ) {
+ $args->{nullable} ||= $self->column_nullable($col);
}
- $selected ||= {};
- if (ref $self and my $id = eval { $self->$col->id }) {
- $selected->{$id} = 1;
- }
- #pjs Possible sql limiting clause ("WHERE acol = 'X' " or "LIMIT 10", etc)
- my $select_box_limit = eval { $self->has_a_select_limit->{$col} } || '' ;
-
- # Get columns to appear in select box options on forms.
- # TODO -- there is maybe a good idiom for this.
- my @select_box_cols;
- @select_box_cols = $has_a_class->columns('SelectBox');
- @select_box_cols = $has_a_class->columns('Stringify')
- unless @select_box_cols;
- @select_box_cols = $has_a_class->_essential
- unless @select_box_cols;
- unshift @select_box_cols, $has_a_class->columns('Primary');
- my $sql = "SELECT " . join( ', ', @select_box_cols) . " FROM " .
- $has_a_class->table . " " . $select_box_limit;
- my $opts_data = $self->db_Main->selectall_arrayref($sql);
-
- my $a = HTML::Element->new("select", name => $col);
- for (@$opts_data) {
- my $id = shift @$_;
- my $opt = HTML::Element->new("option", value => $id );
- $opt->attr("selected" => "selected") if $selected->{$id};
- my $content = eval {$has_a_class->stringify_selectbox($_);} ||
- join(' ', @$_);
- $opt->push_content( $content );
- $a->push_content($opt);
- }
+ # Get items to select from
+ $args->{items} = _select_items($args);
+use Data::Dumper;
+warn "Just got items. They are " . Dumper($args->{items});
+
+ # Make select HTML element
+ $a = $self->_select_guts($col, $args);
+
+ # Return
$OLD_STYLE && return $a->as_HTML;
$a;
+
+}
+
+
+############
+# FUNCTION #
+############
+# Get Items
+sub _select_items {
+ my $args = shift;
+ my $fclass = $args->{class};
+ my @select_box_cols;
+ @select_box_cols = $fclass->columns('SelectBox');
+ @select_box_cols = $fclass->columns('Stringify')
+ unless @select_box_cols;
+ @select_box_cols = $fclass->_essential
+ unless @select_box_cols;
+ unshift @select_box_cols, $fclass->columns('Primary')
+ unless $select_box_cols[0] eq $fclass->columns('Primary');
+
+ my $sql = "SELECT " . join( ', ', @select_box_cols) .
+ " FROM " . $fclass->table;
+
+ $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";
+
+ return $fclass->db_Main->selectall_arrayref($sql);
+
}
+
# Makes a readonly input box out of column's value
-# Currently object method only
+# No args makes object to readonly
sub _to_readonly {
- my ($self, $col, $val) = @_;
- unless (defined $val) {
- $self->_croak("Cannot call _to_readonly on class without value arg.")
- 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;
- $a;
+ my ($self, $col, $val) = @_;
+ if (! $col) { # object to readonly
+ $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;
+ $a;
}
+
=head2 _to_enum_select
$sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");
sub _to_enum_select {
my ($self, $col, $type) = @_;
- $type =~ /ENUM\((.*?)\)/i;
- (my $enum = $1) =~ s/'//g;
- my @enum_vals = split /\s*,\s*/, $enum;
+ $type =~ /ENUM\((.*?)\)/i;
+ (my $enum = $1) =~ s/'//g;
+ my @enum_vals = split /\s*,\s*/, $enum;
+
+ # determine which is pre selected --
+ # if obj, the value is , otherwise use column_default which is the first
+ # value in the enum list unless it has been overridden
+ my $selected = eval { $self->$col };
+ $selected = eval{$self->column_default($col)} 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 ref $self
- and eval { $self->$col eq $_ };
- $sel->push_content($_);
+ 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;
}
-=head2 _to_hidden($name, $value)
+=head2 _to_hidden($col, $args)
-This makes a hidden html element. Give it a name and value.
+This makes a hidden html element. Give it a name and value or if name is
+a ref it will use the PK name and value of the object.
=cut
+
sub _to_hidden {
my ($self, $name, $val) = @_;
- return HTML::Element->new('input', 'type' => 'hidden',
- 'name' => $name, 'value'=>$val
- );
+ my $args = {};
+ my $obj;
+ if (ref $name and $name->isa("Class::DBI")) {
+ $obj = $name;
+ $name= ($obj->primary_columns)[0]->name;
+ }
+ if (ref $val) {
+ $args = $val;
+ $val = $args->{value};
+ $name = $args->{name} if $args->{name};
+ }
+ elsif (not $name ) { # hidding object caller
+ $self->_croak("No object available in _to_hidden") unless ref $self;
+ $name = ($self->primary_column)[0]->name;
+ $val = $self->id;
+ }
+ return HTML::Element->new('input', 'type' => 'hidden',
+ 'name' => $name, 'value'=>$val
+ );
+}
+
+=head2 _to_link_hidden($col, $args)
+
+Makes a link with a hidden input with the id of $obj as the value and name.
+Name defaults to the objects primary key. The object defaults to self.
+
+=cut
+
+sub _to_link_hidden {
+ my ($self, $accessor, $args) = @_;
+ my $r = $args->{r} || '';
+ my $url = $args->{url} || '';
+
+ $self->_croak("_to_link_hidden called without Maypole Request object (\$r) and url. Need one or other.")
+ unless $r;
+ my ($obj, $name);
+ if (ref $self) { # hidding linking self
+ $obj = $self;
+ $name = $args->{name} || $obj->primary_column->name;
+ }
+ else { # hiding linking related object with id in args
+ $obj = $self->related_class($r, $accessor)->retrieve($args->{id});
+ $name = $args->{name} || $obj->primary_column->name; # TODO make use meta data
+ }
+ $self->_croak("_to_link_hidden has no object") unless ref $obj;
+ my $href = $url || $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_hidden($name, $obj->id));
+ $OLD_STYLE && return $a->as_HTML;
+ $a;
}
return \%inputs;
}
-=head2 _rename_foreign_input
-
-_rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
-
-Recursively renames the foreign inputs made by to_foreign_inputs so they
-can be processed generically. The format is "accessor__AsForeign_colname".
-
-So if an Employee is a Person who has own Address and you call
-
- Employee->to_field("person")
-
-then you will get inputs for Address named like this:
- person__AsForeign__address__AsForeign__street
- person__AsForeign__address__AsForeign__city
- person__AsForeign__address__AsForeign__state
- person__AsForeign__address__AsForeign__zip
+=head2 _hash_selected
-And the processor would know to create this address, put the address id in
-person address slot, create the person and put the address id in the employee
-before creating the employee.
+Method to make sense out of the "selected" argument which can be in a number
+of formats perhaps. It returns a hashref with the the values of options to be
+as the keys.
-=cut
+Below handles these formats for the "selected" slot in the arguments hash:
+ Object (with id method)
+ Scalar (assumes it is value)
+ Array ref *OF* objects, arrays of data (0 elmnt used), hashes of data
+ (id key used), and simple scalars.
+
-sub _rename_foreign_input {
- my ($self, $accssr, $input) = @_;
- if ( ref $input ne 'HASH' ) {
- my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
- $input->attr( name => $new_name );
- }
- else {
- $self->_rename_foreign_input($accssr, $input->{$_})
- foreach (keys %$input);
+=cut
+
+############
+# FUNCTION #
+############
+sub _hash_selected {
+ my ($args) = shift;
+ my $selected = $args->{selected};
+ return $selected unless $selected and ref $selected ne 'HASH';
+ my $type = ref $selected;
+ # Single Object
+ if ($type and $type ne 'ARRAY') {
+ return {$selected->id => 1};
+ }
+ # Single Scalar id
+ elsif (not $type) {
+ return { $selected => 1};
}
-}
-
-# pjs
-
-=head2 to_select_from_many
+ # 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"; }
+}
+
-Usage: $object->to_select_from_many($accessor|$objects_to_select_from, [$element_name], [$options]);
-CD->has_many( 'songs' => "Songs" );
-... in some nearby piece of code:
-my $cd = CD->retrieve($id);
-my $select_song_html = $cd->to_select_from_many('songs');
-print "<h1>Choose your Favorite song from $cd</h1>";
-print $select_song_html.as_XML;
-return;
+=head2 _select_guts
-# OR if you only want to select from a group of objects
+Internal api method to make the actual select box form elements.
-my @favorites = $cd->favorite_songs;
-my $select_from_favorites = $cd->to_select_from_many(\@favorites);
+3 types of lists making for --
+ Array of CDBI objects.
+ Array of scalars ,
+ Array or Array refs with cols from class.
+=cut
-This an object method that makes a select box out of the objects related to this object by a has_many relationship. The select box only allows one selection.
-The multiple attribute can easily be added if needed to the element returned :
-$this_element->attr('multiple', 'multiple');
-You can pass an array ref of objects to select from instead of the class accessor name if you already have the objects to select from.
-Also, you can pass the name you want the element to have as a second argument.
-The default is the primary key name (as returned by primary_column) of the firstobject that is being selected from.
+sub _select_guts {
+ my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
-If related class has a multi column pk, this dies for now.#strange things may happen as primary_column method is used.
+ $args->{stringify} ||= 'stringify_selectbox';
+ $args->{selected} = _hash_selected($args);
+ my $name = $args->{name} || $col;
+ my $a = HTML::Element->new('select', name => $name);
+ $a->attr( %{$args->{attr}} ) if $args->{attr};
+
+ if ($args->{nullable}) {
+ my $null_element = HTML::Element->new('option');
+ $null_element->attr(selected => 'selected')
+ if $args->{selected}{'null'};
+ $null_element->push_content('-- choose or type --');
+ $a->push_content($null_element);
+ }
-=cut
+ my $items = $args->{items};
+ my $proto = $items->[0];
+ my $type = ref $proto || '';
+
+ # Objects
+ if ($type and $type !~ /ARRAY|HASH/i) {
+ # make select of objects
+ $a->push_content($self->_options_from_objects($items, $args));
+ }
+ elsif ($type =~ /ARRAY/i) {
+ $a->push_content($self->_options_from_arrays($items, $args));
+ }
+ elsif ($type =~ /HASH/i) {
+ $a->push_content($self->_options_from_hashes($items, $args));
+ }
+ else {
+ $a->push_content($self->_options_from_scalars($items, $args));
+ }
+ return $a;
+}
-sub to_select_from_many {
- my ($self, $accessor, $elmnt_name) = @_;
- my $objs = ref $accessor eq "ARRAY" ? $accessor : [$self->$accessor];
- my $rel_class = ( @$objs ) ? ref $objs->[0] :
- eval{$self->hasmany_class($accessor)};
+
+
+
- $elmnt_name = eval {$rel_class->primary_column} || "__AF_TSFM_OBJS__"
- unless $elmnt_name;
- return _to_select_from_objs($objs, $elmnt_name);
-
-}
-=head2 _to_select_from_objs($objects, $name, $selected);
+=head2 _options_from_objects ( $objects, $args);
-Private method to makes a select box of objects passed with name passed.
-Assumes they are same type
+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.
=cut
-sub _to_select_from_objs {
- my ($objs, $elmnt_name) = @_;
- CGI::Carp::croak("Usage: element name required") unless ($elmnt_name);
-# $elmnt_name ||= eval {$objs->[0]->primary_column};
-# unless ($elmnt_name) {
-# my $num = @$objs;
-# $self->_carp ("Element name arg. not passed and couldn't get element name from object 0. Number of objects in arg are: $num");
-# return;
-# }
-
- my $a = HTML::Element->new("select", name => $elmnt_name);
- for (@$objs) {
+sub _options_from_objects {
+ my ($self, $items, $args) = @_;
+ my $selected = $args->{selected} || {};
+ my $stringify = $args->{stringify} || '';
+ my @res;
+ for (@$items) {
my $opt = HTML::Element->new("option", value => $_->id);
- $opt->push_content($_->stringify_self);
- $a->push_content($opt);
+ $opt->attr(selected => "selected") if $selected->{$_->id};
+ my $content = $stringify ? $_->$stringify : "$_";
+ $opt->push_content($content);
+ push @res, $opt;
}
- $OLD_STYLE && return $a->as_HTML;
- $a;
+ return @res;
}
-
-
-# pjs EXPERIMENTAL
-# TODO this is crap. I think this will just be a public sub to select many objects from a class. Then you can do thingks like add them to has_many and stuff.
-#
-# not finished
-# usage: CD->has_many('songs', 'Song', 'cd_id');
-# my $song_sel_element = $class->_to_select_many('songs', @options);
-# @options have same form as a SQL::Abstract options with exception of
-# -HINT element which is the class name if you want to give it.
-# { '-HINT' => $classname, # so you can cheat, or be efficient
-# 'logic'=> 'OR', # default is OR
-# $limiting_col => $limit_val,
-# $limiting_col2=> $limit_val2,
-# . . . }
-#
-#
-# make select box for has many. This is a multiple select box (select many)
-# element. If you want to choose between on of the has_many's an object has (
-# ie -- a cd has many songs and you want to choose one of the songs from it)
-# then pass an additional hash ref of limiting cols and vals.
-# $cd->_to_many_select('songs', {'cd_id' => $cd->id, . . .}
-sub _to_select_many {
- my ($self, $accessor, $hint, $where, $order ) = @_;
- my $has_many_class = $hint || $self->hasmany_class($accessor);
- my %selected = ();
- %selected = map { $_->id => 1} $self->$accessor if ref $self;
-
- my $pk = $has_many_class->primary_column;
- my $a = $self->_to_select($pk, $has_many_class, \%selected, $where, $order);
- $a->attr('multiple', 'multiple');
- $OLD_STYLE && return $a->as_HTML;
- $a;
+sub _options_from_arrays {
+ my ($self, $items, $args) = @_;
+ my $selected = $args->{selected} || {};
+ my @res;
+ my $fclass = $args->{class} || '';
+ my $stringify = $args->{stringify} || '';
+ for (@$items) {
+ my $id = $_->[0];
+ my $opt = HTML::Element->new("option", value => $id );
+ #$opt->attr(selected => "selected") if $selected =~/^$id$/;
+ $opt->attr(selected => "selected") if $selected->{$id};
+
+ my $content = ($fclass and $stringify and $fclass->can($stringify)) ?
+ $fclass->$stringify($_) :
+ join('/', @{$_});
+use Data::Dumper;
+warn "Content is $content";
+ $opt->push_content( $content );
+ push @res, $opt;
+ }
+ return @res;
}
-
-
-
-sub _to_select_old_version {
- my ($self, $col, $hint) = @_;
- my $has_a_class = $hint || $self->__hasa_rels->{$col}->[0];
- my @objs = $has_a_class->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;
+sub _options_from_scalars {
+ my ($self, $items, $args) = @_;
+ my $selected = $args->{selected} || {};
+ my @res;
+ for (@$items) {
+ my $opt = HTML::Element->new("option", value => $_ );
+ #$opt->attr(selected => "selected") if $selected =~/^$id$/;
+ $opt->attr(selected => "selected") if $selected->{$_};
+ $opt->push_content( $_ );
+ push @res, $opt;
+ }
+ return @res;
}
-
-
-############################ HELPER METHODS ######################
-##################################################################
-
-# hasmany_class($accessor) -- stole code from Maypole::Model::CDBI
-# Returns class of has_many relationship when given the accessor
-sub hasmany_class {
- my ( $self, $accessor ) = @_;
- $self->_croak("No accessor (2nd arg) passed to hasmany_class")
- unless $accessor;
- my $rel_meta = $self->meta_info('has_many' => $accessor);
+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 (@$items) {
+ my $val = $_->{$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(' ', @$_);
+ $opt->push_content( $content );
+ push @res, $opt;
+ }
+ return @res;
+}
- my $mapping;
- if ( $mapping = $rel_meta->{args}->{mapping} and @$mapping ) {
- return $rel_meta->{foreign_class}->meta_info('has_a')->{ $$mapping[0] }->{foreign_class};
- }
- else {
- return $rel_meta->{foreign_class};
- }
+#
+# checkboxes: if no data in hand (ie called as class method), replace
+# with a radio button, in order to allow this field to be left
+# unspecified in search / add forms.
+#
+# Not tested
+# TODO -- make this general checkboxse
+#
+#
+sub _to_checkbox {
+ my ($self, $col, $args) = @_;
+ my $nullable = eval {self->column_nullable($col)} || 0;
+
+ return $self->_to_radio($col) if !ref($self) || $nullable;
+ my $value = $self->$col;
+ my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
+ $a->attr("checked" => 'true') if $value eq 'Y';
+ return $a;
}
-1;
-
-=head1 ***NEW PJS Stuff**** GETTING SPECIFIC IN MODEL CLASS
+# 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;
+}
-You can tell AsForm some things in your model classes to get custom results. In particular you can have:
-=head2 Custom column_type methods
-Since much of this modules functionality relies on the subroutine C<column_type>
-returning the type string from the database table definition Model classes can
-benefit a great deal by writing their own. See example. This version tries to
-call column_type with the model class first. IF your model's column_type returns
-undef or it has no such method it falls back on
-C<&Class::DBI::Plugin::Type::column_type> which is database independent but not
-fully functional yet. For full functionality make a custom C<column_type> method
-in your base model class and override it in subclasses at will. Some \
-Class::DBI::* drivers such as Class::DBI::mysql have mostly functional ones.
+############################ HELPER METHODS ######################
+##################################################################
-With a column_type sub you can set bool options for users , make select boxes
-for ordinary columns (by lying and returning an enum('blah', 'blh') string for a
-column, get correct types for is_a inherited columns, optimize , and maybe more.
+=head2 _rename_foreign_input
-=head2 Appropriate elements for columns inherited from an is_a relationship
+_rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
-At least you have the power to get them by making column_type work.
+Recursively renames the foreign inputs made by to_foreign_inputs so they
+can be processed generically. The format is "accessor__AsForeign_colname".
-=head2 Select box specifications for has_a columns.
+So if an Employee is a Person who has own Address and you call
-You can specify columns to be selected for a select box's options
- for a class by :
+ Employee->to_field("person")
+
+then you will get inputs for Address named like this:
- __Package__->columns('SelectBox' => qw/col1 col2/);
+ person__AsForeign__address__AsForeign__street
+ person__AsForeign__address__AsForeign__city
+ person__AsForeign__address__AsForeign__state
+ person__AsForeign__address__AsForeign__zip
-If you don't, 'Stringify' columns are used if they exist and lastly 'Essential'
-columns. The 'Primary' column is always the option value. This means don't
-include it in the 'SelectBox' columns unless you want it in the option content.
+And the processor would know to create this address, put the address id in
+person address slot, create the person and put the address id in the employee
+before creating the employee.
-You can limit rows selected for the select box with a has_a_select_limit sub like so:
+=cut
- Customer->has_a(pay_plan => "PayPlan");
- Customer->has_a(pick_fromTopFive => "Movie");
- sub has_a_select_limit { {
- pay_plan => "WHERE is_available = 1",
- pick_fromTopFive => "ORDER BY rank ASC LIMIT 5" }
+sub _rename_foreign_input {
+ my ($self, $accssr, $input) = @_;
+ if ( ref $input ne 'HASH' ) {
+ # my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
+ $input->attr( name => $accssr . "__AsForeign__" . $input->attr('name'));
+ }
+ else {
+ $self->_rename_foreign_input($accssr, $input->{$_})
+ foreach (keys %$input);
}
+}
+=head2 _box($value)
-If you need complex stringification make a C<stringify_selectbox> sub which
-takes an arrayref. Elements are in order specified in columns('SelectBox')
-or whatever columns list was used. Otherwise, the array is joined on ' '.
+This functions computes the dimensions of a textarea based on the value
+or the defaults.
=cut
+our ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
+sub _box
+{
+ 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)
+ }
+ else { ($min_rows, $min_cols) }
+}
-=head1 CHANGES
-Many by Peter Speltz
+1;
-Version 1.x of this module returned raw HTML instead of
-C<HTML::Element> objects, which made it harder to manipulate the
-HTML before sending it out. If you depend on the old behaviour, set
-C<$Class::DBI::AsForm::OLD_STYLE> to a true value.
+=head1 CHANGES
=head1 MAINTAINER
-Tony Bowden
+Maypole Developers
=head1 ORIGINAL AUTHOR
-Simon Cozens
+Peter Speltz, Aaron Trevena
+
+=head1 TODO
+
+ Documenting
+ Testing - lots
+ chekbox 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
=head1 BUGS and QUERIES
Please direct all correspondence regarding this module to:
- bug-Class-DBI-AsForm@rt.cpan.org
+ Maypole list.
=head1 COPYRIGHT AND LICENSE
=cut
\r
+\r
+\r
projects / maypole.git / commitdiff