lib/Maypole/Model/CDBI/AsForm.pm

   1 package Maypole::Model::CDBI::AsForm;
   2
   3 use 5.006;
   4
   5 use strict;
   6 use warnings;
   7
   8 use base 'Exporter';
   9 use Data::Dumper;
  10 use Class::DBI::Plugin::Type ();
  11 use HTML::Element;
  12
  13 our $OLD_STYLE = 0;
  14 # pjs  --  Added new methods to @EXPORT
  15 our @EXPORT =
  16         qw(
  17                 to_cgi to_field _to_textarea _to_textfield _to_select
  18                 _to_foreign_inputs _to_enum_select _to_bool_select
  19                 _to_select_from_many _to_select_from_related _to_select_from_objs
  20                 _to_hidden _to_link_hidden _rename_foreign_input _to_readonly
  21                 _options_from_objects _options_from_arrays _options_from_hashes
  22                 _options_from_scalars
  23                 _field_from_how _field_from_relationship _field_from_column
  24                 _select_guts unselect_element  search_inputs make_param_foreign
  25     );
  26
  27 our $VERSION = '.09';
  28
  29 # 11-05-05  - added _to_link_hidden  to make a link to the hidden object
  30 #           - fixed _to_hidden when called with no args. Hides self obj.
  31 # 11-04-05  - _to_textfield: tries to call "deflate4edit" if column is has_a
  32 # 11-08-05  - Changed Version to .08
  33
  34
  35
  36 # 1-10-06  -- fixed bug in to_textfiled that was stringifyingf CDBI objects
  37 # #
  38 #
  39 # 1-20-06  - to_select - call db_Main with has a class.
  40 # 1-24-06  - to_select_from_many now named _to_select_from_many . Old deprecated
  41 #          - hasmany_class removed in favor of model's related_class method.
  42 #                  - took out do_select. That is a model action.
  43 #          - use search_columns instead of  search_fields now.
  44 #          - use to_field('column', 'select', {args}) instead of a_select_box.
  45 #          -- took out make_hidden_element.was my own personal hack
  46 #          -- added _box from DH's FormView to calculate decent textarea size
  47 #          -- Refactor to_field into _from_* method calls.
  48 #
  49 # 1-25-06  -- Added _to_checkbox and _to_radio from FView
  50 # 1-27-06  -- Refactored into yet more exported  methods
  51 # 1-28-06  -- select constraints where, join order by
  52
  53
  54 =head1 NAME
  55
  56 Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns
  57
  58 =head1 SYNOPSIS
  59
  60     package Music::CD;
  61     use Maypole::Model::CDBI::AsForm;
  62     use base 'Class::DBI';
  63     use CGI;
  64     ...
  65
  66     sub create_or_edit {
  67         my $self = shift;
  68         my %cgi_field = $self->to_cgi;
  69         return start_form,
  70                (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
  71                     $class->Columns),
  72                end_form;
  73     }
  74
  75         . . . somewhere use to_field($col, $how, $args)
  76         package BeerDB::Pint;
  77         __PACKAGE__->has_a('drinker', 'BeerDB::Drinker');
  78         __PACKAGE__->has_a('beer',    'BeerDB::Beer');
  79         package BeerDB::Drinker;
  80         __PACKAGE__->has_many('pints', 'BeerDB::Pint');
  81
  82         # NEED to do mapping
  83         my $sel = BeerDB::Drinker->to_field('pints', 'select') # multiple
  84         my $sel = $Drunk->to_field('pints', 'select'); # Already had beers selected
  85
  86 package Job;
  87
  88 __PACKAGE__->has_a('employer' => 'Employer');
  89 __PACKAGE__->has_a('contact'  => 'Contact')
  90
  91 package Contact;
  92
  93 __PACKAGE__->has_a('employer_also' => 'Employer');
  94 __PACKAGE__->has_many('jobs'  => 'Job',
  95         { join => { employer => 'employer_also' },
  96           constraint => { 'finshed' => 0  },
  97           order_by   => "created ASC",
  98         }
  99 );
 100
 101 package Employer;
 102
 103 __PACKAGE__->has_many('jobs'  => 'Job',);
 104 __PACKAGE__->has_many('contacts'  => 'Contact',
 105             order_by => 'name DESC',
 106 );
 107
 108
 109   # Below gives select boxes with the multiple attribute.
 110   my $select_jobs_for_new_contact =
 111     Contact->to_field('jobs', 'select'); # Uses constraint and order by
 112
 113   my $edit_jobs_for_existing_contact =
 114     $contact->to_field('jobs', 'select');
 115
 116
 117
 118         # Random uses
 119
 120
 121
 122 =head1 DESCRIPTION
 123
 124 This module helps to generate HTML forms for creating new database rows
 125 or editing existing rows. It maps column names in a database table to
 126 HTML form elements which fit the schema. Large text fields are turned
 127 into textareas, and fields with a has-a relationship to other
 128 C<Class::DBI> tables are turned into select drop-downs populated with
 129 objects from the joined class.
 130
 131 =head1 METHODS
 132
 133 The module is a mix-in which adds two additional methods to your
 134 C<Class::DBI>-derived class.
 135
 136
 137 =head2 search_inputs
 138
 139 Returns hashref of search inputs elements to use in cgi.
 140
 141 Uses fields specified in search_fields, makes foreign inputs if necessary.
 142
 143 =cut
 144
 145 # TODO -- use search_columns
 146 sub search_inputs {
 147   my ($class, $r) = @_;
 148   warn "In model search_inputs " if $class->model_debug;
 149   $class = ref $class || $class;
 150   #my $accssr_class = { $class->accessor_classes };
 151   my %cgi;
 152   my $sfs = [$class->search_columns];
 153
 154   foreach my $field ( @$sfs ) {
 155     if ( ref $field eq "HASH" ) { # foreign search fields
 156       my ($accssr, $cols)  = each %$field;
 157       unless (  @$cols ) {
 158                                 # default to search fields for related
 159                                 #$cols =  $accssr_class->{$accssr}->search_columns;
 160         die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
 161       }
 162       my $fcgi  = $class->_to_foreign_inputs($accssr, $cols);
 163       # unset the default values for a select box
 164       foreach (keys %$fcgi) {
 165         $class->unselect_element($fcgi->{$_});
 166       }
 167       $cgi{$accssr} = $fcgi;
 168     } else {
 169       $cgi{$field} = $class->to_field($field);
 170       $class->unselect_element($cgi{$field});
 171     }
 172   }
 173   return \%cgi;
 174 }
 175
 176
 177
 178 =head2 unselect_element
 179
 180 Unselects all options in a HTML::Element of type select.
 181 It does nothing if element is not a select element.
 182
 183 =cut
 184
 185 sub unselect_element {
 186         my ($self, $el) = @_;
 187         #unless (ref $el eq 'HTML::Element') {
 188         #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
 189         if ($el->tag eq 'select') {
 190                 foreach my $opt ($el->content_list) {
 191                         $opt->attr('selected', undef) if $opt->attr('selected');
 192                 }
 193         }
 194 }
 195
 196
 197 # make a select box from args
 198 sub a_select_box {
 199         my ($self, $name, $vals, $selected_val, $contents) = @_;
 200         die "Usage: Need a name and array ref of values to make a select boxes" unless ($name && $vals);
 201         $selected_val ||= "";
 202         $contents ||= $vals ;
 203
 204         my $a = HTML::Element->new('select', 'name' => $name);
 205         my $i = 0;
 206         my $c;
 207         foreach my $v ( @$vals ) {
 208                 my $opt = HTML::Element->new('option', 'value' => $v);
 209                 $opt->attr('selected' => 'selected') if $v eq $selected_val;
 210                 $c = $contents->[$i++] || $v;
 211                 $opt->push_content($c);
 212                 $a->push_content($opt);
 213         }
 214         $a;
 215 }
 216
 217
 218
 219 =head2 make_param_foreign
 220
 221 Makes a new foreign parameter out of parameter and accessor
 222 Just puts accssr__FOREIGN__ in front of param name
 223
 224 =cut
 225
 226 sub make_param_foreign {
 227         my ($self, $r, $p, $accssr) = @_;
 228         $r->params->{$accssr . '__FOREIGN__' . $p} = $r->params->{$p};
 229 }
 230
 231 =head2 to_cgi
 232
 233 This returns a hash mapping all the column names of the class to
 234 HTML::Element objects representing form widgets.
 235
 236 pjs -- added a columns list argument to specify which columns to make
 237 inputs for.
 238
 239 =cut
 240
 241 sub to_cgi {
 242         my ($class, @columns) = @_; # pjs -- added columns arg
 243         @columns = $class->columns unless (@columns);
 244         map { $_ => $class->to_field($_) } @columns;
 245 }
 246
 247
 248 =head2 to_field($field [, $how])
 249
 250 This maps an individual column to a form element. The C<how> argument
 251 can be used to force the field type into one of C<textfield>, C<textarea>
 252 or C<select>; you can use this is you want to avoid the automatic detection
 253 of has-a relationships.
 254
 255 # pjs
 256    -- added support for enum and bool.   Note for enum and bool you need
 257       a better column_type method than the Plugin::Type ' s as it won't work
 258       if you are using MySQL. I have not tried others.
 259       See those method's docs below.
 260    -- Foreign inputs for might_have, must_have, has_own, and has_many(i think).
 261    -- Really any relationship except has_a and is_a as has_a gets a select box
 262       and is_a are not considered foreign.
 263    -- Note a good column_type sub can be
 264       used to get the correct type for is_a columns.
 265    -- More efficient _to_select -- no object creation.
 266    -- Attempts to set default value in field for you using a "column_default"
 267       method you write yourself or your CDBI driver like mysql writes.
 268    -- _to_hidden
 269
 270 =cut
 271
 272 sub to_field {
 273         my ($self, $field, @args) = @_;
 274     my $how = shift @args unless ref $args[0];
 275     my $args = shift @args;  # argument hash ref
 276
 277         return  $self->_field_from_how($field, $how, $args)   ||
 278                 $self->_field_from_relationship($field, $args) ||
 279                         $self->_field_from_column($field, $args)  ||
 280                         $self->_to_textfield($field, $args);
 281 }
 282
 283 =head2 _field_from_how($field, $how,$args)
 284
 285 Returns an input element based the "how" parameter or nothing at all.
 286 Override at will.
 287
 288 =cut
 289
 290 sub _field_from_how {
 291         my ($self, $field, $how, $args) = @_;
 292         if ($how) {
 293                 no strict 'refs';
 294                 my $meth = "_to_$how";
 295                 return $self->$meth($field, $args) if $self->can($meth);
 296         }
 297         return;
 298 }
 299
 300 =head2 _field_from_relationship($field, $args)
 301
 302 Returns an input based on the relationship associated with the field or nothing.
 303 Override at will.
 304
 305 =cut
 306
 307 sub _field_from_relationship {
 308         my ($self, $field, $args) = @_;
 309         my $meta = $self->meta_info;
 310         my ($rel_type) = grep{ defined $meta->{$_}{$field} } keys %$meta;
 311         $rel_type ||= '';
 312         my $fclass = $rel_type ? $meta->{$rel_type}{$field}{foreign_class} : '';
 313     $args->{class} = $fclass;
 314         my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
 315
 316         # maybe has_a select
 317     return  $self->_to_select($field, $args)
 318                 if $rel_type eq 'has_a' and $fclass_is_cdbi;
 319
 320         # maybe foreign inputs
 321         my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
 322         if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_type eq 'has_own'))
 323         {
 324                 return $self->_to_foreign_inputs($field, undef, $meta->{$rel_type}{$field});
 325         }
 326         return;
 327 }
 328
 329 =head2 _field_from_column($field, $args)
 330
 331 Returns an input based on the column's characteristics, namely type, or nothing.
 332 Override at will.
 333
 334 =cut
 335
 336 sub _field_from_column {
 337         my ($self, $field, $args) = @_;
 338         my $class = ref $self || $self;
 339         # Get column type
 340     unless ($args->{column_type}) {
 341         if ($class->can('column_type')) {
 342                         $args->{column_type} = $class->column_type($field);
 343                 }
 344                 else {
 345                 # Right, have some of this
 346                 eval "package $class; Class::DBI::Plugin::Type->import()";
 347                 $args->{column_type} = $class->column_type($field);
 348                 }
 349     }
 350     my $type = $args->{column_type};
 351
 352         return $self->_to_textfield($field)
 353                 if $type  and $type =~ /(VAR)?CHAR/i;  #common type
 354         return $self->_to_textarea($field, $args)
 355                 if $type and $type =~ /^(TEXT|BLOB)$/i;
 356         return $self->_to_enum_select($field, $args)
 357                 if $type and  $type =~ /^ENUM\((.*?)\)$/i;
 358         return $self->_to_bool_select($field, $args)
 359                 if $type and  $type =~ /^BOOL/i;
 360         return $self->_to_readonly($field, $args)
 361             if $type and $type =~ /^readonly$/i;
 362         return;
 363 }
 364
 365
 366 sub _to_textarea {
 367         my ($self, $col, $args) = @_;
 368         # pjs added default
 369     $args ||= {};
 370     my $val =  $args->{value};
 371
 372     unless (defined $val) {
 373         if (ref $self) {
 374                         $val = $self->$col;
 375                 }
 376                 else {
 377                         $val = eval {$self->column_default($col);};
 378                 $val = '' unless defined $val;
 379                 }
 380         }
 381     my ($rows, $cols) = _box($val);
 382     $rows = $args->{rows} if $args->{rows};
 383     $cols = $args->{cols} if $args->{cols};;
 384     my $name = $args->{name} || $col;
 385         my $a =
 386                 HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
 387         $a->push_content($val);
 388         $OLD_STYLE && return $a->as_HTML;
 389         $a;
 390 }
 391
 392 sub _to_textfield {
 393     my ($self, $col, $args ) = @_;
 394     $args ||= {};
 395     my $val = $args->{value};
 396     my $name = $args->{name} || $col;
 397
 398     unless (defined $val) {
 399         if (ref $self) {
 400             # Case where column inflates.
 401             # Input would get stringification which could be not good.
 402             #  as in the case of Time::Piece objects
 403             $val = $self->$col;
 404             if (ref $val) {
 405                                 if (my $meta = $self->related_meta('',$col)) {
 406                         if (my $code = $meta->{args}{deflate4edit} ) {
 407                         $val  = ref $code ? &$code($val) : $val->$code;
 408                                         }
 409                                         else {
 410                                             $val  = $self->_attr($col);
 411                                         }
 412                 }
 413                                 else {
 414                                         $val  = $self->_attr($col);
 415                }
 416                 }
 417
 418         }
 419         else {
 420                 $val = eval {$self->column_default($col);};
 421                 $val = '' unless defined $val;
 422         }
 423     }
 424     my $a = HTML::Element->new("input", type => "text", name => $name);
 425     $a->attr("value" => $val);
 426     $OLD_STYLE && return $a->as_HTML;
 427     $a;
 428 }
 429
 430
 431 # Too expensive version -- TODO
 432 #sub _to_select {
 433 #       my ($self, $col, $hint) = @_;
 434 #       my $fclass = $hint || $self->__hasa_rels->{$col}->[0];
 435 #       my @objs        = $fclass->retrieve_all;
 436 #       my $a           = HTML::Element->new("select", name => $col);
 437 #       for (@objs) {
 438 #               my $sel = HTML::Element->new("option", value => $_->id);
 439 #               $sel->attr("selected" => "selected")
 440 #                       if ref $self
 441 #                       and eval { $_->id eq $self->$col->id };
 442 #               $sel->push_content($_->stringify_self);
 443 #               $a->push_content($sel);
 444 #       }
 445 #       $OLD_STYLE && return $a->as_HTML;
 446 #       $a;
 447 #}
 448
 449
 450
 451 # pjs
 452 # -- Rewrote this to be efficient -- no object creation.
 453 # -- Added option for CDBI classes to specify a limiting clause
 454 # via "has_a_select_limit".
 455 # -- Added selected argument to set a selected
 456
 457 =head2 recognized arguments
 458
 459   selected => $object|$id,
 460   name     => $name,
 461   value    => $value,
 462   where    => SQL 'WHERE' clause,
 463   order_by => SQL 'ORDER BY' clause,
 464   limit    => SQL 'LIMIT' clause,
 465   items    => [ @items_of_same_type_to_select_from ],
 466   class => $class_we_are_selecting_from
 467   stringify => $stringify_coderef|$method_name
 468
 469
 470
 471
 472 # select box requirements
 473 # 1. a select box for objecs of a has_a related class -- DONE
 474 =head2  1. a select box out of a has_a or has_many related class.
 475   # For has_a the default behavior is to make a select box of every element in
 476   # related class and you choose one.
 477   #Or explicitly you can create one and pass options like where and order
 478   BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
 479
 480   # For has_many the default is to get a multiple select box with all objects.
 481   # If called as an object method, the objects existing ones will be selected.
 482   Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"});
 483
 484
 485 =head2  2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun.
 486   # general
 487   BeerDB::Beer->to_field('', 'select', $options)
 488
 489   BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
 490                                   # with PK as ID, $Class->to_field() same.
 491   BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
 492   # specify exact where clause
 493
 494 =head2 3. If you already have a list of objects to select from  --
 495
 496   BeerDB:;Beer->to_field($col, 'select' , {items => $objects});
 497
 498 # 3. a select box for arbitrary set of objects
 499  # Pass array ref of objects as first arg rather than field
 500  $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
 501
 502
 503 =cut
 504
 505 sub _to_select {
 506     my ($self, $col, $args) = @_;
 507     $args ||= {};
 508 # Do we have items already ? Go no further.
 509     if ($args->{items}) {
 510         my $a = $self->_select_guts($col,  $args);
 511         $OLD_STYLE && return $a->as_HTML;
 512                 return $a;
 513         }
 514
 515 # Else what are we making a select box out of ?
 516         # No Column parameter --  means making a select box of args->class or self
 517     # Using all rows from class's table
 518     if (not $col) {
 519         warn "No col. $self";
 520                 unless ($args->{class}) {
 521                 $args->{class} = ref $self || $self;
 522                         # object selected if called with one
 523             $args->{selected} = { $self->id => 1}
 524                                 if not $args->{selected} and ref $self;
 525                 }
 526         $col = $args->{class}->primary_column;
 527     }
 528     # Related Class maybe ?
 529     elsif (my ($rel_type, $rel_meta) =  $self->related_meta('r:)', $col) ) {
 530         $args->{class} = $rel_meta->{foreign_class};
 531         # related objects pre selected if object
 532                 $args->{selected} ||= [ $self->$col ] if  ref $self;
 533
 534                 # "Has many" --  we get multiple select
 535                 if ($rel_type =~ /has_many/i) {
 536                         $args->{attr}{multiple}  = 'multiple';
 537                         # TODO -- handle mapping
 538                 }
 539                 my $c = $rel_meta->{args}{constraint} || {};
 540                 my $j = $rel_meta->{args}{join} || {};
 541                 my @join ;
 542                 if (ref $self) {
 543                         @join   =  map { $_ ." = ". $self->_attr($_) } keys %$j;
 544                 }
 545                 my @constr= map { "$_ = '$c->{$_}'"} keys %$c;
 546                 $args->{where}    ||= join (' AND ', (@join, @constr));
 547                 $args->{order_by} ||= $rel_meta->{args}{order_by};
 548                 $args->{limit}    ||= $rel_meta->{args}{limit};
 549
 550     }
 551     # We could say :Col is name and we are selecting  out of class arg.
 552         # DIE for now
 553         else {
 554                 #$args->{name} = $col;
 555                 die "Usage _to_select. $col not related to any class to select from. ";
 556
 557     }
 558
 559     # Set arguments
 560         if ( $self->can('column_nullable') ) {
 561                 $args->{nullable} ||= $self->column_nullable($col);
 562         }
 563
 564         # Get items to select from
 565     $args->{items} = _select_items($args);
 566 use Data::Dumper;
 567 warn "Just got items. They are  " . Dumper($args->{items});
 568
 569         # Make select HTML element
 570         $a = $self->_select_guts($col, $args);
 571
 572         # Return
 573     $OLD_STYLE && return $a->as_HTML;
 574     $a;
 575
 576 }
 577
 578
 579 ############
 580 # FUNCTION #
 581 ############
 582 # Get Items
 583 sub _select_items {
 584         my $args = shift;
 585         my $fclass = $args->{class};
 586     my @select_box_cols;
 587     @select_box_cols = $fclass->columns('SelectBox');
 588     @select_box_cols = $fclass->columns('Stringify')
 589                                             unless @select_box_cols;
 590     @select_box_cols = $fclass->_essential
 591                                             unless @select_box_cols;
 592     unshift @select_box_cols, $fclass->columns('Primary')
 593         unless $select_box_cols[0] eq $fclass->columns('Primary');
 594
 595     my $sql = "SELECT " . join( ', ', @select_box_cols) .
 596                   " FROM " . $fclass->table;
 597
 598         $sql .= " WHERE " . $args->{where}   if $args->{where};
 599         $sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
 600         $sql .= " LIMIT " . $args->{limit} if $args->{limit};
 601 warn "_select_items sql is : $sql";
 602
 603         return $fclass->db_Main->selectall_arrayref($sql);
 604
 605 }
 606
 607
 608 # Makes a readonly input box out of column's value
 609 # No args makes object to readonly
 610 sub _to_readonly {
 611     my ($self, $col, $val) = @_;
 612     if (! $col) { # object to readonly
 613         $val = $self->id;
 614         $col = $self->primary_column;
 615     }
 616     unless (defined $val) {
 617         $self->_croak("Cannot get value in _to_readonly .")
 618             unless ref $self;
 619         $val = $self->$col;
 620     }
 621     my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
 622         'name' => $col, 'value'=>$val);
 623 $OLD_STYLE && return $a->as_HTML;
 624     $a;
 625 }
 626
 627
 628 =head2 _to_enum_select
 629
 630 $sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");
 631
 632 Returns an enum select box given a column name and an enum string.
 633 NOTE: The Plugin::Type does not return an enum string for mysql enum columns.
 634 This will not work unless you write your own column_type method in your model.
 635
 636 =cut
 637
 638 sub _to_enum_select {
 639     my ($self, $col, $type) = @_;
 640     $type =~ /ENUM\((.*?)\)/i;
 641     (my $enum = $1) =~ s/'//g;
 642     my @enum_vals = split /\s*,\s*/, $enum;
 643
 644     # determine which is pre selected --
 645     # if obj, the value is , otherwise use column_default which is the first
 646     # value in the enum list unless it has been overridden
 647     my $selected = eval { $self->$col  };
 648     $selected = eval{$self->column_default($col)} unless defined $selected;
 649     $selected = $enum_vals[0]               unless defined $selected;
 650
 651
 652     my $a = HTML::Element->new("select", name => $col);
 653     for ( @enum_vals ) {
 654         my $sel = HTML::Element->new("option", value => $_);
 655         $sel->attr("selected" => "selected") if $_ eq $selected ;
 656         $sel->push_content($_);
 657         $a->push_content($sel);
 658     }
 659     $OLD_STYLE && return $a->as_HTML;
 660     $a;
 661 }
 662
 663
 664 =head2 _to_bool_select
 665
 666   my $sel = $self->_to_bool_select($column, $bool_string);
 667
 668 This  makes select input for boolean column.  You can provide a
 669 bool string of form: Bool('zero','one') and those are used for option
 670 content. Onthervise No and Yes are used.
 671 TODO -- test without bool string.
 672
 673 =cut
 674
 675 sub _to_bool_select {
 676     my ($self, $col, $type) = @_;
 677         my @bool_text = ('No', 'Yes');
 678         if ($type =~ /BOOL\((.+?)\)/i) {
 679                 (my $bool = $1) =~ s/'//g;
 680                 @bool_text = split /,/, $bool;
 681         }
 682         my $one= ref $self ? eval {$self->$col;} : $self->column_default($col);
 683     my $a = HTML::Element->new("select", name => $col);
 684     my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
 685                                                   HTML::Element->new("option", value => 1) );
 686     $opt0->attr("selected" => "selected") if not $one;
 687     $opt0->push_content($bool_text[0]);
 688     $opt1->attr("selected" => "selected") if $one;
 689     $opt1->push_content($bool_text[1]);
 690     $a->push_content($opt0, $opt1);
 691     $OLD_STYLE && return $a->as_HTML;
 692     $a;
 693 }
 694
 695
 696 =head2 _to_hidden($col, $args)
 697
 698 This makes a hidden html element. Give it a name and value or if name is
 699 a ref it will use the PK name and value of the object.
 700
 701 =cut
 702
 703 sub _to_hidden {
 704     my ($self, $name, $val) = @_;
 705     my $args = {};
 706     my $obj;
 707     if (ref $name and $name->isa("Class::DBI")) {
 708        $obj = $name;
 709        $name= ($obj->primary_columns)[0]->name;
 710     }
 711     if (ref $val) {
 712                 $args = $val;
 713         $val = $args->{value};
 714         $name = $args->{name} if $args->{name};
 715     }
 716     elsif (not $name ) { # hidding object caller
 717         $self->_croak("No object available in _to_hidden") unless ref $self;
 718         $name = ($self->primary_column)[0]->name;
 719         $val  = $self->id;
 720     }
 721     return HTML::Element->new('input', 'type' => 'hidden',
 722                               'name' => $name, 'value'=>$val
 723     );
 724 }
 725
 726 =head2 _to_link_hidden($col, $args)
 727
 728 Makes a link with a hidden input with the id of $obj as the value and name.
 729 Name defaults to the objects primary key. The object defaults to self.
 730
 731 =cut
 732
 733 sub _to_link_hidden {
 734     my ($self, $accessor, $args) = @_;
 735     my $r = $args->{r} || '';
 736     my $url = $args->{url} || '';
 737
 738     $self->_croak("_to_link_hidden called without Maypole Request object (\$r) and url. Need one or other.")
 739         unless $r;
 740     my ($obj, $name);
 741     if (ref $self) { # hidding linking self
 742          $obj  = $self;
 743          $name = $args->{name} || $obj->primary_column->name;
 744     }
 745     else {           # hiding linking related object with id in args
 746         $obj  = $self->related_class($r, $accessor)->retrieve($args->{id});
 747         $name = $args->{name} || $obj->primary_column->name; # TODO make use meta data
 748     }
 749     $self->_croak("_to_link_hidden has no object") unless ref $obj;
 750     my $href =  $url || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
 751     my $a = HTML::Element->new('a', 'href' => $href);
 752     $a->push_content("$obj");
 753     $a->push_content($self->_to_hidden($name, $obj->id));
 754         $OLD_STYLE && return $a->as_HTML;
 755     $a;
 756 }
 757
 758
 759
 760 =head2 _to_foreign_inputs
 761
 762 $html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]);
 763
 764 Get inputs for the accessor's class.  Pass an array ref of fields to get
 765 inputs for only those fields. Otherwise display_columns or all columns is used.
 766 If you have the meta info handy for the accessor you can pass that too.
 767
 768 TODO make AsForm know more about the request like what action we are doing
 769 so it can use edit columns or search_columns
 770
 771 NOTE , this names the foreign inputs is a particular way so they can be
 772 processed with a general routine and so there are not name clashes.
 773
 774 =cut
 775
 776 sub _to_foreign_inputs {
 777         my ($self, $accssr, $fields, $accssr_meta) = @_;
 778         if (!$accssr_meta) {
 779                 my $class_meta = $self->meta_info;
 780                 my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
 781                         keys %$class_meta;
 782                 $self->_croak( "No relationship for accessor $accssr") if not $rel_type;
 783                 $accssr_meta = $class_meta->{$rel_type}->{$accssr};
 784         }
 785
 786         my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $accssr_meta->{foreign_class};
 787
 788         unless ($fields) {
 789                 $fields = $classORobj->can('display_columns') ?
 790                         [$classORobj->display_columns] : [$classORobj->columns];
 791         }
 792
 793         # Ignore our fkey in them to  prevent infinite recursion
 794         my $me          = eval {$accssr_meta->{args}{foreign_column}} || '';
 795         my $constrained = $accssr_meta->{args}{constraint};
 796         my %inputs;
 797         foreach ( @$fields ) {
 798                 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
 799                 $inputs{$_} =  $classORobj->to_field($_);
 800         }
 801
 802         # Make hidden inputs for constrained columns unless we are editing object
 803         # TODO -- is this right thing to do?
 804         unless (ref $classORobj) {
 805                 $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_})
 806                         foreach ( keys %$constrained );
 807         }
 808         $self->_rename_foreign_input($accssr, \%inputs);
 809         return \%inputs;
 810 }
 811
 812
 813 =head2 _hash_selected
 814
 815 Method to make sense out of the "selected" argument which can be in a number
 816 of formats perhaps.  It returns a hashref with the the values of options to be
 817 as the keys.
 818
 819 Below handles these formats for the "selected" slot in the arguments hash:
 820   Object (with id method)
 821   Scalar (assumes it is value)
 822   Array ref *OF* objects, arrays of data (0 elmnt used), hashes of data
 823     (id key used), and simple scalars.
 824
 825
 826 =cut
 827
 828 ############
 829 # FUNCTION #
 830 ############
 831 sub _hash_selected {
 832         my ($args) = shift;
 833         my $selected = $args->{selected};
 834     return $selected unless $selected and ref $selected ne 'HASH';
 835         my $type = ref $selected;
 836         # Single Object
 837     if ($type and $type ne 'ARRAY') {
 838        return  {$selected->id => 1};
 839     }
 840     # Single Scalar id
 841         elsif (not $type) {
 842                 return { $selected => 1};
 843         }
 844
 845         # Array of objs, arrays, hashes, or just scalalrs.
 846         elsif ($type eq 'ARRAY') {
 847                 my %hashed;
 848                 my $ltype = ref $selected->[0];
 849                 # Objects
 850                 if ($ltype and $ltype ne 'ARRAY')  {
 851                         %hashed = map { $_->id  => 1 } @$selected;
 852         }
 853                 # Arrays of data with id first
 854             elsif ($ltype and $ltype eq 'ARRAY') {
 855                         %hashed = map { $_->[0]  => 1 } @$selected;
 856                 }
 857                 # Hashes using pk or id key
 858                 elsif ($ltype and $ltype eq 'HASH') {
 859                         my $pk = $args->{class}->primary_column || 'id';
 860                         %hashed = map { $_->{$pk}  => 1 } @$selected;
 861                 }
 862                 # Just Scalars
 863         else {
 864                         %hashed = map { $_  => 1 } @$selected;
 865                 }
 866                 return \%hashed;
 867         }
 868         else { warn "AsForm Could not hash the selected argument: $selected"; }
 869 }
 870
 871
 872
 873
 874 =head2 _select_guts
 875
 876 Internal api  method to make the actual select box form elements.
 877
 878 3 types of lists making for --
 879   Array of CDBI objects.
 880   Array of scalars ,
 881   Array or  Array refs with cols from class.
 882 =cut
 883
 884
 885
 886 sub _select_guts {
 887     my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;
 888
 889     $args->{stringify} ||=  'stringify_selectbox';
 890     $args->{selected} = _hash_selected($args);
 891         my $name = $args->{name} || $col;
 892     my $a = HTML::Element->new('select', name => $name);
 893         $a->attr( %{$args->{attr}} ) if $args->{attr};
 894
 895     if ($args->{nullable}) {
 896                 my $null_element = HTML::Element->new('option');
 897         $null_element->attr(selected => 'selected')
 898                 if $args->{selected}{'null'};
 899                 $null_element->push_content('-- choose or type --');
 900         $a->push_content($null_element);
 901     }
 902
 903     my $items = $args->{items};
 904     my $proto = $items->[0];
 905     my $type  = ref $proto || '';
 906
 907     # Objects
 908     if ($type and  $type !~ /ARRAY|HASH/i) {
 909                 # make select  of objects
 910                 $a->push_content($self->_options_from_objects($items, $args));
 911         }
 912     elsif ($type =~ /ARRAY/i) {
 913                 $a->push_content($self->_options_from_arrays($items, $args));
 914     }
 915     elsif ($type =~ /HASH/i) {
 916                 $a->push_content($self->_options_from_hashes($items, $args));
 917     }
 918     else {
 919                 $a->push_content($self->_options_from_scalars($items, $args));
 920     }
 921
 922     return $a;
 923 }
 924
 925
 926
 927
 928
 929
 930
 931 =head2 _options_from_objects ( $objects, $args);
 932
 933 Private method to makes a options out of  objects. It attempts to call each
 934 objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.
 935
 936 =cut
 937 sub _options_from_objects {
 938     my ($self, $items, $args) = @_;
 939         my $selected = $args->{selected} || {};
 940         my $stringify = $args->{stringify} || '';
 941     my @res;
 942         for (@$items) {
 943                 my $opt = HTML::Element->new("option", value => $_->id);
 944                 $opt->attr(selected => "selected") if $selected->{$_->id};
 945                 my $content = $stringify ? $_->$stringify : "$_";
 946                 $opt->push_content($content);
 947                 push @res, $opt;
 948         }
 949     return @res;
 950 }
 951
 952 sub _options_from_arrays {
 953     my ($self, $items, $args) = @_;
 954         my $selected = $args->{selected} || {};
 955     my @res;
 956         my $fclass = $args->{class} || '';
 957         my $stringify = $args->{stringify} || '';
 958         for (@$items) {
 959                 my $id = $_->[0];
 960                 my $opt = HTML::Element->new("option", value => $id );
 961                 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
 962                 $opt->attr(selected => "selected") if $selected->{$id};
 963
 964                 my $content = ($fclass and $stringify and $fclass->can($stringify)) ?
 965                               $fclass->$stringify($_) :
 966                                   join('/', @{$_});
 967 use Data::Dumper;
 968 warn "Content is $content";
 969                 $opt->push_content( $content );
 970         push @res, $opt;
 971     }
 972     return @res;
 973 }
 974
 975 sub _options_from_scalars {
 976     my ($self, $items, $args) = @_;
 977         my $selected = $args->{selected} || {};
 978     my @res;
 979         for (@$items) {
 980                 my $opt = HTML::Element->new("option", value => $_ );
 981                 #$opt->attr(selected => "selected") if $selected =~/^$id$/;
 982                 $opt->attr(selected => "selected") if $selected->{$_};
 983                 $opt->push_content( $_ );
 984         push @res, $opt;
 985     }
 986     return @res;
 987 }
 988
 989 sub _options_from_hashes {
 990     my ($self, $items, $args) = @_;
 991         my $selected = $args->{selected} || {};
 992         my $pk = eval {$args->{class}->primary_column} || 'id';
 993         my $fclass = $args->{class} || '';
 994         my $stringify = $args->{stringify} || '';
 995         my @res;
 996         for (@$items) {
 997                 my $val = $_->{$pk};
 998                 my $opt = HTML::Element->new("option", value => $val );
 999                 $opt->attr(selected => "selected") if $selected->{$val};
1000                 my $content = $fclass and $stringify and $fclass->can($stringify) ?
1001                               $fclass->$stringify($_) :
1002                                   join(' ', @$_);
1003                 $opt->push_content( $content );
1004         push @res, $opt;
1005     }
1006         return @res;
1007 }
1008
1009 #
1010 # checkboxes: if no data in hand (ie called as class method), replace
1011 # with a radio button, in order to allow this field to be left
1012 # unspecified in search / add forms.
1013 #
1014 # Not tested
1015 # TODO  --  make this general checkboxse
1016 #
1017 #
1018 sub _to_checkbox {
1019     my ($self, $col, $args) = @_;
1020     my $nullable = eval {self->column_nullable($col)} || 0;
1021
1022     return $self->_to_radio($col) if !ref($self) || $nullable;
1023     my $value = $self->$col;
1024     my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
1025     $a->attr("checked" => 'true') if $value eq 'Y';
1026     return $a;
1027 }
1028
1029
1030 # TODO  -- make this general radio butons
1031 #
1032 sub _to_radio {
1033     my ($self, $col) = @_;
1034     my $value = ref $self && $self->$col || '';
1035     my $nullable = eval {self->column_nullable($col)} || 0;
1036     my $a = HTML::Element->new("span");
1037     my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
1038     my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
1039     my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
1040     $ry->push_content('Yes'); $rn->push_content('No');
1041     $ru->push_content('n/a') if $nullable;
1042     if ($value eq 'Y') { $ry->attr("checked" => 'true') }
1043     elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
1044     elsif ($nullable) { $ru->attr("checked" => 'true') }
1045     $a->push_content($ry, $rn);
1046     $a->push_content($ru) if $nullable;
1047     return $a;
1048 }
1049
1050
1051
1052 ############################ HELPER METHODS ######################
1053 ##################################################################
1054
1055 =head2 _rename_foreign_input
1056
1057 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
1058
1059 Recursively renames the foreign inputs made by to_foreign_inputs so they
1060 can be processed generically.  The format is "accessor__AsForeign_colname".
1061
1062 So if an Employee is a Person who has own  Address and you call
1063
1064   Employee->to_field("person")
1065
1066 then you will get inputs for Address named like this:
1067
1068   person__AsForeign__address__AsForeign__street
1069   person__AsForeign__address__AsForeign__city
1070   person__AsForeign__address__AsForeign__state
1071   person__AsForeign__address__AsForeign__zip
1072
1073 And the processor would know to create this address, put the address id in
1074 person address slot, create the person and put the address id in the employee
1075 before creating the employee.
1076
1077 =cut
1078
1079 sub _rename_foreign_input {
1080         my ($self, $accssr, $input) = @_;
1081         if ( ref $input ne 'HASH' ) {
1082         #       my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
1083                 $input->attr( name => $accssr . "__AsForeign__" . $input->attr('name'));
1084         }
1085         else {
1086                 $self->_rename_foreign_input($accssr, $input->{$_})
1087                         foreach (keys %$input);
1088         }
1089 }
1090 =head2 _box($value)
1091
1092 This functions computes the dimensions of a textarea based on the value
1093 or the defaults.
1094
1095 =cut
1096
1097 our ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
1098 sub _box
1099 {
1100     my $text = shift;
1101     if ($text) {
1102         my @rows = split /^/, $text;
1103         my $cols = $min_cols;
1104         my $chars = 0;
1105         for (@rows) {
1106             my $len = length $_;
1107             $chars += $len;
1108             $cols = $len if $len > $cols;
1109             $cols = $max_cols if $cols > $max_cols;
1110         }
1111         my $rows = @rows;
1112         $rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
1113         $rows = $min_rows if $rows < $min_rows;
1114         $rows = $max_rows if $rows > $max_rows;
1115         ($rows, $cols)
1116     }
1117     else { ($min_rows, $min_cols) }
1118 }
1119
1120
1121 1;
1122
1123
1124 =head1 CHANGES
1125
1126 =head1 MAINTAINER
1127
1128 Maypole Developers
1129
1130 =head1 ORIGINAL AUTHOR
1131
1132 Peter Speltz, Aaron Trevena
1133
1134 =head1 TODO
1135
1136   Documenting
1137   Testing - lots
1138   chekbox generalization
1139   radio generalization
1140   select work
1141   Make link_hidden use standard make_url stuff when it gets in Maypole
1142   How do you tell AF --" I want a has_many select box for this every time so,
1143      when you call "to_field($this_hasmany)" you get a select box
1144
1145 =head1 BUGS and QUERIES
1146
1147 Please direct all correspondence regarding this module to:
1148  Maypole list.
1149
1150 =head1 COPYRIGHT AND LICENSE
1151
1152 Copyright 2003-2004 by Simon Cozens / Tony Bowden
1153
1154 This library is free software; you can redistribute it and/or modify
1155 it under the same terms as Perl itself.
1156
1157 =head1 SEE ALSO
1158
1159 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.
1160
1161 =cut
1162
1163 \r
1164 \r
1165 \r