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