File Coverage

lib/CGI/FormBuilder/Source/File.pm
Criterion Covered Total %
statement 117 135 86.6
branch 48 70 68.5
condition 22 41 53.6
subroutine 8 9 88.8
pod 3 3 100.0
total 198 258 76.7


line stmt bran cond sub pod time code
1              
2             ###########################################################################
3             # Copyright (c) Nate Wiger http://nateware.com. All Rights Reserved.
4             # Please visit http://formbuilder.org for tutorials, support, and examples.
5             ###########################################################################
6              
7             package CGI::FormBuilder::Source::File;
8              
9             =head1 NAME
10              
11             CGI::FormBuilder::Source::File - Initialize FormBuilder from external file
12              
13             =head1 SYNOPSIS
14              
15             # use the main module
16             use CGI::FormBuilder;
17              
18             my $form = CGI::FormBuilder->new(source => 'form.conf');
19              
20             my $lname = $form->field('lname'); # like normal
21              
22             =cut
23              
24 2     2   7 use Carp;
  2         2  
  2         109  
25 2     2   7 use strict;
  2         2  
  2         29  
26 2     2   6 use warnings;
  2         2  
  2         44  
27 2     2   6 no warnings 'uninitialized';
  2         2  
  2         58  
28              
29 2     2   37 use 5.006; # or later
  2         4  
30 2     2   6 use CGI::FormBuilder::Util;
  2         3  
  2         2304  
31              
32              
33             our $VERSION = '3.10';
34              
35             # Begin "real" code
36             sub new {
37 23     23 1 33 my $mod = shift;
38 23   33     116 my $class = ref($mod) || $mod;
39 23         65 my %opt = arghash(@_);
40 23         63 return bless \%opt, $class;
41             }
42              
43             sub parse {
44 23     23 1 74 local $^W = 0; # -w sucks so hard
45 23         30 my $self = shift;
46 23   33     104 my $file = shift || $self->{source};
47              
48 23 50 33     117 $CGI::FormBuilder::Util::DEBUG ||= $self->{debug} if ref $self;
49              
50 23         30 my $ret = {}; # top level
51 23         42 my $ptr = $ret; # curr ptr
52 23         33 my @lvl = (); # previous levels
53              
54 23         26 my $s = 0; # curr spaces
55 23         22 my $lsp = 0; # level spaces
56 23         27 my $psp = 0; # prev spaces
57              
58 23         21 my $refield = 0;
59 23         23 my @file;
60 23         20 my $utf8 = 0; # parse file as utf8
61              
62 23         93 debug 1, "parsing $file as input source";
63 23 50       73 if (ref $file eq 'SCALAR') {
    0          
64 23         208 @file = split /[\r\n]+/, $$file;
65             } elsif (ref $file eq 'ARRAY') {
66 0         0 @file = @$file;
67             } else {
68 0 0       0 open(F, "<$file") || puke "Cannot read $file: $!";
69 0         0 @file = ;
70 0         0 close F;
71             }
72              
73 23         29 my($lterm, $here); # level term, here string
74 23         26 my $inval = 0;
75 23         48 for (@file) {
76 239 100 100     899 next if /^\s*$/ || /^\s*#/; # blanks and comments
77 214 50       731 next if /^\s*\[\%\s*\#|^\s*-*\%\]/; # TT comments too
78 214         172 chomp;
79 214         717 my($term, $line) = split /\s*:\s*/, $_, 2;
80 214 50 33     409 $utf8 = 1 if $term eq 'charset' && $line =~ /^utf/; # key off charset to decode value
81 214 50       275 $line = Encode::decode('utf-8', $line) if $utf8;
82              
83             # here string term-inator (har)
84 214 100       224 if ($here) {
85 3 100       6 if ($term eq $here) {
86 1         1 undef $here;
87 1         768 next;
88             } else {
89 2         3 $line = $term;
90 2         2 $term = $lterm;
91             }
92             } else {
93             # count leading space if it's there
94 211         170 $s = 1; # reset
95 211 100       544 $s += length($1) if $term =~ s/^(\s+)//;
96 211         233 $line =~ s/\s+$//; # trailing space
97              
98             # uplevel pre-check (may have a value below)
99 211 100       313 if ($s == 1) {
    100          
100 91         73 $ptr = $ret;
101 91         91 @lvl = ();
102 91         67 $lsp = 1; # set to zero for next pass
103 91         60 $refield = 0;
104 91         68 $inval = 0;
105             } elsif ($s <= $lsp) {
106 24   33     36 $ptr = pop(@lvl) || $ret;
107 24         23 $lsp = $s; # uplevel term indent
108 24         19 $inval = 0;
109             }
110              
111             # special catch for continued (indented) line
112 211 100 100     625 if ($s >= $psp && $inval && ! length $line) {
      100        
113 1         1 $line = $term;
114 1         2 $term = $lterm;
115             }
116 211         614 debug 2, "[$s >= $psp, inval=$inval] term=$term; line=$line";
117             }
118 213         186 $psp = $s;
119              
120             # has a value
121 213 100       258 if (length $line) {
122 132         316 debug 2, "$term = $line ($s < $lsp)";
123              
124 132   33     181 $lsp ||= $s; # first valid term indent
125              
126             # <
127 132 100       254 if ($line =~ /^<<(.+)/) {
    100          
128 1         2 $lterm = $term;
129 1         2 $here = $1;
130 1         2 next;
131             } elsif ($here) {
132 2         4 $ptr->{$term} .= "$line\n";
133 2         3 next;
134             }
135              
136 129         95 my @val;
137 129 100 66     792 if ($term =~ /^js/ || $term =~ /^on[a-z]/ || $term eq 'messages' || $term eq 'comment') {
    100 66        
      66        
138 8         15 @val = $line; # verbatim
139             } elsif ($line =~ s/^\\(.)//) {
140             # Reference - this is tricky. Go all the way up to
141             # the top to make sure, or use $self->{caller} if
142             # we were given a place to go.
143 2         4 my $r = $1;
144 2         3 my $l = 0;
145 2         3 my @p;
146 2 50       4 if ($self->{caller}) {
147 0         0 @p = $self->{caller};
148             } else {
149 2         7 while (my $pkg = caller($l++)) {
150 4         10 push @p, $pkg;
151             }
152             }
153 2 50       8 $line = "$r$p[-1]\::$line" unless $line =~ /::/;
154 2         8 debug 2, qq{eval "\@val = (\\$line)"};
155 2         109 eval "\@val = (\\$line)";
156 2 50       9 belch "Loading $line failed: $@" if $@;
157             } else {
158             # split commas
159 119         280 @val = split /\s*,\s*/, $line;
160              
161             # m=Male, f=Female -> [m,Male], [f,Female]
162 119         218 for (my $i=0; $i < @val; $i++) {
163 221 100       560 $val[$i] = [ split /\s*=\s*/, $val[$i], 2 ] if $val[$i] =~ /=/;
164             }
165             }
166              
167             # only arrayref on multi values b/c FB is "smart"
168 129 100       164 if ($ptr->{$term}) {
169             $ptr->{$term} = (ref $ptr->{$term})
170 1 0       4 ? [ @{$ptr->{$term}}, @val ] : @val > 1 ? \@val :
  1 0       4  
    50          
171             ref($val[0]) eq 'ARRAY' ? \@val : $val[0];
172             } else {
173 128 100       325 $ptr->{$term} = @val > 1 ? \@val : ref($val[0]) eq 'ARRAY' ? \@val : $val[0];
    100          
174             }
175 129         123 $inval = 1;
176             } else {
177 81         187 debug 2, "$term: new level ($s < $lsp)";
178              
179             # term:\n -> nest with bracket
180 81 100       168 if ($term eq 'fields') {
    100          
181 15         14 $refield = 1;
182 15         16 $term = 'fieldopts';
183             } elsif ($refield) {
184 41         32 push @{$ret->{fields}}, $term;
  41         84  
185             }
186              
187 81   50     278 $ptr->{$term} ||= {};
188 81         83 push @lvl, $ptr;
189 81         77 $ptr = $ptr->{$term};
190              
191 81         58 $lsp = $s; # reset spaces
192 81         64 $inval = 0;
193             }
194 210         244 $lterm = $term;
195             }
196              
197 23 50       59 if (ref $self) {
198             # add in any top-level options
199 23         81 while (my($k,$v) = each %$self) {
200 23 50       97 $ret->{$k} = $v unless exists $ret->{$k};
201             }
202              
203             # in FB, this is a class (not object) for speed
204 23         39 $self->{data} = $ret;
205 23         27 $self->{source} = $file;
206             }
207              
208 23 50       156 return wantarray ? %$ret : $ret;
209             }
210              
211             sub write_module {
212 0     0 1   my $self = shift;
213 0   0       my $mod = shift || puke "Missing required Module::Name";
214 0           (my $out = $mod) =~ s/.+:://;
215 0           $out .= '.pm';
216              
217 0 0         open(M, ">$out") || puke "Can't write $out: $!";
218              
219 0           print M "\n# Generated ".localtime()." by ".__PACKAGE__." $VERSION\n";
220 0           print M <
221             #
222             # To use this, you must write a script and then use this module.
223             # In your script, get this form with "my \$form = $mod->new()"
224              
225             package $mod;
226              
227             use CGI::FormBuilder;
228             use strict;
229              
230             sub new {
231             # $mod->new() calling format
232             my \$self = shift if \@_ && \@_ % 2 != 0;
233              
234             # data structure from '$self->{source}'
235             EOH
236              
237 0           require Data::Dumper;
238 0           local $Data::Dumper::Varname = 'form';
239 0           print M " my ". Data::Dumper::Dumper($self->{data});
240              
241 0           print M <<'EOV';
242              
243             # allow overriding of individual parameters
244             while (@_) {
245             $form1->{shift()} = shift;
246             }
247              
248             # return a new form object
249             return CGI::FormBuilder->new(%$form1);
250             }
251              
252             1;
253             # End of module
254             EOV
255              
256 0           close M;
257 0           print STDERR "Wrote $out\n"; # send to stderr in case of httpd
258             }
259              
260             1;
261             __END__