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