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