File Coverage

blib/lib/Text/FormBuilder.pm

Criterion	Covered	Total	%
statement	113	250	45.2
branch	22	110	20.0
condition	6	42	14.2
subroutine	15	26	57.6
pod	10	10	100.0
total	166	438	37.9

package Text::FormBuilder;

use strict;
use warnings;

use base qw(Exporter Class::ParseText::Base);
use vars qw($VERSION @EXPORT);

$VERSION = '0.14';
@EXPORT = qw(create_form);

use Carp;
use Text::FormBuilder::Parser;
use CGI::FormBuilder;

use Data::Dumper;
$Data::Dumper::Terse = 1;           # don't dump $VARn names
$Data::Dumper::Quotekeys = 0;       # don't quote simple string keys

# the static default options passed to CGI::FormBuilder->new
my %DEFAULT_OPTIONS = (
    method => 'GET',
    keepextras => 1,
);

# the built in CSS for the template
my $DEFAULT_CSS = <
table { padding: 1em; }
td table { padding: 0; } /* exclude the inner checkbox tables */
#author, #footer { font-style: italic; }
caption h2 { padding: .125em .5em; background: #ccc; text-align: left; }
fieldset { margin: 1em 0; border: none; border-top: 2px solid #999; }
legend { font-size: 1.25em; font-weight: bold; background: #ccc; padding: .125em .25em; border: 1px solid #666; }
th { text-align: left; }
th h2 { padding: .125em .5em; background: #eee; font-size: 1.25em; }
.label { font-weight: normal; text-align: right; vertical-align: top; }
td ul { list-style: none; padding-left: 0; margin-left: 0; }
.note { background: #eee; padding: .5em 1em; }
.sublabel { color: #999; }
.invalid { background: red; }
END

# default messages that can be localized
my %DEFAULT_MESSAGES = (
    text_author   => 'Created by %s',
    text_madewith => 'Made with %s version %s',
    text_required => 'Fields that are highlighted are required.',
    text_invalid  => 'Missing or invalid value.',
);

my $DEFAULT_CHARSET = 'iso-8859-1';

# options to clean up the code with Perl::Tidy
my $TIDY_OPTIONS = '-nolq -ci=4 -ce';

my $HTML_EXTS   = qr/\.html?$/;
my $MODULE_EXTS = qr/\.pm$/;
my $SCRIPT_EXTS = qr/\.(pl|cgi)$/;

# superautomagical exported function
sub create_form {
    my ($source, $options, $destination) = @_;
    my $parser = __PACKAGE__->parse($source);
    $parser->build(%{ $options || {} });
    if ($destination) {
        if (ref $destination) {
            croak '[' . (caller(0))[3] . "] Don't know what to do with a ref for $destination";
            #TODO: what DO ref dests mean?
        } else {
            # write webpage, script, or module
            if ($destination =~ $MODULE_EXTS) {
                $parser->write_module($destination, 1);
            } elsif ($destination =~ $SCRIPT_EXTS) {
                $parser->write_script($destination, 1);
            } else {
                $parser->write($destination);
            }
        }
    } else {
        defined wantarray ? return $parser->form : $parser->write;
    }
}

# subclass of Class::ParseText::Base
sub init {
    my $self = shift;
    $self->{parser}         = Text::FormBuilder::Parser->new;
    $self->{start_rule}     = 'form_spec';
    $self->{ensure_newline} = 1;
    return $self;
}

# this is where a lot of the magic happens
sub build {
    my ($self, %options) = @_;

    # our custom %options:
    # form_only: use only the form part of the template
    my $form_only = $options{form_only};

    # css, extra_css: allow for custom inline stylesheets
    #   neat trick: css => '@import(my_external_stylesheet.css);'
    #   will let you use an external stylesheet
    #   CSS Hint: to get multiple sections to all line up their fields,
    #   set a standard width for th.label
    # external_css: scalar for a single external stylesheet; array for
    #   multiple sheets; prepended to the beginning of the CSS as @import
    #   statetments
    my $css;
    $css = $options{css} || $DEFAULT_CSS;
    if ($options{external_css}) {
        my $ref = ref $options{external_css};
        if ($ref eq 'ARRAY') {
            # loop over the list of external sheets
            my $external_sheets = join("\n", map { "\@import url($_);" } @{ $options{external_css} });
            $css = "$external_sheets\n$css";
        } elsif ($ref) {
            croak '[' . (caller(0))[3] . "] Don't know how to handle $ref reference as an argument to external_css";
        } else {
            $css = "\@import url($options{external_css});\n$css";
        }
    }
    $css .= $options{extra_css} if $options{extra_css};

    # messages
    # code pulled (with modifications) from CGI::FormBuilder
    if ($options{messages}) {
        # if its a hashref, we'll just pass it on to CGI::FormBuilder

        if (my $ref = ref $options{messages}) {
            # hashref pass on to CGI::FormBuilder
            croak "[Text::FormBuilder] Argument to 'messages' option must be a filename or hashref" unless $ref eq 'HASH';
            while (my ($key,$value) = each %DEFAULT_MESSAGES) {
                $options{messages}{$key} ||= $DEFAULT_MESSAGES{$key};
            }
        } else {
            # filename, just *warn* on missing, and use defaults
            if (-f $options{messages} && -r _ && open(MESSAGES, "< $options{messages}")) {
                $options{messages} = { %DEFAULT_MESSAGES };
                while() {
                    next if /^\s*#/ || /^\s*$/;
                    chomp;
                    my($key,$value) = split ' ', $_, 2;
                    ($options{messages}{$key} = $value) =~ s/\s+$//;
                }
                close MESSAGES;
            } else {
                carp '[' . (caller(0))[3] . "] Could not read messages file $options{messages}: $!";
            }
        }
    } else {
        $options{messages} = { %DEFAULT_MESSAGES };
    }

    # character set
    my $charset = $options{charset};

    # save the build options so they can be used from write_module
    $self->{build_options} = { %options };

    # remove our custom options before we hand off to CGI::FormBuilder
    delete $options{$_} foreach qw(form_only css extra_css charset);

    # expand groups
    if (my %groups = %{ $self->{form_spec}{groups} || {} }) {
        for my $section (@{ $self->{form_spec}{sections} || [] }) {
            foreach (grep { $$_[0] eq 'group' } @{ $$section{lines} }) {
                $$_[1]{group} =~ s/^\%//;       # strip leading % from group var name

                if (exists $groups{$$_[1]{group}}) {
                    my @fields; # fields in the group
                    push @fields, { %$_ } foreach @{ $groups{$$_[1]{group}} };
                    for my $field (@fields) {
                        $$field{label} ||= ucfirst $$field{name};
                        $$field{name} = "$$_[1]{name}_$$field{name}";
                    }
                    $_ = [
                        'group',
                        {
                            label => $$_[1]{label} || ucfirst(join(' ',split('_',$$_[1]{name}))),
                            comment => $$_[1]{comment},
                            group => \@fields,
                        },
                    ];
                }
            }
        }
    }

    # the actual fields that are given to CGI::FormBuilder
    # make copies so that when we trim down the sections
    # we don't lose the form field information
    $self->{form_spec}{fields} = [];

    for my $section (@{ $self->{form_spec}{sections} || [] }) {
        for my $line (@{ $$section{lines} }) {
            if ($$line[0] eq 'group') {
                push @{ $self->{form_spec}{fields} }, { %{$_} } foreach @{ $$line[1]{group} };
            } elsif ($$line[0] eq 'field') {
                #die $$line[1] unless ref $$line[1];
                push @{ $self->{form_spec}{fields} }, { %{$$line[1]} };
            }
        }
    }

    # substitute in custom validation subs and pattern definitions for field validation
    my %patterns = %{ $self->{form_spec}{patterns} || {} };
    my %subs = %{ $self->{form_spec}{subs} || {} };

    foreach (@{ $self->{form_spec}{fields} }) {
        if ($$_{validate}) {
            if (exists $patterns{$$_{validate}}) {
                $$_{validate} = $patterns{$$_{validate}};
            # TODO: need the Data::Dumper code to work for this
            # for now, we just warn that it doesn't work
            } elsif (exists $subs{$$_{validate}}) {
                warn '[' . (caller(0))[3] . "] validate coderefs don't work yet";
                delete $$_{validate};
##                 $$_{validate} = $subs{$$_{validate}};
            }
        }
    }

    # get user-defined lists; can't make this conditional because
    # we need to be able to fall back to CGI::FormBuilder's lists
    # even if the user didn't define any
    my %lists = %{ $self->{form_spec}{lists} || {} };

    # substitute in list names
    foreach (@{ $self->{form_spec}{fields} }) {
        next unless $$_{list};

        $$_{list} =~ s/^\@//;   # strip leading @ from list var name

        # a hack so we don't get screwy reference errors
        if (exists $lists{$$_{list}}) {
            my @list;
            push @list, { %$_ } foreach @{ $lists{$$_{list}} };
            $$_{options} = \@list;
        } else {
            # assume that the list name is a builtin
            # and let it fall through to CGI::FormBuilder
            $$_{options} = $$_{list};
        }
    } continue {
        delete $$_{list};
    }

    # special case single-value checkboxes
    foreach (grep { $$_{type} && $$_{type} eq 'checkbox' } @{ $self->{form_spec}{fields} }) {
        unless ($$_{options}) {
            $$_{options} = [ { $$_{name} => $$_{label} || ucfirst join(' ',split(/_/,$$_{name})) } ];
        }
    }

    # use columns for displaying checkbox fields larger than 2 items
    foreach (@{ $self->{form_spec}{fields} }) {
        if (ref $$_{options} and @{ $$_{options} } >= 3) {
            $$_{columns} = int(@{ $$_{options} } / 8) + 1;
        }
    }

    # remove extraneous undefined values
    # also check for approriate version of CGI::FormBuilder
    # for some advanced options
    my $FB_version = CGI::FormBuilder->VERSION;
    for my $field (@{ $self->{form_spec}{fields} }) {
        defined $$field{$_} or delete $$field{$_} foreach keys %{ $field };

        unless ($FB_version >= '3.02') {
            for (qw(growable other)) {
                if ($$field{$_}) {
                    warn '[' . (caller(0))[3] . "] '$_' fields not supported by FB $FB_version (requires 3.02)";
                    delete $$field{$_};
                }
            }
        }
    }

    # assign the field names to the sections
    foreach (@{ $self->{form_spec}{sections} }) {
        for my $line (@{ $$_{lines} }) {
            if ($$line[0] eq 'field') {
                $$line[1] = $$line[1]{name};
            }
        }
    }

    my %fb_params;
    if ($self->{form_spec}->{fb_params}) {
        require YAML;
        eval { %fb_params = %{ YAML::Load($self->{form_spec}->{fb_params}) } };
        if ($@) {
            warn '[' . (caller(0))[3] . "] Bad !fb parameter block:\n$@";
        }
    }

    # gather together all of the form options
    $self->{form_options} = {
        %DEFAULT_OPTIONS,
        # need to explicity set the fields so that simple text fields get picked up
        fields   => [ map { $$_{name} } @{ $self->{form_spec}{fields} } ],
        required => [ map { $$_{name} } grep { $$_{required} } @{ $self->{form_spec}{fields} } ],
        title => $self->{form_spec}{title},
        text  => $self->{form_spec}{description},
        # use 'defined' so we are able to differentiate between 'submit = 0' (no submit button)
        # and 'submit = undef' (use default submit button)
        ( defined $self->{form_spec}{submit} ? (submit => $self->{form_spec}{submit}) : () ),
        reset => $self->{form_spec}{reset},
        template => {
            type => 'Text',
            engine => {
                TYPE       => 'STRING',
                SOURCE     => $form_only ? $self->_form_template : $self->_template($css, $charset),
                DELIMITERS => [ qw(<% %>) ],
            },
            data => {
                #TODO: make FB aware of sections
                sections    => $self->{form_spec}{sections},
                author      => $self->{form_spec}{author},
                description => $self->{form_spec}{description},
            },
        },
        #TODO: fields in fb_params are not getting recognized
        %fb_params,     # params from the formspec file
        %options,       # params from this method invocation
    };

    # create the form object
    $self->{form} = CGI::FormBuilder->new(%{ $self->{form_options} });

    # ...and set up its fields
    $self->{form}->field(%{ $_ }) foreach @{ $self->{form_spec}{fields} };

    # mark structures as built
    $self->{built} = 1;

    return $self;
}

sub write {
    my ($self, $outfile) = @_;

    # automatically call build if needed to
    # allow the new->parse->write shortcut
    $self->build unless $self->{built};

    if ($outfile) {
        open FORM, "> $outfile";
        print FORM $self->form->render;
        close FORM;
    } else {
        print $self->form->render;
    }
}

# dump the form options as eval-able code
sub _form_options_code {
    my $self = shift;
    my $d = Data::Dumper->new([ $self->{form_options} ], [ '*options' ]);
    return keys %{ $self->{form_options} } > 0 ? $d->Dump : '';
}
# dump the field setup subs as eval-able code
# pass in the variable name of the form object
# (defaults to '$form')
# TODO: revise this code to use the new 'fieldopts'
# option to the FB constructor (requires FB 3.02)
sub _field_setup_code {
    my $self = shift;
    my $object_name = shift || '$form';
    return join(
        "\n",
        map { $object_name . '->field' . Data::Dumper->Dump([$_],['*field']) . ';' } @{ $self->{form_spec}{fields} }
    );
}

sub as_module {
    my ($self, $package, $use_tidy) = @_;

    croak '[' . (caller(0))[3] . '] Expecting a package name' unless $package;

    # remove a trailing .pm
    $package =~ s/\.pm$//;

    # auto-build
    $self->build unless $self->{built};

    my $form_options = $self->_form_options_code;
    my $field_setup = $self->_field_setup_code('$self');

    # old style of module
    # TODO: how to keep this (as deprecated method)
    my $old_module = <
package $package;
use strict;
use warnings;

use CGI::FormBuilder;

sub get_form {
    my \$q = shift;

    my \$self = CGI::FormBuilder->new(
        $form_options,
        \@_,
    );

    $field_setup

    return \$self;
}

# module return
1;
END

    # new style of module
    my $module = <
package $package;
use strict;
use warnings;

use base qw(CGI::FormBuilder);

sub new {
    my \$invocant = shift;
    my \$class = ref \$invocant || \$invocant;

    my \$self = CGI::FormBuilder->new(
        $form_options,
        \@_,
    );

    $field_setup

    # re-bless into this class
    bless \$self, \$class;
}

# module return
1;
END

    $module = _tidy_code($module, $use_tidy) if $use_tidy;

    return $module;
}

sub write_module {
    my ($self, $package, $use_tidy) = @_;

    my $module = $self->as_module($package, $use_tidy);

    my $outfile = (split(/::/, $package))[-1];
    $outfile .= '.pm' unless $outfile =~ /\.pm$/;
    _write_output_file($module, $outfile);
    return $self;
}

sub as_script {
    my ($self, $use_tidy) = @_;

    # auto-build
    $self->build unless $self->{built};

    my $form_options = $self->_form_options_code;
    my $field_setup = $self->_field_setup_code('$form');

    my $script = <
#!/usr/bin/perl
use strict;
use warnings;

use CGI::FormBuilder;

my \$form = CGI::FormBuilder->new(
    $form_options
);

$field_setup

unless (\$form->submitted && \$form->validate) {
    print \$form->render;
} else {
    # do something with the entered data
}
END
    $script = _tidy_code($script, $use_tidy) if $use_tidy;

    return $script;
}

sub write_script {
    my ($self, $script_name, $use_tidy) = @_;

    croak '[' . (caller(0))[3] . '] Expecting a script name' unless $script_name;

    my $script = $self->as_script($use_tidy);

    _write_output_file($script, $script_name);
    return $self;
}

sub _tidy_code {
    my ($source_code, $use_tidy) = @_;
    eval 'use Perl::Tidy';
    carp '[' . (caller(0))[3] . "] Can't tidy the code: $@" and return $source_code if $@;

    # use the options string only if it begins with '_'
    my $options = ($use_tidy =~ /^-/) ? $use_tidy : undef;

    my $tidy_code;
    Perl::Tidy::perltidy(source => \$source_code, destination => \$tidy_code, argv => $options || $TIDY_OPTIONS);

    return $tidy_code;
}


sub _write_output_file {
    my ($source_code, $outfile) = @_;
    open OUT, "> $outfile" or croak '[' . (caller(1))[3] . "] Can't open $outfile for writing: $!";
    print OUT $source_code;
    close OUT;
}


sub form {
    my $self = shift;

    # automatically call build if needed to
    # allow the new->parse->write shortcut
    $self->build unless $self->{built};

    return $self->{form};
}

sub _form_template {
    my $self = shift;
    my $msg_required = $self->{build_options}{messages}{text_required};
    my $msg_invalid = $self->{build_options}{messages}{text_invalid};
    return q{<% $description ? qq[$description] : '' %>
<% (grep { $_->{required} } @fields) ? qq[} . $msg_required . q{] : '' %>
<% $start %>
<%
    # drop in the hidden fields here
    $OUT = join("\n", map { $$_{field} } grep { $$_{type} eq 'hidden' } @fields);
%>} .
q[
<%
    SECTION: while (my $section = shift @sections) {
        $OUT .= qq[\n];
        $OUT .= qq[  $$section{head}] if $$section{head};
        $OUT .= qq[\n]; ] if $$section{head}; \n] \n] ] : qq[  ]; ]; '; ]; ]; \n]; \n] : qq[  \n]; \n]; \n]; \n]; 




554




 





 





 





 





 





 



         #$OUT .= qq[  $$section{head}




555




 





 





 





 





 





 



         TABLE_LINE: for my $line (@{ $$section{lines} }) { 




556




 





 





 





 





 





 



             if ($$line[0] eq 'head') { 




557




 





 





 





 





 





 



                 $OUT .= qq[  $$line[1]




558




 





 





 





 





 





 



             } elsif ($$line[0] eq 'note') { 




559




 





 





 





 





 





 



                 $OUT .= qq[  $$line[1]




560




 





 





 





 





 





 



             } elsif ($$line[0] eq 'field') { 




561




 





 





 





 





 





 



                 local $_ = $field{$$line[1]}; 




562




 





 





 





 





 





 



                  




563




 





 





 





 





 





 



                 # skip hidden fields in the table 




564




 





 





 





 





 





 



                 next TABLE_LINE if $$_{type} eq 'hidden'; 




565




 





 





 





 





 





 



                  




566




 





 





 





 





 





 



                 $OUT .= $$_{invalid} ? qq[  




567




 





 





 





 





 





 



                  




568




 





 





 





 





 





 



                 # special case single value checkboxes 




569




 





 





 





 





 





 



                 if ($$_{type} eq 'checkbox' && @{ $$_{options} } == 1) { 




570




 





 





 





 





 





 



                     $OUT .= qq[




571




 





 





 





 





 





 



                 } else { 




572




 





 





 





 





 





 



                     $OUT .= '' . ($$_{required} ? qq[$$_{label}] : "$$_{label}") . '




573




 





 





 





 





 





 



                 } 




574




 





 





 





 





 





 



                  




575




 





 





 





 





 





 



                 # mark invalid fields 




576




 





 





 





 





 





 



                 if ($$_{invalid}) { 




577




 





 





 





 





 





 



                     $OUT .= qq[$$_{field} $$_{comment} $$_{error}




578




 





 





 





 





 





 



                 } else { 




579




 





 





 





 





 





 



                     $OUT .= qq[$$_{field} $$_{comment}




580




 





 





 





 





 





 



                 } 




581




 





 





 





 





 





 



                  




582




 





 





 





 





 





 



                 $OUT .= qq[




583




 





 





 





 





 





 



                  




584




 





 





 





 





 





 



             } elsif ($$line[0] eq 'group') { 




585




 





 





 





 





 





 



                 my @group_fields = map { $field{$_} } map { $$_{name} } @{ $$line[1]{group} }; 




586




 





 





 





 





 





 



                 $OUT .= (grep { $$_{invalid} } @group_fields) ? qq[  




587




 





 





 





 





 





 



                  




588




 





 





 





 





 





 



                 $OUT .= '    '; 




589




 





 





 





 





 





 



                 $OUT .= (grep { $$_{required} } @group_fields) ? qq[$$line[1]{label}] : "$$line[1]{label}"; 




590




 





 





 





 





 





 



                 $OUT .= qq[




591




 





 





 





 





 





 



                  




592




 





 





 





 





 





 



                 $OUT .= qq[    ]; 




593




 





 





 





 





 





 



                 $OUT .= join(' ', map { qq[$$_{label} $$_{field} $$_{comment}] } @group_fields); 




594




 





 





 





 





 





 



                 if (my @invalid = grep { $$_{invalid} } @group_fields) { 




595




 





 





 





 





 





 



                     $OUT .= ' ' . join('; ', map { $$_{error} } @invalid); 




596




 





 





 





 





 





 



                 }                 




597




 





 





 





 





 





 



                 $OUT .= qq[ $$line[1]{comment}




598




 





 





 





 





 





 



                 $OUT .= qq[  




599




 





 





 





 





 





 



             }    




600




 





 





 





 





 





 



         } 




601




 





 





 





 





 





 



         # close the table if there are sections remaining 




602




 





 





 





 





 





 



         # but leave the last one open for the submit button 




603




 





 





 





 





 





 



         if (@sections) { 




604




 





 





 





 





 





 



             $OUT .= qq[\n];
        #$OUT .= qq[
        TABLE_LINE: for my $line (@{ $$section{lines} }) {
            if ($$line[0] eq 'head') {
                $OUT .= qq[
            } elsif ($$line[0] eq 'note') {
                $OUT .= qq[
            } elsif ($$line[0] eq 'field') {
                local $_ = $field{$$line[1]};

                # skip hidden fields in the table
                next TABLE_LINE if $$_{type} eq 'hidden';

                $OUT .= $$_{invalid} ? qq[

                # special case single value checkboxes
                if ($$_{type} eq 'checkbox' && @{ $$_{options} } == 1) {
                    $OUT .= qq[
                } else {
                    $OUT .= '
                }

                # mark invalid fields
                if ($$_{invalid}) {
                    $OUT .= qq[
                } else {
                    $OUT .= qq[
                }

                $OUT .= qq[

            } elsif ($$line[0] eq 'group') {
                my @group_fields = map { $field{$_} } map { $$_{name} } @{ $$line[1]{group} };
                $OUT .= (grep { $$_{invalid} } @group_fields) ? qq[

                $OUT .= '
                $OUT .= (grep { $$_{required} } @group_fields) ? qq[$$line[1]{label}] : "$$line[1]{label}";
                $OUT .= qq[

                $OUT .= qq[
                $OUT .= join(' ', map { qq[$$_{label} $$_{field} $$_{comment}] } @group_fields);
                if (my @invalid = grep { $$_{invalid} } @group_fields) {
                    $OUT .= ' ' . join('; ', map { $$_{error} } @invalid);
                }
                $OUT .= qq[ $$line[1]{comment}
                $OUT .= qq[
            }
        }
        # close the table if there are sections remaining
        # but leave the last one open for the submit button
        if (@sections) {
            $OUT .= qq[
            $OUT .= qq[\n];
        }
    }
%>