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

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

added !section directive

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