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