Index: /tags/0.06_02/Changes =================================================================== --- /tags/0.06_02/Changes (revision 36) +++ /tags/0.06_02/Changes (revision 36) @@ -0,0 +1,18 @@ +Release history for Text::FormBuilder. + +0.06 + * marked Parse::RecDescent as an explicit dependency + * added a single-quoted string to the grammar that + can be used in the labels and default values to include + characters in [^\w\t ] + * generated code leaves out overwrriten options + * allow option lists to have simple multiword and quoted + string values + * allow for validated but not required fields + * added a !section directive that splits up a form into + sub-tables with their own ids and captions + * fall through to CGI::FormBuilder builtin option lists + if @LIST does not match a list directive + +0.05 - 9 Nov 2004 + * First CPAN release Index: /tags/0.06_02/MANIFEST =================================================================== --- /tags/0.06_02/MANIFEST (revision 36) +++ /tags/0.06_02/MANIFEST (revision 36) @@ -0,0 +1,9 @@ +Changes +Makefile.PL +MANIFEST +README +t/Text-FormBuilder.t +lib/Text/FormBuilder.pm +lib/Text/FormBuilder/Parser.pm +lib/Text/FormBuilder/grammar +META.yml Module meta-data (added by MakeMaker) Index: /tags/0.06_02/Makefile.PL =================================================================== --- /tags/0.06_02/Makefile.PL (revision 36) +++ /tags/0.06_02/Makefile.PL (revision 36) @@ -0,0 +1,16 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + NAME => 'Text::FormBuilder', + VERSION_FROM => 'lib/Text/FormBuilder.pm', # finds $VERSION +## EXE_FILES => [ 'bin/fb.pl' ], + PREREQ_PM => { + CGI::FormBuilder => 2.13, + Parse::RecDescent => 1.94, + Text::Template => 1.44, + }, # e.g., Module::Name => 1.1 + ($] >= 5.005 ? ## Add these new keywords supported since 5.005 + (ABSTRACT_FROM => 'lib/Text/FormBuilder.pm', # retrieve abstract from module + AUTHOR => 'Peter Eichman ') : ()), +); Index: /tags/0.06_02/README =================================================================== --- /tags/0.06_02/README (revision 36) +++ /tags/0.06_02/README (revision 36) @@ -0,0 +1,31 @@ +Text-FormBuilder version 0.05 +============================= + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +DEPENDENCIES + +This module requires these other modules and libraries: + + CGI::FormBuilder 2.13 + Text::Template 1.44 + +Optional: + + Perl::Tidy + YAML + +COPYRIGHT AND LICENCE + +Copyright (C) 2004 by Peter Eichman + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + Index: /tags/0.06_02/bin/fb-cgi.pl =================================================================== --- /tags/0.06_02/bin/fb-cgi.pl (revision 36) +++ /tags/0.06_02/bin/fb-cgi.pl (revision 36) @@ -0,0 +1,42 @@ +use strict; +use warnings; + +use Text::FormBuilder; +use CGI; + +my $q = CGI->new; + +my $form_id = $q->param('form_id'); +my $src_file = get_src_file($form_id); + +my $parser = Text::FormBuilder->new; +my $form = $parser->parse($src_file)->build(method => 'POST', params => $q)->form; + +if (1 or $form->submitted && $form->validate) { + + # call storage function + + my $plugin = 'StoreSQLite'; + + eval "use $plugin;"; + die "Can't use $plugin; $@" if $@; + die "Plugin $plugin doesn't know how to process" unless $plugin->can('process'); + + # plugin process method should return a true value + if ($plugin->process($q, $form, $form_id)) { + # show thank you page + } else { + # there was an error processing the results + die "There was an error processing the submission: " . $plugin->error; + } + +} else { + print $q->header; + print $form->render; +} + +sub get_src_file { + my $form_id = shift; + my $form_spec_path = 'F:/Projects/SurveyMaker/form_specs'; + return "$form_spec_path/$form_id.txt"; +} Index: /tags/0.06_02/bin/fb.pl =================================================================== --- /tags/0.06_02/bin/fb.pl (revision 36) +++ /tags/0.06_02/bin/fb.pl (revision 36) @@ -0,0 +1,37 @@ +use strict; +use warnings; + +use Getopt::Long; +use Text::FormBuilder; + +GetOptions( + 'o=s' => \my $outfile, + 'D=s' => \my %fb_options, +); +my $src_file = shift; + +Text::FormBuilder->parse($src_file)->build(%fb_options)->write($outfile); + +=head1 NAME + +fb - Frontend script for Text::FormBuilder + +=head1 SYNOPSIS + + $ fb my_form.txt -o form.html + + $ fb my_form.txt -o my_form.html -D action=/cgi-bin/my-script.pl + +=head1 OPTIONS + +=over + +=item -D = + +Define options that are passed to the CGI::FormBuilder object. For example, +to create a form on a static html page, and have it submitted to an external +CGI script, you would want to define the C parameter: + + $ fb ... -D action=/cgi-bin/some_script.pl + +=item -o Index: /tags/0.06_02/lib/Text/FormBuilder.pm =================================================================== --- /tags/0.06_02/lib/Text/FormBuilder.pm (revision 36) +++ /tags/0.06_02/lib/Text/FormBuilder.pm (revision 36) @@ -0,0 +1,825 @@ +package Text::FormBuilder; + +use strict; +use warnings; + +use vars qw($VERSION); + +$VERSION = '0.06_02'; + +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 = < Text::FormBuilder::Parser->new, + }; + return bless $self, $class; +} + +sub parse { + my ($self, $source) = @_; + if (ref $source && ref $source eq 'SCALAR') { + $self->parse_text($$source); + } else { + $self->parse_file($source); + } +} + +sub parse_file { + my ($self, $filename) = @_; + + # so it can be called as a class method + $self = $self->new unless ref $self; + + local $/ = undef; + open SRC, "< $filename" or croak "[Text::FormBuilder::parse_file] Can't open $filename: $!" and return; + my $src = ; + close SRC; + + return $self->parse_text($src); +} + +sub parse_text { + my ($self, $src) = @_; + + # so it can be called as a class method + $self = $self->new unless ref $self; + + # append a newline so that it can be called on a single field easily + $src .= "\n"; + + $self->{form_spec} = $self->{parser}->form_spec($src); + + # mark structures as not built (newly parsed text) + $self->{built} = 0; + + return $self; +} + +sub build { + my ($self, %options) = @_; + + # save the build options so they can be used from write_module + $self->{build_options} = { %options }; + + # our custom %options: + # form_only: use only the form part of the template + my $form_only = $options{form_only}; + my $css; + $css = $options{css} || $DEFAULT_CSS; + $css .= $options{extra_css} if $options{extra_css}; + + # remove our custom options + delete $options{$_} foreach qw(form_only css extra_css); + + # substitute in custom pattern definitions for field validation + if (my %patterns = %{ $self->{form_spec}{patterns} || {} }) { + foreach (@{ $self->{form_spec}{fields} }) { + if ($$_{validate} and exists $patterns{$$_{validate}}) { + $$_{validate} = $patterns{$$_{validate}}; + } + } + } + + # expand groups + 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 } ]; + } + } + } + + $self->{form_spec}{fields} = []; + + for my $section (@{ $self->{form_spec}{sections} || [] }) { + #for my $line (@{ $self->{form_spec}{lines} || [] }) { + 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 list names + my %lists = %{ $self->{form_spec}{lists} || {} }; + 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})) } ]; + } + } + + # TODO: configurable threshold for this + 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 }; + } + + # 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} }; + + # need to explicity set the fields so that simple text fields get picked up + $self->{form} = CGI::FormBuilder->new( + %DEFAULT_OPTIONS, + 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), + 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; + } +} + +sub write_module { + my ($self, $package, $use_tidy) = @_; + + croak '[Text::FormBuilder::write_module] Expecting a package name' unless $package; + + # 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 $@; + + # don't dump $VARn names + $Data::Dumper::Terse = 1; + + 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), + DELIMITERS => [ qw(<% %>) ], + }, + data => { + sections => $self->{form_spec}{sections}, + author => $self->{form_spec}{author}, + description => $self->{form_spec}{description}, + }, + }, + %{ $self->{build_options} }, + ); + + my $source = $options{form_only} ? $self->_form_template : $self->_template; + + # remove our custom options + delete $options{$_} foreach qw(form_only css extra_css); + + my $form_options = keys %options > 0 ? Data::Dumper->Dump([\%options],['*options']) : ''; + + my $field_setup = join( + "\n", + map { '$cgi_form->field' . Data::Dumper->Dump([$_],['*field']) . ';' } @{ $self->{form_spec}{fields} } + ); + + my $module = <new( + params => \$cgi, + $form_options + ); + + $field_setup + + return \$cgi_form; +} + +# module return +1; +END + + my $outfile = (split(/::/, $package))[-1] . '.pm'; + + if ($use_tidy) { + # clean up the generated code, if asked + eval 'use Perl::Tidy'; + die "Can't tidy the code: $@" if $@; + Perl::Tidy::perltidy(source => \$module, destination => $outfile); + } else { + # otherwise, just print as is + open FORM, "> $outfile"; + print FORM $module; + close FORM; + } +} + +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 { +q[<% $description ? qq[

$description

] : '' %> +<% (grep { $_->{required} } @fields) ? qq[

(Required fields are marked in bold.)

] : '' %> +<% $start %> +<% + # drop in the hidden fields here + $OUT = join("\n", map { $$_{field} } grep { $$_{type} eq 'hidden' } @fields); +%> + +<% + SECTION: while (my $section = shift @sections) { + $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 'field') { + #TODO: we only need the field names, not the full field spec in the lines strucutre + local $_ = $field{$$line[1]{name}}; + # 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 .= ''; + } + if ($$_{invalid}) { + $OUT .= qq[]; + } else { + $OUT .= qq[]; + } + $OUT .= qq[\n]; + + } elsif ($$line[0] eq 'group') { + my @field_names = map { $$_{name} } @{ $$line[1]{group} }; + my @group_fields = map { $field{$_} } @field_names; + $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 + $OUT .= qq[

$$section{head}

$$line[1]

' . ($$_{required} ? qq[$$_{label}:] : "$$_{label}:") . '$$_{field} $$_{comment} Missing or invalid value.$$_{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); + $OUT .= qq[
\n] if @sections; + } +%> + <% $submit %> + +<% $end %> +]; +} + +sub _template { + my $self = shift; + my $css = shift || $DEFAULT_CSS; +q[ + + <% $title %><% $author ? ' - ' . ucfirst $author : '' %> + + + + +

<% $title %>

+<% $author ? qq[

Created by $author

] : '' %> +] . $self->_form_template . q[ +
+ + + +]; +} + +sub dump { + eval "use YAML;"; + unless ($@) { + print YAML::Dump(shift->{form_spec}); + } else { + warn "Can't dump form spec structure: $@"; + } +} + + +# 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 + +=head1 DESCRIPTION + +=head2 new + +=head2 parse + + # parse a file + $parser->parse($filename); + + # or pass a scalar ref for parse a literal string + $parser->parse(\$string); + +Parse the file or string. Returns the parser 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 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. + +=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. + +CSS Hint: to get multiple sections to all line up their fields, set a +standard width for th.label + +=head2 write_module + + $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 has one function (not exported) +called C, that takes a CGI object as its only argument, and returns +a CGI::FormBuilder object. + +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::get_form($q); + + # 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 dump + +Uses L to print out a human-readable representation of the parsed +form spec. + +=head1 LANGUAGE + + 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], + ... + } + + !list name &{ CODE } + + !section id heading + + !head ... + +=head2 Directives + +=over + +=item C + +Defines a validation pattern. + +=item C + +Defines a list for use in a C, C, or C, C, and +C), here's how you do it: + + color|Favorite color:select{red,blue,green} + +Values are in a comma-separated list of single words or multiword strings +inside curly braces. Whitespace between values is irrelevant. + +To add more descriptive display text to a value in a list, add a square-bracketed +``subscript,'' as in: + + ...:select{red[Scarlet],blue[Azure],green[Olive Drab]} + +If you have a list of options that is too long to fit comfortably on one line, +you should use the C directive: + + !list MONTHS { + 1[January], + 2[February], + 3[March], + # and so on... + } + + month:select@MONTHS + +There is another form of the C directive: the dynamic list: + + !list RANDOM &{ map { rand } (0..5) } + +The code inside the C<&{ ... }> is Ced by C, and the results +are stuffed into the list. The Ced code can either return a simple +list, as the example does, or the fancier C<< ( { value1 => 'Description 1'}, +{ value2 => 'Description 2}, ... ) >> form. + +I This feature of the language may go away unless I find a compelling +reason for it in the next few versions. What I really wanted was lists that +were filled in at run-time (e.g. from a database), and that can be done easily +enough with the CGI::FormBuilder object directly.> + +If you want to have a single checkbox (e.g. for a field that says ``I want to +recieve more information''), you can just specify the type as checkbox without +supplying any options: + + moreinfo|I want to recieve more information:checkbox + +In this case, the label ``I want to recieve more information'' will be +printed to the right of the checkbox. + +You can also supply a default value to the field. To get a default value of +C for the color field: + + color|Favorite color:select=green{red,blue,green} + +Default values can also be either single words or multiword strings. + +To validate a field, include a validation type at the end of the field line: + + email|Email address//EMAIL + +Valid validation types include any of the builtin defaults from L, +or the name of a pattern that you define with the C directive elsewhere +in your form spec: + + !pattern DAY /^([1-3][0-9])|[1-9]$/ + + last_day//DAY + +If you just want a required value, use the builtin validation type C: + + title//VALUE + +By default, adding a validation type to a field makes that field required. To +change this, add a C to the end of the validation type: + + contact//EMAIL? + +In this case, you would get a C field that was optional, but if it +were filled in, would have to validate as an C. + +=head2 Comments + + # comment ... + +Any line beginning with a C<#> is considered a comment. + +=head1 TODO + +Allow for custom wrappers around the C + +Use the custom message file format for messages in the built in template + +Maybe use HTML::Template instead of Text::Template for the built in template +(since CGI::FormBuilder users may be more likely to already have HTML::Template) + +Better examples in the docs (maybe a standalone or two as well) + +Document the defaults that are passed to CGI::FormBuilder + +C directive to include external formspec files + +Better tests! + +=head1 BUGS + +I'm sure they're in there, I just haven't tripped over any new ones lately. :-) + +=head1 SEE ALSO + +L + +=head1 THANKS + +Thanks to eszpee for pointing out some bugs in the default value parsing, +as well as some suggestions for i18n/l10n and splitting up long forms into +sections. + +=head1 AUTHOR + +Peter Eichman + +=head1 COPYRIGHT AND LICENSE + +Copyright E2004 by Peter Eichman. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut Index: /tags/0.06_02/lib/Text/FormBuilder/Makefile =================================================================== --- /tags/0.06_02/lib/Text/FormBuilder/Makefile (revision 36) +++ /tags/0.06_02/lib/Text/FormBuilder/Makefile (revision 36) @@ -0,0 +1,3 @@ +# pre-compile the parser from the grammar +Parser.pm: grammar + perl -MParse::RecDescent - grammar Text::FormBuilder::Parser Index: /tags/0.06_02/lib/Text/FormBuilder/grammar =================================================================== --- /tags/0.06_02/lib/Text/FormBuilder/grammar (revision 36) +++ /tags/0.06_02/lib/Text/FormBuilder/grammar (revision 36) @@ -0,0 +1,219 @@ +{ + my ( + $context, # line or group + @sections, # master data structure + $section_head, + $section_id, + @lines, # lines in each section + $title, + $author, + $description, + %lists, + %patterns, + @group, # current group + %groups, # stored groups of fields + $type, + @options, + $required, + $list_var, + $size, + $rows, + $cols, + ); + $context = 'line'; +} + +form_spec: (list_def | description_def | group_def | line)(s) + { + # grab the last section, if there is any + if (@lines) { + push @sections, + { + id => $section_id, + head => $section_head, + lines => [ @lines ], + }; + } + + $section_id = $item{identifier}; + $section_head = $item[3]; + @lines = (); + $return = { + title => $title, + author => $author, + description => $description, + lists => \%lists, + patterns => \%patterns, + groups => \%groups, + sections => \@sections, + } + } + +list_def: '!list' var_name (static_list | dynamic_list) + { $lists{$item{var_name}} = [ @options ]; @options = () } + +static_list: '{' option(s /,\s*/) /,?/ '}' + +dynamic_list: '&' + { + my @results = (eval $item[2]); + if (ref $results[0] eq 'HASH') { + @options = @results; + } else { + @options = map { { $_ => $_ } } @results; + } + } + +description_def: '!description' + { warn "[Text::FormBuilder] Description redefined at input text line $thisline\n" if defined $description; + + $description = $item[2]; + $description =~ s/^{\s*|\s*}$//g; + } + +group_def: '!group' { $context = 'group' } var_name '{' field_line(s) '}' { $context = 'line' } + { + #warn "$item{var_name} group; context $context\n" + $groups{$item{var_name}} = [ @group ]; + @group = (); + } + +field_line: ( field | comment | blank ) "\n" +line: ( title | author | pattern_def | section_head | heading | group_field | unknown_directive | field | comment | blank ) "\n" + +title: '!title' /.*/ + { + warn "[Text::Formbuilder] Title redefined at input text line $thisline\n" if defined $title; + $title = $item[2]; + } + +author: '!author' /.*/ + { + warn "[Text::Formbuilder] Author redefined at input text line $thisline\n" if defined $author; + $author = $item[2]; + } + +pattern_def: '!pattern' var_name pattern + { $patterns{$item{var_name}} = $item{pattern} } + +pattern: /.*/ + +section_head: '!section' identifier /.*/ + { + #warn "starting section $item{identifier}\n"; + #warn " with heading $item[3]\n" if $item[3]; + + if (@lines) { + push @sections, + { + id => $section_id, + head => $section_head, + lines => [ @lines ], + }; + } + + $section_id = $item{identifier}; + $section_head = $item[3]; + @lines = (); + } + +heading: '!head' /.*/ { push @lines, [ 'head', $item[2] ] } + +group_field: '!field' group_name name label(?) + { + push @lines, [ 'group', { name => $item{name}, label => $item{'label(?)'}[0], group => $item{group_name} } ]; + } + +group_name: /%[A-Z_]+/ + +field: name field_size(?) label(?) hint(?) type(?) default(?) option_list(?) validate(?) + { + my $field = { + name => $item{name}, + label => $item{'label(?)'}[0], + comment => $item{'hint(?)'}[0], + type => $item{'type(?)'}[0], + value => $item{'default(?)'}[0], + list => $list_var, + validate => $item{'validate(?)'}[0], + required => $required || 0, + }; + + $$field{options} = [ @options ] if @options; + + $$field{rows} = $rows if defined $rows; + $$field{cols} = $cols if defined $cols; + $$field{size} = $size if defined $size; + + #warn "[$thisline] field $item{name}; context $context\n"; + if ($context eq 'group') { + push @group, $field; + } else { + push @lines, [ 'field', $field ]; + } + + $type = undef; + $required = 0; + $list_var = undef; + $size = undef; + $rows = undef; + $cols = undef; + @options = (); + + } + +name: identifier + +var_name: /[A-Z_]+/ + +field_size: '[' ( row_col | size ) ']' + +size: /\d+/ + { $size = $item[1] } + +row_col: /\d+/ /,\s*/ /\d+/ + { $rows = $item[1]; $cols = $item[3] } + +label: '|' (simple_multiword | quoted_string) { $item[2] } + +hint: '[' /[^\]]+/ ']' { $item[2] } + +type: ':' /textarea|text|password|file|checkbox|radio|select|hidden|static/ + +default: '=' (simple_multiword | quoted_string) { $item[2] } + +# for simple multiword values not involving punctuation +simple_multiword: /[\w\t ]+/ { $item[2] } + +# my attempt at a single-quoted, non-interpolating string +# where the backslash can escape literal single quotes +quoted_string: "'" /(\\'|[^'])*/ "'" + { $item[3] =~ s/\\'/'/g; $item[3] } + +option_list: options | list_var + +options: '{' option(s /,\s*/) '}' + +list_var: /@[A-Z_]+/ { $list_var = $item[1] } + +option: (simple_multiword | value | quoted_string) display_text(?) + { push @options, { $item[1] => $item{'display_text(?)'}[0] } } + +value: identifier + +display_text: '[' /[^\]]+/i ']' { $item[2] } + +validate: '//' (optional_pattern | required_pattern) { $item[2] } + +optional_pattern: /[A-Z_]+/ '?' { $required = 0; $item[1] } + +required_pattern: /[A-Z_]+/ { $required = 1; $item[1] } + +comment: '#' /.*/ +blank: + +identifier: /\w+/ + +# skip unknown directives with a warning +unknown_directive: /\!\S*/ /.*/ + { warn "[Text::Formbuilder] Skipping unknown directive '$item[1]' at input text line $thisline\n"; } Index: /tags/0.06_02/t/Text-FormBuilder.t =================================================================== --- /tags/0.06_02/t/Text-FormBuilder.t (revision 36) +++ /tags/0.06_02/t/Text-FormBuilder.t (revision 36) @@ -0,0 +1,26 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl Text-FormBuilder.t' + +######################### + +# change 'tests => 1' to 'tests => last_test_to_print'; + +use Test::More tests => 6; +BEGIN { use_ok('Text::FormBuilder'); }; + +######################### + +# Insert your test code below, the Test::More module is use()ed here so read +# its man page ( perldoc Test::More ) for help writing this test script. + +my $p = Text::FormBuilder->new; +isa_ok($p, 'Text::FormBuilder', 'new parser'); +isa_ok($p->parse_text('')->build->form, 'CGI::FormBuilder', 'generated CGI::FormBuilder object (build->form)'); +isa_ok($p->parse_text('')->form, 'CGI::FormBuilder', 'generated CGI::FormBuilder object (form)'); + +$p = Text::FormBuilder->parse_text(''); +isa_ok($p, 'Text::FormBuilder', 'new parser (from parse_text as class method)'); + +$p = Text::FormBuilder->parse(\''); +isa_ok($p, 'Text::FormBuilder', 'new parser (from parse as class method)'); +