source: text-formbuilder/trunk/lib/Text/FormBuilder.pm @ 29

Last change on this file since 29 was 29, checked in by peter, 20 years ago

added !section directive

File size: 22.6 KB
Line 
1package Text::FormBuilder;
2
3use strict;
4use warnings;
5
6use vars qw($VERSION);
7
8$VERSION = '0.06_02';
9
10use Carp;
11use Text::FormBuilder::Parser;
12use CGI::FormBuilder;
13
14# the static default options passed to CGI::FormBuilder->new
15my %DEFAULT_OPTIONS = (
16    method => 'GET',
17    javascript => 0,
18    keepextras => 1,
19);
20
21sub new {
22    my $invocant = shift;
23    my $class = ref $invocant || $invocant;
24    my $self = {
25        parser => Text::FormBuilder::Parser->new,
26    };
27    return bless $self, $class;
28}
29
30sub parse {
31    my ($self, $source) = @_;
32    if (ref $source && ref $source eq 'SCALAR') {
33        $self->parse_text($$source);
34    } else {
35        $self->parse_file($source);
36    }
37}
38
39sub parse_file {
40    my ($self, $filename) = @_;
41   
42    # so it can be called as a class method
43    $self = $self->new unless ref $self;
44   
45    local $/ = undef;
46    open SRC, "< $filename";
47    my $src = <SRC>;
48    close SRC;
49   
50    return $self->parse_text($src);
51}
52
53sub parse_text {
54    my ($self, $src) = @_;
55   
56    # so it can be called as a class method
57    $self = $self->new unless ref $self;
58   
59    $self->{form_spec} = $self->{parser}->form_spec($src);
60   
61    # mark structures as not built (newly parsed text)
62    $self->{built} = 0;
63   
64    return $self;
65}
66
67sub build {
68    my ($self, %options) = @_;
69
70    # save the build options so they can be used from write_module
71    $self->{build_options} = { %options };
72   
73    # our custom %options:
74    # form_only: use only the form part of the template
75    my $form_only = $options{form_only};
76    delete $options{form_only};
77   
78    # substitute in custom pattern definitions for field validation
79    if (my %patterns = %{ $self->{form_spec}{patterns} || {} }) {
80        foreach (@{ $self->{form_spec}{fields} }) {
81            if ($$_{validate} and exists $patterns{$$_{validate}}) {
82                $$_{validate} = $patterns{$$_{validate}};
83            }
84        }
85    }
86   
87    # expand groups
88    my %groups = %{ $self->{form_spec}{groups} || {} };
89   
90    for my $section (@{ $self->{form_spec}{sections} || [] }) {
91##         foreach (grep { $$_[0] eq 'group' } @{ $self->{form_spec}{lines} || [] }) {
92        foreach (grep { $$_[0] eq 'group' } @{ $$section{lines} }) {
93            $$_[1]{group} =~ s/^\%//;       # strip leading % from group var name
94           
95            if (exists $groups{$$_[1]{group}}) {
96                my @fields; # fields in the group
97                push @fields, { %$_ } foreach @{ $groups{$$_[1]{group}} };
98                for my $field (@fields) {
99                    $$field{label} ||= ucfirst $$field{name};
100                    $$field{name} = "$$_[1]{name}_$$field{name}";               
101                }
102                $_ = [ 'group', { label => $$_[1]{label} || ucfirst(join(' ',split('_',$$_[1]{name}))), group => \@fields } ];
103            }
104        }
105    }
106   
107    $self->{form_spec}{fields} = [];
108   
109    for my $section (@{ $self->{form_spec}{sections} || [] }) {
110        #for my $line (@{ $self->{form_spec}{lines} || [] }) {
111        for my $line (@{ $$section{lines} }) {
112            if ($$line[0] eq 'group') {
113                push @{ $self->{form_spec}{fields} }, $_ foreach @{ $$line[1]{group} };
114            } elsif ($$line[0] eq 'field') {
115                push @{ $self->{form_spec}{fields} }, $$line[1];
116            }
117        }
118    }
119   
120    # substitute in list names
121    my %lists = %{ $self->{form_spec}{lists} || {} };
122    foreach (@{ $self->{form_spec}{fields} }) {
123        next unless $$_{list};
124       
125        $$_{list} =~ s/^\@//;   # strip leading @ from list var name
126       
127        # a hack so we don't get screwy reference errors
128        if (exists $lists{$$_{list}}) {
129            my @list;
130            push @list, { %$_ } foreach @{ $lists{$$_{list}} };
131            $$_{options} = \@list;
132        } else {
133##             #TODO: this is not working in CGI::FormBuilder
134##             # assume that the list name is a builtin
135##             # and let it fall through to CGI::FormBuilder
136##             $$_{options} = $$_{list};
137##             warn "falling through to builtin $$_{options}";
138        }
139    } continue {
140        delete $$_{list};
141    }   
142   
143    # TODO: configurable threshold for this
144    foreach (@{ $self->{form_spec}{fields} }) {
145        $$_{ulist} = 1 if defined $$_{options} and @{ $$_{options} } >= 3;
146    }
147   
148    # remove extraneous undefined values
149    for my $field (@{ $self->{form_spec}{fields} }) {
150        defined $$field{$_} or delete $$field{$_} foreach keys %{ $field };
151    }
152   
153    # because this messes up things at the CGI::FormBuilder::field level
154    # it seems to be marking required based on the existance of a 'required'
155    # param, not whether it is true or defined
156    $$_{required} or delete $$_{required} foreach @{ $self->{form_spec}{fields} };
157
158    # need to explicity set the fields so that simple text fields get picked up
159    $self->{form} = CGI::FormBuilder->new(
160        %DEFAULT_OPTIONS,
161        fields   => [ map { $$_{name} } @{ $self->{form_spec}{fields} } ],
162        required => [ map { $$_{name} } grep { $$_{required} } @{ $self->{form_spec}{fields} } ],
163        title => $self->{form_spec}{title},
164        text  => $self->{form_spec}{description},
165        template => {
166            type => 'Text',
167            engine => {
168                TYPE       => 'STRING',
169                SOURCE     => $form_only ? $self->_form_template : $self->_template,
170                DELIMITERS => [ qw(<% %>) ],
171            },
172            data => {
173                sections    => $self->{form_spec}{sections},
174                author      => $self->{form_spec}{author},
175                description => $self->{form_spec}{description},
176            },
177        },
178        %options,
179    );
180    $self->{form}->field(%{ $_ }) foreach @{ $self->{form_spec}{fields} };
181   
182    # mark structures as built
183    $self->{built} = 1;
184   
185    return $self;
186}
187
188sub write {
189    my ($self, $outfile) = @_;
190   
191    # automatically call build if needed to
192    # allow the new->parse->write shortcut
193    $self->build unless $self->{built};
194   
195    if ($outfile) {
196        open FORM, "> $outfile";
197        print FORM $self->form->render;
198        close FORM;
199    } else {
200        print $self->form->render;
201    }
202}
203
204sub write_module {
205    my ($self, $package, $use_tidy) = @_;
206
207    croak 'Expecting a package name' unless $package;
208   
209    # automatically call build if needed to
210    # allow the new->parse->write shortcut
211    $self->build unless $self->{built};
212   
213    # conditionally use Data::Dumper
214    eval 'use Data::Dumper;';
215    die "Can't write module; need Data::Dumper. $@" if $@;
216   
217    # don't dump $VARn names
218    $Data::Dumper::Terse = 1;
219   
220    my %options = (
221        %DEFAULT_OPTIONS,
222        title => $self->{form_spec}{title},
223        text  => $self->{form_spec}{description},
224        fields   => [ map { $$_{name} } @{ $self->{form_spec}{fields} } ],
225        required => [ map { $$_{name} } grep { $$_{required} } @{ $self->{form_spec}{fields} } ],
226        template => {
227            type => 'Text',
228            engine => {
229                TYPE       => 'STRING',
230                SOURCE     => $self->{build_options}{form_only} ? $self->_form_template : $self->_template,
231                DELIMITERS => [ qw(<% %>) ],
232            },
233            data => {
234                sections    => $self->{form_spec}{sections},
235                author      => $self->{form_spec}{author},
236                description => $self->{form_spec}{description},
237            },
238        }, 
239        %{ $self->{build_options} },
240    );
241   
242    my $source = $options{form_only} ? $self->_form_template : $self->_template;
243   
244    delete $options{form_only};
245   
246    my $form_options = keys %options > 0 ? Data::Dumper->Dump([\%options],['*options']) : '';
247   
248    my $field_setup = join(
249        "\n", 
250        map { '$cgi_form->field' . Data::Dumper->Dump([$_],['*field']) . ';' } @{ $self->{form_spec}{fields} }
251    );
252   
253    my $module = <<END;
254package $package;
255use strict;
256use warnings;
257
258use CGI::FormBuilder;
259
260sub get_form {
261    my \$cgi = shift;
262    my \$cgi_form = CGI::FormBuilder->new(
263        params => \$cgi,
264        $form_options
265    );
266   
267    $field_setup
268   
269    return \$cgi_form;
270}
271
272# module return
2731;
274END
275
276    my $outfile = (split(/::/, $package))[-1] . '.pm';
277   
278    if ($use_tidy) {
279        # clean up the generated code, if asked
280        eval 'use Perl::Tidy';
281        die "Can't tidy the code: $@" if $@;
282        Perl::Tidy::perltidy(source => \$module, destination => $outfile);
283    } else {
284        # otherwise, just print as is
285        open FORM, "> $outfile";
286        print FORM $module;
287        close FORM;
288    }
289}
290
291sub form {
292    my $self = shift;
293   
294    # automatically call build if needed to
295    # allow the new->parse->write shortcut
296    $self->build unless $self->{built};
297
298    return $self->{form};
299}
300
301sub _form_template {
302q[<% $description ? qq[<p id="description">$description</p>] : '' %>
303<% (grep { $_->{required} } @fields) ? qq[<p id="instructions">(Required fields are marked in <strong>bold</strong>.)</p>] : '' %>
304<% $start %>
305<%
306    # drop in the hidden fields here
307    $OUT = join("\n", map { $$_{field} } grep { $$_{type} eq 'hidden' } @fields);
308%>
309
310<%
311    SECTION: while (my $section = shift @sections) {
312        $OUT .= qq[<table id="$$section{id}">\n];
313        $OUT .= qq[  <caption><h2>$$section{head}</h2></caption>] if $$section{head};
314        TABLE_LINE: for my $line (@{ $$section{lines} }) {
315            if ($$line[0] eq 'head') {
316                $OUT .= qq[  <tr><th class="sectionhead" colspan="2"><h3>$$line[1]</h3></th></tr>\n]
317            } elsif ($$line[0] eq 'field') {
318                #TODO: we only need the field names, not the full field spec in the lines strucutre
319                local $_ = $field{$$line[1]{name}};
320                # skip hidden fields in the table
321                next TABLE_LINE if $$_{type} eq 'hidden';
322               
323                $OUT .= $$_{invalid} ? qq[  <tr class="invalid">] : qq[  <tr>];
324                $OUT .= '<th class="label">' . ($$_{required} ? qq[<strong class="required">$$_{label}:</strong>] : "$$_{label}:") . '</th>';
325                if ($$_{invalid}) {
326                    $OUT .= qq[<td>$$_{field} $$_{comment} Missing or invalid value.</td></tr>\n];
327                } else {
328                    $OUT .= qq[<td>$$_{field} $$_{comment}</td></tr>\n];
329                }
330            } elsif ($$line[0] eq 'group') {
331                my @field_names = map { $$_{name} } @{ $$line[1]{group} };
332                my @group_fields = map { $field{$_} } @field_names;
333                $OUT .= (grep { $$_{invalid} } @group_fields) ? qq[  <tr class="invalid">\n] : qq[  <tr>\n];
334               
335                $OUT .= '    <th class="label">';
336                $OUT .= (grep { $$_{required} } @group_fields) ? qq[<strong class="required">$$line[1]{label}:</strong>] : "$$line[1]{label}:";
337                $OUT .= qq[</th>\n];
338               
339                $OUT .= qq[    <td>];
340                $OUT .= join(' ', map { qq[<small class="sublabel">$$_{label}</small> $$_{field} $$_{comment}] } @group_fields);
341                $OUT .= qq[    </td>\n];
342                $OUT .= qq[  </tr>\n];
343            }   
344        }
345        # close the table if there are sections remaining
346        # but leave the last one open for the submit button
347        $OUT .= qq[</table>\n] if @sections;
348    }
349%>
350  <tr><th></th><td style="padding-top: 1em;"><% $submit %></td></tr>
351</table>
352<% $end %>
353];
354}
355
356sub _template {
357    my $self = shift;
358q[<html>
359<head>
360  <title><% $title %><% $author ? ' - ' . ucfirst $author : '' %></title>
361  <style type="text/css">
362    table { margin: .5em 1em; }
363    #author, #footer { font-style: italic; }
364    caption h2 { padding: .125em .5em; background: #ddd; text-align: left; }
365    th { text-align: left; }
366    th h3 { padding: .125em .5em; background: #eee; }
367    th.label { font-weight: normal; text-align: right; vertical-align: top; }
368    td ul { list-style: none; padding-left: 0; margin-left: 0; }
369    .sublabel { color: #999; }
370    .invalid { background: red; }
371  </style>
372</head>
373<body>
374
375<h1><% $title %></h1>
376<% $author ? qq[<p id="author">Created by $author</p>] : '' %>
377] . $self->_form_template . q[
378<hr />
379<div id="footer">
380  <p id="creator">Made with <a href="http://formbuilder.org/">CGI::FormBuilder</a> version <% CGI::FormBuilder->VERSION %>.</p>
381</div>
382</body>
383</html>
384];
385}
386
387sub dump { 
388    eval "use YAML;";
389    unless ($@) {
390        print YAML::Dump(shift->{form_spec});
391    } else {
392        warn "Can't dump form spec structure: $@";
393    }
394}
395
396
397# module return
3981;
399
400=head1 NAME
401
402Text::FormBuilder - Create CGI::FormBuilder objects from simple text descriptions
403
404=head1 SYNOPSIS
405
406    use Text::FormBuilder;
407   
408    my $parser = Text::FormBuilder->new;
409    $parser->parse($src_file);
410   
411    # returns a new CGI::FormBuilder object with
412    # the fields from the input form spec
413    my $form = $parser->form;
414   
415    # write a My::Form module to Form.pm
416    $parser->write_module('My::Form');
417
418=head1 REQUIRES
419
420L<Parse::RecDescent>, L<CGI::FormBuilder>, L<Text::Template>
421
422=head1 DESCRIPTION
423
424=head2 new
425
426=head2 parse
427
428    # parse a file
429    $parser->parse($filename);
430   
431    # or pass a scalar ref for parse a literal string
432    $parser->parse(\$string);
433
434Parse the file or string. Returns the parser object.
435
436=head2 parse_file
437
438    $parser->parse_file($src_file);
439   
440    # or as a class method
441    my $parser = Text::FormBuilder->parse($src_file);
442
443=head2 parse_text
444
445    $parser->parse_text($src);
446
447Parse the given C<$src> text. Returns the parser object.
448
449=head2 build
450
451    $parser->build(%options);
452
453Builds the CGI::FormBuilder object. Options directly used by C<build> are:
454
455=over
456
457=item C<form_only>
458
459Only uses the form portion of the template, and omits the surrounding html,
460title, author, and the standard footer. This does, however, include the
461description as specified with the C<!description> directive.
462
463=back
464
465All other options given to C<build> are passed on verbatim to the
466L<CGI::FormBuilder> constructor. Any options given here override the
467defaults that this module uses.
468
469The C<form>, C<write>, and C<write_module> methods will all call
470C<build> with no options for you if you do not do so explicitly.
471This allows you to say things like this:
472
473    my $form = Text::FormBuilder->new->parse('formspec.txt')->form;
474
475However, if you need to specify options to C<build>, you must call it
476explictly after C<parse>.
477
478=head2 form
479
480    my $form = $parser->form;
481
482Returns the L<CGI::FormBuilder> object. Remember that you can modify
483this object directly, in order to (for example) dynamically populate
484dropdown lists or change input types at runtime.
485
486=head2 write
487
488    $parser->write($out_file);
489    # or just print to STDOUT
490    $parser->write;
491
492Calls C<render> on the FormBuilder form, and either writes the resulting
493HTML to a file, or to STDOUT if no filename is given.
494
495CSS Hint: to get multiple sections to all line up their fields, set a
496standard width for th.label
497
498=head2 write_module
499
500    $parser->write_module($package, $use_tidy);
501
502Takes a package name, and writes out a new module that can be used by your
503CGI script to render the form. This way, you only need CGI::FormBuilder on
504your server, and you don't have to parse the form spec each time you want
505to display your form. The generated module has one function (not exported)
506called C<get_form>, that takes a CGI object as its only argument, and returns
507a CGI::FormBuilder object.
508
509First, you parse the formspec and write the module, which you can do as a one-liner:
510
511    $ perl -MText::FormBuilder -e"Text::FormBuilder->parse('formspec.txt')->write_module('My::Form')"
512
513And then, in your CGI script, use the new module:
514
515    #!/usr/bin/perl -w
516    use strict;
517   
518    use CGI;
519    use My::Form;
520   
521    my $q = CGI->new;
522    my $form = My::Form::get_form($q);
523   
524    # do the standard CGI::FormBuilder stuff
525    if ($form->submitted && $form->validate) {
526        # process results
527    } else {
528        print $q->header;
529        print $form->render;
530    }
531
532If you pass a true value as the second argument to C<write_module>, the parser
533will run L<Perl::Tidy> on the generated code before writing the module file.
534
535    # write tidier code
536    $parser->write_module('My::Form', 1);
537
538=head2 dump
539
540Uses L<YAML> to print out a human-readable representation of the parsed
541form spec.
542
543=head1 LANGUAGE
544
545    field_name[size]|descriptive label[hint]:type=default{option1[display string],...}//validate
546   
547    !title ...
548   
549    !author ...
550   
551    !description {
552        ...
553    }
554   
555    !pattern name /regular expression/
556   
557    !list name {
558        option1[display string],
559        option2[display string],
560        ...
561    }
562   
563    !list name &{ CODE }
564   
565    !section id heading
566   
567    !head ...
568
569=head2 Directives
570
571=over
572
573=item C<!pattern>
574
575Defines a validation pattern.
576
577=item C<!list>
578
579Defines a list for use in a C<radio>, C<checkbox>, or C<select> field.
580
581=item C<!title>
582
583=item C<!author>
584
585=item C<!description>
586
587A brief description of the form. Suitable for special instructions on how to
588fill out the form.
589
590=item C<!section>
591
592Starts a new section. Each section has its own heading and id, which are
593written by default into spearate tables.
594
595=item C<!head>
596
597Inserts a heading between two fields. There can only be one heading between
598any two fields; the parser will warn you if you try to put two headings right
599next to each other.
600
601=back
602
603=head2 Fields
604
605First, a note about multiword strings in the fields. Anywhere where it says
606that you may use a multiword string, this means that you can do one of two
607things. For strings that consist solely of alphanumeric characters (i.e.
608C<\w+>) and spaces, the string will be recognized as is:
609
610    field_1|A longer label
611
612If you want to include non-alphanumerics (e.g. punctuation), you must
613single-quote the string:
614
615    field_2|'Dept./Org.'
616
617To include a literal single-quote in a single-quoted string, escape it with
618a backslash:
619
620    field_3|'\'Official\' title'
621
622Now, back to the basics. Form fields are each described on a single line.
623The simplest field is just a name (which cannot contain any whitespace):
624
625    color
626
627This yields a form with one text input field of the default size named `color'.
628The label for this field as generated by CGI::FormBuilder would be ``Color''.
629To add a longer or more descriptive label, use:
630
631    color|Favorite color
632
633The descriptive label can be a multiword string, as described above.
634
635To use a different input type:
636
637    color|Favorite color:select{red,blue,green}
638
639Recognized input types are the same as those used by CGI::FormBuilder:
640
641    text        # the default
642    textarea
643    password
644    file
645    checkbox
646    radio
647    select
648    hidden
649    static
650
651To change the size of the input field, add a bracketed subscript after the
652field name (but before the descriptive label):
653
654    # for a single line field, sets size="40"
655    title[40]:text
656   
657    # for a multiline field, sets rows="4" and cols="30"
658    description[4,30]:textarea
659
660For the input types that can have options (C<select>, C<radio>, and
661C<checkbox>), here's how you do it:
662
663    color|Favorite color:select{red,blue,green}
664
665Values are in a comma-separated list of single words or multiword strings
666inside curly braces. Whitespace between values is irrelevant.
667
668To add more descriptive display text to a value in a list, add a square-bracketed
669``subscript,'' as in:
670
671    ...:select{red[Scarlet],blue[Azure],green[Olive Drab]}
672
673If you have a list of options that is too long to fit comfortably on one line,
674you should use the C<!list> directive:
675
676    !list MONTHS {
677        1[January],
678        2[February],
679        3[March],
680        # and so on...
681    }
682   
683    month:select@MONTHS
684
685There is another form of the C<!list> directive: the dynamic list:
686
687    !list RANDOM &{ map { rand } (0..5) }
688
689The code inside the C<&{ ... }> is C<eval>ed by C<build>, and the results
690are stuffed into the list. The C<eval>ed code can either return a simple
691list, as the example does, or the fancier C<< ( { value1 => 'Description 1'},
692{ value2 => 'Description 2}, ... ) >> form.
693
694I<B<NOTE:> This feature of the language may go away unless I find a compelling
695reason for it in the next few versions. What I really wanted was lists that
696were filled in at run-time (e.g. from a database), and that can be done easily
697enough with the CGI::FormBuilder object directly.>
698
699If you want to have a single checkbox (e.g. for a field that says ``I want to
700recieve more information''), you can just specify the type as checkbox without
701supplying any options:
702
703    moreinfo|I want to recieve more information:checkbox
704
705The one drawback to this is that the label to the checkbox will still appear
706to the left of the field. I am leaving it this way for now, but if enough
707people would like this to change, I may make single-option checkboxes a special
708case and put the label on the right.
709
710You can also supply a default value to the field. To get a default value of
711C<green> for the color field:
712
713    color|Favorite color:select=green{red,blue,green}
714
715Default values can also be either single words or multiword strings.
716
717To validate a field, include a validation type at the end of the field line:
718
719    email|Email address//EMAIL
720
721Valid validation types include any of the builtin defaults from L<CGI::FormBuilder>,
722or the name of a pattern that you define with the C<!pattern> directive elsewhere
723in your form spec:
724
725    !pattern DAY /^([1-3][0-9])|[1-9]$/
726   
727    last_day//DAY
728
729If you just want a required value, use the builtin validation type C<VALUE>:
730
731    title//VALUE
732
733By default, adding a validation type to a field makes that field required. To
734change this, add a C<?> to the end of the validation type:
735
736    contact//EMAIL?
737
738In this case, you would get a C<contact> field that was optional, but if it
739were filled in, would have to validate as an C<EMAIL>.
740
741=head2 Comments
742
743    # comment ...
744
745Any line beginning with a C<#> is considered a comment.
746
747=head1 TODO
748
749Use the custom message file format for messages in the built in template
750
751Custom CSS, both in addition to, and replacing the built in.
752
753Use HTML::Template instead of Text::Template for the built in template
754(since CGI::FormBuilder users may be more likely to already have HTML::Template)
755
756Better examples in the docs (maybe a standalone or two as well)
757
758Document the defaults that are passed to CGI::FormBuilder
759
760C<!include> directive to include external formspec files
761
762Better tests!
763
764=head1 BUGS
765
766For now, checkboxes with a single value still display their labels on
767the left.
768
769=head1 SEE ALSO
770
771L<CGI::FormBuilder>
772
773=head1 THANKS
774
775Thanks to eszpee for pointing out some bugs in the default value parsing,
776as well as some suggestions for i18n/l10n and splitting up long forms into
777sections.
778
779=head1 AUTHOR
780
781Peter Eichman <peichman@cpan.org>
782
783=head1 COPYRIGHT AND LICENSE
784
785Copyright E<copy>2004 by Peter Eichman.
786
787This program is free software; you can redistribute it and/or
788modify it under the same terms as Perl itself.
789
790=cut
Note: See TracBrowser for help on using the repository browser.