lib/Maypole/Model/CDBI/AsForm.pm

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