lib/Maypole/Model/CDBI/AsForm.pm

   1 package Maypole::Model::CDBI::AsForm;
   2
   3 #TODO --
   4 # lots of doc
   5 # _to_select_or_create  -- select input stays
   6 # _to_create_or_select  -- create input trumps
   7 #
   8
   9 # TESTED and Works --
  10 #  has_many select -- $obj->to_field($has_many_col);   # select one form many
  11 #                  -- $class->to_field($has_many_col); # foreign inputs
  12 #  $class->search_inputs; /
  13
  14 use strict;
  15 use warnings;
  16
  17 use base 'Exporter';
  18 use Data::Dumper;
  19 use Class::DBI::Plugin::Type ();
  20 use HTML::Element;
  21 use Carp qw/cluck/;
  22
  23 our $OLD_STYLE = 0;
  24 # pjs  --  Added new methods to @EXPORT
  25 our @EXPORT =
  26         qw(
  27                 to_cgi to_field  make_element_foreign search_inputs unselect_element
  28                 _field_from_how _field_from_relationship _field_from_column
  29                 _to_textarea _to_textfield _to_select  _select_guts
  30                 _to_foreign_inputs _to_enum_select _to_bool_select
  31                 _to_hidden _to_link_hidden _rename_foreign_input _to_readonly
  32                 _options_from_objects _options_from_arrays _options_from_hashes
  33                 _options_from_array _options_from_hash _to_select_or_create
  34     );
  35
  36 our $VERSION = '.10';
  37
  38 =head1 NAME
  39
  40 Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns
  41
  42 =head1 SYNOPSIS
  43
  44     package Music::CD;
  45     use Maypole::Model::CDBI::AsForm;
  46     use base 'Class::DBI';
  47     use CGI;
  48     ...
  49
  50     sub create_or_edit {
  51         my $self = shift;
  52         my %cgi_field = $self->to_cgi;
  53         return start_form,
  54                (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
  55                     $class->Columns),
  56                end_form;
  57     }
  58
  59 # Example of has_many select
  60 package Job;
  61 __PACKAGE__->has_a('job_employer' => 'Employer');
  62 __PACKAGE__->has_a('contact'  => 'Contact')
  63
  64 package Contact;
  65 __PACKAGE__->has_a('cont_employer' => 'Employer');
  66 __PACKAGE__->has_many('jobs'  => 'Job',
  67         { join => { job_employer => 'cont_employer' },
  68           constraint => { 'finshed' => 0  },
  69           order_by   => "created ASC",
  70         }
  71 );
  72
  73 package Employer;
  74 __PACKAGE__->has_many('jobs'  => 'Job',);
  75 __PACKAGE__->has_many('contacts'  => 'Contact',
  76             order_by => 'name DESC',
  77 );
  78
  79
  80   # Choose some jobs to add to a contact (has multiple attribute).
  81   my $job_sel = Contact->to_field('jobs'); # Uses constraint and order by
  82
  83
  84   # Choose a job from $contact->jobs
  85   my $job_sel = $contact->to_field('jobs');
  86
  87
  88
  89 =head1 DESCRIPTION
  90
  91 This module helps to generate HTML forms for creating new database rows
  92 or editing existing rows. It maps column names in a database table to
  93 HTML form elements which fit the schema. Large text fields are turned
  94 into textareas, and fields with a has-a relationship to other
  95 C<Class::DBI> tables are turned into select drop-downs populated with
  96 objects from the joined class.
  97
  98
  99 =head1 ARGUMENTS HASH
 100
 101 This provides a convenient way to tweak AsForm's behavior in exceptional or
 102 not so exceptional instances. Below describes the arguments hash and
 103 example usages.
 104
 105
 106   $beer->to_field($col, $how, $args);
 107   $beer->to_field($col, $args);
 108
 109 Not all _to_* methods pay attention to all arguments. For example, '_to_textfield' does not look in $args->{'items'} at all.
 110
 111 =over
 112
 113 =item name -- the name the element will have , this trumps the derived name.
 114
 115   $beer->to_field('brewery', 'readonly', {
 116                 name => 'brewery_id'
 117   });
 118
 119 =item value -- the initial value the element will have, trumps derived value
 120
 121   $beer->to_field('brewery', 'textfield', {
 122                 name => 'brewery_id', value => $beer->brewery,
 123                 # however, no need to set value since $beer is object
 124   });
 125
 126 =item items -- array of items generally used to make select box options
 127
 128 Can be array of objects, hashes, arrays, or strings, or just a hash.
 129
 130    # Rate a beer
 131    $beer->to_field(rating =>  select => {
 132                 items => [1 , 2, 3, 4, 5],
 133    });
 134
 135    # Select a Brewery to visit in the UK
 136    Brewery->to_field(brewery_id => {
 137                 items => [ Brewery->search_like(location => 'UK') ],
 138    });
 139
 140   # Make a select for a boolean field
 141   $Pub->to_field('open' , { items => [ {'Open' => 1, 'Closed' => 0 } ] });
 142
 143 =item selected -- something representing which item is selected in a select box
 144
 145    $beer->to_field('brewery', {
 146                 selected => $beer->brewery, # again not necessary since caller is obj.
 147    });
 148
 149 Can be an simple scalar id, an object, or an array of either
 150
 151 =item class -- the class for which the input being made for field pertains to.
 152
 153 This in almost always derived in cases where it may be difficult to derive, --
 154    # Select beers to serve on handpump
 155    Pub->to_field(handpumps => select => {
 156                 class => 'Beer', order_by => 'name ASC', multiple => 1,
 157         });
 158
 159 =item column_type -- a string representing column type
 160
 161   $pub->to_field('open', 'bool_select', {
 162                 column_type => "bool('Closed', 'Open'),
 163   });
 164
 165 =item column_nullable -- flag saying if column is nullable or not
 166
 167 Generally this can be set to get or not get a null/empty option added to
 168 a select box.  AsForm attempts to call "$class->column_nullable" to set this
 169 and it defaults to true if there is no shuch method.
 170
 171   $beer->to_field('brewery', { column_nullable => 1 });
 172
 173 =item r or request  -- the mapyole request object
 174
 175 =item uri -- uri for a link , used in methods such as _to_link_hidden
 176
 177  $beer->to_field('brewery', 'link_hidden',
 178       {r => $r, uri => 'www.maypole.perl.org/brewery/view/'.$beer->brewery});
 179  # an html link that is also a hidden input to the object. R is required to
 180  # make the uri  unless you  pass a  uri
 181
 182 =item order_by, constraint, join
 183
 184 These are used in making select boxes. order_by is a simple order by clause
 185 and constraint and join are hashes used to limit the rows selected. The
 186 difference is that join uses methods of the object and constraint uses
 187 static values. You can also specify these in the relationship arguments.
 188
 189   BeerDB::LondonBeer->has_a('brewery', 'BeerDB::Brewery',
 190            order_by     => 'brewery_name ASC',
 191            constraint   => {location  => 'London'},
 192            'join'       => {'brewery_tablecolumn  => 'beer_obj_column'},
 193           );
 194
 195 =item no_hidden_constraints --
 196
 197 Tell AsForm not to make hidden inputs for relationship constraints. It does
 198 this  sometimes when making foreign inputs .
 199
 200 =back
 201
 202 =head2 to_cgi
 203
 204   $self->to_cgi([@columns, $args]);
 205
 206 This returns a hash mapping all the column names to HTML::Element objects
 207 representing form widgets.  It takes two opitonal arguments -- a list of
 208 columns and a hashref of hashes of arguments for each column.  If called with an object like for editing, the inputs will have the object's values.
 209
 210   $self->to_cgi(); # uses $self->columns;  # most used
 211   $self->to_cgi(qw/brewery style rating/); # sometimes
 212   # and on rare occassions this is desireable if you have a lot of fields
 213   # and dont want to call to_field a bunch of times just to tweak one or
 214   # two of them.
 215   $self->to_cgi(@cols, {brewery => {
 216                                      how => 'textfield' # too big for select
 217                                                                    },
 218                         style   => {
 219                                                              column_nullable => 0,
 220                                                              how => 'select',
 221                                                                      items => ['Ale', 'Lager']
 222                                                                    }
 223                                                 }
 224
 225 =cut
 226
 227 sub to_cgi {
 228         my ($class, @columns) = @_; # pjs -- added columns arg
 229         my $args = {};
 230         if (not @columns) {
 231                 @columns = $class->columns;
 232         }
 233         else {
 234                 if ( ref $columns[-1] eq 'HASH' ) { $args = pop @columns; }
 235         }
 236         map { $_ => $class->to_field($_, $args->{$_}) } @columns;
 237 }
 238
 239 =head2 to_field($field [, $how][, $args])
 240
 241 This maps an individual column to a form element. The C<how> argument
 242 can be used to force the field type into any you want. It tells AsForm how
 243 to make the input ie-- forces it to use the method "_to_$how".
 244 If C<how> is specified but the class cannot call the method it maps to,
 245 then AsForm will issue a warning and the default input will be made.
 246 You can write your own "_to_$how" methods and AsForm comes with many.
 247 See C<HOW Methods>. You can also pass this argument in $args->{how}.
 248
 249
 250 =cut
 251
 252 sub to_field {
 253         my ($self, $field, $how, $args) = @_;
 254     if (ref $how)   { $args = $how; $how = ''; }
 255         unless ($how)   { $how = $args->{how} || ''; }
 256 #warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n";
 257
 258     #if (ref $field) { $args = $field; $field = '' }
 259
 260         #use Data::Dumper;
 261         #warn "args to_field  are $field, . " . Dumper($how) . " ,  " . Dumper($args);
 262
 263
 264         return  $self->_field_from_how($field, $how, $args)   ||
 265                 $self->_field_from_relationship($field, $args) ||
 266                         $self->_field_from_column($field, $args)  ||
 267                         $self->_to_textfield($field, $args);
 268 }
 269
 270 =head2 search_inputs
 271
 272   my $cgi = $class->search_inputs ([$args]); # optional $args
 273
 274 Returns hash or hashref of search inputs elements for a class making sure the
 275 inputs are empty of any initial values.
 276 You can specify what columns you want inputs for in
 277 $args->{columns} or
 278 by the method "search_columns". The default is  "display_columns".
 279 If you want to te search on columns in related classes you can do that by
 280 specifying a one element hashref in place of the column name where
 281 the key is the related "column" (has_a or has_many method for example) and
 282 the value is a list ref of columns to search on in the related class.
 283
 284 Example:
 285   sub  BeerDB::Beer::search_columns {
 286      return ( 'name' , 'rating', { brewery => [ 'name', 'location'] } );
 287   }
 288
 289   # Now foreign inputs are made for Brewery name and location and the
 290   # there will be no name clashing and processing can be automated.
 291
 292 =cut
 293
 294
 295 sub search_inputs {
 296     my ($class, $args) = @_;
 297     $class = ref $class || $class;
 298     #my $accssr_class = { $class->accessor_classes };
 299     my %cgi;
 300
 301     $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns];
 302
 303     foreach my $field ( @{ $args->{columns} } ) {
 304                 my $base_args = {
 305                         no_hidden_constraints => 1,
 306                         column_nullable => 1, # empty option on select boxes
 307                         value  => '',
 308                 };
 309         if ( ref $field eq "HASH" ) { # foreign search fields
 310             my ($accssr, $cols)  = each %$field;
 311                         $base_args->{columns} = $cols;
 312             unless (  @$cols ) {
 313                 # default to search fields for related
 314                 #$cols =  $accssr_class->{$accssr}->search_columns;
 315                 die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
 316             }
 317             my $fcgi  = $class->to_field($accssr, 'foreign_inputs', $base_args);
 318
 319             # unset the default values for a select box
 320             foreach (keys %$fcgi) {
 321                         my $el = $fcgi->{$_};
 322                                 if ($el->tag eq 'select') {
 323
 324                                         $class->unselect_element($el);
 325                                         my ($first, @content) = $el->content_list;
 326                                         my @fc = $first->content_list;
 327                                         my $val = $first ? $first->attr('value') : undef;
 328                                         if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or
 329
 330                                            #(defined $first->attr('value') or $first->attr('value') ne ''))
 331                                            # push an empty option on stactk
 332                                            $el->unshift_content(HTML::Element->new('option'));
 333                                     }
 334                                 }
 335
 336             }
 337             $cgi{$accssr} = $fcgi;
 338                         delete $base_args->{columns};
 339                 }
 340         else {
 341             $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} });
 342                 my $el = $cgi{$field};
 343                         if ($el->tag eq 'select') {
 344                                 $class->unselect_element($el);
 345                                 my ($first, @content) = $el->content_list;
 346                                 if ($first and $first->content_list) { # something
 347                                            #(defined $first->attr('value') or $first->attr('value') ne ''))
 348                                            # push an empty option on stactk
 349                                            $el->unshift_content(HTML::Element->new('option'));
 350                                 }
 351                         }
 352         }
 353     }
 354     return \%cgi;
 355 }
 356
 357
 358 =head2 unselect_element
 359
 360   unselect any selected elemets in a HTML::Element select list widget
 361
 362 =cut
 363
 364 #
 365 sub unselect_element {
 366    my ($self, $el) = @_;
 367    #unless (ref $el eq 'HTML::Element') {
 368    #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
 369    if ($el->tag eq 'select') {
 370        foreach my $opt ($el->content_list) {
 371            $opt->attr('selected', undef) if $opt->attr('selected');
 372        }
 373    }
 374 }
 375
 376 =head2 _field_from_how($field, $how,$args)
 377
 378 Returns an input element based the "how" parameter or nothing at all.
 379 Override at will.
 380
 381 =cut
 382
 383 sub _field_from_how {
 384         my ($self, $field, $how, $args) = @_;
 385         #if (ref $how) { $args = $how; $how = undef; }
 386 #warn "In filed from how . filed is $field how is $how. args ar e" . Dumper($args) . " \n";
 387         return unless $how;
 388         $args ||= {};
 389         no strict 'refs';
 390         my $meth = "_to_$how";
 391         if (not $self->can($meth)) {
 392                 warn "Class can not $meth";
 393                 return;
 394         }
 395         return $self->$meth($field, $args);
 396         return;
 397 }
 398
 399 =head2 _field_from_relationship($field, $args)
 400
 401 Returns an input based on the relationship associated with the field or nothing.
 402 Override at will.
 403
 404 For has_a it will give select box
 405
 406 =cut
 407
 408 sub _field_from_relationship {
 409         my ($self, $field, $args) = @_;
 410 #warn "In filed from rel . filed is $field \n";
 411         return unless $field;
 412         my $rel_meta = $self->related_meta('r',$field) || return;
 413         my $rel_name = $rel_meta->{name};
 414         #my $meta = $self->meta_info;
 415         #grep{ defined $meta->{$_}{$field} } keys %$meta;
 416         my $fclass = $rel_meta->foreign_class;
 417         my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
 418
 419         # maybe has_a select
 420         #warn "Dumper of relmeta. " . Dumper($rel_meta);
 421         if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) {
 422             # This condictions allows for trumping of the has_a args
 423                 if  (not $rel_meta->{args}{no_select} and not $args->{no_select})
 424                 {
 425                 $args->{class} = $fclass;
 426                 return  $self->_to_select($field, $args);
 427                 }
 428                 return;
 429         }
 430         # maybe has many select
 431         if ($rel_meta->{name} eq 'has_many' and $fclass_is_cdbi and ref $self) {
 432             # This condictions allows for trumping of the has_a args
 433                 if  (not $rel_meta->{args}{no_select} and not $args->{no_select})
 434                 {
 435                 $args->{class} = $fclass;
 436                         $args->{items} = $self->$field;
 437                 return  $self->_to_select($field, $args);
 438                 }
 439                 return;
 440         }
 441
 442
 443
 444         #NOOO!  maybe select from has_many
 445 #       if ($rel_type eq 'has_many' and ref $self) {
 446 #               $args->{items} ||= [$self->$field];
 447 #               # arg name || fclass pk name || field
 448 #               if (not $args->{name}) {
 449 #                       $args->{name} =  eval{$fclass->primary_column->name} || $field;
 450 #               }
 451 #       return  $self->_to_select($field, $args);
 452 #       }
 453 #
 454         # maybe foreign inputs
 455         my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
 456         if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_name eq 'has_own'))
 457         {
 458                 $args->{related_meta} = $rel_meta; # suspect faster to set these args
 459                 return $self->_to_foreign_inputs($field, $args);
 460         }
 461         return;
 462 }
 463
 464
 465 =head2 _field_from_column($field, $args)
 466
 467 Returns an input based on the column's characteristics, namely type, or nothing.
 468 Override at will.
 469
 470 =cut
 471
 472 sub _field_from_column {
 473         my ($self, $field, $args) = @_;
 474         return unless $field;
 475         my $class = ref $self || $self;
 476         #warn "Class is $class\n";
 477         # Get column type
 478     unless ($args->{column_type}) {
 479                         $args->{column_type} = $class->column_type($field);
 480         if ($class->can('column_type')) {
 481                         $args->{column_type} = $class->column_type($field);
 482                 }
 483                 else {
 484                 # Right, have some of this
 485                 eval "package $class; Class::DBI::Plugin::Type->import()";
 486                 $args->{column_type} = $class->column_type($field);
 487                 }
 488     }
 489     my $type = $args->{column_type};
 490
 491         return $self->_to_textfield($field, $args)
 492                 if $type  and $type =~ /(VAR)?CHAR/i;  #common type
 493         return $self->_to_textarea($field, $args)
 494                 if $type and $type =~ /^(TEXT|BLOB)$/i;
 495         return $self->_to_enum_select($field, $args)
 496                 if $type and  $type =~ /^ENUM\((.*?)\)$/i;
 497         return $self->_to_bool_select($field, $args)
 498                 if $type and  $type =~ /^BOOL/i;
 499         return $self->_to_readonly($field, $args)
 500             if $type and $type =~ /^readonly$/i;
 501         return;
 502 }
 503
 504
 505 sub _to_textarea {
 506         my ($self, $col, $args) = @_;
 507         # pjs added default
 508     $args ||= {};
 509     my $val =  $args->{value};
 510
 511     unless (defined $val) {
 512         if (ref $self) {
 513                         $val = $self->$col;
 514                 }
 515                 else {
 516                         $val = eval {$self->column_default($col);};
 517                 $val = '' unless defined $val;
 518                 }
 519         }
 520     my ($rows, $cols) = _box($val);
 521     $rows = $args->{rows} if $args->{rows};
 522     $cols = $args->{cols} if $args->{cols};;
 523     my $name = $args->{name} || $col;
 524         my $a =
 525                 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
 526         $a->push_content($val);
 527         $OLD_STYLE && return $a->as_HTML;
 528         $a;
 529 }
 530
 531 sub _to_textfield {
 532     my ($self, $col, $args ) = @_;
 533     $args ||= {};
 534     my $val  = $args->{value};
 535     my $name = $args->{name} || $col;
 536
 537     unless (defined $val) {
 538         if (ref $self) {
 539             # Case where column inflates.
 540             # Input would get stringification which could be not good.
 541             #  as in the case of Time::Piece objects
 542             $val = $self->can($col) ? $self->$col : ''; # in case it is a virtual column
 543             if (ref $val) {
 544                                 if (my $meta = $self->related_meta('',$col)) {
 545                                 #warn "Meta for $col";
 546                         if (my $code = $meta->{args}{deflate4edit} || $meta->{args}{deflate} ) {
 547                         $val  = ref $code ? &$code($val) : $val->$code;
 548                                         }
 549                                         elsif ( $val->isa('Class::DBI') ) {
 550                                             $val  = $val->id;
 551                                         }
 552                                         else {
 553                                                 #warn "No deflate4edit code defined for $val of type " .
 554                                              #ref $val . ". Using the stringified value in textfield..";
 555                                         }
 556                 }
 557                                 else {
 558                                         #warn "No meta for $col but ref $val.\n";
 559                                         $val  = $val->id if $val->isa("Class::DBI");
 560                }
 561                 }
 562
 563         }
 564         else {
 565                 $val = eval {$self->column_default($col);};
 566                 $val = '' unless defined $val;
 567         }
 568     }
 569     my $a = HTML::Element->new("input", type => "text", name => $name, value =>
 570                                                                 $val);
 571
 572     $OLD_STYLE && return $a->as_HTML;
 573     $a;
 574 }
 575
 576
 577 # Too expensive version -- TODO
 578 #sub _to_select {
 579 #       my ($self, $col, $hint) = @_;
 580 #       my $fclass = $hint || $self->__hasa_rels->{$col}->[0];
 581 #       my @objs        = $fclass->retrieve_all;
 582 #       my $a           = HTML::Element->new("select", name => $col);
 583 #       for (@objs) {
 584 #               my $sel = HTML::Element->new("option", value => $_->id);
 585 #               $sel->attr("selected" => "selected")
 586 #                       if ref $self
 587 #                       and eval { $_->id eq $self->$col->id };
 588 #               $sel->push_content($_->stringify_self);
 589 #               $a->push_content($sel);
 590 #       }
 591 #       $OLD_STYLE && return $a->as_HTML;
 592 #       $a;
 593 #}
 594
 595
 596
 597 # pjs
 598 # -- Rewrote this to be efficient -- no object creation.
 599 # -- Added option for CDBI classes to specify a limiting clause
 600 # via "has_a_select_limit".
 601 # -- Added selected argument to set a selected
 602
 603 =head2 recognized arguments
 604
 605   selected => $object|$id,
 606   name     => $name,
 607   value    => $value,
 608   where    => SQL 'WHERE' clause,
 609   order_by => SQL 'ORDER BY' clause,
 610   limit    => SQL 'LIMIT' clause,
 611   items    => [ @items_of_same_type_to_select_from ],
 612   class => $class_we_are_selecting_from
 613   stringify => $stringify_coderef|$method_name
 614
 615
 616
 617
 618 # select box requirements
 619 # 1. a select box for objecs of a has_a related class -- DONE
 620 =head2  1. a select box out of a has_a or has_many related class.
 621   # For has_a the default behavior is to make a select box of every element in
 622   # related class and you choose one.
 623   #Or explicitly you can create one and pass options like where and order
 624   BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
 625
 626   # For has_many the default is to get a multiple select box with all objects.
 627   # If called as an object method, the objects existing ones will be selected.
 628   Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"});
 629
 630
 631 =head2  2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun.
 632   # general
 633   BeerDB::Beer->to_field('', 'select', $options)
 634
 635   BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
 636                                   # with PK as ID, $Class->to_field() same.
 637   BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
 638   # specify exact where clause
 639
 640 =head2 3. If you already have a list of objects to select from  --
 641
 642   BeerDB:;Beer->to_field($col, 'select' , {items => $objects});
 643
 644 # 3. a select box for arbitrary set of objects
 645  # Pass array ref of objects as first arg rather than field
 646  $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
 647
 648
 649 =cut
 650
 651 sub _to_select {
 652     my ($self, $col, $args) = @_;
 653     $args ||= {};
 654 # Do we have items already ? Go no further.
 655     if ($args->{items} and ref $args->{items}) {
 656         my $a = $self->_select_guts($col,  $args);
 657         $OLD_STYLE && return $a->as_HTML;
 658                 if ($args->{multiple}) { $a->attr('multiple', 'multiple');}
 659                 return $a;
 660         }
 661
 662 # Else what are we making a select box out of ?
 663         # No Column parameter --  means making a select box of args->class or self
 664     # Using all rows from class's table
 665     if (not $col) {
 666                 unless ($args->{class}) {
 667                 $args->{class} = ref $self || $self;
 668                         # object selected if called with one
 669             $args->{selected} = { $self->id => 1}
 670                                 if not $args->{selected} and ref $self;
 671                 }
 672         $col = $args->{class}->primary_column;
 673     }
 674     # Related Class maybe ?
 675     elsif (my $rel_meta =  $self->related_meta('r:)', $col) ) {
 676         $args->{class} = $rel_meta->{foreign_class};
 677         # related objects pre selected if object
 678
 679                 # "Has many" -- Issues:
 680                 # 1) want to select one from list if self is an object
 681                 # Thats about all we can do really,
 682                 # 2) except for mapping which is TODO and  would
 683                 # do something like add to and take away from list of permissions for
 684                 # example.
 685
 686                 # Hasmany select one from list if ref self
 687                 if ($rel_meta->{name} =~ /has_many/i and ref $self) {
 688                         $args->{items} = [ $self->$col ];
 689                         my $a = $self->_select_guts($col,  $args);
 690                     $OLD_STYLE && return $a->as_HTML;
 691                     return $a;
 692                 }
 693                 else {
 694                         $args->{selected} ||= [ $self->$col ] if  ref $self;
 695                         #warn "selected is " . Dumper($args->{selected});
 696                         my $c = $rel_meta->{args}{constraint} || {};
 697                         my $j = $rel_meta->{args}{join} || {};
 698                         my @join ;
 699                         if (ref $self) {
 700                                 @join   =  map { $_ ." = ". $self->_attr($_) } keys %$j;
 701                         }
 702                         my @constr= map { "$_ = '$c->{$_}'"} keys %$c;
 703                         $args->{where}    ||= join (' AND ', (@join, @constr));
 704                         $args->{order_by} ||= $rel_meta->{args}{order_by};
 705                         $args->{limit}    ||= $rel_meta->{args}{limit};
 706                 }
 707
 708     }
 709     # We could say :Col is name and we are selecting  out of class arg.
 710         # DIE for now
 711         else {
 712                 #$args->{name} = $col;
 713                 die "Usage _to_select. $col not related to any class to select from. ";
 714
 715     }
 716
 717     # Set arguments
 718         unless ( defined  $args->{column_nullable} ) {
 719             $args->{column_nullable} = $self->can('column_nullable') ?
 720                          $self->column_nullable($col) : 1;
 721         }
 722
 723         # Get items to select from
 724     $args->{items} = _select_items($args);
 725     #warn "Items selecting from are " . Dumper($args->{items});
 726 #use Data::Dumper;
 727 #warn "Just got items. They are  " . Dumper($args->{items});
 728
 729         # Make select HTML element
 730         $a = $self->_select_guts($col, $args);
 731
 732         if ($args->{multiple}) {$a->attr('multiple', 'multiple');}
 733
 734         # Return
 735     $OLD_STYLE && return $a->as_HTML;
 736     $a;
 737
 738 }
 739
 740
 741 ##############
 742 # Function #
 743 # #############
 744 # returns the intersection of list refs a and b
 745 sub _list_intersect {
 746         my ($a, $b) = @_;
 747         my %isect; my %union;
 748     foreach my $e (@$a, @$b) { $union{$e}++ && $isect{$e}++ }
 749         return  %isect;
 750 }
 751 ############
 752 # FUNCTION #
 753 ############
 754 # Get Items
 755 sub _select_items {
 756         my $args = shift;
 757         my $fclass = $args->{class};
 758     my @disp_cols = @{$args->{columns} || []};
 759     @disp_cols = $fclass->columns('SelectBox') unless @disp_cols;
 760     @disp_cols = $fclass->columns('Stringify')unless @disp_cols;
 761     @disp_cols = $fclass->_essential unless @disp_cols;
 762         unshift @disp_cols,  $fclass->columns('Primary');
 763         #my %isect = _list_intersect(\@pks, \@disp_cols);
 764         #foreach (@pks) { push @sel_cols, $_ unless $isect{$_}; }
 765     #push @sel_cols, @disp_cols;
 766
 767         #warn "in select items. args are : " . Dumper($args);
 768         my $distinct = '';
 769         if ($args->{'distinct'}) {
 770         $distinct = 'DISTINCT ';
 771         }
 772
 773     my $sql = "SELECT $distinct" . join( ', ', @disp_cols) .
 774                   " FROM " . $fclass->table;
 775
 776         $sql .= " WHERE " . $args->{where}   if $args->{where};
 777         $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
 778         $sql .= " LIMIT " . $args->{limit} if $args->{limit};
 779 #warn "_select_items sql is : $sql";
 780
 781         return $fclass->db_Main->selectall_arrayref($sql);
 782
 783 }
 784
 785
 786 # Makes a readonly input box out of column's value
 787 # No args makes object to readonly
 788 sub _to_readonly {
 789     my ($self, $col, $val) = @_;
 790     if (! $col) { # object to readonly
 791         $val = $self->id;
 792         $col = $self->primary_column;
 793     }
 794     unless (defined $val) {
 795         $self->_croak("Cannot get value in _to_readonly .")
 796             unless ref $self;
 797         $val = $self->$col;
 798     }
 799     my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
 800         'name' => $col, 'value'=>$val);
 801 $OLD_STYLE && return $a->as_HTML;
 802     $a;
 803 }
 804
 805
 806 =head2 _to_enum_select
 807
 808 $sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");
 809
 810 Returns an enum select box given a column name and an enum string.
 811 NOTE: The Plugin::Type does not return an enum string for mysql enum columns.
 812 This will not work unless you write your own column_type method in your model.
 813
 814 =cut
 815
 816 sub _to_enum_select {
 817     my ($self, $col, $args) = @_;
 818         my $type = $args->{column_type};
 819     $type =~ /ENUM\((.*?)\)/i;
 820     (my $enum = $1) =~ s/'//g;
 821     my @enum_vals = split /\s*,\s*/, $enum;
 822
 823     # determine which is pre selected --
 824     # if obj, the value is , otherwise use column_default which is the first
 825     # value in the enum list unless it has been overridden
 826     my $selected = eval { $self->$col  };
 827     $selected = eval{$self->column_default($col)} unless defined $selected;
 828     $selected = $enum_vals[0]               unless defined $selected;
 829
 830     my $a = HTML::Element->new("select", name => $col);
 831     for ( @enum_vals ) {
 832         my $sel = HTML::Element->new("option", value => $_);
 833         $sel->attr("selected" => "selected") if $_ eq $selected ;
 834         $sel->push_content($_);
 835         $a->push_content($sel);
 836     }
 837     $OLD_STYLE && return $a->as_HTML;
 838     $a;
 839 }
 840
 841
 842 =head2 _to_bool_select
 843
 844   my $sel = $self->_to_bool_select($column, $bool_string);
 845
 846 This  makes select input for boolean column.  You can provide a
 847 bool string of form: Bool('zero','one') and those are used for option
 848 content. Onthervise No and Yes are used.
 849 TODO -- test without bool string.
 850
 851 =cut
 852
 853 # TCODO fix this mess with args
 854 sub _to_bool_select {
 855     my ($self, $col, $args) = @_;
 856         #warn "In to_bool select\n";
 857         my $type = $args->{column_type};
 858         my @bool_text = ('No', 'Yes');
 859         if ($type =~ /BOOL\((.+?)\)/i) {
 860                 (my $bool = $1) =~ s/'//g;
 861                 @bool_text = split /,/, $bool;
 862         }
 863
 864         # get selectedod
 865
 866         my $selected = $args->{value} if defined $args->{value};
 867         $selected = $args->{selected} unless defined $selected;
 868         $selected =  ref $self ? eval {$self->$col;} : $self->column_default($col)
 869                 unless (defined $selected);
 870
 871     my $a = HTML::Element->new("select", name => $col);
 872     if ($args->{column_nullable} || $args->{value} eq '') {
 873                 my $null =  HTML::Element->new("option");
 874                 $null->attr('selected', 'selected') if  $args->{value} eq '';
 875             $a->push_content( $null );
 876         }
 877
 878     my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
 879                                                   HTML::Element->new("option", value => 1) );
 880     $opt0->push_content($bool_text[0]);
 881     $opt1->push_content($bool_text[1]);
 882         unless ($selected eq '') {
 883         $opt0->attr("selected" => "selected") if not $selected;
 884         $opt1->attr("selected" => "selected") if $selected;
 885         }
 886     $a->push_content($opt0, $opt1);
 887     $OLD_STYLE && return $a->as_HTML;
 888     $a;
 889 }
 890
 891
 892 =head2 _to_hidden($col, $args)
 893
 894 This makes a hidden html element. Give it a name and value or if name is
 895 a ref it will use the PK name and value of the object.
 896
 897 =cut
 898
 899 sub _to_hidden {
 900     my ($self, $name, $val) = @_;
 901     my $args = {};
 902     my $obj;
 903     if (ref $name and $name->isa("Class::DBI")) {
 904        $obj = $name;
 905        $name= ($obj->primary_columns)[0]->name;
 906     }
 907     if (ref $val) {
 908                 $args = $val;
 909         $val = $args->{value};
 910         $name = $args->{name} if $args->{name};
 911     }
 912     elsif (not $name ) { # hidding object caller
 913         $self->_croak("No object available in _to_hidden") unless ref $self;
 914         $name = ($self->primary_column)[0]->name;
 915         $val  = $self->id;
 916     }
 917     return HTML::Element->new('input', 'type' => 'hidden',
 918                               'name' => $name, 'value'=>$val
 919     );
 920 }
 921
 922 =head2 _to_link_hidden($col, $args)
 923
 924 Makes a link with a hidden input with the id of $obj as the value and name.
 925 Name defaults to the objects primary key. The object defaults to self.
 926
 927 =cut
 928
 929 sub _to_link_hidden {
 930     my ($self, $accessor, $args) = @_;
 931     my $r =  eval {$self->controller} || $args->{r} || '';
 932     my $uri = $args->{uri} || '';
 933    use Data::Dumper;
 934     $self->_croak("_to_link_hidden cant get uri. No  Maypole Request class (\$r) or uri arg. Need one or other.")
 935         unless $r;
 936     my ($obj, $name);
 937     if (ref $self) { # hidding linking self
 938          $obj  = $self;
 939          $name = $args->{name} || $obj->primary_column->name;
 940     }
 941     elsif ($obj = $args->{items}->[0]) {
 942        # cool)
 943         $name = $args->{name} || $obj->primary_column->name; # TODO make use meta data
 944     }
 945
 946     else {           # hiding linking related object with id in args
 947         $obj  = $self->related_class($r, $accessor)->retrieve($args->{id});
 948         $name = $args->{name} || $obj->primary_column->name; # TODO make use meta data
 949     }
 950     $self->_croak("_to_link_hidden has no object") unless ref $obj;
 951     my $href =  $uri || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
 952     my $a = HTML::Element->new('a', 'href' => $href);
 953     $a->push_content("$obj");
 954     $a->push_content($self->_to_hidden($name, $obj->id));
 955         $OLD_STYLE && return $a->as_HTML;
 956     $a;
 957 }
 958
 959
 960
 961 =head2 _to_foreign_inputs
 962
 963 $html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]);
 964
 965 Get inputs for the accessor's class.  Pass an array ref of fields to get
 966 inputs for only those fields. Otherwise display_columns or all columns is used.
 967 If you have the meta info handy for the accessor you can pass that too.
 968
 969 TODO make AsForm know more about the request like what action we are doing
 970 so it can use edit columns or search_columns
 971
 972 NOTE , this names the foreign inputs is a particular way so they can be
 973 processed with a general routine and so there are not name clashes.
 974
 975 args -
 976 related_meta -- if you have this, great, othervise it will determine or die
 977 columns  -- list of columns to make inputs for
 978
 979 =cut
 980
 981 sub _to_foreign_inputs {
 982         my ($self, $accssr, $args) = @_;
 983         my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr);
 984         my $fields              = $args->{columns};
 985         if (!$rel_meta) {
 986                 $self->_croak( "No relationship for accessor $accssr");
 987         }
 988
 989         my $rel_type = $rel_meta->{name};
 990         my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_meta->{foreign_class};
 991
 992         unless ($fields) {
 993                 $fields = $classORobj->can('display_columns') ?
 994                         [$classORobj->display_columns] : [$classORobj->columns];
 995         }
 996
 997         # Ignore our fkey in them to  prevent infinite recursion
 998         my $me          = eval {$rel_meta->{args}{foreign_column}} || '';
 999         my $constrained = $rel_meta->{args}{constraint};
1000         my %inputs;
1001         foreach ( @$fields ) {
1002                 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
1003                 $inputs{$_} =  $classORobj->to_field($_);
1004         }
1005
1006         # Make hidden inputs for constrained columns unless we are editing object
1007         # TODO -- is this right thing to do?
1008         unless (ref $classORobj || $args->{no_hidden_constraints}) {
1009                 $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_})
1010                         foreach ( keys %$constrained );
1011         }
1012         $self->_rename_foreign_input($accssr, \%inputs);
1013         return \%inputs;
1014 }
1015
1016
1017 =head2 _hash_selected
1018
1019 Method to make sense out of the "selected" argument which can be in a number
1020 of formats perhaps.  It returns a hashref with the the values of options to be
1021 as the keys.
1022
1023 Below handles these formats for the "selected" slot in the arguments hash:
1024   Object (with id method)
1025   Scalar (assumes it is value)
1026   Array ref *OF* objects, arrays of data (0 elmnt used), hashes of data
1027     (id key used), and simple scalars.
1028
1029
1030 =cut
1031
1032 ############
1033 # FUNCTION #
1034 ############
1035 sub _hash_selected {
1036         my ($args) = shift;
1037         my $selected = $args->{value} || $args->{selected};
1038     return $selected unless $selected and ref $selected ne 'HASH';
1039         #warn "Selected dump : " . Dumper($selected);
1040         my $type = ref $selected;
1041         # Single Object
1042     if ($type and $type ne 'ARRAY') {
1043        return  {$selected->id => 1};
1044     }
1045     # Single Scalar id
1046         elsif (not $type) {
1047                 return { $selected => 1};
1048         }
1049
1050
1051         # Array of objs, arrays, hashes, or just scalalrs.
1052         elsif ($type eq 'ARRAY') {
1053                 my %hashed;
1054                 my $ltype = ref $selected->[0];
1055                 # Objects
1056                 if ($ltype and $ltype ne 'ARRAY')  {
1057                         %hashed = map { $_->id  => 1 } @$selected;
1058         }
1059                 # Arrays of data with id first
1060             elsif ($ltype and $ltype eq 'ARRAY') {
1061                         %hashed = map { $_->[0]  => 1 } @$selected;
1062                 }
1063                 # Hashes using pk or id key
1064                 elsif ($ltype and $ltype eq 'HASH') {
1065                         my $pk = $args->{class}->primary_column || 'id';
1066                         %hashed = map { $_->{$pk}  => 1 } @$selected;
1067                 }
1068                 # Just Scalars
1069         else {
1070                         %hashed = map { $_  => 1 } @$selected;
1071                 }
1072                 return \%hashed;
1073         }
1074         else { warn "AsForm Could not hash the selected argument: $selected"; }
1075 }
1076
1077
1078
1079
1080 =head2 _select_guts
1081
1082 Internal api  method to make the actual select box form elements.
1083
1084 3 types of lists making for --
1085   Hash, Array,
1086   Array of CDBI objects.
1087   Array of scalars ,
1088   Array or  Array refs with cols from class,
1089   Array of hashes
1090
1091 =cut
1092
1093
1094
1095 sub _select_guts {
1096     my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
1097
1098     #$args->{stringify} ||=  'stringify_selectbox';
1099     $args->{selected} = _hash_selected($args) if defined $args->{selected};
1100         my $name = $args->{name} || $col;
1101     my $a = HTML::Element->new('select', name => $name);
1102         $a->attr( %{$args->{attr}} ) if $args->{attr};
1103
1104     if ($args->{column_nullable}) {
1105                 my $null_element = HTML::Element->new('option', value => '');
1106         $null_element->attr(selected => 'selected')
1107                 if ($args->{selected}{'null'});
1108         $a->push_content($null_element);
1109     }
1110
1111         my $items = $args->{items};
1112     my $type = ref $items;
1113         my $proto = eval { ref $items->[0]; } || "";
1114         warn "Type is $type, proto is $proto\n";
1115     # Single Hash
1116     if ($type eq 'HASH') {
1117         $a->push_content($self->_options_from_hash($items, $args));
1118     }
1119     # Single Array
1120     elsif ( $type eq 'ARRAY' and not ref $items->[0] ) {
1121         $a->push_content($self->_options_from_array($items, $args));
1122     }
1123     # Array of Objects
1124     elsif( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) {
1125         # make select  of objects
1126         $a->push_content($self->_options_from_objects($items, $args));
1127     }
1128     # Array of Arrays
1129     elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) {
1130         $a->push_content($self->_options_from_arrays($items, $args));
1131     }
1132     # Array of Hashes
1133     elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) {
1134         $a->push_content($self->_options_from_hashes($items, $args));
1135     }
1136     else {
1137         die "You passed a weird type of data structure to me. Here it is: " .
1138         Dumper($items );
1139     }
1140
1141     return $a;
1142 }
1143
1144 =head2 _options_from_objects ( $objects, $args);
1145
1146 Private method to makes a options out of  objects. It attempts to call each
1147 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
1148
1149 =cut
1150 sub _options_from_objects {
1151     my ($self, $items, $args) = @_;
1152         my $selected = $args->{selected} || {};
1153         my $stringify = $args->{stringify} || '';
1154     my @res;
1155         for (@$items) {
1156                 my $opt = HTML::Element->new("option", value => $_->id);
1157                 $opt->attr(selected => "selected") if $selected->{$_->id};
1158                 my $content = $stringify ? $_->stringify :  "$_";
1159                 $opt->push_content($content);
1160                 push @res, $opt;
1161         }
1162     return @res;
1163 }
1164
1165 sub _options_from_arrays {
1166     my ($self, $items, $args) = @_;
1167         my $selected = $args->{selected} || {};
1168     my @res;
1169         my $class = $args->{class} || '';
1170         my $stringify = $args->{stringify} || '';
1171         for my $item (@$items) {
1172             my @pks; # for future multiple key support
1173             push @pks, shift @$item foreach $class->columns('Primary');
1174                 my $id = $pks[0];
1175                 $id =~ ~ s/^0+//;  # In case zerofill is on .
1176                 my $opt = HTML::Element->new("option", value => $id );
1177                 $opt->attr(selected => "selected") if $selected->{$id};
1178
1179                 my $content = ($class and $stringify and $class->can($stringify)) ?
1180                               $class->$stringify($_) :
1181                                   join( '/', map { $_ if $_; }@{$item} );
1182                 $opt->push_content( $content );
1183         push @res, $opt;
1184     }
1185     return @res;
1186 }
1187
1188
1189 sub _options_from_array {
1190     my ($self, $items, $args) = @_;
1191     my $selected = $args->{selected} || {};
1192     my @res;
1193     for (@$items) {
1194         my $opt = HTML::Element->new("option", value => $_ );
1195         #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1196         $opt->attr(selected => "selected") if $selected->{$_};
1197         $opt->push_content( $_ );
1198         push @res, $opt;
1199     }
1200     return @res;
1201 }
1202
1203 sub _options_from_hash {
1204     my ($self, $items, $args) = @_;
1205     my $selected = $args->{selected} || {};
1206     my @res;
1207
1208     my @values = values %$items;
1209     # hash Key is the option content  and the hash value is option value
1210     for (sort keys %$items) {
1211         my $opt = HTML::Element->new("option", value => $items->{$_} );
1212         #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1213         $opt->attr(selected => "selected") if $selected->{$items->{$_}};
1214         $opt->push_content( $_ );
1215         push @res, $opt;
1216     }
1217     return @res;
1218 }
1219
1220
1221 sub _options_from_hashes {
1222     my ($self, $items, $args) = @_;
1223         my $selected = $args->{selected} || {};
1224         my $pk = eval {$args->{class}->primary_column} || 'id';
1225         my $fclass = $args->{class} || '';
1226         my $stringify = $args->{stringify} || '';
1227         my @res;
1228         for (@$items) {
1229                 my $val = $_->{$pk};
1230                 my $opt = HTML::Element->new("option", value => $val );
1231                 $opt->attr(selected => "selected") if $selected->{$val};
1232                 my $content = ($fclass and $stringify and $fclass->can($stringify)) ?
1233                               $fclass->$stringify($_) :
1234                                   join(' ', @$_);
1235                 $opt->push_content( $content );
1236         push @res, $opt;
1237     }
1238         return @res;
1239 }
1240
1241 sub _to_select_or_create {
1242         my ($self, $col, $args) = @_;
1243         $args->{name} ||= $col;
1244         my $select = $self->to_field($col, 'select', $args);
1245         $args->{name} = "create_" . $args->{name};
1246         my $create = $self->to_field($col, 'foreign_inputs', $args);
1247         $create->{'__select_or_create__'} =
1248                 $self->to_field('__select_or_create__',{ name => '__select_or_create__' , value => 1 } );
1249         return ($select, $create);
1250 }
1251
1252 #
1253 # checkboxes: if no data in hand (ie called as class method), replace
1254 # with a radio button, in order to allow this field to be left
1255 # unspecified in search / add forms.
1256 #
1257 # Not tested
1258 # TODO  --  make this general checkboxse
1259 #
1260 #
1261 sub _to_checkbox {
1262     my ($self, $col, $args) = @_;
1263     my $nullable = eval {self->column_nullable($col)} || 0;
1264     return $self->_to_radio($col) if !ref($self) || $nullable;
1265     my $value = $self->$col;
1266     my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1267     $a->attr("checked" => 'true') if $value eq 'Y';
1268     return $a;
1269 }
1270
1271
1272 # TODO  -- make this general radio butons
1273 #
1274 sub _to_radio {
1275     my ($self, $col) = @_;
1276     my $value = ref $self && $self->$col || '';
1277     my $nullable = eval {self->column_nullable($col)} || 0;
1278     my $a = HTML::Element->new("span");
1279     my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1280     my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1281     my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1282     $ry->push_content('Yes'); $rn->push_content('No');
1283     $ru->push_content('n/a') if $nullable;
1284     if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1285     elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1286     elsif ($nullable) { $ru->attr("checked" => 'true') }
1287     $a->push_content($ry, $rn);
1288     $a->push_content($ru) if $nullable;
1289     return $a;
1290 }
1291
1292
1293
1294 ############################ HELPER METHODS ######################
1295 ##################################################################
1296
1297 =head2 _rename_foreign_input
1298
1299 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1300
1301 Recursively renames the foreign inputs made by _to_foreign_inputs so they
1302 can be processed generically.  The format is "accessor__AsForeign_colname".
1303
1304 So if an Employee is a Person who has_own  Address and you call
1305
1306   Employee->to_field("person")
1307
1308 then you will get inputs for the Person as well as their Address (by default,
1309 override _field_from_relationship to change logic) named like this:
1310
1311   person__AsForeign__address__AsForeign__street
1312   person__AsForeign__address__AsForeign__city
1313   person__AsForeign__address__AsForeign__state
1314   person__AsForeign__address__AsForeign__zip
1315
1316 And the processor would know to create this address, put the address id in
1317 person->address data slot, create the person and put the person id in the employee->person data slot and then create the employee with that data.
1318
1319 Overriede make_element_foreign to change how you want a foreign param labeled.
1320
1321 =head2 make_element_foreign
1322
1323   $class->make_element_foreign($accessor, $element);
1324
1325 Makes an HTML::Element type object foreign elemen representing the
1326 class's accessor.  (IE this in an input element for $class->accessor :) )
1327
1328 =cut
1329
1330 sub make_element_foreign {
1331         my ($self, $accssr, $element)  = @_;
1332         $element->attr( name => $accssr . "__AsForeign__" . $element->attr('name'));
1333 }
1334
1335
1336
1337 sub _rename_foreign_input {
1338         my ($self, $accssr, $element) = @_;
1339         if ( ref $element ne 'HASH' ) {
1340         #       my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
1341                 $self->make_element_foreign($accssr, $element);
1342         }
1343         else {
1344                 $self->_rename_foreign_input($accssr, $element->{$_})
1345                         foreach (keys %$element);
1346         }
1347 }
1348
1349 =head2 _box($value)
1350
1351 This functions computes the dimensions of a textarea based on the value
1352 or the defaults.
1353
1354 =cut
1355
1356 our ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1357
1358 sub _box
1359 {
1360     my $text = shift;
1361     if ($text) {
1362         my @rows = split /^/, $text;
1363         my $cols = $min_cols;
1364         my $chars = 0;
1365         for (@rows) {
1366             my $len = length $_;
1367             $chars += $len;
1368             $cols = $len if $len > $cols;
1369             $cols = $max_cols if $cols > $max_cols;
1370         }
1371         my $rows = @rows;
1372         $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1373         $rows = $min_rows if $rows < $min_rows;
1374         $rows = $max_rows if $rows > $max_rows;
1375         ($rows, $cols)
1376     }
1377     else { ($min_rows, $min_cols) }
1378 }
1379
1380
1381 1;
1382
1383
1384 =head1 CHANGES
1385
1386 =head1 MAINTAINER
1387
1388 Maypole Developers
1389
1390 =head1 AUTHORS
1391
1392 Peter Speltz, Aaron Trevena
1393
1394 =head1 AUTHORS EMERITUS
1395
1396 Simon Cozens, Tony Bowden
1397
1398 =head1 TODO
1399
1400   Documenting
1401   Testing - lots
1402   chekbox generalization
1403   radio generalization
1404   select work
1405   Make link_hidden use standard make_url stuff when it gets in Maypole
1406   How do you tell AF --" I want a has_many select box for this every time so,
1407      when you call "to_field($this_hasmany)" you get a select box
1408
1409 =head1 BUGS and QUERIES
1410
1411 Please direct all correspondence regarding this module to:
1412  Maypole list.
1413
1414 =head1 COPYRIGHT AND LICENSE
1415
1416 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1417
1418 This library is free software; you can redistribute it and/or modify
1419 it under the same terms as Perl itself.
1420
1421 =head1 SEE ALSO
1422
1423 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.
1424
1425 =cut
1426