Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Inline::denter; |
2 | ||
3 | use strict; | |
4 | use Carp; | |
5 | use AutoLoader 'AUTOLOAD'; | |
6 | ||
7 | sub new { | |
8 | my $class = shift; | |
9 | bless {width => 4, | |
10 | comma => " : ", | |
11 | level => 0, | |
12 | tabwidth => 8, | |
13 | }, $class; | |
14 | } | |
15 | ||
16 | sub undent { | |
17 | local $/ = "\n"; | |
18 | my ($o, $text) = @_; | |
19 | my ($comma) = $o->{comma}; | |
20 | my $package = caller; | |
21 | $package = caller(1) if $package eq 'Inline::denter'; | |
22 | %{$o->{xref}} = (); | |
23 | @{$o->{objects}} = (); | |
24 | @{$o->{context}} = (); | |
25 | my $glob = ''; | |
26 | chomp $text; | |
27 | @{$o->{lines}} = split $/, $text; | |
28 | $o->{level} = 0; | |
29 | $o->{line} ||= 1; | |
30 | $o->_setup_line; | |
31 | while (not $o->{done}) { | |
32 | if ($o->{level} == 0 and | |
33 | $o->{content} =~ /^(\w+)\s*$comma\s*(.*)$/) { | |
34 | $o->{content} = $2; | |
35 | no strict 'refs'; | |
36 | push @{$o->{objects}}, "$1"; | |
37 | } | |
38 | push @{$o->{objects}}, $o->_undent_data; | |
39 | } | |
40 | return @{$o->{objects}}; | |
41 | } | |
42 | ||
43 | sub _undent_data { | |
44 | my $o = shift; | |
45 | my ($obj, $class) = ('', ''); | |
46 | my @refs; | |
47 | my %refs; | |
48 | while ($o->{content} =~ s/^\\(?:\((\w+)\))?((\%|\@|\$|\\).*)/$2/) { | |
49 | push @refs, $1; | |
50 | $refs{$1} = scalar @refs; | |
51 | } | |
52 | if ($o->{content} =~ /^([\%\@\$]) | |
53 | (\w(?:\w|::)*)? | |
54 | \s*$/x | |
55 | ) { | |
56 | my $foo; | |
57 | $obj = ($1 eq '%') ? {} : ($1 eq '@') ? [] : \$foo; | |
58 | $class = $2 || ''; | |
59 | if ($1 eq '%') { | |
60 | %$obj = $o->_undent_hash; | |
61 | } | |
62 | elsif ($1 eq '@') { | |
63 | @$obj = $o->_undent_array; | |
64 | } | |
65 | else { | |
66 | $$obj = $o->_undent_scalar; | |
67 | } | |
68 | bless $obj, $class if length $class; | |
69 | } | |
70 | elsif ($o->{content} =~ /^\?\s*$/) { | |
71 | $obj = $o->_undent_undef; | |
72 | } | |
73 | else { | |
74 | $obj = $o->_undent_value; | |
75 | } | |
76 | while (@refs) { | |
77 | my $ref = pop @refs; | |
78 | my $copy = $obj; | |
79 | $obj = \ $copy; | |
80 | $o->{xref}{$ref} = $obj if $ref; | |
81 | } | |
82 | return $obj; | |
83 | } | |
84 | ||
85 | sub _undent_value { | |
86 | my $o = shift; | |
87 | my $value = ''; | |
88 | if ($o->{content} =~ /^\<\<(\w+)(\-?)\s*$/) { | |
89 | my ($marker, $chomp) = ($1, $2); | |
90 | my $line = $o->{line}; | |
91 | $o->_next_line; | |
92 | while (not $o->{done} and | |
93 | $o->{lines}[0] ne $marker) { | |
94 | $value .= $o->{lines}[0] . "\n"; | |
95 | $o->_next_line; | |
96 | } | |
97 | croak M03_no_value_end_marker($marker, $line) if $o->{done}; | |
98 | chomp $value if $chomp; | |
99 | } | |
100 | elsif ($o->{content} =~ /^\"/) { | |
101 | croak $o->M04_mismatched_quotes unless $o->{content} =~ /^\".*\"\s*$/; | |
102 | ($value = $o->{content}) =~ s/^\"|\"\s*$//g; | |
103 | } | |
104 | else { | |
105 | $value = $o->{content}; | |
106 | } | |
107 | $o->_next_line; | |
108 | $o->_setup_line; | |
109 | return $value; | |
110 | } | |
111 | ||
112 | sub _undent_hash { | |
113 | my @values; | |
114 | my $o = shift; | |
115 | my $level = $o->{level} + 1; | |
116 | $o->_next_line; | |
117 | $o->_setup_line; | |
118 | while ($o->{level} == $level) { | |
119 | my ($key, $value) = split $o->{comma}, $o->{content}; | |
120 | croak $o->M05_invalid_key_value unless (defined $key and defined $value); | |
121 | $o->{content} = $value; | |
122 | push @values, $o->_get_key($key), $o->_undent_data;; | |
123 | } | |
124 | croak $o->M06_invalid_indent_level if $o->{level} > $level; | |
125 | return @values; | |
126 | } | |
127 | ||
128 | sub _get_key { | |
129 | my ($o, $key) = @_; | |
130 | return $key unless $key =~ /^\<\<(\w+)(\-?)/; | |
131 | my ($marker, $chomp) = ($1, $2); | |
132 | $key = ''; | |
133 | my $line = $o->{line}; | |
134 | $o->_next_line; | |
135 | while (not $o->{done} and | |
136 | $o->{lines}[0] ne $marker) { | |
137 | $key .= $o->{lines}[0] . "\n"; | |
138 | $o->_next_line; | |
139 | } | |
140 | croak M02_no_key_end_marker($marker, $line) if $o->{done}; | |
141 | chomp $key if $chomp; | |
142 | $o->_next_line; | |
143 | $o->_setup_line; | |
144 | return $key; | |
145 | } | |
146 | ||
147 | sub _undent_array { | |
148 | my @values; | |
149 | my $o = shift; | |
150 | my $level = $o->{level} + 1; | |
151 | $o->_next_line; | |
152 | $o->_setup_line; | |
153 | while ($o->{level} == $level) { | |
154 | push @values, $o->_undent_data; | |
155 | } | |
156 | croak $o->M06_invalid_indent_level if $o->{level} > $level; | |
157 | return @values; | |
158 | } | |
159 | ||
160 | sub _undent_scalar { | |
161 | my $values; | |
162 | my $o = shift; | |
163 | my $level = $o->{level} + 1; | |
164 | $o->_next_line; | |
165 | $o->_setup_line; | |
166 | croak $o->M06_invalid_indent_level if $o->{level} != $level; | |
167 | croak $o->M07_invalid_scalar_value if $o->{content} =~ /^[\%\@\$\\]/; | |
168 | return $o->_undent_undef if $o->{content} =~ /^\?/; | |
169 | return $o->_undent_value; | |
170 | } | |
171 | ||
172 | sub _undent_undef { | |
173 | my $o = shift; | |
174 | $o->_next_line; | |
175 | $o->_setup_line; | |
176 | return undef; | |
177 | } | |
178 | ||
179 | sub _next_line { | |
180 | my $o = shift; | |
181 | $o->{done}++, $o->{level} = -1, return unless @{$o->{lines}}; | |
182 | $_ = shift @{$o->{lines}}; | |
183 | $o->{line}++; | |
184 | } | |
185 | ||
186 | sub _setup_line { | |
187 | my $o = shift; | |
188 | $o->{done}++, $o->{level} = -1, return unless @{$o->{lines}}; | |
189 | my ($width, $tabwidth) = @{$o}{qw(width tabwidth)}; | |
190 | while (1) { | |
191 | $_ = $o->{lines}[0]; | |
192 | # expand tabs in leading whitespace; | |
193 | $o->next_line, next if /^(\s*$|\#)/; # skip comments and blank lines | |
194 | while (s{^( *)(\t+)} | |
195 | {' ' x (length($1) + length($2) * $tabwidth - | |
196 | length($1) % $tabwidth)}e){} | |
197 | croak $o->M01_invalid_indent_width unless /^(( {$width})*)(\S.*)$/; | |
198 | $o->{level} = length($1) / $width; | |
199 | $o->{content} = $3; | |
200 | last; | |
201 | } | |
202 | } | |
203 | ||
204 | 1; | |
205 | __END__ | |
206 | ||
207 | sub indent { | |
208 | my $o = shift; | |
209 | my $package = caller; | |
210 | $package = caller(1) if $package eq 'Inline::denter'; | |
211 | my $stream = ''; | |
212 | $o->{key} = ''; | |
213 | while (@_) { | |
214 | $_ = shift; | |
215 | $stream .= $o->indent_name($_, shift), next | |
216 | if (/^\*$package\::\w+$/); | |
217 | $stream .= $o->indent_data($_); | |
218 | } | |
219 | return $stream; | |
220 | } | |
221 | ||
222 | sub indent_data { | |
223 | my $o = shift; | |
224 | $_ = shift; | |
225 | return $o->indent_undef($_) | |
226 | if not defined; | |
227 | return $o->indent_value($_) | |
228 | if (not ref); | |
229 | return $o->indent_hash($_) | |
230 | if (ref eq 'HASH' and not /=/ or /=HASH/); | |
231 | return $o->indent_array($_) | |
232 | if (ref eq 'ARRAY' and not /=/ or /=ARRAY/); | |
233 | return $o->indent_scalar($_) | |
234 | if (ref eq 'SCALAR' and not /=/ or /=SCALAR/); | |
235 | return $o->indent_ref($_) | |
236 | if (ref eq 'REF'); | |
237 | return "$_\n"; | |
238 | } | |
239 | ||
240 | sub indent_value { | |
241 | my ($o, $data) = @_; | |
242 | my $stream; | |
243 | if ($data =~ /\n/) { | |
244 | my $marker = 'EOV'; | |
245 | $marker++ while $data =~ /^$marker$/m; | |
246 | my $chomp = ($data =~ s/\n\Z//) ? '' : '-'; | |
247 | $stream = "<<$marker$chomp\n"; | |
248 | $stream .= $o->{key}, $o->{key} = '' if $o->{key}; | |
249 | $stream .= "$data\n$marker\n"; | |
250 | } | |
251 | elsif ($data =~ /^[\s\%\@\$\\?\"]|\s$/ or | |
252 | $data =~ /\Q$o->{comma}\E/ or | |
253 | $data =~ /[\x00-\x1f]/ or | |
254 | $data eq '') { | |
255 | $stream = qq{"$data"\n}; | |
256 | $stream .= $o->{key}, $o->{key} = '' if $o->{key}; | |
257 | } | |
258 | else { | |
259 | $stream = "$data\n"; | |
260 | $stream .= $o->{key}, $o->{key} = '' if $o->{key}; | |
261 | } | |
262 | return $stream; | |
263 | } | |
264 | ||
265 | sub indent_hash { | |
266 | my ($o, $data) = @_; | |
267 | my $stream = $o->_print_ref($data, '%', 'HASH'); | |
268 | return $$stream if ref $stream; | |
269 | my $indent = ++$o->{level} * $o->{width}; | |
270 | for my $key (sort keys %$data) { | |
271 | my $key_out = $key; | |
272 | if ($key =~ /\n/ or | |
273 | $key =~ /\Q$o->{comma}\E/) { | |
274 | my $marker = 'EOK'; | |
275 | $marker++ while $key =~ /^$marker$/m; | |
276 | my $chomp = (($o->{key} = $key) =~ s/\n\Z//m) ? '' : '-'; | |
277 | $o->{key} .= "\n$marker\n"; | |
278 | $key_out = "<<$marker$chomp"; | |
279 | } | |
280 | elsif ($data =~ /^[\s\%\@\$\\?\"]|\s$/) { | |
281 | $key_out = qq{"$key"}; | |
282 | } | |
283 | $stream .= ' ' x $indent . $key_out . $o->{comma}; | |
284 | $stream .= $o->indent_data($data->{$key}); | |
285 | } | |
286 | $o->{level}--; | |
287 | return $stream; | |
288 | } | |
289 | ||
290 | sub indent_array { | |
291 | my ($o, $data) = @_; | |
292 | my $stream = $o->_print_ref($data, '@', 'ARRAY'); | |
293 | return $$stream if ref $stream; | |
294 | my $indent = ++$o->{level} * $o->{width}; | |
295 | for my $datum (@$data) { | |
296 | $stream .= ' ' x $indent; | |
297 | $stream .= $o->indent_data($datum); | |
298 | } | |
299 | $o->{level}--; | |
300 | return $stream; | |
301 | } | |
302 | ||
303 | sub indent_scalar { | |
304 | my ($o, $data) = @_; | |
305 | my $stream = $o->_print_ref($data, q{$}, 'SCALAR'); | |
306 | return $$stream if ref $stream; | |
307 | my $indent = ($o->{level} + 1) * $o->{width}; | |
308 | $stream .= ' ' x $indent; | |
309 | $stream .= $o->indent_data($$data); | |
310 | return $stream; | |
311 | } | |
312 | ||
313 | sub indent_ref { | |
314 | my ($o, $data) = @_; | |
315 | my $stream = $o->_print_ref($data, '\\', 'SCALAR'); | |
316 | return $$stream if ref $stream; | |
317 | chomp $stream; | |
318 | return $stream . $o->indent_data($$data); | |
319 | } | |
320 | ||
321 | sub indent_undef { | |
322 | my ($o, $data) = @_; | |
323 | my $stream = "?\n"; | |
324 | $stream .= $o->{key}, $o->{key} = '' if $o->{key}; | |
325 | return $stream; | |
326 | } | |
327 | ||
328 | sub indent_name { | |
329 | my ($o, $name, $value) = @_; | |
330 | $name =~ s/^.*:://; | |
331 | my $stream = $name . $o->{comma}; | |
332 | $stream .= $o->indent_data($value); | |
333 | return $stream; | |
334 | } | |
335 | ||
336 | sub _print_ref { | |
337 | my ($o, $data, $symbol, $type) = @_; | |
338 | $data =~ /^(([\w:]+)=)?$type\(0x([0-9a-f]+)\)$/ | |
339 | or croak "Invalid reference: $data\n"; | |
340 | my $stream = $symbol; | |
341 | $stream .= $2 if defined $2; | |
342 | $o->{xref}{$3}++; | |
343 | croak "Inline::denter does not handle duplicate references" | |
344 | if $o->{xref}{$3} > 1; | |
345 | $stream .= "\n"; | |
346 | $stream .= $o->{key}, $o->{key} = '' if $o->{key}; | |
347 | return $stream; | |
348 | } | |
349 | ||
350 | # Undent error messages | |
351 | sub M01_invalid_indent_width { | |
352 | my $o = shift; | |
353 | "Invalid indent width detected at line $o->{line}\n"; | |
354 | } | |
355 | ||
356 | sub M02_no_key_end_marker { | |
357 | my ($marker, $line) = @_; | |
358 | "No terminating marker '$marker' found for key at line $line\n"; | |
359 | } | |
360 | ||
361 | sub M03_no_value_end_marker { | |
362 | my ($marker, $line) = @_; | |
363 | "No terminating marker '$marker' found for value at line $line\n"; | |
364 | } | |
365 | ||
366 | sub M04_mismatched_quotes { | |
367 | my $o = shift; | |
368 | "Mismatched double quotes for value at line $o->{line}\n"; | |
369 | } | |
370 | ||
371 | sub M05_invalid_key_value { | |
372 | my $o = shift; | |
373 | "Missing or invalid hash key/value pair at $o->{line}\n"; | |
374 | } | |
375 | ||
376 | sub M06_invalid_indent_level { | |
377 | my $o = shift; | |
378 | "Invalid indentation level at $o->{line}\n"; | |
379 | } | |
380 | ||
381 | sub M07_invalid_scalar_value { | |
382 | my $o = shift; | |
383 | "Invalid value for scalar ref context at $o->{line}\n"; | |
384 | } | |
385 | ||
386 | 1; | |
387 | __END__ |