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