lib/Maypole/Model/CDBI/AsForm.pm

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