Class::DBI::FormBuilder - Class::DBI/CGI::FormBuilder integration

    package Film;
    use strict;
    use warnings;

    use base 'Class::DBI';
    use Class::DBI::FormBuilder;

    # for indented output:
    # use Class::DBI::FormBuilder PrettyPrint => 'ALL';

    # POST all forms to server
    Film->form_builder_defaults->{method} = 'post';

    # customise how some fields are built:
    # 'actor' is a has_a field, and the 
    # related table has 1000's of rows, so we don't want the default popup widget,
    # we just want to show the current value
    Film->form_builder_defaults->{process_fields}->{actor} = 'VALUE';

    # 'trailer' stores an mpeg file, but CDBI::FB cannot automatically detect 
    # file upload fields, so need to tell it:
    Film->form_builder_defaults->{process_fields}->{trailer} = 'FILE';

    # has_a fields will be automatically set to 'required'. Additional fields can be specified:
    Film->form_builder_defaults->{required} = qw( foo bar );

    


    


    # In a nearby piece of code...

    my $film = Film->retrieve( $id ); 
    print $film->as_form( params => $q )->render;   # or $r if mod_perl

    # For a search app:    
    my $search_form = Film->search_form;            # as_form plus a few tweaks

    


    # A fairly complete mini-app:

    my $form = Film->as_form( params => $q );       # or $r if mod_perl

    if ( $form->submitted and $form->validate )
    {
        # whatever you need:

        my $obj = Film->create_from_form( $form );
        my $obj = Film->update_from_form( $form );              
        my $obj = Film->update_or_create_from_form( $form );    
        my $obj = Film->retrieve_from_form( $form );

        my $iter = Film->search_from_form( $form );
        my $iter = Film->search_like_from_form( $form );
        my $iter = Film->search_where_from_form( $form );

        my $obj = Film->find_or_create_from_form( $form );
        my $obj = Film->retrieve_or_create_from_form( $form );

        print $form->confirm;
    }
    else
    {
        print $form->render;
    }

    # See CGI::FormBuilder docs and website for lots more information.

    http://beerfb.riverside-cms.co.uk

    $class      the CDBI::FormBuilder class or subclass
    $form       the CGI::FormBuilder form object
    $render     reference to &CGI::FormBuilder::render
    $pp_args    value of the post_process_args argument, or undef
    %args       the arguments used in the CGI::FormBuilder->new call

    return unless $fb->submitted && $fb->validate;

    print Film->update_from_form( $form ) ? $form->confirm : $form->render;

   my $related = $object->some_col;

   print $related->as_form->render;

package Class::DBI::FormBuilder;

use warnings;
use strict;
use Carp();

use List::Util();
use CGI::FormBuilder 3;
use Class::DBI::FormBuilder::Meta::Table;

use UNIVERSAL::require;

use constant ME     => 0;
use constant THEM   => 1;
use constant FORM   => 2;
use constant FIELD  => 3;
use constant COLUMN => 4;

use base 'Class::Data::Inheritable';

our $VERSION = '0.481';

# process_extras *must* come 2nd last 
our @BASIC_FORM_MODIFIERS = qw( pks options file timestamp text process_extras final );

# C::FB sometimes gets confused when passed CDBI::Column objects as field names, 
# hence all the map {''.$_} column filters. Some of them are probably unnecessary, 
# but I need to track down which. UPDATE: the dev version now uses map { $_->name }
# everywhere.

# CDBI has accessor_name *and* mutator_name methods, so potentially, each column could 
# have 2 methods to get/set its values, neither of which are the column's name.

# Column objects can be queried for these method names: $col->accessor and $col->mutator

# Not sure yet what to do about caller-supplied column names. 

# General strategy: don't stringify anything until sending stuff to CGI::FB, at which point:
#   1. stringify all values
#   2. test field names to see if they are (CDBI column) objects, and if so, extract the 
#       appropriate accessor or mutator name

# UPDATE: forms should be built with $column->name as the field name, because in general 
#   form submissions will need to do both get and set operations. So the form handling 
#   methods should assume forms supply column names, and should look up column mutator/accessor 
#   as appropriate.

our %ValidMap = ( varchar   => 'VALUE',
                  char      => 'VALUE', # includes MySQL enum and set - UPDATE - not since 0.41
                  
                  enum      => 'VALUE',
                  set       => 'VALUE',
                  
                  blob      => 'VALUE', # includes MySQL text
                  text      => 'VALUE',
                  
                  integer   => 'INT',
                  bigint    => 'INT',
                  smallint  => 'INT',
                  tinyint   => 'INT',
                  int       => 'INT',
                  
                  date      => 'VALUE',
                  time      => 'VALUE',
                  datetime  => 'VALUE',
                  
                  # normally you want to skip validating a timestamp column...
                  #timestamp => 'VALUE',
                  
                  double    => 'NUM',
                  float     => 'NUM',
                  decimal   => 'NUM',
                  numeric   => 'NUM',
                  );    
                  
__PACKAGE__->mk_classdata( field_processors => {} );
__PACKAGE__->mk_classdata( post_processors  => {} );
                  
{
    # field_processors
    my $built_ins = { # default in form_pks
                      HIDDEN => [ '+HIDDEN', '+VALUE' ],
                      
                      '+HIDDEN' => sub { $_[FORM]->field( name  => $_[FIELD],
                                                          type  => 'hidden',
                                                          ) },
                                                          
                      VALUE => '+VALUE',
                      
                      '+VALUE' => sub 
                      { 
                                my $value;
                                
                                my $accessor = $_[COLUMN]->accessor;
                                 
                                eval { $value = $_[THEM]->$accessor if ref( $_[THEM] ) };
                                     
                                if ( $@ )
                                {
                                    die sprintf "Error running +VALUE on '%s' field: '%s' (value: '%s'): $@", 
                                        $_[THEM], $_[COLUMN]->accessor, defined $value ? $value : 'undef';
                                }
                                
                                $value = ''.$value if defined $value;  # CGI::FB chokes on objects
                                
                                if ( ! defined $value )
                                {
                                    # if the column can be NULL, and the value is undef, we have no way of 
                                    # knowing whether the value has never been set, or has been set to NULL
                                    if ( ! $_[ME]->table_meta( $_[THEM] )->column( $_[FIELD] )->nullable )
                                    {
                                        # but if the column can not be NULL, and the value is undef, 
                                        # set it to the default for the column
                                        $value = $_[ME]->table_meta( $_[THEM] )->column( $_[FIELD] )->default;
                                    }
                                }
                                
                                $_[FORM]->field( name  => $_[FIELD],
                                                 value => $value,   
                                                 );
                      },
                            
                      TIMESTAMP => 'READONLY',
                      
                      DISABLED => [ '+DISABLED', '+VALUE' ],
                      
                      '+DISABLED' => sub { $_[FORM]->field( name     => $_[FIELD],
                                                            disabled => 1,
                                                            class    => 'Disabled',
                                                            ) },
                           
                      READONLY => [ '+READONLY', '+VALUE' ],
                                              
                      '+READONLY' => sub { $_[FORM]->field( name     => $_[FIELD],
                                                            readonly => 1,
                                                            class    => 'ReadOnly',
                                                            ) },
                                                            
                      FILE => [ '+FILE', '+VALUE' ],
                      
                      '+FILE' => sub 
                      { 
                          my $value = $_[THEM]->get( $_[FIELD] ) if ref( $_[THEM] );
                          
                          $_[FORM]->field( name  => $_[FIELD],
                                           type  => 'file',
                                           );
                      },
                      
                      # default in form_options
                      OPTIONS_FROM_DB => [ '+OPTIONS_FROM_DB', '+VALUE' ],
                      
                      '+OPTIONS_FROM_DB' => sub 
                      {    
                          my ( $series, $multiple ) = 
                              $_[ME]->table_meta( $_[THEM] )->column( $_[FIELD] )->options;
                              
                          return unless @$series;
                        
                          $_[FORM]->field( name      => $_[FIELD],
                                           options   => $series,
                                           multiple  => $multiple,
                                           );
                      },
                      
                      '+REQUIRED' => sub { $_[FORM]->field( name      => $_[FIELD],
                                                            required  => 1,
                                                            ) },
                                                         
                      '+NULL' => sub {},
                      
                      '+ADD_FIELD' => sub { $_[FORM]->field( name     => $_[FIELD],
                                                             # need to set something to vivify the field
                                                             required => 0, 
                                                             ) },
                                                          
                      };
                      
    __PACKAGE__->field_processors( $built_ins );    
}

{
    # post processors - note that the calling code is responsible for loading prerequisites 
    #                   of a processor e.g. HTML::Tree
    my $built_ins = { 
        PrettyPrint => sub 
            {
                my ( $me, $form, $render, undef, %args ) = @_;
                
                # the <div></div> is a trick to force HTML::TB to put the 
                # noscript in the body and not in the head
                my $html_in = '<div></div>' . $render->( $form, %args );
                
                my $tree = HTML::TreeBuilder->new;
                
                $tree->store_comments( 1 );
                #$tree->ignore_unknown( 0 );
                $tree->no_space_compacting( 1 );
                #$tree->warn( 1 );     
                
                $tree->parse( $html_in );
                $tree->eof;
                
                my $html_out = $tree->guts->as_HTML( undef, '  ', {} );
                
                $tree->delete;
                
                # clean up after the <div></div> trick, and remove the outer div 
                # added by the guts() call (which removed html-head-body implicit tags)
                $html_out =~ s'^<div>\s*<div>\s*</div>'';
                $html_out =~ s'</div>$'';
                
                return $html_out;
            },
        
        # Duplicates => sub ... # removed after revision 368
        
        NoTextAreas => sub 
            {
                my ( $me, $form, $render, undef, %args ) = @_;
            
                foreach my $field ( $form->field )
                {
                    $field->type( 'text' ) if $field->type eq 'textarea';
                }   
                
                return $render->( $form, %args );
            },
        
        };
        
    __PACKAGE__->post_processors( $built_ins );    
}
    
sub import
{
    my ( $class, %args ) = @_;
    
    my $caller = caller(0);
    
    $caller->can( 'form_builder_defaults' ) || $caller->mk_classdata( 'form_builder_defaults', {} );
    
    # replace CGI::FB's render() method with a hookable version
    {
        my $render = \&CGI::FormBuilder::render;
        
        my $hookable_render = sub 
        { 
            my ( $form, %args ) = @_;
            
            if ( my $post_processor = delete( $args{post_process} ) || $form->__cdbi_original_args__->{post_process} )
            {
                # the pp can mess with the form, then render it (as in the else clause below), then mess 
                # with the HTML, before returning the HTML
                my $pp_args = $form->__cdbi_original_args__->{post_process_args};
                
                my $pp = ref( $post_processor ) eq 'CODE' ? $post_processor : $class->post_processors->{ $post_processor };
                
                return $pp->( $class, $form, $render, $pp_args, %args );           
            }
            else
            {
                return $render->( $form, %args );
            }
        };
        
        no warnings 'redefine';
        *CGI::FormBuilder::render = $hookable_render;
    }
    
    # To support subclassing, store the FB (sub)class on the caller, and use that whenever we need
    # to call an internal method on the CDBI::FB class 
    # i.e. say $them->__form_builder_subclass__ instead of __PACKAGE__
    $caller->mk_classdata( __form_builder_subclass__ => $class );
    
    # _col_name_from_mutator_or_object() needs a cache of mutator_name => column_name
    # on each CDBI class. Note that this accessor is used in a slightly unusual way, 
    # by including a key on the CDBI class. Otherwise, lookups on one class could 
    # fall through to an inherited map, rather than the map for the class we're 
    # interested in. So the map is only stored on $caller.
    $caller->mk_classdata( __mutator_to_name__ => {} );
    
    my @export = qw( as_form 
                     search_form
                     
                     as_form_with_related
                     
                     as_multiform
                     create_from_multiform
                     
                     update_or_create_from_form
                     
                     update_from_form_with_related
                     
                     retrieve_from_form
                     search_from_form 
                     search_like_from_form
                     search_where_from_form
                     
                     find_or_create_from_form 
                     retrieve_or_create_from_form
                     );
                   
    if ( $args{BePoliteToFromForm} )
    {
        no strict 'refs';
        *{"$caller\::${_}_fb"} = \&{"${_}_form"} for qw( update_from create_from );
    }
    else
    { 
        push @export, qw( update_from_form create_from_form );
    }
    
    no strict 'refs';
    *{"$caller\::$_"} = \&$_ for @export;  
}

    
# ----------------------------------------------------------------- field processor architecture -----

# install a new default processor that can be referred to by name
sub new_field_processor
{
    my ( $me, $p_name, $p ) = @_;
    
    my $coderef = $p if ref( $p ) eq 'CODE';
    
    unless ( $coderef )
    {
        $p->require || die "Error loading custom field processor package $p: $@";
        
        UNIVERSAL::can( $p, 'field' ) or die "$p does not have a field() subroutine";
        
        no strict 'refs';
        $coderef = \&{"$p\::field"};    
    }
    
    $me->field_processors->{ $p_name } = $coderef;    
}

# use a chain of processors to construct a field
sub _process_field
{
    my ( $me, $them, $form, $field, $process ) = @_;
    
    # $field will normally be a CDBI column object, but can be a string
    #my $field_name = ref $field ? $field->mutator : $field;
    my $field_name = ref $field ? $field->name : $field;
    
    # some processors (e.g. +VALUE) need access to accessor name, not mutator name
    #my $column = ref $field ? $field : $me->_column_from_mutator( $them, $field );
    my $column = ref $field ? $field : $them->find_column( $field );
    
    my $chain = $me->_build_processor_chain( $process );
    
    # pass the form to each sub in the chain and tweak the specified field
    while ( my $p = $chain->() )
    {
        $p->( $me, $them, $form, $field_name, $column );
    }
}

# returns an iterator
sub _build_processor_chain
{
    my ( $me, $process ) = @_;
    
    my @agenda = ( $process );
    
    # Expand each item on the agenda. Arrayrefs get listified and unshifted back 
    # on to the start of the agenda. Coderefs on the agenda are returned. Non-code scalars are 
    # looked up in the pre-processors dispatch table, or in another package, and 
    # unshifted onto the start of the agenda, because they may be pointing to 
    # further keys in the dispatch table. 
    my $chain;
    
    $chain = sub
    {
        my $next = pop( @agenda );
        
        return unless $next;
        
        return $next if ref( $next ) eq 'CODE';
        
        unshift @agenda, ref $next eq 'ARRAY' ? @$next : $me->_track_down( $next );
        
        return $chain->();    
    };
    
    return $chain;
}

sub _track_down
{
    my ( $me, $processor ) = @_;
    
    return $processor if ref( $processor ) eq 'CODE';
    
    my $p = $me->field_processors->{ $processor };
    
    # might be a coderef, might be another key
    return $p if $p;
    
    # +SET_VALUE() special case - DEPRECATED in 0.41
    if ( $processor =~ /^\+SET_VALUE\(\s*(.*)\s*\)$/ )
    {
        my $value = $1;
        
        warn '+SET_VALUE($value) is deprecated - use +SET_value($value) instead';
        
        $p = sub { $_[FORM]->field( name  => $_[FIELD],
                                    value => $value,   
                                    );
                 };
                 
        return $p;
    }          
    
    # +SET_$foo($bar) general special case
    if ( $processor =~ /^(?:\+?)SET_(\w+)\(\s*(.*)\s*\)$/ )
    {
        my $attribute = $1;
        my $value     = $2;
        
        $p = sub { $_[FORM]->field( name       => $_[FIELD],
                                    $attribute => $value,
                                    );
                   };
         
        return $p;
    }       
    
#    # +FIELD_PREFIX($prefix)
#    if ( $processor =~ /^\+FIELD_PREFIX(\s*(.*)\s*\)$/ )
#    {
#        my $prefix = $1;
#        
#        $p = sub { $_[FORM]->field( name => $_[FIELD],
#    
#    }
    
    die "Unexpected ref: $processor (expected class name)" if ref $processor;
    
    # it's a field sub in another class
    $processor->require or die "Couldn't load field processor package $processor: $@";
    
    $p = $processor->can( 'field' ) || die "No field method in $processor";
    
    return $p;
}

# Combines automatic and custom processors. Custom processors are 
# traversed until a 'stop' processor is found (a named processor without a leading '+'). 
# If found, returns the custom set only. If no 'stop' processor is found, appends the 
# custom set to the auto set. 
sub _add_processors
{
    my ( $me, $field, $pre_process, $auto ) = @_;
    
    # $field will usually be a CDBI column object
    my $field_name = ref $field ? $field->mutator : $field;
    
    my $custom = $pre_process->{ $field_name };
    
    #warn sprintf "Combining procs %s and %s\n", $auto || '', $custom || '';
    
    # I'd use xor if I had a one-liner that doesn't use the temp var
    #my $only = $custom xor $auto;
    #return $only if $only; 
    return $custom unless $auto;
    return $auto   unless $custom;
    
    my $chain = $me->_build_named_processor_chain( $custom );
    
    while ( my $name = $chain->() )
    {
        #warn "Checking custom processor $name for stop";
        #warn "Dropping automatic processors - found custom stop processor $name" if $name !~ /^\+/;
        return $custom if $name !~ /^\+/;
    }
    
    return [ $auto, $custom ]; # it's OK if either are already arrayrefs
}

# only use this to look at the names, not to do any processing, because it throws away 
# any processors that are not named
sub _build_named_processor_chain
{
    my ( $me, $process ) = @_;
    
    my @agenda = ( $process );
    
    # Expand each item on the agenda. Arrayrefs get listified and unshifted back 
    # on to the start of the agenda. Coderefs on the agenda are returned. Non-code scalars are 
    # looked up in the pre-processors dispatch table, or in another package, and 
    # unshifted onto the start of the agenda, because they may be pointing to 
    # further keys in the dispatch table. 
    my $chain;
    
    $chain = sub
    {
        my $next = pop( @agenda );
        
        return unless $next;
        
        # if it's a coderef, drop it and move on to next item
        return $chain->() if ref( $next ) eq 'CODE'; 
        
        # if it's an arrayref, expand it onto the start of the agenda and move on 
        # to next item (i.e. first item in the arrayref)
        if ( ref( $next ) eq 'ARRAY' )
        {
            unshift @agenda, @$next;
            return $chain->();
        }
        
        die "Unexpected ref for processor: $next" if ref $next;
        
        # It's a string
        # if it's in the processors hash, then
        #   - check if it returns a coderef or an arrayref or a string when looked up
        #       - if a coderef, return the string
        #       - unshift anything else onto the agenda
        if ( my $foo = $me->field_processors->{ $next } )
        {
            return $next if ref $foo eq 'CODE';
            
            # it's a string or an arrayref
            unshift @agenda, $foo;
        }
        
        return $chain->();
    };
    
    return $chain;
}

# ----------------------------------------------------------------- / field processor architecture -----

# ----------------------------------------------------------------------- column meta data -----

sub table_meta
{
    my ($me, $them) = @_;
    
    return Class::DBI::FormBuilder::Meta::Table->instance($them);
}

# Return the class or object(s) associated with a field, if anything is associated. 
# This can't go in table_meta because it can be called on objects (???)
sub _related
{
    my ($me, $them, $field) = @_;
    
    my ($related_class, $rel_type) = $me->table_meta($them)->related_class_and_rel_type($field);
    
    return unless $related_class;
    
    return ($related_class, $rel_type) unless ref $them;
    
    my $related_meta = $them->meta_info( $rel_type => $field ) ||
            die "No '$rel_type' meta for '$them', field '$field'";
    
    my $accessor = eval { $related_meta->accessor };    
    die "Error retrieving accessor in meta '$related_meta' for '$rel_type' field '$field' in '$them': $@" if $@;
    
    # multiple objects for has_many
    my @related_objects = $them->$accessor;
    
    return ( $related_class,      $rel_type ) unless @related_objects;
    return ( $related_objects[0], $rel_type ) if @related_objects == 1; 
    return ( \@related_objects,   $rel_type );
}

# ----------------------------------------------------------------------- / column meta data -----

sub as_form
{
    my ( $them, %args_in ) = @_;
    
    my $me = $them->__form_builder_subclass__;
    
    return scalar $me->_as_form( $them, %args_in );    
}

sub as_multiform
{
    my ( $them, %args_in ) = @_;
    
    my $me = $them->__form_builder_subclass__;
    
    my $how_many = delete $args_in{how_many} || die 'need to know how many to build';
    
    my @forms;
    
    foreach my $fnum ( 1..$how_many )
    {
        my $prefix = "R$fnum\__";
        my $form = $them->as_form( %args_in );
        
        my @fields = $form->fields;
        
        foreach my $field ( @fields )
        {
            # get the label before it changes
            my $label = $field->label;
            my $name  = $field->name;
            $field->name( "$prefix${name}" );
            # put the label back
            $field->label( $label );
        }
        
        # put a bit of space after the last field
        $fields[-1]->comment( '<br />&nbsp;' );
        
        push @forms, $form;
    }
     
    return $me->_merge_forms( @forms );   
}

sub _merge_forms
{
    my ( $me, @forms ) = @_;
    
    my $form = shift @forms;
    
    foreach my $additional_form ( @forms )
    {
        foreach my $field ( $additional_form->fields )
        {
            $field->_form( $form );
            
            $form->{fieldrefs}{ $field->name } = $field;
        
            push @{ $form->{fields} }, $field;
        }
    }
    
    return $form;
}

sub _as_form
{
    my ( $me, $them, %args_in ) = @_;
    
    # search_form does not (automatically) validate input
    my $skip_validation = delete $args_in{__SKIP_VALIDATION__};
    
    my ( $orig, %args ) = $me->_get_args( $them, %args_in );
    
    $me->_setup_auto_validation( $them, \%args ) unless $skip_validation;
    
    my $form = $me->_make_form( $them, $orig, %args );
    
    return wantarray ? ( $form, %args ) : $form;
}

sub search_form
{
    my ( $them, %args_in ) = @_;
    
    my $me = $them->__form_builder_subclass__;
    
    my $cdbi_class = ref( $them ) || $them;
    
    $args_in{__SKIP_VALIDATION__}++;
    
    my ( $form, %args ) = $me->_as_form( $cdbi_class, %args_in );
    
    # We need the names of two special fields and a regexp to recognize them
    my $order_by_field_name = 'search_opt_order_by';
    my $cmp_field_name      = 'search_opt_cmp';
    my $regexp = qr/^(?:$order_by_field_name|$cmp_field_name)$/o;    
    
    # make all selects multiple, no fields required unless explicitly set, 
    # and change textareas back into text inputs
    my %force_required = map { $_ => 1 } @{ $args{required} || [] };
    foreach my $field ( $form->field )
    {
        next unless exists $form->field->{ $field }; 
        
        # skip search controls 
        next if $field =~ $regexp;
        
        $field->multiple( 1 ) if $field->options;
                      
        $field->required( 0 ) unless $force_required{ $field };
        
        $field->type( 'text' ) if $field->type eq 'textarea';
        
        # some default field processors may set a value, which needs to be 
        # removed on the search form
        #$field->value( undef ); # this requires CGI::FB 3.03
        $form->field( name => $field->name, value => undef );
    }   
    
    # ----- customise the search -----
    # For processing a submitted form, remember that the field _must_ be added to the form 
    # so that its submitted value can be extracted in search_where_from_form()
    
    # ----- order_by
    # this must come before adding any other fields, because the list of columns 
    # is taken from the form (not the CDBI class/object) so we match whatever 
    # column selection happened during form construction
    my %order_by_spec = ( # name     => 'search_opt_order_by',
                          multiple => 1,
                          );
    
    if ( my $order_by = delete $args{ $order_by_field_name } )
    {
        $order_by = [ map  { ''.$_, "$_ DESC" } 
                      grep { $_->type ne 'hidden' and $_ !~ $regexp } 
                      $form->field 
                      ] 
                      unless ref $order_by;
        
        $order_by_spec{options} = $order_by;
    }
    
    # ----- comparison operator    
    my $cmp = delete( $args{ $cmp_field_name } ) || '=';
    
    my %cmp_spec; # = ( name => 'search_opt_cmp' );
    
    if ( ref( $cmp ) )
    {
        $cmp_spec{options}  = $cmp;
        $cmp_spec{value}    = $cmp->[0];
        #$cmp_spec{multiple} = 0;
    }
    else
    {
        $cmp_spec{value} = $cmp;
        $cmp_spec{type}  = 'hidden';
    }
    
    # this is annoying...
    my %fields = map { ''.$_ => $_ } $form->field;
    
    # if the caller has passed in some custom settings, they will have caused the field to be 
    # auto-vivified
    if ( my $cmp_field = $fields{ $cmp_field_name } )
    {
        # this (used to?) causes a warning when setting the value, which may mean the value has already been set before
        $cmp_field->$_( $cmp_spec{ $_ } ) for keys %cmp_spec;    
    }
    else
    # otherwise, we need to auto-vivify it now
    {
        $form->field( name => $cmp_field_name, %cmp_spec );    
    }
    
    if ( my $order_by_field = $fields{ $order_by_field_name } )
    {
        $order_by_field->$_( $order_by_spec{ $_ } ) for keys %order_by_spec;   
    }
    else
    {
        $form->field( name => $order_by_field_name, %order_by_spec );    
    }
    
    # ...why did this stop working? - I think because sometimes the fields are auto-vivified before getting 
    # to this point, and that seems to be problem when setting the value
    #$form->field( %cmp_spec );    
    #$form->field( %order_by_spec );    
    
    return $form;
}

# need to do much better argument merging
sub _get_args
{
    my ( $me, $them, %args_in ) = @_;
    
    #@{ $args_in{fields} } = map { ''.$_ } @{ $args_in{fields} } if $args_in{fields};
    
    # NOTE: this merging still means any custom processors for a given field, will replace all default 
    #           processors for that field, but at least we can mix some fields having default 
    #           processors, and others having custom ones.
    my $pre_process1 = $them->form_builder_defaults->{process_fields} || {};
    my $pre_process2 = delete( $args_in{process_fields} ) || {};
    my %pre_process  = ( %$pre_process1, %$pre_process2 );
    
    # merge sorters and remove from %args_in (although note that any default sorters will still 
    # be present in %args)
    my %options_sorters = ( %{ $them->form_builder_defaults->{options_sorters} || {} }, 
                            %{ delete( $args_in{options_sorters} ) || {} },
                            );
    
    my %args = ( %{ $them->form_builder_defaults }, %args_in );
    
    $args{process_fields} = \%pre_process;
    
    # take a copy, and make sure not to transform undef into []
    my $original_fields = $args{fields} ? [ @{ $args{fields} } ] : undef;
    
    my %pk = map { $_ => $_ } $them->primary_columns;
    
    $args{fields} ||= [ grep { ! $pk{ $_ } } $me->table_meta( $them )->columns( 'All' ) ];
    
    # convert anything referring to a column, into a CDBI column object
    $args{fields} = [ map { ref $_ ? $_ : $them->find_column( $_ ) || $_ } @{ $args{fields} } ];
                        
    push( @{ $args{keepextras} }, values %pk ) unless ( $args{keepextras} && $args{keepextras} == 1 );
    
    # for objects, populate with data
    if ( ref $them )
    {
        # nb. can't simply say $proto->get( $_ ) because $_ may be an accessor installed by a relationship 
        # (e.g. has_many) - get() only works with real columns. 
        # Note that has_many and might_have and has_a fields are re-processed later (in form_* methods), 
        # it might become necessary to filter them out here?
        my @values = eval { map { $them->$_ }  # may return a scalar, undef, or object (or objects for has_many?)
                            map { ref $_ ? $_->accessor : $_ }
                            @{ $args{fields} } # may be strings or CDBI column objects
                            };
        
        die "Error populating values for $them from '@{ $args{fields} }': $@" if $@;
    
        $args{values} ||= \@values;
    }
    
    my %post_process = ( 
        post_process      => delete( $args_in{post_process} )      || $them->form_builder_defaults->{post_process},
        post_process_args => delete( $args_in{post_process_args} ) || $them->form_builder_defaults->{post_process_args},
                         );
                         
    %post_process = () unless $post_process{post_process};
    
    my $process_extras = delete( $args_in{process_extras} ) || [];
    
    # store a few CDBI::FB arguments that may be needed later
    my $orig = { fields => $original_fields,
                 %post_process,
                 process_extras => $process_extras,
                 options_sorters => \%options_sorters,
                 };
    
    return $orig, %args;
}

sub _make_form
{
    my ($me, $them, $orig, %args) = @_;
    
    my $pre_process = delete( $args{process_fields} ) || {};
    
    my %clean_args = $me->_stringify_args(%args);
    
    my $form = CGI::FormBuilder->new(%clean_args);
    
    $form->{__cdbi_original_args__} = $orig;
    
    # this assumes meta_info only holds data on relationships
    foreach my $modify ( @BASIC_FORM_MODIFIERS, keys %{ $them->meta_info } ) 
    {
        my $form_modify = "form_$modify";
        
        $me->$form_modify($them, $form, $pre_process);
    }
    
    return $form;
}

# If any columns are supplied as CDBI column objects, we need to change them into the appropriate 
# string, which is supplied by the mutator method on the column. 
# Also, CGI::FB does some argument pre-processing that chokes on objects, even if the objects can be 
# stringified, so values need to be stringified here. 
sub _stringify_args
{
    my ( $me, %args ) = @_;
    
    #warn "Dirty args: " . Dumper( \%args );

    # fields - but this could also be a hashref?
    @{ $args{fields} } = map { ref $_ ? $_->mutator : $_ } @{ $args{fields} };
    
    # keepextras
    @{ $args{keepextras} } = map { ref $_ ? $_->mutator : $_ } @{ $args{keepextras} };
    
    
    # values
    @{ $args{values} } = map { defined $_ ? ''.$_ : undef } @{ $args{values} };
    
    
    # validate
    
    
    # auto_validate is still in here - needs to be removed
    
    
    #warn "Clean args: " . Dumper( \%args );
    return %args;
}

sub as_form_with_related
{
    my ( $proto, %args ) = @_;
    
    my $cdbifb = $proto->__form_builder_subclass__;
    
    my $related_args = delete( $args{related} );
    my $show_related = delete( $args{show_related} ) || [];
    
    my $parent_form = $proto->as_form( %args );
    
    foreach my $field ( $cdbifb->_fields_and_has_many_accessors( $proto, $parent_form, $show_related ) )
    {
        # object or class
        my ( $related, $rel_type ) = $cdbifb->_related( $proto, $field );
        
        next unless $related;
        
        my @relateds = ref( $related ) eq 'ARRAY' ? @$related : ( $related );
        
        $cdbifb->_splice_form( $_, $parent_form, $field, $related_args->{ $field }, $rel_type ) for @relateds;
    }
    
    return $parent_form;
}

# deliberately ugly name to encourage something more generic in future
sub _fields_and_has_many_accessors
{
    my ( $me, $them, $form, $show_related ) = @_;
    
    return @$show_related if @$show_related;
    
    # Cleaning these out appears not to fix multiple pc fields, but also seems like the 
    # right thing to do. 
    my %pc = map { $_ => 1 } $them->primary_columns;
    
    my @fields = grep { ! $pc{ $_ } } $form->field;
    
    my %seen = map { $_ => 1 } @fields;
    
    my @related = keys %{ $them->meta_info( 'has_many' ) || {} };
    
    push @fields, grep { ! $seen{ $_ } } @related;
    
    return @fields;
}
        
# Add fields representing related class/object $them, to $parent_form, which represents 
# the class/object as_form_with_related was called on. E.g. add brewery, style, and many pubs 
# to a beer form. 
sub _splice_form
{
    my ( $me, $them, $parent_form, $field_name, $args, $rel_type ) = @_;
    
    # related pkdata are encoded in the fake field name
    warn 'not sure if pk for related objects is getting added - if so, it should not';
    
    #warn "need to add 'add relatives' button"; - see Maypole edit template now
    return unless ref $them; # for now
    
    my $related_form = $them->as_form( %$args );
    
    my $moniker = $them->moniker;
    
    my @related_fields;
    
    foreach my $related_field ( $related_form->fields )
    {
        my $related_field_name = $related_field->name; # XXX mutator
        
        my $fake_name = $me->_false_related_field_name( $them, $related_field_name );
        
        $related_field->_form( $parent_form );
        
        $related_field->name( $fake_name );  
        
        $related_field->label( ucfirst( $moniker ) . ': ' . $related_field_name ) 
            unless $args->{labels}{ $related_field_name };
        
        $parent_form->{fieldrefs}{ $fake_name } = $related_field;
    
        push @related_fields, $related_field;
    }

    my $offset = 0;
    
    foreach my $parent_field ( $parent_form->fields )
    {
        $offset++;
        last if $parent_field->name eq $field_name;        
    }
    
    splice @{ $parent_form->{fields} }, $offset, 0, @related_fields;

    # different rel_types get treated differently e.g. is_a should probably not 
    # allow editing
    if ( $rel_type eq 'has_a' )
    {
        $parent_form->field( name => $field_name,
                             type => 'hidden',
                             );
    }
    elsif ( $rel_type eq 'is_a' )
    {
        $parent_form->field( name     => ''.$_,
                             readonly => 1,
                             )
                                for @related_fields;
    }
    
}


# ------------------------------------------------------- encode / decode field names -----
sub _false_related_field_name
{
    my ( $me, $them, $real_field_name ) = @_;
    
    my $class = $me->_encode_class( $them );
    my $pk    = $me->_encode_pk( $them );
    
    return $real_field_name . $class . $pk;
}

sub _real_related_field_name
{
    my ( $me, $field_name ) = @_;

    # remove any encoded class
    $field_name =~ s/CDBI_.+_CDBI//;
    
    # remove any primary keys
    $field_name =~ s/PKDATA_.+_PKDATA//;
    
    return $field_name;
}

sub _encode_pk
{
    my ( $me, $them ) = @_;
    
    return '' unless ref( $them );
    
    my @pk = map { $them->get( $_ ) } $them->primary_columns;
    
    die "dots in primary key values will confuse _encode_pk and _decode_pk"
        if grep { /\./ } @pk;
    
    my $pk = sprintf 'PKDATA_%s_PKDATA', join( '.', @pk );

    return $pk;
}

sub _decode_pk
{
    my ( $me, $fake_field_name ) = @_;
    
    return unless $fake_field_name =~ /PKDATA_(.+)_PKDATA/;
    
    my $pv = $1;
    
    my @pv = split /\./, $pv;
    
    my $class = $me->_decode_class( $fake_field_name );
    
    my @pc = map { ''.$_ } $class->primary_columns;
    
    my %pk = map { $_ => shift( @pv ) } @pc;
    
    return %pk;
}

sub _decode_class
{
    my ( $me, $fake_field_name ) = @_;

    $fake_field_name =~ /CDBI_(.+)_CDBI/;
    
    my $class = $1;
    
    $class || die "no class in fake field name $fake_field_name";
    
    $class =~ s/\./::/g;
    
    return $class;
}

sub _encode_class
{
    my ( $me, $them ) = @_;
    
    my $token = ref( $them ) || $them;
    
    $token =~ s/::/./g;
    
    return "CDBI_$token\_CDBI";   
}

sub _retrieve_entity_from_fake_fname
{
    my ( $me, $fake_field_name ) = @_;
    
    my $class = $me->_decode_class( $fake_field_name );
    
    my %pk = $me->_decode_pk( $fake_field_name );
    
    return $class unless %pk;
    
    my $obj = $class->retrieve( %pk );

    return $obj;
}

# ------------------------------------------------------- end encode / decode field names -----

# these fields are not in the 'fields' list, but are in 'keepextras'
sub form_hidden { warn 'form_hidden is deprecated - use form_pks instead'; goto &form_pks }

sub form_pks
{
    my ( $me, $them, $form, $pre_process ) = @_;
    
    # don't add pk fields to class forms
    return unless ref $them;
    
    foreach my $field ( $them->primary_columns )
    {
        my $process = $me->_add_processors( $field, $pre_process, 'HIDDEN' ); 
        
        $me->_process_field( $them, $form, $field, $process );
    }
}

sub form_options
{
    my ( $me, $them, $form, $pre_process ) = @_;
    
    foreach my $field ( $them->columns('All') )
    {
        next unless exists $form->field->{ $field->mutator }; # $form->field( name => $field );
        
        # +OPTIONS_FROM_DB is a no-op if the db column isn't enum or set
        my $process = $me->_add_processors( $field, $pre_process, 'OPTIONS_FROM_DB' ); 
        
        $me->_process_field( $them, $form, $field, $process );
    }    
}

sub form_has_a
{
    my ($me, $them, $form, $pre_process) = @_;
    
    my $meta = $them->meta_info('has_a') || return;
    
    my @haves = map { $them->find_column($_) } keys %$meta;
    
    foreach my $field (@haves) 
    {
        next unless exists $form->field->{ $field->mutator };
        
        # See Ron's bug report about inconsistent behaviour of processors. 
        # This will also affect form_has_many and form_might_have
        #warn "BUG: it's an error to stop processing the field just because a processor is defined";
        
        # if a custom field processor has been supplied, use that
        my $processor = $pre_process->{ $field->mutator };
        $me->_process_field($them, $form, $field, $processor) if $processor;
        next if $processor;        
        
        my ($related_class, undef) = $me->table_meta($them)->related_class_and_rel_type($field);
        
        my $nullable = $me->table_meta($them)->column($field)->is_nullable;
        
        if ( $related_class->isa('Class::DBI') ) 
        {
            my $options = $me->_field_options($them, $form, $field) || 
                die "No options detected for field '$field'";
                
            my ($related_object, $value);
            
            if (ref $them)
            {
                my $accessor = $field->accessor;
                $related_object = $them->$accessor;
                 
                if( ! defined $related_object and ! $nullable )
                {
                    die sprintf 
                        'Failed to retrieve a related object from %s has_a field %s - inconsistent db?',
                            ref $them, $accessor;
                }
                    
                my $pk = $related_object->primary_column if defined $related_object;
                    
                $value = $related_object->$pk if defined $related_object; 
            }
            
            my $required = $nullable ? 0 : 1;
                
            $form->field( name     => $field->mutator,
                          options  => $options,
                          required => $required,
                          value    => $value,
                          );        
        } 
        else 
        {
            my $class = "Class::DBI::FormBuilder::Plugin::$related_class";
                        
            # if the class is not in its own file, require will not find it, 
            # even if it has been loaded
            if ( eval { $class->can('field') } or $class->require )
            {
                $class->field($me, $them, $form, $field);
            }
#            elsif ( $@ =~ // ) XXX
#            {
#                # or simply stringify
#                $form->field( name     => $field,
#                              required => 1,
#                              value    => $them->$field.'',
#                              );        
#            }
            else
            {
                die "Failed to load $class: $@";
            }
        }        
        
    }
}

sub form_has_many
{
    my ( $me, $them, $form, $pre_process ) = @_;
    
    my $meta = $them->meta_info( 'has_many' ) || return;
    
    my @has_many_fields = $me->_multiplicity_fields( $them, $form, 'has_many' );
    
    # The target class/object ($them) does not have a column for the related class, 
    # so we need to add these to the form, then figure out their options.
    # Need to make sure and set some attribute to create the new field.
    # BUT - do not create the new field if it wasn't in the list passed in the original 
    # args, or if [] was passed in the original args. 
    
    # note that these are *not* columns in $them
    foreach my $field ( @has_many_fields )
    {
        # the 'next' condition is not tested because @wanted lists fields that probably 
        # don't exist yet, but should
        #next unless exists $form->field->{ $field };
        
        # if a custom field processor has been supplied, use that
        my $processor = $pre_process->{ $field };
        $me->_process_field( $them, $form, $field, $processor ) if $processor;
        next if $processor;        
        
        my $options = $me->_field_options( $them, $form, $field ) || 
            die "No options detected for '$them' field '$field'";
            
        my @many_pks;
        
        if ( ref $them )
        {
            my $rel = $meta->{ $field };
            
            my $accessor = $rel->accessor || die "no accessor for $field";
            
            my ( $related_class, undef ) = $me->table_meta( $them )->related_class_and_rel_type( $field );
            die "no foreign_class for $field" unless $related_class;
            
            my $foreign_pk = $related_class->primary_column;
            
            # don't be tempted to access pks directly in $iter->data - they may refer to an 
            # intermediate table via a mapping method
            my $iter = $them->$accessor;
            
            while ( my $obj = $iter->next )
            {
                die "retrieved " . ref( $obj ) . " '$obj' is not a $related_class" 
                    unless ref( $obj ) eq $related_class;
                    
                push @many_pks, $obj->$foreign_pk;
            }
        }    
                      
        $form->field( name     => $field,
                      value    => \@many_pks,
                      options  => $options,
                      multiple => 1,
                      );
    }
}

# this code is almost identical to form_has_many
sub form_might_have
{
    my ( $me, $them, $form, $pre_process ) = @_;
    
    my $meta = $them->meta_info( 'might_have' ) || return;
    
    my @might_have_fields = $me->_multiplicity_fields( $them, $form, 'might_have' );
    
    # note that these are *not* columns in $them
    foreach my $field ( @might_have_fields ) 
    {
        # the 'next' condition is not tested because @wanted lists fields that probably 
        # don't exist yet, but should
        
        # if a custom field processor has been supplied, use that
        my $processor = $pre_process->{ $field };
        $me->_process_field( $them, $form, $field, $processor ) if $processor;
        next if $processor;        
        
        my $options = $me->_field_options( $them, $form, $field ) || 
            die "No options detected for '$them' field '$field'";

        my $might_have_object_id;
        
        if ( ref $them )
        {        
            my $rel = $meta->{ $field };
            
            my $accessor = $rel->accessor || die "no accessor for $field";

            my ( $related_class, undef ) = $me->table_meta( $them )->related_class_and_rel_type( $field );
            die "no foreign_class for $field" unless $related_class;
            
            my $foreign_pk = $related_class->primary_column;
                        
            my $might_have_object = $them->$accessor;
            
            if ( $might_have_object )
            {
                die "retrieved " . ref( $might_have_object ) . " '$might_have_object' is not a $related_class" 
                    unless ref( $might_have_object ) eq $related_class;
            }
            
            $might_have_object_id = $might_have_object ? $might_have_object->$foreign_pk : undef; # was ''
        }
        
        $form->field( name     => $field,
                      value    => $might_have_object_id,
                      options  => $options,
                      );
    }
}

# Returns fields (in random order) that represent has_many or might_have relationships. 
# Note that if any of these fields are specified in __cdbi_original_args__, the order will be 
# preserved elsewhere during form construction.
sub _multiplicity_fields
{
    my ( $me, $them, $form, $rel ) = @_;
    
    die "Can't handle $rel relationships yet" unless $rel =~ /^(?:has_many|might_have)$/;

    my $meta = $them->meta_info( $rel ) || return;
    
    # @extras are field names that do not exist as columns in the db
    my @extras = keys %$meta;
    
    # if the call to as_form explicitly specified a list of fields, we only return 
    # fields from @extras that are in that list
    my %allowed = map { $_ => 1 } @{ $form->{__cdbi_original_args__}->{fields} || [ @extras ] };
    
    my @wanted = grep { $allowed{ $_ } } @extras;

    return @wanted;
}

# $field can be a CDBI column object, or the name of a has_many etc. field - i.e. not a column 
# in $them, but in another class
sub _field_options
{
    my ( $me, $them, $form, $field ) = @_;
    
    my ($related_class, undef) = $me->table_meta($them)->related_class_and_rel_type($field);
     
    return unless $related_class;
    
    return unless $related_class->isa( 'Class::DBI' );
    
    my $iter = $related_class->retrieve_all;            # potentially expensive
    
    my $pk = $related_class->primary_column;
    
    my @options;
    
    my $column_meta = $me->table_meta($them)->column($field);
    push @options, [ undef, 'n/a' ] if $column_meta and $column_meta->is_nullable;
    
    while ( my $object = $iter->next )                  # potentially very expensive
    {
        push @options, [ $object->$pk, ''.$object ]; 
    }
    
    if ( my $sorter = $me->_get_options_sorter( $them, $form, $field ) )
    {
        @options = sort $sorter @options;
    }
    
    return \@options;
}

sub _get_options_sorter
{
    my ( $me, $them, $form, $field ) = @_;

    # this href is a merge between the original args, and form_builder_defaults
    my $sorter = $form->__cdbi_original_args__->{options_sorters}->{$field};
                    
    return $sorter;
}

sub form_timestamp
{
    my ($me, $them, $form, $pre_process) = @_;
    
    foreach my $field ( $them->columns('All') )
    {
        next unless exists $form->field->{ $field->mutator };
    
        next unless $me->table_meta($them)->column_deep_type( $field->name ) eq 'timestamp';
    
        my $process = $me->_add_processors($field, $pre_process, 'TIMESTAMP'); 
        
        $me->_process_field($them, $form, $field, $process);
    }
}

sub form_text
{
    my ( $me, $them, $form, $pre_process ) = @_;

    foreach my $field ( $them->columns( 'All' ) )
    {
        next unless exists $form->field->{ $field->mutator };
    
        next unless $me->table_meta( $them )->column_deep_type( $field->name ) eq 'text';
    
        my $process = $me->_add_processors( $field, $pre_process, [ '+SET_type(textarea)', '+VALUE' ] ); 
        
        $me->_process_field( $them, $form, $field, $process );
    }
}

sub form_file
{
    my ( $me, $them, $form, $pre_process ) = @_;

    return;
}

sub form_process_extras
{
    my ( $me, $them, $form, $pre_process ) = @_;
    
    # this is a flag used in Maypole::FormBuilder::Model::setup_form_mode() button modes to 
    # prevent extra fields that may be mentioned in form_builder_defaults->{process_fields} 
    # from being added to the form
    #return if $pre_process->{__SKIP_PROCESS_EXTRAS__};
    
    my %process_extras = map { $_ => 1 } @{ $form->__cdbi_original_args__->{process_extras} };
    
    return unless %process_extras;
    
    foreach my $field ( keys %$pre_process )
    {
        next if exists $form->field->{ $field }; 
        
        #next if $field eq '__FINAL__'; # reserved for form_final
        
        next unless $process_extras{ $field };
        
        #my $process = $pre_process->{ $field };
        # this is just to help with debugging _add_processors
        my $process = $me->_add_processors( $field, $pre_process, [ ] );
        
        $me->_process_field( $them, $form, $field, $process );
    }    
}

sub form_final
{
    my ( $me, $them, $form, $pre_process ) = @_;
    
    my $final = $pre_process->{__FINAL__} or return;
    
    $me->_process_field( $them, $form, $_, $final ) for map { $_->name } $form->fields;
}

sub create_from_form 
{
    my ( $them, $form ) = @_;
    
    Carp::croak "create_from_form can only be called as a class method" if ref $them;
    
    return unless $form->submitted && $form->validate;
    
    my $me = $them->__form_builder_subclass__;
    
    my $created = $them->create( $me->_fb_create_data( $them, $form ) );
    
    $me->_update_many_to_many( $created, $form );
    
    return $created;
}

sub _fb_create_data
{
    my ( $me, $them, $form ) = @_;
    
    my $cols = {};
    
    my $data = $form->fields;
    
    foreach my $column ( $them->columns('All') ) 
    {
        next unless exists $data->{ $column->name };
        
        $cols->{ $column->mutator } = $data->{ $column->name };
    }
    
    return $cols;
}

# TODO: check if we need to call _update_many_many
sub create_from_multiform
{
    my ( $them, $form ) = @_;
    
    Carp::croak "create_from_multiform can only be called as a class method" if ref $them;
    
    return unless $form->submitted && $form->validate;

    my $form_data = $form->field; 
    
    my $items_data;
    
    foreach my $fname ( keys %$form_data )
    {
        $fname =~ /^R(\d+)__(\w+)$/;
        
        my $item_num = $1;
        my $col_name = $2;
        
        my $mutator = $them->find_column( $col_name )->mutator;
        
        $items_data->{ $item_num }->{ $mutator } = $form_data->{ $fname };
    }
    
    my @new = map { $them->create( $_ ) } values %$items_data;

    return @new;    
}

sub update_from_form 
{
    my ( $proto, $form ) = @_;
    
    my $them = ref( $proto ) ? $proto : $proto->retrieve_from_form( $form );
    
    Carp::croak "No object found matching submitted primary key data" unless $them;
    
    my $me = $proto->__form_builder_subclass__;
    
    $me->_run_update( $them, $form );
    
    $me->_update_many_to_many( $them, $form );
    
    return $them;
}

sub _run_update 
{
    my ( $me, $them, $fb ) = @_;
    
    return unless $fb->submitted && $fb->validate;
    
    my $formdata = $fb->fields;
    
    # I think this is now unnecessary (0.4), because pks are in keepextras
    delete $formdata->{ $_ } for map {''.$_} $them->primary_columns;
    
    # assumes no extra fields in the form
    #$them->set( %$formdata );
    
    # Start with all possible columns. Only ask for the subset represented 
    # in the form. This allows correct handling of fields that result in 
    # 'missing' entries in the submitted data - e.g. checkbox groups with 
    # no item selected will not even appear in the raw request data, but here
    # they should result in an undef value being sent to the object.
    my %coldata = map  { $_->mutator => $formdata->{ $_->name } } 
                  grep { exists $formdata->{ $_->name } }
                  $them->columns( 'All' );
    
    $them->set( %coldata );
    
    $them->update;
    
    return $them;
}


# from Ron McClain:
sub _update_many_to_many 
{
    my ( $me, $obj, $form ) = @_;
    
    my $has_many = $obj->meta_info('has_many') || return;
    
    foreach my $field ( keys %{ $form->fields } ) 
    {
        next unless $has_many->{$field};
        
        # many-many
        next unless $has_many->{$field}->{args}->{mapping};       
        
        my $mkey   = $has_many->{$field}->{args}->{mapping}->[0];
        my $fkey   = $has_many->{$field}->{args}->{foreign_key};
        my $fclass = $has_many->{$field}->{foreign_class};
        
        my %rel_exists;
        
        foreach my $rel ( $fclass->search( $fkey => $obj->id ) ) 
        {
            if ( grep { $rel->$mkey->id == $_ } $form->field($field) )
            {
                $rel_exists{ $rel->$mkey->id }++;
            } 
            else 
            {
                $rel->delete;
            }
        }
        
        foreach my $val ( $form->field($field) ) 
        {
            $fclass->create( { $fkey => $obj->id, 
                               $mkey => $val,
                               } ) 
                unless $rel_exists{$val};
        }
    }
}

# Also, this patch only applies to many-many.  Not one-many.  I got to
# thinking about it, and it doesn't make sense to me  have a select list
# for one-many with existing records..  Because if you edit a record and
# select a record to relate to it..  The related record may already be
# associated with a separate record, and it would kill that association..
# Not intuitive.  But for many-many, I don't see the downside of having
# something like this be standard.  The only thing I can think of is, what
# if the glue table has additional columns besides the two foreign keys?
# I can't think of an example right now, but I guess it's possible.  The
# other thing I don't quite understand is why
# meta_info->field->args->mapping is an array and not a scalar.  I just
# pull off the first element, but I don't know whether it's possible that
# there be more elements than that, and what they mean.

sub update_or_create_from_form
{
    my ( $them, $form ) = @_;
    
    Carp::croak "update_or_create_from_form can only be called as a class method" if ref $them;

    $them->__form_builder_subclass__->_run_update_or_create_from_form( $them, $form );
}

sub _run_update_or_create_from_form
{
    my ( $me, $them, $form ) = @_;

    return unless $form->submitted && $form->validate;

    my $object = $them->retrieve_from_form( $form );
    
    return $object->update_from_form( $form ) if $object;
    
    $them->create_from_form( $form );
}

sub retrieve_from_form
{
    my ( $them, $form ) = @_;
    
    Carp::croak "retrieve_from_form can only be called as a class method" if ref $them;

    $them->__form_builder_subclass__->_run_retrieve_from_form( $them, $form );
}

sub _run_retrieve_from_form
{
    my ( $me, $them, $form ) = @_;
    
    # we don't validate because pk data must side-step validation as it's 
    # unknowable in advance whether they will even be present. 
    #return unless $fb->submitted && $fb->validate;
    
    my %pkdata = map { $_ => $form->cgi_param( $_->mutator ) || undef } $them->primary_columns;
    
    return $them->retrieve( %pkdata );
}

sub search_from_form 
{
    my ( $them, $form ) = @_;
    
    Carp::croak "search_from_form can only be called as a class method" if ref $them;

    $them->__form_builder_subclass__->_run_search_from_form( $them, '=', $form );
}

sub search_like_from_form
{
    my ( $them, $form ) = @_;
    
    Carp::croak "search_like_from_form can only be called as a class method" if ref $them;

    $them->__form_builder_subclass__->_run_search_from_form( $them, 'LIKE', $form );
}

sub _run_search_from_form
{    
    my ( $me, $them, $search_type, $form ) = @_;
    
    return unless $form->submitted && $form->validate;

    my %searches = ( LIKE => 'search_like',
                     '='  => 'search',
                     );
                     
    my $search_method = $searches{ $search_type };
    
    my @search = $me->_get_search_spec( $them, $form );
    
    my @modifiers = qw( order_by order_direction ); # others too
    
    my %search_modifiers = $me->_get_search_spec( $them, $form, \@modifiers );
    
    push( @search, \%search_modifiers ) if %search_modifiers;
    
    return $them->$search_method( @search );
}

sub _get_search_spec
{
    my ( $me, $them, $form, $fields ) = @_;

    my @fields = $fields ? @$fields : map { $_->accessor } $them->columns( 'All' );

    # this would miss multiple items
    #my $formdata = $fb->fields;
    
    my $formdata;
    
    foreach my $field ( $form->fields )
    {
        my @data = $field->value;
        
        $formdata->{ $field } = @data > 1 ? \@data : $data[0];
    }
    
    return map  { $_ => $formdata->{ $_ } } 
           grep { defined $formdata->{ $_ } } # don't search on unsubmitted fields
           @fields;
}

sub search_where_from_form
{
    my ( $them, $form ) = @_;
    
    Carp::croak "search_where_from_form can only be called as a class method" if ref $them;

    $them->__form_builder_subclass__->_run_search_where_from_form( $them, $form );
}

# have a look at Maypole::Model::CDBI::search()
sub _run_search_where_from_form
{
    my ( $me, $them, $form ) = @_;
    
    return unless $form->submitted && $form->validate;

    my %search_data = $me->_get_search_spec( $them, $form );
    
    # clean out empty fields
    do { delete( $search_data{ $_ } ) unless $search_data{ $_ } } for keys %search_data;
    
    # these match fields added in search_form()
    my %modifiers = ( search_opt_cmp      => 'cmp', 
                      search_opt_order_by => 'order_by',
                      );
    
    my %search_modifiers = $me->_get_search_spec( $them, $form, [ keys %modifiers ] );
    
    # rename modifiers for SQL::Abstract - taking care not to autovivify entries
    $search_modifiers{ $modifiers{ $_ } } = delete( $search_modifiers{ $_ } ) 
        for grep { $search_modifiers{ $_ } } keys %modifiers;
    
    # return everything if no search terms specified
    unless ( %search_data )
    {
        $search_data{1}        = 1;
        $search_modifiers{cmp} = '=';
    }
    
    my @search = %search_modifiers ? ( \%search_data, \%search_modifiers ) : %search_data;
    
    return $them->search_where( @search );
}

    
sub find_or_create_from_form
{
    my ( $them, $form ) = @_;
    
    Carp::croak "find_or_create_from_form can only be called as a class method" if ref $them;

    $them->__form_builder_subclass__->_run_find_or_create_from_form( $them, $form );
}

sub _run_find_or_create_from_form
{
    my ( $me, $them, $form ) = @_;

    return unless $form->submitted && $form->validate;

    my %search_data = $me->_get_search_spec( $them, $form );
    
    return $them->find_or_create( \%search_data );    
}

sub retrieve_or_create_from_form
{
    my ( $them, $form ) = @_;
    
    Carp::croak "retrieve_or_create_from_form can only be called as a class method" if ref $them;

    $them->__form_builder_subclass__->_run_retrieve_or_create_from_form( $them, $form );
}

sub _run_retrieve_or_create_from_form
{
    my ( $me, $them, $form ) = @_;

    return unless $form->submitted && $form->validate;

    my $object = $them->retrieve_from_form( $form );
    
    return $object if $object;
    
    $them->create_from_form( $form );
}

# ---------------------------------------------------------------------------------- validation -----

sub _valid_map
{
    my ( $me, $type ) = @_;
    
    return $ValidMap{ $type };
}

# $fb_args is the args hash that will be sent to CGI::FB to construct the form. 
# Here we re-write $fb_args->{validate}
sub _setup_auto_validation 
{
    my ( $me, $them, $fb_args ) = @_;
    
    # this simply returns either the auto-validation spec (as set up by the caller), or 
    # undef (if the caller has set up a standard CGI::FB validation spec)
    my %args = $me->_get_auto_validate_args( $them );
     
    return unless %args;
    
    my $debug = delete $args{debug};
    warn "auto-validating $them\n" if $debug;
    
    # validate and columns are the same thing. validate matches the terminology 
    # used in CGI::FB, so it should be retained, but 'columns' is more descriptive, 
    # and to be preferred
    if ( exists $args{validate} and exists $args{columns} )
    {
        Carp::croak "Automatic validation profile contains both 'validate' and 'columns' entries. " . 
                "Use one or other, not both (they're aliases)";
    }
    
    my $v_cols        = delete $args{columns} || delete $args{validate} || {}; 
    my $skip_cols     = delete $args{skip_columns}     || [];
    my $match_cols    = delete $args{match_columns}    || {}; 
    my $v_types       = delete $args{validate_types}   || {}; 
    my $match_types   = delete $args{match_types}      || {}; 
    
    # anything left over is an error
    if ( my @unknown = keys %args )
    {
        Carp::croak "Unknown keys in auto-validation spec: " . join( ', ', @unknown );
    }
    
    my %skip = map { $_ => 1 } @$skip_cols;
    
    my %validate; 
    
    foreach my $field ( @{ $fb_args->{fields} } ) 
    {
        my $column   = ref $field ? $field : $them->find_column($field);
        my $col_name = ref $field ? $column->name : $field;
    
        next if $skip{$col_name};    
        
        # this will get added at the end
        next if $v_cols->{$col_name}; 
        
        # look for columns with options
        # TODO - what about related columns? - do not want to add 10^6 db rows to validation
        #           - the caller just has to set up a different config for these cases
             
        my $options = $them->form_builder_defaults->{options} || {};
        
        my $o = $options->{$col_name};
        
        # $o could be an aref of arefs, each consisting of a value and a label - 
        # we only want the values. Note that in general, there could be a mix of 
        # arrayrefs and strings in the options list, e.g. for a leading empty item 
        if ( ref($o) eq 'ARRAY' )
        {
            $o = [ map { ref $_ eq 'ARRAY' ? $_->[0] : $_ } @$o ];
        }
        
        unless ($o)
        {
            # if $fb_args has entries for has_many fields, this will croak
            my $column_meta = $me->table_meta( $them )->column( $col_name );
            
            last unless $column_meta; # it's a has_many (or similar) field
            
            my ( $series, undef ) = $column_meta->options;
            $o = $series; 
            warn "(Probably) setting validation to options (@$o) for $col_name in $them" 
                if ( $debug > 1 and @$o );
            undef($o) unless @$o;            
        }
        
        my $type = $me->table_meta($them)->column_deep_type($col_name);
        
        die "No type for $col_name in $them" unless $type;
        
        my $v = $o || $v_types->{$type}; 
                 
        foreach my $regex ( keys %$match_types )
        {
            last if $v;
            $v = $match_types->{$regex} if $type =~ $regex;
        }
        
        foreach my $regex ( keys %$match_cols )
        {
            last if $v;
            $v = $match_cols->{$regex} if $col_name =~ $regex;
        }
        
        my $skip_ts = ( ( $type eq 'timestamp' ) && ! $v );
        
        warn "Skipping $them $col_name [timestamp]\n" if ( $skip_ts and $debug > 1 );
        
        next if $skip_ts;
        
        $v ||= $me->_valid_map($type) || '';
        
        my $fail = "No validate type detected for column $col_name, type $type in $them"
            unless $v;
            
        $fail and $args{strict} ? die $fail : warn $fail;
    
        my $type2 = substr( $type, 0, 25 );
        $type2 .= '...' unless $type2 eq $type;
        
        warn sprintf "Validating %s %s [%s] as %s\n", $them, $col_name, $type2, $v
                if $debug > 1;
        
        $validate{$col_name} = $v if $v;
    }
    
    my $validation = {%validate, %$v_cols};
    
    if ($debug)
    {
        Data::Dumper->require || die $@;
        my $label = ref($them) ? ref($them) . "($them)" : $them;
        warn "Setting up validation for $label: ".Data::Dumper::Dumper($validation);
    }
    
    $fb_args->{validate} = $validation;
    
    return;
}

sub _get_auto_validate_args
{
    my ( $me, $them ) = @_;
    
    my $fb_defaults = $them->form_builder_defaults;
    
    if ( %{ $fb_defaults->{validate} || {} } && %{ $fb_defaults->{auto_validate} || {} } )
    {
        Carp::croak 'Got validation AND auto-validation settings in form_builder_defaults - ' . 
                        'should only have one or the other';
    }
    
    # don't do auto-validation if the caller has set up a standard CGI::FB validation spec
    return if %{ $fb_defaults->{validate} || {} };
    
    # stop lots of warnings when testing debug value, and ensure something is set so the cfg exists test passes
    $fb_defaults->{auto_validate}->{debug} ||= 0;
    
    return %{ $fb_defaults->{auto_validate} };
}

# ---------------------------------------------------------------------------------- / validation -----

1; # End of Class::DBI::Plugin::FormBuilder

__END__

Example of a dumped CDBI meta_info structure for BeerDB::Beer:

$VAR1 = {
          'has_a' => {
                       'style' => bless( {
                                           'foreign_class' => 'BeerFB::Style',
                                           'name' => 'has_a',
                                           'args' => {},
                                           'class' => 'BeerFB::Beer',
                                           'accessor' => bless( {
                                                                  '_groups' => {
                                                                                 'All' => 1
                                                                               },
                                                                  'name' => 'style',
                                                                  'mutator' => 'style',
                                                                  'placeholder' => '?',
                                                                  'accessor' => 'style'
                                                                }, 'Class::DBI::Column' )
                                         }, 'Class::DBI::Relationship::HasA' ),
                       'brewery' => bless( {
                                             'foreign_class' => 'BeerFB::Brewery',
                                             'name' => 'has_a',
                                             'args' => {},
                                             'class' => 'BeerFB::Beer',
                                             'accessor' => bless( {
                                                                    '_groups' => {
                                                                                   'All' => 1
                                                                                 },
                                                                    'name' => 'brewery',
                                                                    'mutator' => 'brewery',
                                                                    'placeholder' => '?',
                                                                    'accessor' => 'brewery'
                                                                  }, 'Class::DBI::Column' )
                                           }, 'Class::DBI::Relationship::HasA' )
                     },
          'has_many' => {
                          'pubs' => bless( {
                                             'foreign_class' => 'BeerFB::Handpump',
                                             'name' => 'has_many',
                                             'args' => {
                                                         'mapping' => [
                                                                        'pub'
                                                                      ],
                                                         'foreign_key' => 'beer',
                                                         'order_by' => undef
                                                       },
                                             'class' => 'BeerFB::Beer',
                                             'accessor' => 'pubs'
                                           }, 'Class::DBI::Relationship::HasMany' )
                        }
        };


And for BeerFB::Pub:

$VAR1 = {
          'has_many' => {
                          'beers' => bless( {
                                              'foreign_class' => 'BeerFB::Handpump',
                                              'name' => 'has_many',
                                              'args' => {
                                                          'mapping' => [
                                                                         'beer'
                                                                       ],
                                                          'foreign_key' => 'pub',
                                                          'order_by' => undef
                                                        },
                                              'class' => 'BeerFB::Pub',
                                              'accessor' => 'beers'
                                            }, 'Class::DBI::Relationship::HasMany' )
                        }
        };

And for BeerFB::Handpump:

$VAR1 = {
          'has_a' => {
                       'pub' => bless( {
                                         'foreign_class' => 'BeerFB::Pub',
                                         'name' => 'has_a',
                                         'args' => {},
                                         'class' => 'BeerFB::Handpump',
                                         'accessor' => bless( {
                                                                'name' => 'pub',
                                                                '_groups' => {
                                                                               'All' => 1
                                                                             },
                                                                'mutator' => 'pub',
                                                                'placeholder' => '?',
                                                                'accessor' => 'pub'
                                                              }, 'Class::DBI::Column' )
                                       }, 'Class::DBI::Relationship::HasA' ),
                       'beer' => bless( {
                                          'foreign_class' => 'BeerFB::Beer',
                                          'name' => 'has_a',
                                          'args' => {},
                                          'class' => 'BeerFB::Handpump',
                                          'accessor' => bless( {
                                                                 'name' => 'beer',
                                                                 '_groups' => {
                                                                                'All' => 1
                                                                              },
                                                                 'mutator' => 'beer',
                                                                 'placeholder' => '?',
                                                                 'accessor' => 'beer'
                                                               }, 'Class::DBI::Column' )
                                        }, 'Class::DBI::Relationship::HasA' )
                     }
        };


A plain has_many (not part of a many_many) - a consultant has_many referees
$VAR1 = bless( {
                 'foreign_class' => 'Referee',
                 'name' => 'has_many',
                 'args' => {
                             'mapping' => [],
                             'foreign_key' => 'consultant',
                             'order_by' => undef
                           },
                 'class' => 'Consultant',
                 'accessor' => 'referees'
               }, 'Class::DBI::Relationship::HasMany' );