The Perl Advent Calendar needs more articles for 2022. Submit your idea today!
package Maypole::Plugin::FormBuilder;

use warnings;
use strict;

use NEXT;
use UNIVERSAL::require;

use Maypole::FormBuilder::View;
use Maypole::Config;
use Maypole::FormBuilder;

use URI;
use URI::QueryParam;
    
Maypole::Config->mk_accessors( qw( form_builder_defaults pager_class table_labels ) );

our $VERSION = $Maypole::FormBuilder::VERSION;

=head1 NAME

Maypole::Plugin::FormBuilder - CGI::FormBuilder for Maypole

=head1 SYNOPSIS

    package BeerFB;
    use warnings;
    use strict;
    
    use Class::DBI::Loader::Relationship;
    use Apache::Session::File();
    
    use Maypole::Application qw( FormBuilder QuickTable Session );
    
    BeerFB->config->model( 'Maypole::FormBuilder::Model' );
    
    BeerFB->config->session( { args => { Directory     => "/tmp/sessions/beerfb",
                                         LockDirectory => "/tmp/sessions/beerfb",
                                         },
                               } );
    
    # note: the latest development version is broken
    #BeerFB->config->pager_class( 'Class::DBI::Plugin::Pager' );
    
    # global FormBuilder defaults
    BeerFB->config->form_builder_defaults( { method => 'post' } );
    
    # standard config
    BeerFB->config->{template_root}  = '/home/beerfb/www/www/htdocs';
    BeerFB->config->{uri_base}       = '/';
    BeerFB->config->{rows_per_page}  = 10;
    BeerFB->config->{display_tables} = [ qw( beer brewery pub style ) ];
    BeerFB->config->{application_name} = 'The BeerFB Database';

    BeerFB->setup( 'dbi:mysql:BeerDB', 'username', 'password' );
    
    BeerFB->config->loader->relationship( $_ ) for (
        'a brewery produces beers',
        'a style defines beers',
        'a pub has beers on handpumps',
        );
    
    # ----- set up validation and other form defaults -----
    
    # has_a fields (style, brewery) are automatically required in CDBI::FormBuilder
    BeerFB::Beer->form_builder_defaults( { validate => { abv     => 'NUM',
                                                        style   => 'INT',
                                                        brewery => 'INT',
                                                        price   => 'NUM',
                                                        url     => 'VALUE',
                                                        notes   => 'VALUE',
                                                        name    => 'VALUE',
                                                        score   => [ qw( 1 2 3 4 5 ) ],
                                                        },
                                        options => { score => [ qw( 1 2 3 4 5 ) ],
                                                        },
                                        required => [ qw( name ) ],
                                        } );
        
    BeerFB::Brewery->form_builder_defaults( { validate => { name  => 'VALUE',
                                                            notes => 'VALUE',
                                                            url   => 'VALUE',
                                                            },
                                               required => [ qw( name ) ],
                                            } );
                                            
    BeerFB::Pub->form_builder_defaults( { validate => { name  => 'VALUE',
                                                        notes => 'VALUE',
                                                        url   => 'VALUE',
                                                        },
                                        required => [ qw( name ) ],
                                        } );
                                            
    BeerFB::Style->form_builder_defaults( { validate => { name  => 'VALUE',
                                                          notes => 'VALUE',
                                                          },
                                            required => [ qw( name ) ],
                                            } );    
    
    1;
    
    
    # -------------------------------------------------------------------------
    # --- in a Mason template (adapt syntax for your preferred template system)
    
    <% $request->as_form->render %>
    
=head1 DESCRIPTION

Generate L<CGI::FormBuilder|CGI::FormBuilder> forms from Maypole objects, using L<Class::DBI::FormBuilder|Class::DBI::FormBuilder>. 

Includes an alternative Maypole model, which should be set up in your config:

    BeerFB->config->model( 'Maypole::FormBuilder::Model' );

B<Note> that a new C<vars> method is installed, which removes the 
C<classmetadata> functionality. It just seemed like an extra level of API to learn, 
and we don't need the L<Class::DBI::AsForm|Class::DBI::AsForm> stuff.

=head2 Sessions

The demo application (shown in the synopsis) uses sessions to keep track of the user's 
preferred list view mode (editlist or plain list). The demo should work without sessions, 
but it will not show the editable list view.  

=head1 METHODS

=over 4

=item setup

Called automatically by Maypole during compilation.

Among other things, this method sets an empty hashref into each model's C<form_builder_defaults> 
class data slot. This is done to prevent models inheriting each other's settings, but has the 
side-effect of clobbering anything set up during model compilation. So you can't populate 
C<form_builder_defaults> in the subclass itself. Instead, set up each subclass's 
C<form_builder_defaults> in the application driver, after the C<setup()> call.

=cut

sub setup
{
    my $r = shift; # class name
    
    # ensure Maypole::setup() is called, which will load the model class
    $r->NEXT::DISTINCT::setup( @_ );

    warn "Running " . __PACKAGE__ . " setup for $r" if $r->debug;
    
    $r->config->{form_builder_defaults} ||= {};
    $r->config->{pager_class}           ||= 'Class::DBI::Pager';
    
    my $model = $r->config->model ||
        die "Please configure a model in $r before calling setup()";
        
    my $pager = $r->config->{pager_class};
    
    eval "package $model; use $pager";
    die $@ if $@;
    
    # table labels
    my $labels = { map { $_ => ucfirst( $_ ) } @{ $r->config->display_tables } };
    s/_/ /g for values %$labels;    
    $r->config->table_labels( $labels );    

    # give each class its own private ref, or else everyone will end up sharing the same settings:
    $_->form_builder_defaults( {} ) for @{ $r->config->classes };
}

=item init

=cut

sub init
{
    my ( $class ) = @_;
    
    my $config = $class->config;

    $class->NEXT::DISTINCT::init;
    
    my $old_view = $class->config->view ||
        die "Please configure a view in $class before calling init()";
        
    my $virtual_view = "$class\::__::View";
    
    eval <<VIEW;
package $virtual_view; 
use base qw( Maypole::FormBuilder::View $old_view );
VIEW
          
    die $@ if $@;
    
    $config->view( $virtual_view );
    
    $class->view_object( $class->config->view->new );
}

=item as_form

This returns a L<CGI::FormBuilder|CGI::FormBuilder> object. Accepts any parameters that 
C<< CGI::FormBuilder->new() >> accepts. 

Defaults are as in L<CGI::FormBuilder|CGI::FormBuilder>, you can alter them using 
the C<form_builder_default> Maypole config slot.

There are a few additional Maypole-specific options:
    
=over 4
    
=item mode

The form generated depends on the C<mode>. Defaults to the current action. 

As a special case, you can pass this as a positional argument, instead of a named 
argument, i.e. these mean the same:

    my $form = $request->as_form( $mode );
    my $form = $request->as_form( mode => $mode );
    my $form = $request->as_form( { mode => $mode } );

as do these:

    my %args = ( whatever => whatever );
    
    my $form = $request->as_form( $mode, %args );
    my $form = $request->as_form( $mode, \%args );
    
    $args{mode} = $mode;
    
    my $form = $request->as_form( %args );
    my $form = $request->as_form( \%args );
    
Pass the mode argument to generate a different form from that specified by the current 
value of C<< $r->action >>. For instance, to generate a search form to include on a 
list template, say 

    print $r->as_form( mode => 'do_search' )->render;
    
You can add more modes by defining C<setup_form_mode> methods in your model classes. See 
L<Maypole::FormBuilder::Model|Maypole::FormBuilder::Model> and 
L<Maypole::FormBuilder::Model::Base|Maypole::FormBuilder::Model::Base>.

=item entity

Normally, C<as_form> builds a form based on the first object 
in C<< $r->objects >>, or based on the current model (C<< $r->model_class >>) if there are no 
objects. To use a different object or model, pass it in the C<entity> argument:

    my $form = $r->as_form( entity => $class_or_object );
    
=back

=cut

# arg processing is complicated:
#  case 1 : mode
#  case 2 : hashref
#  case 3 : mode  argx2
#  case 4 : mode  hashref
#  case 5 : argx2
sub as_form
{
    my $r = shift;
    
#    my $mode = shift if @_ % 2;
#    my %args_in = @_;
#    $args_in{mode} = $mode if $mode;

    my ( $mode, %args_in );
    
    if ( @_ == 1 and not ref $_[0] )      # case 1
    {
        $args_in{mode} = shift;
    }
    elsif ( @_ == 1 )                     # case 2
    {
        %args_in =  %{$_[0]};
    }
    elsif ( @_ % 2 )                      # case 3
    {
        $mode = shift;
        %args_in = @_;
        $args_in{mode} = $mode;
    }
    elsif ( @_ == 2 and ref $_[1] )       # case 4
    {
        $mode = shift;
        %args_in = %{ $_[0] };
        $args_in{mode} = $mode;
    }
    else                                  # case 5
    {
        %args_in = @_;
    }
    
    my ($entity, %args) = $r->_form_args(%args_in);
    
    my $form = $entity->as_form(%args);
    
    $r->_add_unique_id($form);
    
    return $form;
}

sub _add_unique_id
{
    my ( $r, $form ) = @_;
    
    my $action = $form->action;
    
    my $uri = URI->new( $form->action );
    
    $uri->query_param_append( __form_id => $r->make_random_id );
    
    $form->action( $uri->as_string );
}

=item as_multiform

Wrapper for C<Class::DBI::FormBuilder::as_multiform()>.

=cut

sub as_multiform
{
    my $r = shift;
    
    my $mode = shift if @_ % 2;
    
    my %args_in = @_;
    
    $args_in{mode} = $mode if $mode;
    
    my $how_many = delete $args_in{how_many} or die 'need to know how many to make';
    
    my ( $entity, %args ) = $r->_form_args( %args_in );
    
    my $form = $entity->as_multiform( %args, how_many => $how_many );
    
    $r->_add_unique_id($form);
    
    return $form;
}

sub _form_args
{
    my ( $r, %args ) = @_;
    
    %args = $r->_merge_form_args( %args );
    
    my $entity = delete( $args{entity} ) || ( @{ $r->objects || [] } )[0] || $r->model_class;
    
    die "Entity $entity does not inherit from Maypole::Model::Base" 
        unless $entity->isa( 'Maypole::Model::Base' );
    
    $args{mode} ||= $r->action;
    
    $args{params} ||= $r; # $r has a suitable param() method
    
    # now modify for the Maypole action/mode 
    my $spec = $entity->setup_form_mode( $r, { %args } );
    
    $entity = delete( $spec->{entity} ) if $spec->{entity};
    
    $spec->{name} ||= $r->_make_form_name( $entity, $args{mode} );
    
    unless ( $spec->{required} or $entity->form_builder_defaults->{required} )
    {
        $spec->{required} = [ $entity->stringify_column ];
    }

    return $entity, %$spec;    
}

sub _merge_form_args
{
    my ( $r, %args ) = @_;

    # CDBI::FB will later merge in %{ $proto->form_builder_defaults }, 
    %args = ( %{ $r->config->form_builder_defaults }, 
              %args,
              );

    return %args;              
}

# Give every form a unique name.
sub _make_form_name
{
    my ( $r, $proto, $mode ) = @_;
    
    die 'no mode' unless $mode;
    
    my @name;
    
    if ( my $class = ref( $proto ) )
    {
        push @name, $class, $mode, map { $proto->get( $_ ) } $proto->primary_columns;
    }
    else
    {
        push @name, $proto, $mode;
    }
    
    # Need to use a separator that is legal in javascript function names (not .) and 
    # CSS identifiers (not _ ?). Need to use a separator in case of multiple primary columns.
    # CGI::FB will still add an underscore to some identifiers though, so we'll use '_'. 
    my $name = join( '_', @name ); 
                          
    $name =~ s/[^\w]+/_/g;
    
    return $name;
}

=item search_form

Returns a search form, via C<Class::DBI::FormBuilder::search_form()>. The C<mode> 
defaults to C<do_search>. 

=cut

sub search_form
{
    #my ( $r, %args ) = @_;
    my $r = shift;
    my %args = ( @_ == 1 && ref $_[0] && ref $_[0] eq 'HASH' ) ? %{ $_[0] } : @_;
    
    $args{required} ||= [];
    
    # this has to come after setting 'required', so we don't pick up a default 'required' setting 
    # intended for other forms of this class
    %args = $r->_merge_form_args( %args );
    
    my $class = delete( $args{entity} ) || $r->model_class;
    
    # this is probably not true, since CDBI::FB is careful to change an object into a class
    # before building the form
    die "search_form() must be called on a class, not an object" if ref $class;
    
    # this must be set before calling _get_form_args()
    $args{mode} ||= 'search'; # or do_search - both set the form action to do_search in setup_form_mode()
    
    $args{name} ||= $r->_make_form_name( $class, $args{mode} );
    
    $args{params} ||= $r; # $r has a suitable param() method
    
    my $spec = $class->setup_form_mode( $r, \%args );
    
    my $form = $class->search_form(%$spec);

    $r->_add_unique_id($form);
    
    return $form;
}
    
=item as_forms( %args )

    %args = ( objects => $object|$arrayref_of_objects,   # defaults to $r->objects
              %other_form_args,
              );

Generates multiple forms and returns them as a list.

You may want to reduce C<selectnum> to generate popup menus rather than multiple radiobuttons 
or checkboxes ( see the C<list> template in this distribution).

=cut

sub as_forms
{
    my $r = shift;
    
    my $mode = shift if @_ % 2;
    
    my %args = @_;
    
    $args{mode} = $mode if $mode;
    
    my $objects = delete $args{objects} || $r->objects;
    
    my @objects = ref( $objects ) eq 'ARRAY' ? @$objects : ( $objects );
    
    my @forms = map { $r->_add_unique_id($_); $_ } 
                map { $r->as_form( %args, entity => $_ ) } 
                @objects;
    
    return @forms;    
}    

=item render_form_as_row( $form )

Returns a form marked up as a single row for a table. 

This will probably get converted to a template some time. 

Yes, it's bad XHTML - suggestions about how to do this legally would be good.

=cut
    
# chopped out of CGI::FormBuilder::render()
# XXX - maybe better implemented as a post-processor now
sub render_form_as_row
{
    my ( $r, $form ) = @_;
    
    my $font = $form->font;
    my $fcls = $font ? '</font>' : '';
    
    my $html;
    
    # JavaScript validate/head functions
    if ( my $sc = $form->script ) 
    {
        $html .= $sc . $form->noscript;
    }    
    
    $html .= "<tr>\n" . $form->start . "\n" . $form->statetags . "\n" . $form->keepextras;
    
    my $table = $form->table;

    # Render hidden fields first
    my @unhidden;
    
    foreach my $field ( $form->field ) 
    {
        $field->type( 'text' ) if $field->type eq 'textarea';
        
        push( @unhidden, $field ), next if $field->type ne 'hidden';
        
        $html .= $field->tag . "\n";   # no label/etc for hidden fields
    }

    foreach my $field ( @unhidden ) 
    {
        next if $field->static && $field->static > 1 && ! $field->tag_value;  # skip missing static vals
        
        if ( $table ) 
        {
            $html .= $form->td . $font . $field->tag;
            $html .= ' ' . $field->comment if $field->comment && ! $field->static;
            $html .= ' ' . $field->message if $field->invalid;
            $html .= $fcls . "</td>\n";
        }
        else
        {
            $html .= $field->label . ' ' . $field->tag . ' ';
            $html .= '<br />' if $form->linebreaks;
        }
    }
    
    # buttons
    my $buttons = $form->reset . $form->submit;
    
    if ( $buttons ) 
    {
        if ($table) 
        {
            my @buttons = split( '><', $form->reset . $form->submit );
            do { $_ .= '>' unless />$/; $_ = "<$_" unless /^</; } for @buttons;
            $html .= $form->td . $font . "${_}${fcls}</td>\n" for @buttons;
        }
        else
        {
            $html .= $buttons;
        }
    }
        
    # close off the form and row
    $html .= "</form>\n</tr>\n";
        
    return $html;
}


=item Maypole::Config::form_builder_defaults()

Defaults that apply to all forms. 

    # make all forms POST their data
    BeerFB->config->form_builder_defaults->{method} = 'post';

=item listviewmode

A convenience method to allow the default templates 
to work without a session. With no session configured, always returns C<list>. With a session, 
returns/sets the list view mode, which can be C<list> or C<editlist>.

=cut

sub listviewmode
{
    my ( $r, $new_mode ) = @_;
    
    return 'list' unless $r->can( 'session' ); 
    
    my $mode = $r->session->{listviewmode} || 'list';
    
    return $mode unless $new_mode;
    
    die "List view mode must be 'list' or 'editlist'" 
        unless $new_mode =~ /^(?:edit)?list$/;
        
    $r->session->{listviewmode} = $new_mode;
    
    return $mode;
}

=back

=head1 Configuring custom actions

Custom actions may require custom configuration of the form object (in addition to providing an Exported method in your model class to support the new action). Write a C<setup_form_mode> 
method in your model class. See 
L<Maypole::Plugin::FormBuilder::Model::Base|Maypole::Plugin::FormBuilder::Model::Base>.

=head1 SEE ALSO

L<Maypole::FormBuilder::Model|Maypole::FormBuilder::Model> and 
L<Maypole::FormBuilder::Model::Base|Maypole::FormBuilder::Model::Base>.

=head1 AUTHOR

David Baird, C<< <cpan@riverside-cms.co.uk> >>

=head1 BUGS

The way the pager is loaded (in setup()) means that every Maypole app in the current 
interpreter that uses the same model, will be using the same pager. I've no immediate plans 
to fix this unless someone asks me.

Please report any bugs or feature requests to
C<bug-maypole-formbuilder@rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Maypole-FormBuilder>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 COPYRIGHT & LICENSE

Copyright 2005 David Baird, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of Maypole::Plugin::FormBuilder