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_column}} || '';
 987         my $constrained = $rel_meta->{args}{constraint};
 988         my %inputs;
 989         foreach ( @$fields ) {
 990                 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
 991                 $inputs{$_} =  $classORobj->to_field($_);
 992         }
 993
 994         # Make hidden inputs for constrained columns unless we are editing object
 995         # TODO -- is this right thing to do?
 996         unless (ref $classORobj || $args->{no_hidden_constraints}) {
 997                 $inputs{$_} = $classORobj->to_field('blahfooey', 'hidden',
 998                                       {name => $_, value => $constrained->{$_}} )
 999                         foreach ( keys %$constrained );
1000         }
1001         $self->_rename_foreign_input($accssr, \%inputs);
1002         return \%inputs;
1003 }
1004
1005
1006 =head2 _hash_selected
1007
1008 *Function* to make sense out of the "selected" argument which has values of the
1009 options that should be selected by default when making a select box.  It
1010 can be in a number formats.  This method returns a map of which options to
1011 select with the values being the keys in the map ( {val1 => 1, val2 = 1} ).
1012
1013 Currently this method  handles the following formats for the "selected" argument
1014 and in the following ways
1015
1016   Object                                -- uses the id method  to get the value
1017   Scalar                                -- assumes it *is* the value
1018   Array ref of objects  -- same as Object
1019   Arrays of data                -- uses the 0th element in each
1020   Hashes of data                -- uses key named 'id'
1021
1022 =cut
1023
1024 ############
1025 # FUNCTION #
1026 ############
1027 sub _hash_selected {
1028         my ($args) = shift;
1029         my $selected = $args->{value} || $args->{selected};
1030         #warn "**** SELECTED is $selected ****";
1031         my $type = ref $selected;
1032     return $selected unless $selected and $type ne 'HASH';
1033         #warn "Selected dump : " . Dumper($selected);
1034         # Single Object
1035     if ($type and $type ne 'ARRAY') {
1036            my $id = $selected->id;
1037            $id =~ s/^0*//;
1038        return  {$id => 1};
1039     }
1040     # Single Scalar id
1041         elsif (not $type) {
1042                 return { $selected => 1};
1043         }
1044
1045
1046         # Array of objs, arrays, hashes, or just scalalrs.
1047         elsif ($type eq 'ARRAY') {
1048                 my %hashed;
1049                 my $ltype = ref $selected->[0];
1050                 # Objects
1051                 if ($ltype and $ltype ne 'ARRAY')  {
1052                         %hashed = map { $_->id  => 1 } @$selected;
1053         }
1054                 # Arrays of data with id first
1055             elsif ($ltype and $ltype eq 'ARRAY') {
1056                         %hashed = map { $_->[0]  => 1 } @$selected;
1057                 }
1058                 # Hashes using pk or id key
1059                 elsif ($ltype and $ltype eq 'HASH') {
1060                         my $pk = $args->{class}->primary_column || 'id';
1061                         %hashed = map { $_->{$pk}  => 1 } @$selected;
1062                 }
1063                 # Just Scalars
1064         else {
1065                         %hashed = map { $_  => 1 } @$selected;
1066                 }
1067                 return \%hashed;
1068         }
1069         else { warn "AsForm Could not hash the selected argument: $selected"; }
1070 }
1071
1072
1073
1074
1075 =head2 _select_guts
1076
1077 Internal api  method to make the actual select box form elements.
1078 the data.
1079
1080 Items to make options out of can be
1081   Hash, Array,
1082   Array of CDBI objects.
1083   Array of scalars ,
1084   Array or  Array refs with cols from class,
1085   Array of hashes
1086
1087 =cut
1088
1089
1090
1091 sub _select_guts {
1092     my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
1093
1094     #$args->{stringify} ||=  'stringify_selectbox';
1095
1096     $args->{selected} = _hash_selected($args) if defined $args->{selected};
1097         my $name = $args->{name} || $col;
1098     my $a = HTML::Element->new('select', name => $name);
1099         $a->attr( %{$args->{attr}} ) if $args->{attr};
1100
1101     if ($args->{column_nullable}) {
1102                 my $null_element = HTML::Element->new('option', value => '');
1103         $null_element->attr(selected => 'selected')
1104                 if ($args->{selected}{'null'});
1105         $a->push_content($null_element);
1106     }
1107
1108         my $items = $args->{items};
1109     my $type = ref $items;
1110         my $proto = eval { ref $items->[0]; } || "";
1111         my $optgroups = $args->{optgroups} || '';
1112
1113         # Array of hashes, one for each optgroup
1114         if ($optgroups) {
1115                 my $i = 0;
1116                 foreach (@$optgroups) {
1117                         my $ogrp=  HTML::Element->new('optgroup', label => $_);
1118                         $ogrp->push_content($self->_options_from_hash($items->[$i], $args));
1119                         $a->push_content($ogrp);
1120                         $i++;
1121                 }
1122         }
1123     # Single Hash
1124     elsif ($type eq 'HASH') {
1125         $a->push_content($self->_options_from_hash($items, $args));
1126     }
1127     # Single Array
1128     elsif ( $type eq 'ARRAY' and not ref $items->[0] ) {
1129         $a->push_content($self->_options_from_array($items, $args));
1130     }
1131     # Array of Objects
1132     elsif( $type eq 'ARRAY' and $proto !~ /ARRAY|HASH/i ) {
1133         # make select  of objects
1134         $a->push_content($self->_options_from_objects($items, $args));
1135     }
1136     # Array of Arrays
1137     elsif ( $type eq 'ARRAY' and $proto eq 'ARRAY' ) {
1138         $a->push_content($self->_options_from_arrays($items, $args));
1139     }
1140     # Array of Hashes
1141     elsif ( $type eq 'ARRAY' and $proto eq 'HASH' ) {
1142         $a->push_content($self->_options_from_hashes($items, $args));
1143     }
1144     else {
1145         die "You passed a weird type of data structure to me. Here it is: " .
1146         Dumper($items );
1147     }
1148
1149     return $a;
1150
1151
1152 }
1153
1154 =head2 _options_from_objects ( $objects, $args);
1155
1156 Private method to makes a options out of  objects. It attempts to call each
1157 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
1158
1159 *Note only  single primary keys supported
1160
1161 =cut
1162 sub _options_from_objects {
1163     my ($self, $items, $args) = @_;
1164         my $selected = $args->{selected} || {};
1165         my $stringify = $args->{stringify} || '';
1166     my @res;
1167         for (@$items) {
1168                 my $id = $_->id;
1169                 my $opt = HTML::Element->new("option", value => $id);
1170                 $id =~ s/^0*//; # leading zeros no good in hash key
1171                 $opt->attr(selected => "selected") if $selected->{$id};
1172                 my $content = $stringify ? $_->stringify :  "$_";
1173                 $opt->push_content($content);
1174                 push @res, $opt;
1175         }
1176     return @res;
1177 }
1178
1179 sub _options_from_arrays {
1180     my ($self, $items, $args) = @_;
1181         my $selected = $args->{selected} || {};
1182     my @res;
1183         my $class = $args->{class} || '';
1184         my $stringify = $args->{stringify} || '';
1185         for my $item (@$items) {
1186             my @pks; # for future multiple key support
1187             push @pks, shift @$item foreach $class->columns('Primary');
1188                 my $id = $pks[0];
1189                 $id =~ s/^0+//;  # In case zerofill is on .
1190                 my $val = defined $id ? $id : '';
1191                 my $opt = HTML::Element->new("option", value =>$val);
1192                 $opt->attr(selected => "selected") if $selected->{$id};
1193
1194                 my $content = ($class and $stringify and $class->can($stringify)) ?
1195                               $class->$stringify($_) :
1196                                   join( '/', map { $_ if $_; }@{$item} );
1197                 $opt->push_content( $content );
1198         push @res, $opt;
1199     }
1200     return @res;
1201 }
1202
1203
1204 sub _options_from_array {
1205     my ($self, $items, $args) = @_;
1206     my $selected = $args->{selected} || {};
1207     my @res;
1208     for (@$items) {
1209                 my $val = defined $_ ? $_ : '';
1210         my $opt = HTML::Element->new("option", value => $val);
1211         #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1212         $opt->attr(selected => "selected") if $selected->{$_};
1213         $opt->push_content( $_ );
1214         push @res, $opt;
1215     }
1216     return @res;
1217 }
1218
1219 sub _options_from_hash {
1220     my ($self, $items, $args) = @_;
1221     my $selected = $args->{selected} || {};
1222     my @res;
1223
1224     my @values = values %$items;
1225     # hash Key is the option content  and the hash value is option value
1226     for (sort keys %$items) {
1227                 my $val = defined $items->{$_} ? $items->{$_} : '';
1228         my $opt = HTML::Element->new("option", value => $val);
1229         #$opt->attr(selected => "selected") if $selected =~/^$id$/;
1230         $opt->attr(selected => "selected") if $selected->{$items->{$_}};
1231         $opt->push_content( $_ );
1232         push @res, $opt;
1233     }
1234     return @res;
1235 }
1236
1237
1238 sub _options_from_hashes {
1239     my ($self, $items, $args) = @_;
1240         my $selected = $args->{selected} || {};
1241         my $pk = eval {$args->{class}->primary_column} || 'id';
1242         my $fclass = $args->{class} || '';
1243         my $stringify = $args->{stringify} || '';
1244         my @res;
1245         for (@$items) {
1246                 my $val = defined $_->{$pk} ? $_->{$pk} : '';
1247                 my $opt = HTML::Element->new("option", value => $val);
1248                 $opt->attr(selected => "selected") if $selected->{$val};
1249                 my $content = ($fclass and $stringify and $fclass->can($stringify)) ?
1250                               $fclass->$stringify($_) :
1251                                   join(' ', keys %$_);
1252                 $opt->push_content( $content );
1253         push @res, $opt;
1254     }
1255         return @res;
1256 }
1257
1258 # TODO -- Maybe
1259 #sub _to_select_or_create {
1260 #       my ($self, $col, $args) = @_;
1261 #       $args->{name} ||= $col;
1262 #       my $select = $self->to_field($col, 'select', $args);
1263 #       $args->{name} = "create_" . $args->{name};
1264 #       my $create = $self->to_field($col, 'foreign_inputs', $args);
1265 #       $create->{'__select_or_create__'} =
1266 #               $self->to_field('__select_or_create__',{ name => '__select_or_create__' , value => 1 } );
1267 #       return ($select, $create);
1268 #}
1269
1270
1271 =head2 _to_checkbox
1272
1273 Makes a checkbox element -- TODO
1274
1275 =cut
1276 #
1277 # checkboxes: if no data in hand (ie called as class method), replace
1278 # with a radio button, in order to allow this field to be left
1279 # unspecified in search / add forms.
1280 #
1281 # Not tested
1282 # TODO  --  make this general checkboxse
1283 #
1284 #
1285 sub _to_checkbox {
1286     my ($self, $col, $args) = @_;
1287     my $nullable = eval {self->column_nullable($col)} || 0;
1288     return $self->_to_radio($col) if !ref($self) || $nullable;
1289     my $value = $self->$col;
1290     my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1291     $a->attr("checked" => 'true') if $value eq 'Y';
1292     return $a;
1293 }
1294
1295 =head2 _to_radio
1296
1297 Makes a radio button element -- TODO
1298
1299 =cut
1300 # TODO  -- make this general radio butons
1301 #
1302 sub _to_radio {
1303     my ($self, $col) = @_;
1304     my $value = ref $self && $self->$col || '';
1305     my $nullable = eval {self->column_nullable($col)} || 0;
1306     my $a = HTML::Element->new("span");
1307     my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1308     my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1309     my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1310     $ry->push_content('Yes'); $rn->push_content('No');
1311     $ru->push_content('n/a') if $nullable;
1312     if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1313     elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1314     elsif ($nullable) { $ru->attr("checked" => 'true') }
1315     $a->push_content($ry, $rn);
1316     $a->push_content($ru) if $nullable;
1317     return $a;
1318 }
1319
1320
1321
1322 ############################ HELPER METHODS ######################
1323 ##################################################################
1324
1325 =head2 _rename_foreign_input
1326
1327 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1328
1329 Recursively renames the foreign inputs made by _to_foreign_inputs so they
1330 can be processed generically.  It uses foreign_input_delimiter.
1331
1332 So if an Employee is a Person who has_many  Addresses and you call and the
1333 method 'foreign_input_delimiter' returns '__AF__' then
1334
1335   Employee->to_field("person");
1336
1337 will get inputs for the Person as well as their Address (by default,
1338 override _field_from_relationship to change logic) named like this:
1339
1340   person__AF__address__AF__street
1341   person__AF__address__AF__city
1342   person__AF__address__AF__state
1343   person__AF__address__AF__zip
1344
1345 And the processor would know to create this address, put the address id in
1346 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.
1347
1348 =cut
1349
1350 sub _rename_foreign_input {
1351         my ($self, $accssr, $element) = @_;
1352         my $del = $self->foreign_input_delimiter;
1353
1354         if ( ref $element ne 'HASH' ) {
1355         #       my $new_name = $accssr . "__AF__" . $input->attr('name');
1356                 $element->attr( name => $accssr . $del . $element->attr('name'));
1357         }
1358         else {
1359                 $self->_rename_foreign_input($accssr, $element->{$_})
1360                         foreach (keys %$element);
1361         }
1362 }
1363
1364 =head2 foreign_input_delimiter
1365
1366 This tells AsForm what to use to delmit forieign input names. This is important
1367 to avoid name clashes as well as automating processing of forms.
1368
1369 =cut
1370
1371 sub foreign_input_delimiter { '__AF__' };
1372
1373 =head2 _box($value)
1374
1375 This functions computes the dimensions of a textarea based on the value
1376 or the defaults.
1377
1378 =cut
1379
1380 sub _box
1381 {
1382
1383         my ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1384     my $text = shift;
1385     if ($text) {
1386         my @rows = split /^/, $text;
1387         my $cols = $min_cols;
1388         my $chars = 0;
1389         for (@rows) {
1390             my $len = length $_;
1391             $chars += $len;
1392             $cols = $len if $len > $cols;
1393             $cols = $max_cols if $cols > $max_cols;
1394         }
1395         my $rows = @rows;
1396         $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1397         $rows = $min_rows if $rows < $min_rows;
1398         $rows = $max_rows if $rows > $max_rows;
1399         ($rows, $cols)
1400     }
1401     else { ($min_rows, $min_cols) }
1402 }
1403
1404
1405 1;
1406
1407
1408 =head1 CHANGES
1409
1410 1.0
1411 15-07-2004 -- Initial version
1412 =head1 MAINTAINER
1413
1414 Maypole Developers
1415
1416 =head1 AUTHORS
1417
1418 Peter Speltz, Aaron Trevena
1419
1420 =head1 AUTHORS EMERITUS
1421
1422 Simon Cozens, Tony Bowden
1423
1424 =head1 TODO
1425
1426   Documenting
1427   Testing - lots
1428   chekbox generalization
1429   radio generalization
1430   select work
1431   Make link_hidden use standard make_url stuff when it gets in Maypole
1432   How do you tell AF --" I want a has_many select box for this every time so,
1433      when you call "to_field($this_hasmany)" you get a select box
1434
1435 =head1 BUGS and QUERIES
1436
1437 Please direct all correspondence regarding this module to:
1438  Maypole list.
1439
1440 =head1 COPYRIGHT AND LICENSE
1441
1442 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1443
1444 This library is free software; you can redistribute it and/or modify
1445 it under the same terms as Perl itself.
1446
1447 =head1 SEE ALSO
1448
1449 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.
1450
1451 =cut
1452