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