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

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

tried adding fall-through to built-in option lists but not yet working
minor tweak to the grammar for option lists (put wimple_multiword in front of value)

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