File Coverage

blib/lib/Text/FormBuilder.pm

Criterion	Covered	Total	%
statement	108	227	47.5
branch	18	96	18.7
condition	7	40	17.5
subroutine	15	22	68.1
pod	8	8	100.0
total	156	393	39.6

package Text::FormBuilder;

use strict;
use warnings;

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

$VERSION = '0.09_01';
@EXPORT = qw(create_form);

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

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

# the built in CSS for the template
my $DEFAULT_CSS = <
table { padding: 1em; }
#author, #footer { font-style: italic; }
caption h2 { padding: .125em .5em; background: #ccc; text-align: left; }
th { text-align: left; }
th h3 { padding: .125em .5em; background: #eee; }
th.label { font-weight: normal; text-align: right; vertical-align: top; }
td ul { list-style: none; padding-left: 0; margin-left: 0; }
.note { background: #eee; }
.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 => '(Required fields are marked in bold.)',
    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
    my $css;
    $css = $options{css} || $DEFAULT_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}))), 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') {
                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 the list for displaying checkbox groups
    foreach (@{ $self->{form_spec}{fields} }) {
        $$_{ulist} = 1 if ref $$_{options} and @{ $$_{options} } >= 3;
    }

    # remove extraneous undefined values
    for my $field (@{ $self->{form_spec}{fields} }) {
        defined $$field{$_} or delete $$field{$_} foreach keys %{ $field };
    }

    # remove false $$_{required} params because this messes up things at
    # the CGI::FormBuilder::field level; it seems to be marking required
    # based on the existance of a 'required' param, not whether it is
    # true or defined
    $$_{required} or delete $$_{required} foreach @{ $self->{form_spec}{fields} };

    foreach (@{ $self->{form_spec}{sections} }) {
        #for my $line (grep { $$_[0] eq 'field' } @{ $$_{lines} }) {
        for my $line (@{ $$_{lines} }) {
            if ($$line[0] eq 'field') {
                $$line[1] = $$line[1]{name};
##                 $_ eq 'name' or delete $$line[1]{$_} foreach keys %{ $$line[1] };
##             } elsif ($$line[0] eq 'group') {
##                 $$line[1] = [ map { $$_{name} } @{ $$line[1]{group} } ];
            }
        }
    }

    $self->{form} = CGI::FormBuilder->new(
        %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},
        template => {
            type => 'Text',
            engine => {
                TYPE       => 'STRING',
                SOURCE     => $form_only ? $self->_form_template : $self->_template($css, $charset),
                DELIMITERS => [ qw(<% %>) ],
            },
            data => {
                sections    => $self->{form_spec}{sections},
                author      => $self->{form_spec}{author},
                description => $self->{form_spec}{description},
            },
        },
        %options,
    );
    $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;
    }
}

# generates the core code to create the $form object
# the generated code assumes that you have a CGI.pm
# object named $q
sub _form_code {
    my $self = shift;

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

    # conditionally use Data::Dumper
    eval 'use Data::Dumper;';
    die "Can't write module; need Data::Dumper. $@" if $@;

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

    my $css;
    $css = $self->{build_options}{css} || $DEFAULT_CSS;
    $css .= $self->{build_options}{extra_css} if $self->{build_options}{extra_css};

    my %options = (
        %DEFAULT_OPTIONS,
        title => $self->{form_spec}{title},
        text  => $self->{form_spec}{description},
        fields   => [ map { $$_{name} } @{ $self->{form_spec}{fields} } ],
        required => [ map { $$_{name} } grep { $$_{required} } @{ $self->{form_spec}{fields} } ],
        template => {
            type => 'Text',
            engine => {
                TYPE       => 'STRING',
                SOURCE     => $self->{build_options}{form_only} ?
                                $self->_form_template :
                                $self->_template($css, $self->{build_options}{charset}),
                DELIMITERS => [ qw(<% %>) ],
            },
            data => {
                sections    => $self->{form_spec}{sections},
                author      => $self->{form_spec}{author},
                description => $self->{form_spec}{description},
            },
        },
        %{ $self->{build_options} },
    );

    # remove our custom options
    delete $options{$_} foreach qw(form_only css extra_css);

    my %module_subs;
    my $d = Data::Dumper->new([ \%options ], [ '*options' ]);

    use B::Deparse;
    my $deparse = B::Deparse->new;
##
##     #TODO: need a workaround/better solution since Data::Dumper doesn't like dumping coderefs
##     foreach (@{ $self->{form_spec}{fields} }) {
##         if (ref $$_{validate} eq 'CODE') {
##             my $body = $deparse->coderef2text($$_{validate});
##             #$d->Seen({ "*_validate_$$_{name}" => $$_{validate} });
##             #$module_subs{$$_{name}} = "sub _validate_$$_{name} $$_{validate}";
##         }
##     }
##     my $sub_code = join("\n", each %module_subs);

    my $form_options = keys %options > 0 ? $d->Dump : '';

    my $field_setup = join(
        "\n",
        map { '$form->field' . Data::Dumper->Dump([$_],['*field']) . ';' } @{ $self->{form_spec}{fields} }
    );

    return <
my \$form = CGI::FormBuilder->new(
    params => \$q,
    $form_options
);

$field_setup
END
}

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

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

    # remove a trailing .pm
    $package =~ s/\.pm$//;
##     warn  "[Text::FromBuilder::write_module] Removed extra '.pm' from package name\n" if $package =~ s/\.pm$//;

    my $form_code = $self->_form_code;

    my $module = <
package $package;
use strict;
use warnings;

use CGI::FormBuilder;

sub get_form {
    my \$q = shift;

    $form_code

    return \$form;
}

# module return
1;
END

    _write_output_file($module, (split(/::/, $package))[-1] . '.pm', $use_tidy);
    return $self;
}

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

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

    my $form_code = $self->_form_code;

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

use CGI;
use CGI::FormBuilder;

my \$q = CGI->new;

$form_code

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

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

sub _write_output_file {
    my ($source_code, $outfile, $use_tidy) = @_;
    if ($use_tidy) {
        # clean up the generated code, if asked
        eval 'use Perl::Tidy';
        unless ($@) {
            Perl::Tidy::perltidy(source => \$source_code, destination => $outfile, argv => $TIDY_OPTIONS);
        } else {
            carp '[' . (caller(0))[3] . "] Can't tidy the code: $@" if $@;
            # fallback to just writing it as-is
            open OUT, "> $outfile" or die $!;
            print OUT $source_code;
            close OUT;
        }
    } else {
        # otherwise, just print as is
        open OUT, "> $outfile" or die $!;
        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]; ] if $$section{head}; \n] \n] ] : qq[  ]; ]; '; "; ]; \n]; \n] : qq[  \n]; \n]; \n]; 




494




 





 





 





 





 





 



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




495




 





 





 





 





 





 



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




496




 





 





 





 





 





 



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




497




 





 





 





 





 





 



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




498




 





 





 





 





 





 



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




499




 





 





 





 





 





 



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




500




 





 





 





 





 





 



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




501




 





 





 





 





 





 



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




502




 





 





 





 





 





 



                  




503




 





 





 





 





 





 



                 # skip hidden fields in the table 




504




 





 





 





 





 





 



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




505




 





 





 





 





 





 



                  




506




 





 





 





 





 





 



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




507




 





 





 





 





 





 



                  




508




 





 





 





 





 





 



                 # special case single value checkboxes 




509




 





 





 





 





 





 



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




510




 





 





 





 





 





 



                     $OUT .= qq[




511




 





 





 





 





 





 



                 } else { 




512




 





 





 





 





 





 



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




513




 





 





 





 





 





 



                 } 




514




 





 





 





 





 





 



                  




515




 





 





 





 





 





 



                 # mark invalid fields 




516




 





 





 





 





 





 



                 if ($$_{invalid}) { 




517




 





 





 





 





 





 



                     $OUT .= "$$_{field} $$_{comment} ] . $msg_invalid . q[




518




 





 





 





 





 





 



                 } else { 




519




 





 





 





 





 





 



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




520




 





 





 





 





 





 



                 } 




521




 





 





 





 





 





 



                  




522




 





 





 





 





 





 



                 $OUT .= qq[




523




 





 





 





 





 





 



                  




524




 





 





 





 





 





 



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




525




 





 





 





 





 





 



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




526




 





 





 





 





 





 



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




527




 





 





 





 





 





 



                  




528




 





 





 





 





 





 



                 $OUT .= '    '; 




529




 





 





 





 





 





 



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




530




 





 





 





 





 





 



                 $OUT .= qq[\n]; 




531




 





 





 





 





 





 



                  




532




 





 





 





 





 





 



                 $OUT .= qq[    ]; 




533




 





 





 





 





 





 



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




534




 





 





 





 





 





 



                 $OUT .= " $msg_invalid" if $$_{invalid}; 




535




 





 





 





 





 





 



   




536




 





 





 





 





 





 



                 $OUT .= qq[    




537




 





 





 





 





 





 



                 $OUT .= qq[  




538




 





 





 





 





 





 



             }    




539




 





 





 





 





 





 



         } 




540




 





 





 





 





 





 



         # close the table if there are sections remaining 




541




 





 





 





 





 





 



         # but leave the last one open for the submit button 




542




 





 





 





 





 





 



         $OUT .= qq[\n] if @sections;
        $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 .= "
                } 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[\n];

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

                $OUT .= qq[
                $OUT .= qq[
            }
        }
        # close the table if there are sections remaining
        # but leave the last one open for the submit button
        $OUT .= qq[
    }
%>