package Text::FormBuilder; use strict; use warnings; use base qw(Exporter Class::ParseText::Base); use vars qw($VERSION @EXPORT); $VERSION = '0.10'; @EXPORT = qw(create_form); #$::RD_TRACE = 1; 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 = < '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 # 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') { 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}; } } } # 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}, 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, }; # 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 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_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 = <new( $form_options, \@_, ); $field_setup return \$self; } # module return 1; END # new style of module my $module = <new( $form_options, \@_, ); $field_setup # re-bless into this class bless \$self, \$class; } # 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_options = $self->_form_options_code; my $field_setup = $self->_field_setup_code('$form'); my $script = <new( $form_options ); $field_setup 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]; $OUT .= qq[ $$section{head}] if $$section{head}; $OUT .= qq[\n]; #$OUT .= qq[ ] if $$section{head}; TABLE_LINE: for my $line (@{ $$section{lines} }) { if ($$line[0] eq 'head') { $OUT .= qq[ \n] } elsif ($$line[0] eq 'note') { $OUT .= qq[ \n] } 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[ ] : 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[\n]; } elsif ($$line[0] eq 'group') { my @group_fields = map { $field{$_} } map { $$_{name} } @{ $$line[1]{group} }; $OUT .= (grep { $$_{invalid} } @group_fields) ? qq[ \n] : qq[ \n]; $OUT .= ' \n]; $OUT .= qq[ \n]; $OUT .= qq[ \n]; } } # close the table if there are sections remaining # but leave the last one open for the submit button if (@sections) { $OUT .= qq[

$$section{head}

$$line[1]

$$line[1]
' . ($$_{required} ? qq[$$_{label}] : "$$_{label}") . '$$_{field} $$_{comment} ] . $msg_invalid . q[$$_{field} $$_{comment}
'; $OUT .= (grep { $$_{required} } @group_fields) ? qq[$$line[1]{label}] : "$$line[1]{label}"; $OUT .= qq[]; $OUT .= join(' ', map { qq[$$_{label} $$_{field} $$_{comment}] } @group_fields); #TODO: allow comments on field groups $OUT .= " ] . $msg_invalid . q[" if grep { $$_{invalid} } @group_fields; $OUT .= qq[ $$line[1]{comment}
\n]; $OUT .= qq[
\n]; } } %> <% $submit %> <% $end %> ]; } # usage: $self->_pre_template($css, $charset) sub _pre_template { my $self = shift; my $css = shift || $DEFAULT_CSS; my $charset = shift || $DEFAULT_CHARSET; my $msg_author = 'sprintf("' . quotemeta($self->{build_options}{messages}{text_author}) . '", $author)'; return q[ <% $title %><% $author ? ' - ' . ucfirst $author : '' %> <% $jshead %>

<% $title %>

<% $author ? qq[

] . ] . $msg_author . q{ . q[

] : '' %> }; } sub _post_template { my $self = shift; my $msg_madewith = 'sprintf("' . quotemeta($self->{build_options}{messages}{text_madewith}) . '", q[CGI::FormBuilder], CGI::FormBuilder->VERSION)'; return qq[
]; } # usage: $self->_template($css, $charset) sub _template { my $self = shift; return $self->_pre_template(@_) . $self->_form_template . $self->_post_template; } sub dump { eval "use YAML;"; unless ($@) { print YAML::Dump(shift->{form_spec}); } else { warn '[' . (caller(0))[3] . "] Can't dump form spec structure using YAML: $@"; } } # module return 1; =head1 NAME Text::FormBuilder - Create CGI::FormBuilder objects from simple text descriptions =head1 SYNOPSIS use Text::FormBuilder; my $parser = Text::FormBuilder->new; $parser->parse($src_file); # returns a new CGI::FormBuilder object with # the fields from the input form spec my $form = $parser->form; # write a My::Form module to Form.pm $parser->write_module('My::Form'); =head1 REQUIRES L, L, L, L =head1 DESCRIPTION This module is intended to extend the idea of making it easy to create web forms by allowing you to describe them with a simple langauge. These I are then passed through this module's parser and converted into L objects that you can easily use in your CGI scripts. In addition, this module can generate code for standalone modules which allow you to separate your form design from your script code. A simple formspec looks like this: name//VALUE email//EMAIL langauge:select{English,Spanish,French,German} moreinfo|Send me more information:checkbox interests:checkbox{Perl,karate,bass guitar} This will produce a required C test field, a required C text field that must look like an email address, an optional select dropdown field C with the choices English, Spanish, French, and German, an optional C checkbox labeled ``Send me more information'', and finally a set of checkboxes named C with the choices Perl, karate, and bass guitar. =head1 METHODS =head2 new my $parser = Text::FormBuilder->new; =head2 parse # parse a file (regular scalar) $parser->parse($filename); # or pass a scalar ref for parse a literal string $parser->parse(\$string); # or an array ref to parse lines $parser->parse(\@lines); Parse the file or string. Returns the parser object. This method, along with all of its C siblings, may be called as a class method to construct a new object. =head2 parse_file $parser->parse_file($src_file); # or as a class method my $parser = Text::FormBuilder->parse($src_file); =head2 parse_text $parser->parse_text($src); Parse the given C<$src> text. Returns the parser object. =head2 parse_array $parser->parse_array(@lines); Concatenates and parses C<@lines>. Returns the parser object. =head2 build $parser->build(%options); Builds the CGI::FormBuilder object. Options directly used by C are: =over =item C Only uses the form portion of the template, and omits the surrounding html, title, author, and the standard footer. This does, however, include the description as specified with the C directive. =item C, C These options allow you to tell Text::FormBuilder to use different CSS styles for the built in template. A value given a C will replace the existing CSS, and a value given as C will be appended to the CSS. If both options are given, then the CSS that is used will be C concatenated with C. If you want to use an external stylesheet, a quick way to get this is to set the C parameter to import your file: css => '@import(my_external_stylesheet.css);' =item C If you want to use multiple external stylesheets, or an external stylesheet in conojunction with the default styles, use the C option: # single external sheet external_css => 'my_styles.css' # mutliple sheets external_css => [ 'my_style_A.css', 'my_style_B.css', ] =item C This works the same way as the C parameter to C<< CGI::FormBuilder->new >>; you can provide either a hashref of messages or a filename. The default messages used by Text::FormBuilder are: 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. Any messages you set here get passed on to CGI::FormBuilder, which means that you should be able to put all of your customization messages in one big file. =item C Sets the character encoding for the generated page. The default is ISO-8859-1. =back All other options given to C are passed on verbatim to the L constructor. Any options given here override the defaults that this module uses. The C
, C, and C methods will all call C with no options for you if you do not do so explicitly. This allows you to say things like this: my $form = Text::FormBuilder->new->parse('formspec.txt')->form; However, if you need to specify options to C, you must call it explictly after C. =head2 form my $form = $parser->form; Returns the L object. Remember that you can modify this object directly, in order to (for example) dynamically populate dropdown lists or change input types at runtime. =head2 write $parser->write($out_file); # or just print to STDOUT $parser->write; Calls C on the FormBuilder form, and either writes the resulting HTML to a file, or to STDOUT if no filename is given. =head2 write_module I The code output from the C methods may be in flux for the next few versions, as I coordinate with the B project.> $parser->write_module($package, $use_tidy); Takes a package name, and writes out a new module that can be used by your CGI script to render the form. This way, you only need CGI::FormBuilder on your server, and you don't have to parse the form spec each time you want to display your form. The generated module is a subclass of L, that will pass along any constructor arguments to FormBuilder, and set up the fields for you. First, you parse the formspec and write the module, which you can do as a one-liner: $ perl -MText::FormBuilder -e"Text::FormBuilder->parse('formspec.txt')->write_module('My::Form')" And then, in your CGI script, use the new module: #!/usr/bin/perl -w use strict; use CGI; use My::Form; my $q = CGI->new; my $form = My::Form->new; # do the standard CGI::FormBuilder stuff if ($form->submitted && $form->validate) { # process results } else { print $q->header; print $form->render; } If you pass a true value as the second argument to C, the parser will run L on the generated code before writing the module file. # write tidier code $parser->write_module('My::Form', 1); =head2 write_script $parser->write_script($filename, $use_tidy); If you don't need the reuseability of a separate module, you can have Text::FormBuilder write the form object to a script for you, along with the simplest framework for using it, to which you can add your actual form processing code. The generated script looks like this: #!/usr/bin/perl use strict; use warnings; use CGI::FormBuilder; my $form = CGI::FormBuilder->new( # lots of stuff here... ); # ...and your field setup subs are here $form->field(name => '...'); unless ($form->submitted && $form->validate) { print $form->render; } else { # do something with the entered data } Like C, you can optionally pass a true value as the second argument to have Perl::Tidy make the generated code look nicer. =head2 dump Uses L to print out a human-readable representation of the parsed form spec. =head1 EXPORTS There is one exported function, C, that is intended to ``do the right thing'' in simple cases. =head2 create_form # get a CGI::FormBuilder object my $form = create_form($source, $options, $destination); # or just write the form immediately create_form($source, $options, $destination); C<$source> accepts any of the types of arguments that C does. C<$options> is a hashref of options that should be passed to C. Finally, C<$destination> is a simple scalar that determines where and what type of output C should generate. /\.pm$/ ->write_module($destination) /\.(cgi|pl)$/ ->write_script($destination) everything else ->write($destination) For anything more than simple, one-off cases, you are usually better off using the object-oriented interface, since that gives you more control over things. =head1 DEFAULTS These are the default settings that are passed to C<< CGI::FormBuilder->new >>: method => 'GET' keepextras => 1 Any of these can be overriden by the C method: # use POST instead $parser->build(method => 'POST')->write; =head1 LANGUAGE # name field_size growable label hint type other default option_list validate field_name[size]|descriptive label[hint]:type=default{option1[display string],...}//validate !title ... !author ... !description { ... } !pattern NAME /regular expression/ !list NAME { option1[display string], option2[display string], ... } !group NAME { field1 field2 ... } !section id heading !head ... !note { ... } =head2 Directives =over =item C Defines a validation pattern. =item C Defines a list for use in a C, C, or C field that includes an "other" option, append the string C<+other> to the field type: position:select+other Or, to let FormBuilder decide whether to use radio buttons or a dropdown: position+other Like growable fields, 'other' fields require FormBuilder 3.02 or higher. For the input types that can have options (C