source: text-formbuilder/trunk/lib/Text/FormBuilder/grammar @ 54

Last change on this file since 54 was 50, checked in by peichman, 20 years ago

fallthrough to CGI::FormBuilder builtin lists working (again); added a !note directive; discovered bug in parsing of !directive and !note

File size: 5.5 KB
RevLine 
[21]1{
2    my (
3        $context,      # line or group
[29]4        @sections,     # master data structure
5        $section_head,
6        $section_id,
7        @lines,        # lines in each section
[21]8        $title,
9        $author,
10        $description,
11        %lists,
12        %patterns,
[39]13        %subs,         # validation subs
[21]14        @group,        # current group
15        %groups,       # stored groups of fields
16        $type,
17        @options,
[24]18        $required,
[21]19        $list_var,
20        $size,
21        $rows,
22        $cols,
23    );
24    $context = 'line';
25}
[1]26
[50]27form_spec: (list_def | description_def | validate_def | group_def | note | line)(s)
[1]28    {
[29]29        # grab the last section, if there is any
30        if (@lines) {
31            push @sections,
32                {
33                    id   => $section_id,
34                    head => $section_head,
35                    lines => [ @lines ],
36                };
37        }
38       
39        $section_id = $item{identifier};
40        $section_head = $item[3];
41        @lines = ();
[1]42        $return = {
43            title    => $title,
44            author   => $author,
[14]45            description => $description,
[28]46            lists    => \%lists,
47            patterns => \%patterns,
[39]48            subs     => \%subs,
[28]49            groups   => \%groups,
[29]50            sections => \@sections,
[1]51        }
52    }
53
[16]54list_def: '!list' var_name (static_list | dynamic_list)
55    { $lists{$item{var_name}} = [ @options ]; @options = () }
[1]56
[10]57static_list: '{' option(s /,\s*/) /,?/ '}'
58
59dynamic_list: '&' <perl_codeblock>
60    {
61        my @results = (eval $item[2]);
62        if (ref $results[0] eq 'HASH') {
63            @options = @results;
64        } else {   
65            @options = map { { $_ => $_ } } @results;
66        }
67    }
68
[14]69description_def: '!description' <perl_codeblock>
70    { warn "[Text::FormBuilder] Description redefined at input text line $thisline\n" if defined $description;
71   
72    $description = $item[2];
73    $description =~ s/^{\s*|\s*}$//g;
74    }
75
[39]76validate_def: '!validate' var_name <perl_codeblock>
[42]77    { $subs{$item{var_name}} = eval "sub $item[3]" }
[39]78
[21]79group_def: '!group' { $context = 'group' } var_name '{' field_line(s) '}' { $context = 'line' }
80    {
81        #warn "$item{var_name} group; context $context\n"
82        $groups{$item{var_name}} = [ @group ];
83        @group = ();
84    }
[1]85
[50]86note: '!note' <perl_codeblock>
87    {   
88        (my $note = $item[2]) =~ s/^{\s*|\s*}$//g;
89        push @lines, [ 'note', $note ];
90    }
91
92
[21]93field_line: <skip:'[ \t]*'> ( field | comment | blank ) "\n"
[29]94line: <skip:'[ \t]*'> ( title | author | pattern_def | section_head | heading | group_field | unknown_directive | field | comment | blank ) "\n"
[21]95
[1]96title: '!title' /.*/
[28]97    {
98        warn "[Text::Formbuilder] Title redefined at input text line $thisline\n" if defined $title;
99        $title = $item[2];
100    }
[1]101
102author: '!author' /.*/
[28]103    {
104        warn "[Text::Formbuilder] Author redefined at input text line $thisline\n" if defined $author;
105        $author = $item[2];
106    }
[1]107
[16]108pattern_def: '!pattern' var_name pattern
109    { $patterns{$item{var_name}} = $item{pattern} }
[1]110
111pattern: /.*/
112
[29]113section_head: '!section' identifier /.*/
114    {
115        #warn "starting section $item{identifier}\n";
116        #warn "  with heading $item[3]\n" if $item[3];
117       
118        if (@lines) {
119            push @sections,
120                {
121                    id   => $section_id,
122                    head => $section_head,
123                    lines => [ @lines ],
124                };
125        }
126       
127        $section_id = $item{identifier};
128        $section_head = $item[3];
129        @lines = ();
130    }
131
[28]132heading: '!head' /.*/    { push @lines, [ 'head', $item[2] ] }
[11]133
[21]134group_field: '!field' group_name name label(?)
[28]135    {
136        push @lines, [ 'group', { name => $item{name}, label => $item{'label(?)'}[0], group => $item{group_name} } ];
[21]137    }
138
139group_name: /%[A-Z_]+/
140
[1]141field: name field_size(?) label(?) hint(?) type(?) default(?) option_list(?) validate(?)
142    {
143        my $field = {
144            name     => $item{name},
145            label    => $item{'label(?)'}[0],
146            comment  => $item{'hint(?)'}[0],
147            type     => $item{'type(?)'}[0],
148            value    => $item{'default(?)'}[0],
149            list     => $list_var,
150            validate => $item{'validate(?)'}[0],
[24]151            required => $required || 0,
[1]152        };
153       
154        $$field{options} = [ @options ] if @options;
155       
156        $$field{rows} = $rows if defined $rows;
157        $$field{cols} = $cols if defined $cols;
158        $$field{size} = $size if defined $size;
159       
[28]160        #warn "[$thisline] field $item{name}; context $context\n";
[21]161        if ($context eq 'group') {
162            push @group, $field;
163        } else {
164            push @lines, [ 'field', $field ];
165        }
[1]166       
167        $type = undef;
[24]168        $required = 0;
[1]169        $list_var = undef;
170        $size = undef;
171        $rows = undef;
172        $cols = undef;
173        @options = ();
174       
175    }
176   
177name: identifier
178
[16]179var_name: /[A-Z_]+/
180
[1]181field_size: '[' ( row_col | size ) ']'
182
183size: /\d+/
184    { $size = $item[1] }
185
186row_col: /\d+/ /,\s*/ /\d+/
187    { $rows = $item[1]; $cols = $item[3] }
188
[22]189label: '|' (simple_multiword | quoted_string) { $item[2] }
[1]190
191hint: '[' /[^\]]+/ ']'    { $item[2] }
192
193type: ':' /textarea|text|password|file|checkbox|radio|select|hidden|static/
194
[22]195default: '=' (simple_multiword | quoted_string) { $item[2] }
[1]196
[22]197# for simple multiword values not involving punctuation
198simple_multiword: <skip:''> /[\w\t ]+/ { $item[2] }
199
200# my attempt at a single-quoted, non-interpolating string
201# where the backslash can escape literal single quotes
202quoted_string: <skip:''> "'" /(\\'|[^'])*/ "'"
203    { $item[3] =~ s/\\'/'/g; $item[3] }
204
[1]205option_list: options | list_var
206   
207options: '{' option(s /,\s*/) '}'
208
209list_var: /@[A-Z_]+/ { $list_var = $item[1] }
210
[25]211option: (simple_multiword | value | quoted_string) display_text(?)
[23]212    { push @options, { $item[1] => $item{'display_text(?)'}[0] } }
[1]213
214value: identifier
215
216display_text: '[' /[^\]]+/i ']'    { $item[2] }
217
[24]218validate: '//' (optional_pattern | required_pattern)    { $item[2] }
[1]219
[24]220optional_pattern: /[A-Z_]+/ '?' { $required = 0; $item[1] }
221
222required_pattern: /[A-Z_]+/ { $required = 1; $item[1] }
223
[1]224comment: '#' /.*/
225blank:
226
227identifier: /\w+/
[16]228
229# skip unknown directives with a warning
230unknown_directive: /\!\S*/ /.*/
231    { warn "[Text::Formbuilder] Skipping unknown directive '$item[1]' at input text line $thisline\n"; }
Note: See TracBrowser for help on using the repository browser.