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 = qw( to_cgi to_field _to_textarea _to_textfield _to_select
  16                                   type_of _to_foreign_inputs _to_enum_select _to_bool_select
  17                                   to_select_from_many _to_select_from_related hasmany_class
  18                                   _to_hidden _rename_foreign_input _to_readonly
  19                                   make_param_foreign make_hidden_elmnt make_hidden_elmnt
  20                                   a_select_box unselect_element do_select search_inputs);
  21
  22
  23
  24 our $VERSION = '2.41';
  25 # PJS VERSION .05
  26 # Changes :
  27 # 08-09-05 - fixed broken has_a select box
  28 #          - fiked some docs
  29 #          - _to_foreign_inputs now takes 3 positional parameters
  30 #            (accssr,  fields, accssr_meta_info)
  31
  32
  33 =head1 NAME
  34
  35 Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns
  36
  37 =head1 SYNOPSIS
  38
  39     package Music::CD;
  40     use Maypole::Model::CDBI::AsForm;
  41     use base 'Class::DBI';
  42     use CGI;
  43     ...
  44
  45     sub create_or_edit {
  46         my $class = shift;
  47         my %cgi_field = $class->to_cgi;
  48         return start_form,
  49                (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" }
  50                     $class->Columns),
  51                end_form;
  52     }
  53
  54     # <form method="post"...>
  55     # Title: <input type="text" name="Title" /> <br>
  56     # Artist: <select name="Artist">
  57     #           <option value=1>Grateful Dead</option>
  58     #           ...
  59     #         </select>
  60     # ...
  61     # </form>
  62
  63 =head1 DESCRIPTION
  64
  65 This module helps to generate HTML forms for creating new database rows
  66 or editing existing rows. It maps column names in a database table to
  67 HTML form elements which fit the schema. Large text fields are turned
  68 into textareas, and fields with a has-a relationship to other
  69 C<Class::DBI> tables are turned into select drop-downs populated with
  70 objects from the joined class.
  71
  72 =head1 METHODS
  73
  74 The module is a mix-in which adds two additional methods to your
  75 C<Class::DBI>-derived class.
  76
  77
  78 =head2 search_inputs
  79
  80 Returns hashref of search inputs elements to use in cgi.
  81
  82 Uses fields specified in search_fields, makes foreign inputs if necessary.
  83
  84 =cut
  85
  86 sub search_inputs {
  87   my ($class, $r) = @_;
  88   warn "In model search_inputs " if $class->model_debug;
  89   $class = ref $class || $class;
  90   #my $accssr_class = { $class->accessor_classes };
  91   my %cgi;
  92   my $sfs = $class->search_fields;
  93
  94   foreach my $field ( @$sfs ) {
  95     if ( ref $field eq "HASH" ) { # foreign search fields
  96       my ($accssr, $cols)  = each %$field;
  97       unless (  @$cols ) {
  98                                 # default to search fields for related
  99                                 #$cols =  $accssr_class->{$accssr}->search_fields;
 100         die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
 101       }
 102       my $fcgi  = $class->_to_foreign_inputs($accssr, $cols);
 103       # unset the default values for a select box
 104       foreach (keys %$fcgi) {
 105         $class->unselect_element($fcgi->{$_});
 106       }
 107       $cgi{$accssr} = $fcgi;
 108       #warn "Searchy inputs for field $field is " . Dumper($cgi{$accssr});
 109     } else {
 110       $cgi{$field} = $class->to_field($field);
 111       $class->unselect_element($cgi{$field});
 112     }
 113   }
 114   return \%cgi;
 115 }
 116
 117
 118 =head2 do_select
 119
 120 Retrieves object selected from a select box and puts in $r->objects[0].
 121 The select box input must be named the same as the primary key.
 122
 123 NOTE only works with tables with single primary key for now.
 124
 125 =cut
 126
 127 sub do_select {
 128     my ($self, $r) = @_;
 129         $r->objects([ $self->retrieve($r->params->{$self->primary_column}) ]);
 130         $r->template('view');
 131 }
 132
 133
 134 =head2 unselect_element
 135
 136 Unselects all options in a HTML::Element of type select.
 137 It does nothing if element is not a select element.
 138
 139 =cut
 140
 141 sub unselect_element {
 142         my ($self, $el) = @_;
 143         #unless (ref $el eq 'HTML::Element') {
 144         #$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
 145         if ($el->tag eq 'select') {
 146                 foreach my $opt ($el->content_list) {
 147                         $opt->attr('selected', undef) if $opt->attr('selected');
 148                 }
 149         }
 150 }
 151
 152
 153 # make a select box from args
 154 sub a_select_box {
 155         my ($self, $name, $vals, $selected_val, $contents) = @_;
 156         die "Usage: Need a name and array ref of values to make a select boxes" unless ($name && $vals);
 157         $selected_val ||= "";
 158         $contents ||= $vals ;
 159
 160         my $a = HTML::Element->new('select', 'name' => $name);
 161         my $i = 0;
 162         my $c;
 163         foreach my $v ( @$vals ) {
 164                 my $opt = HTML::Element->new('option', 'value' => $v);
 165                 $opt->attr('selected' => 'selected') if $v eq $selected_val;
 166                 $c = $contents->[$i++] || $v;
 167                 $opt->push_content($c);
 168                 $a->push_content($opt);
 169         }
 170         $a;
 171 }
 172
 173
 174 =head2 make_hidden_elmnt
 175
 176 Makes a hidden HTML::Element and puts it in template_args{hidden_elements}
 177 $model->make_hidden_elmnt($name, $val);
 178
 179 =cut
 180
 181 sub make_hidden_elmnt {
 182         my ($self, $r, $col, $val) = @_;
 183         my $elmnt = HTML::Element->new('input', 'type'=>'hidden', 'name'=>$col, 'value'=>$val);
 184
 185         $r->{template_args}{hidden_elements} ||= [];
 186         push @{ $r->{template_args}{hidden_elements} }, $elmnt;
 187 }
 188
 189
 190
 191 =head2 make_param_foreign
 192
 193 Makes a new foreign parameter out of parameter and accessor
 194 Just puts accssr__FOREIGN__ in front of param name
 195
 196 =cut
 197
 198 sub make_param_foreign {
 199         my ($self, $r, $p, $accssr) = @_;
 200         $r->params->{$accssr . '__FOREIGN__' . $p} = $r->params->{$p};
 201 }
 202
 203 =head2 to_cgi
 204
 205 This returns a hash mapping all the column names of the class to
 206 HTML::Element objects representing form widgets.
 207
 208 pjs -- added a columns list argument to specify which columns to make
 209 inputs for.
 210
 211 =cut
 212
 213 sub to_cgi {
 214         my ($class, @columns) = @_; # pjs -- added columns arg
 215         @columns = $class->columns unless (@columns);
 216         map { $_ => $class->to_field($_) } @columns;
 217 }
 218
 219
 220 =head2 to_field($field [, $how])
 221
 222 This maps an individual column to a form element. The C<how> argument
 223 can be used to force the field type into one of C<textfield>, C<textarea>
 224 or C<select>; you can use this is you want to avoid the automatic detection
 225 of has-a relationships.
 226
 227 # pjs
 228    -- added support for enum and bool.   Note for enum and bool you need
 229       a better column_type method than the Plugin::Type ' s as it won't work
 230       if you are using MySQL. I have not tried others.
 231       See those method's docs below.
 232    -- Foreign inputs for might_have, must_have, has_own, and has_many(i think).
 233    -- Really any relationship except has_a and is_a as has_a gets a select box
 234       and is_a are not considered foreign.
 235    -- Note a good column_type sub can be
 236       used to get the correct type for is_a columns.
 237    -- More efficient _to_select -- no object creation.
 238    -- Attempts to set default value in field for you using a "column_default"
 239       method you write yourself or your CDBI driver like mysql writes.
 240    -- _to_hidden
 241
 242 =cut
 243
 244 sub to_field {
 245         my ($self, $field, $how) = @_;
 246         my $class = ref $self || $self;
 247         if ($how and $how =~ /^(text(area|field)|select)$/) {
 248                 no strict 'refs';
 249                 my $meth = "_to_$how";
 250                 return $self->$meth($field);
 251         }
 252
 253         my $meta = $self->meta_info;
 254         my ($rel_type) = grep{ defined $meta->{$_}{$field} } keys %$meta;
 255         $rel_type ||= '';
 256         my $fclass = $rel_type ? $meta->{$rel_type}{$field}{foreign_class} : '';
 257         my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;
 258
 259         # maybe has_a select
 260     return  $self->_to_select($field, $fclass) if $rel_type eq 'has_a' and
 261                 $fclass_is_cdbi;
 262
 263         # maybe foreign inputs
 264         my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
 265         if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_type eq 'has_own'))
 266         {
 267                 return $self->_to_foreign_inputs($field, undef, $meta->{$rel_type}{$field});
 268         }
 269
 270         # the rest
 271         my $type;
 272     if ($class->can('column_type')) {
 273                 $type = $class->column_type($field);
 274         }
 275         else {
 276         # Right, have some of this
 277         eval "package $class; Class::DBI::Plugin::Type->import()";
 278         $type = $class->column_type($field);
 279         }
 280
 281         #return $self->_to_textfield($field)
 282         #       if $type  and $type =~ /(var)?char/i;  #common type
 283         return $self->_to_textarea($field)
 284                 if $type and $type =~ /^(TEXT|BLOB)$/i;
 285         return $self->_to_enum_select($field, $type)
 286                 if $type and  $type =~ /^ENUM\((.*?)\)$/i;
 287         return $self->_to_bool_select($field, $type)
 288                 if $type and  $type =~ /^BOOL/i;
 289         return $self->_to_readonly($field)
 290             if $type and $type =~ /^readonly$/i;
 291         return $self->_to_textfield($field);
 292 }
 293
 294 sub _to_textarea {
 295         my ($self, $col) = @_;
 296         # pjs added default
 297         my $a =
 298                 HTML::Element->new("textarea", name => $col, rows => "3", cols => "22");
 299         my $val;
 300         if (ref $self) {
 301                 $val = $self->$col;
 302         }
 303         else {
 304                 $val = eval {$self->column_default($col);};
 305             $val = '' unless defined $val;
 306         }
 307         $a->push_content($val);
 308         $OLD_STYLE && return $a->as_HTML;
 309         $a;
 310 }
 311
 312 sub _to_textfield {
 313         my ($self, $col) = @_;
 314         # pjs added default
 315         my $val;
 316         if (ref $self) {
 317                 $val = $self->$col;
 318         }
 319         else {
 320                 $val = eval {$self->column_default($col);};
 321             $val = '' unless defined $val;
 322         }
 323
 324         my $a = HTML::Element->new("input", type => "text", name => $col);
 325         $a->attr("value" => $val);
 326         $OLD_STYLE && return $a->as_HTML;
 327         $a;
 328 }
 329
 330 # pjs
 331 # -- Rewrote this to be efficient -- no object creation.
 332 # -- Added option for CDBI classes to specify a limiting clause
 333 # via "has_a_select_limit".
 334 # -- Added selected argument to set a selected
 335
 336 sub _to_select {
 337     my ($self, $col, $hint, $selected) = @_;
 338         my $has_a_class;
 339         if (not $col) { # class is making select box of self
 340                 $has_a_class = ref $self || $self;
 341                 $col = $self->primary_column;
 342         }
 343         else {
 344                 $has_a_class = $hint || $self->__hasa_rels->{$col}->[0];
 345         }
 346
 347         $selected ||= {};
 348         if (ref $self and my $id = eval { $self->$col->id }) {
 349                 $selected->{$id} = 1;
 350         }
 351         #pjs  Possible sql limiting clause ("WHERE acol = 'X' " or "LIMIT 10", etc)
 352         my $select_box_limit = eval { $self->has_a_select_limit->{$col} } || '' ;
 353
 354         # Get columns to appear in select box options on forms.
 355         # TODO -- there is maybe a good idiom for this.
 356         my @select_box_cols;
 357         @select_box_cols = $has_a_class->columns('SelectBox');
 358         @select_box_cols = $has_a_class->columns('Stringify')
 359                                                                                         unless @select_box_cols;
 360         @select_box_cols = $has_a_class->_essential
 361                                                                                         unless @select_box_cols;
 362         unshift @select_box_cols, $has_a_class->columns('Primary');
 363         my $sql = "SELECT " . join( ', ', @select_box_cols) . " FROM " .
 364                       $has_a_class->table . " " . $select_box_limit;
 365         my $opts_data = $self->db_Main->selectall_arrayref($sql);
 366
 367     my $a = HTML::Element->new("select", name => $col);
 368     for (@$opts_data) {
 369                 my $id = shift @$_;
 370         my $opt = HTML::Element->new("option", value => $id );
 371         $opt->attr("selected" => "selected") if $selected->{$id};
 372                 my $content = eval {$has_a_class->stringify_selectbox($_);} ||
 373                                           join(' ', @$_);
 374         $opt->push_content( $content );
 375         $a->push_content($opt);
 376     }
 377     $OLD_STYLE && return $a->as_HTML;
 378     $a;
 379 }
 380
 381 # Makes a readonly input box out of column's value
 382 # Currently object method only
 383 sub _to_readonly {
 384         my ($self, $col, $val) = @_;
 385         unless (defined $val) {
 386                 $self->_croak("Cannot call _to_readonly on class without value arg.")
 387                         unless ref $self;
 388                 $val = $self->$col;
 389         }
 390         my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
 391                 'name' => $col, 'value'=>$val);
 392         $OLD_STYLE && return $a->as_HTML;
 393         $a;
 394 }
 395
 396 =head2 _to_enum_select
 397
 398 $sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");
 399
 400 Returns an enum select box given a column name and an enum string.
 401 NOTE: The Plugin::Type does not return an enum string for mysql enum columns.
 402 This will not work unless you write your own column_type method in your model.
 403
 404 =cut
 405
 406 sub _to_enum_select {
 407     my ($self, $col, $type) = @_;
 408         $type =~ /ENUM\((.*?)\)/i;
 409         (my $enum = $1) =~ s/'//g;
 410         my @enum_vals = split /\s*,\s*/, $enum;
 411
 412     my $a = HTML::Element->new("select", name => $col);
 413     for ( @enum_vals ) {
 414         my $sel = HTML::Element->new("option", value => $_);
 415         $sel->attr("selected" => "selected") if ref $self
 416                                                 and eval { $self->$col eq $_ };
 417         $sel->push_content($_);
 418         $a->push_content($sel);
 419     }
 420     $OLD_STYLE && return $a->as_HTML;
 421     $a;
 422 }
 423
 424
 425 =head2 _to_bool_select
 426
 427   my $sel = $self->_to_bool_select($column, $bool_string);
 428
 429 This  makes select input for boolean column.  You can provide a
 430 bool string of form: Bool('zero','one') and those are used for option
 431 content. Onthervise No and Yes are used.
 432 TODO -- test without bool string.
 433
 434 =cut
 435
 436 sub _to_bool_select {
 437     my ($self, $col, $type) = @_;
 438         my @bool_text = ('No', 'Yes');
 439         if ($type =~ /BOOL\((.+?)\)/i) {
 440                 (my $bool = $1) =~ s/'//g;
 441                 @bool_text = split /,/, $bool;
 442         }
 443         my $one= ref $self ? eval {$self->$col;} : $self->column_default($col);
 444     my $a = HTML::Element->new("select", name => $col);
 445     my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
 446                                                   HTML::Element->new("option", value => 1) );
 447     $opt0->attr("selected" => "selected") if not $one;
 448     $opt0->push_content($bool_text[0]);
 449     $opt1->attr("selected" => "selected") if $one;
 450     $opt1->push_content($bool_text[1]);
 451     $a->push_content($opt0, $opt1);
 452     $OLD_STYLE && return $a->as_HTML;
 453     $a;
 454 }
 455
 456
 457 =head2 _to_hidden($name, $value)
 458
 459 This makes a hidden html element. Give it a name and value.
 460
 461 =cut
 462 sub _to_hidden {
 463     my ($self, $name, $val) = @_;
 464         return HTML::Element->new('input', 'type' => 'hidden',
 465                                   'name' => $name, 'value'=>$val
 466         );
 467 }
 468
 469
 470
 471 =head2 _to_foreign_inputs
 472
 473 $html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]);
 474
 475 Get inputs for the accessor's class.  Pass an array ref of fields to get
 476 inputs for only those fields. Otherwise display_columns or all columns is used.
 477 If you have the meta info handy for the accessor you can pass that too.
 478
 479 TODO make AsForm know more about the request like what action we are doing
 480 so it can use edit columns or search_columns
 481
 482 NOTE , this names the foreign inputs is a particular way so they can be
 483 processed with a general routine and so there are not name clashes.
 484
 485 =cut
 486
 487 sub _to_foreign_inputs {
 488         my ($self, $accssr, $fields, $accssr_meta) = @_;
 489         if (!$accssr_meta) {
 490                 my $class_meta = $self->meta_info;
 491                 my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
 492                         keys %$class_meta;
 493                 $self->_croak( "No relationship for accessor $accssr") if not $rel_type;
 494                 $accssr_meta = $class_meta->{$rel_type}->{$accssr};
 495         }
 496
 497         my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $accssr_meta->{foreign_class};
 498
 499         unless ($fields) {
 500                 $fields = $classORobj->can('display_columns') ?
 501                         [$classORobj->display_columns] : [$classORobj->columns];
 502         }
 503
 504         # Ignore our fkey in them to  prevent infinite recursion
 505         my $me          = eval {$accssr_meta->{args}{foreign_column}} || '';
 506         my $constrained = $accssr_meta->{args}{constraint};
 507         my %inputs;
 508         foreach ( @$fields ) {
 509                 next if $constrained->{$_} || ($_ eq $me); # don't display constrained
 510                 $inputs{$_} =  $classORobj->to_field($_);
 511         }
 512
 513         # Make hidden inputs for constrained columns unless we are editing object
 514         # TODO -- is this right thing to do?
 515         unless (ref $classORobj) {
 516                 $inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_})
 517                         foreach ( keys %$constrained );
 518         }
 519         $self->_rename_foreign_input($accssr, \%inputs);
 520         return \%inputs;
 521 }
 522
 523 =head2 _rename_foreign_input
 524
 525 _rename_foreign_input($html_el_or_hash_of_them); # changes made by reference
 526
 527 Recursively renames the foreign inputs made by to_foreign_inputs so they
 528 can be processed generically.  The format is "accessor__AsForeign_colname".
 529
 530 So if an Employee is a Person who has own  Address and you call
 531
 532   Employee->to_field("person")
 533
 534 then you will get inputs for Address named like this:
 535
 536   person__AsForeign__address__AsForeign__street
 537   person__AsForeign__address__AsForeign__city
 538   person__AsForeign__address__AsForeign__state
 539   person__AsForeign__address__AsForeign__zip
 540
 541 And the processor would know to create this address, put the address id in
 542 person address slot, create the person and put the address id in the employee
 543 before creating the employee.
 544
 545 =cut
 546
 547 sub _rename_foreign_input {
 548         my ($self, $accssr, $input) = @_;
 549         if ( ref $input ne 'HASH' ) {
 550                 my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
 551                 $input->attr( name => $new_name );
 552         }
 553         else {
 554                 $self->_rename_foreign_input($accssr, $input->{$_})
 555                         foreach (keys %$input);
 556         }
 557 }
 558
 559
 560 # pjs
 561
 562 =head2 to_select_from_many
 563
 564
 565 Usage:  $object->to_select_from_many($accessor|$objects_to_select_from, [$element_name], [$options]);
 566
 567 CD->has_many( 'songs' => "Songs" );
 568 ... in some nearby piece of code:
 569 my $cd = CD->retrieve($id);
 570 my $select_song_html = $cd->to_select_from_many('songs');
 571 print "<h1>Choose your Favorite song from $cd</h1>";
 572 print $select_song_html.as_XML;
 573 return;
 574
 575 # OR if you only want to select from a group of objects
 576
 577 my @favorites = $cd->favorite_songs;
 578 my $select_from_favorites = $cd->to_select_from_many(\@favorites);
 579
 580 This an object method that makes a select box out of  the objects related to this object by a has_many relationship.  The select box only allows one selection.
 581 The multiple attribute can easily be added if needed to the element returned :
 582 $this_element->attr('multiple', 'multiple');
 583
 584 You can pass an array ref of objects to select from instead of the class accessor name if you already have the objects to select from.
 585
 586 Also, you can pass the name you want the element to have as a second argument.
 587 The default is the primary key name (as returned by primary_column) of the firstobject that is being selected from.
 588
 589 If related class has a multi column pk, this dies for now.#strange things may happen as primary_column method is used.
 590
 591 =cut
 592
 593
 594 sub to_select_from_many {
 595     my ($self, $accessor, $elmnt_name) = @_;
 596         my $objs = ref $accessor eq "ARRAY" ? $accessor : [$self->$accessor];
 597         my $rel_class = ( @$objs ) ? ref $objs->[0] :
 598                         eval{$self->hasmany_class($accessor)};
 599
 600         $elmnt_name = eval {$rel_class->primary_column} ||  "__AF_TSFM_OBJS__"
 601                 unless $elmnt_name;
 602
 603         return  _to_select_from_objs($objs, $elmnt_name);
 604
 605 }
 606
 607 =head2 _to_select_from_objs($objects, $name, $selected);
 608
 609 Private method to makes a select box of objects passed with name passed.
 610 Assumes they are same type
 611
 612 =cut
 613 sub _to_select_from_objs {
 614     my ($objs, $elmnt_name) = @_;
 615         CGI::Carp::croak("Usage: element name required") unless ($elmnt_name);
 616 #       $elmnt_name ||= eval {$objs->[0]->primary_column};
 617 #       unless ($elmnt_name) {
 618 #               my $num = @$objs;
 619 #               $self->_carp ("Element name arg. not passed and couldn't get element name from object 0. Number of objects in arg are: $num");
 620 #               return;
 621 #       }
 622
 623         my $a = HTML::Element->new("select", name => $elmnt_name);
 624         for (@$objs) {
 625                 my $opt = HTML::Element->new("option", value => $_->id);
 626                 $opt->push_content($_->stringify_self);
 627                 $a->push_content($opt);
 628         }
 629         $OLD_STYLE && return $a->as_HTML;
 630         $a;
 631 }
 632
 633
 634 # pjs EXPERIMENTAL
 635 #  TODO this is crap. I think this will just be a public sub to select many objects from a class. Then you can do thingks like add them to has_many and stuff.
 636 #
 637 #  not finished
 638 # usage: CD->has_many('songs', 'Song', 'cd_id');
 639 #        my $song_sel_element = $class->_to_select_many('songs', @options);
 640 # @options have same form as a  SQL::Abstract options with exception of
 641 # -HINT element which is the class name if you want to give it.
 642 # { '-HINT' => $classname, # so you can cheat, or be efficient
 643 #   'logic'=> 'OR',        # default is OR
 644 #   $limiting_col => $limit_val,
 645 #   $limiting_col2=> $limit_val2,
 646 #   . . . }
 647 #
 648 #
 649 # make select box for has many. This is a multiple select box (select many)
 650 # element. If you want to choose between on of the has_many's an object has (
 651 # ie -- a cd has many songs and you want to choose one of the songs from it)
 652 # then pass an additional hash ref of limiting cols and vals.
 653 # $cd->_to_many_select('songs', {'cd_id' => $cd->id, . . .}
 654 sub _to_select_many {
 655     my ($self, $accessor, $hint, $where, $order ) = @_;
 656     my $has_many_class = $hint || $self->hasmany_class($accessor);
 657         my %selected = ();
 658         %selected = map { $_->id => 1} $self->$accessor if ref $self;
 659
 660         my $pk = $has_many_class->primary_column;
 661         my $a = $self->_to_select($pk, $has_many_class, \%selected, $where, $order);
 662         $a->attr('multiple', 'multiple');
 663
 664         $OLD_STYLE && return $a->as_HTML;
 665         $a;
 666 }
 667
 668
 669
 670
 671 sub _to_select_old_version {
 672         my ($self, $col, $hint) = @_;
 673         my $has_a_class = $hint || $self->__hasa_rels->{$col}->[0];
 674         my @objs        = $has_a_class->retrieve_all;
 675         my $a           = HTML::Element->new("select", name => $col);
 676         for (@objs) {
 677                 my $sel = HTML::Element->new("option", value => $_->id);
 678                 $sel->attr("selected" => "selected")
 679                         if ref $self
 680                         and eval { $_->id eq $self->$col->id };
 681                 $sel->push_content($_->stringify_self);
 682                 $a->push_content($sel);
 683         }
 684         $OLD_STYLE && return $a->as_HTML;
 685         $a;
 686 }
 687
 688
 689
 690 ############################ HELPER METHODS ######################
 691 ##################################################################
 692
 693 # hasmany_class($accessor) -- stole code from Maypole::Model::CDBI
 694 # Returns class of has_many relationship when given the accessor
 695 sub hasmany_class  {
 696         my ( $self, $accessor ) = @_;
 697         $self->_croak("No accessor (2nd arg) passed to hasmany_class")
 698                 unless $accessor;
 699         my $rel_meta = $self->meta_info('has_many' => $accessor);
 700
 701         my $mapping;
 702         if ( $mapping = $rel_meta->{args}->{mapping} and @$mapping ) {
 703                 return $rel_meta->{foreign_class}->meta_info('has_a')->{ $$mapping[0] }->{foreign_class};
 704         }
 705         else {
 706                 return $rel_meta->{foreign_class};
 707         }
 708 }
 709
 710
 711 1;
 712
 713 =head1 ***NEW PJS Stuff**** GETTING SPECIFIC IN MODEL CLASS
 714
 715 You can tell AsForm some things in your model classes to get custom results. In particular you can have:
 716
 717 =head2 Custom column_type methods
 718
 719 Since much of this modules functionality relies on the subroutine C<column_type>
 720 returning the type string from the database table definition Model classes can
 721 benefit a great deal by writing their own. See example.  This version tries to
 722 call column_type with the model class first. IF your model's column_type returns
 723 undef or it has no such method it falls back on
 724 C<&Class::DBI::Plugin::Type::column_type> which is database independent but not
 725 fully functional yet. For full functionality make a custom C<column_type> method
 726 in your base model class and override it in subclasses at will. Some \
 727 Class::DBI::* drivers such as Class::DBI::mysql have mostly functional ones.
 728
 729 With a column_type sub you can set bool options for users , make select boxes
 730 for ordinary columns (by lying and returning an enum('blah', 'blh') string for a
 731 column, get correct types for is_a inherited columns, optimize , and maybe more.
 732
 733 =head2 Appropriate elements for columns inherited from an is_a relationship
 734
 735 At least you have the power to get them by making column_type work.
 736
 737 =head2 Select box specifications for has_a columns.
 738
 739 You can specify columns to be selected for a select box's options
 740  for a class by :
 741
 742         __Package__->columns('SelectBox' => qw/col1 col2/);
 743
 744 If you don't, 'Stringify' columns are used if they exist and lastly 'Essential'
 745 columns. The 'Primary' column is always the option value. This means don't
 746 include it in the 'SelectBox' columns unless you want it in the option content.
 747
 748 You can limit rows selected for the select box with a has_a_select_limit sub like so:
 749
 750         Customer->has_a(pay_plan => "PayPlan");
 751         Customer->has_a(pick_fromTopFive  => "Movie");
 752         sub has_a_select_limit { {
 753                 pay_plan            => "WHERE is_available = 1",
 754                 pick_fromTopFive    => "ORDER BY rank ASC LIMIT 5" }
 755         }
 756
 757 If you need complex stringification make a C<stringify_selectbox> sub which
 758 takes an arrayref. Elements are in order specified in columns('SelectBox')
 759 or whatever columns list was used. Otherwise, the array is joined on ' '.
 760
 761 =cut
 762
 763
 764 =head1 CHANGES
 765
 766 Many by Peter Speltz
 767
 768
 769 Version 1.x of this module returned raw HTML instead of
 770 C<HTML::Element> objects, which made it harder to manipulate the
 771 HTML before sending it out. If you depend on the old behaviour, set
 772 C<$Class::DBI::AsForm::OLD_STYLE> to a true value.
 773
 774 =head1 MAINTAINER
 775
 776 Tony Bowden
 777
 778 =head1 ORIGINAL AUTHOR
 779
 780 Simon Cozens
 781
 782 =head1 BUGS and QUERIES
 783
 784 Please direct all correspondence regarding this module to:
 785   bug-Class-DBI-AsForm@rt.cpan.org
 786
 787 =head1 COPYRIGHT AND LICENSE
 788
 789 Copyright 2003-2004 by Simon Cozens / Tony Bowden
 790
 791 This library is free software; you can redistribute it and/or modify
 792 it under the same terms as Perl itself.
 793
 794 =head1 SEE ALSO
 795
 796 L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.
 797
 798 =cut
 799
 800 \r