File Coverage

blib/lib/YAML/Tidy.pm
Criterion Covered Total %
statement 582 636 91.5
branch 224 258 86.8
condition 128 144 88.8
subroutine 32 34 94.1
pod 4 5 80.0
total 970 1077 90.0


line stmt bran cond sub pod time code
1             # ABSTRACT: Tidy YAML files
2 6     6   446156 use strict;
  6         42  
  6         138  
3 6     6   24 use warnings;
  6         9  
  6         135  
4 6     6   24 use warnings FATAL => qw/ substr /;
  6         8  
  6         179  
5              
6 6     6   97 use v5.20;
  6         19  
7 6     6   2273 use experimental qw/ signatures /;
  6         16510  
  6         25  
8             package YAML::Tidy;
9              
10             our $VERSION = '0.006_001'; # TRIAL VERSION
11              
12 6     6   3190 use YAML::Tidy::Node;
  6         13  
  6         158  
13 6     6   2015 use YAML::Tidy::Config;
  6         14  
  6         154  
14 6     6   2104 use YAML::LibYAML::API::XS;
  6         2447  
  6         205  
15 6         249 use YAML::PP::Common qw/
16             YAML_PLAIN_SCALAR_STYLE YAML_SINGLE_QUOTED_SCALAR_STYLE
17             YAML_DOUBLE_QUOTED_SCALAR_STYLE YAML_LITERAL_SCALAR_STYLE
18             YAML_FOLDED_SCALAR_STYLE
19             YAML_FLOW_SEQUENCE_STYLE YAML_FLOW_MAPPING_STYLE
20 6     6   32 /;
  6         10  
21 6     6   2877 use YAML::PP::Parser;
  6         124502  
  6         186  
22 6     6   2216 use YAML::PP::Highlight;
  6         205357  
  6         278  
23 6     6   44 use Data::Dumper;
  6         11  
  6         256  
24              
25 6 50   6   30 use constant DEBUG => $ENV{YAML_TIDY_DEBUG} ? 1 : 0;
  6         12  
  6         42127  
26              
27 22     22 1 1128 sub new($class, %args) {
  22         39  
  22         42  
  22         26  
28 22   66     74 my $cfg = delete $args{cfg} || YAML::Tidy::Config->new();
29             my $self = bless {
30             partial => delete $args{partial},
31 22         70 cfg => $cfg,
32             }, $class;
33 22         76 return $self;
34             }
35              
36 67802     67802 1 67267 sub cfg($self) { $self->{cfg} }
  67802         67819  
  67802         63351  
  67802         137141  
37 22505     22505 0 23599 sub partial($self) { $self->{partial} }
  22505         24121  
  22505         21768  
  22505         41981  
38              
39 3037     3037 1 4272349 sub tidy($self, $yaml) {
  3037         5221  
  3037         5352  
  3037         3896  
40 3037         5643 local $Data::Dumper::Sortkeys = 1;
41 3037         29311 my @lines = split /\n/, $yaml, -1;
42 3037         10063 my $tree = $self->_tree($yaml, \@lines);
43 3037         5498 $self->{tree} = $tree;
44 3037         8717 $self->{lines} = \@lines;
45             # warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@lines], ['lines']);
46 3037 100       6410 if (@lines) {
47 3024         3817 my $from = 0;
48 3024 100       8904 $self->_trimspaces(\$from, $tree) if $self->cfg->trimtrailing;
49 3024         9162 $self->_process(undef, $tree);
50             }
51 3037         5073 $yaml = join "\n", @{ $self->{lines} };
  3037         10909  
52             # warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$yaml], ['yaml']);
53 3037         9622 return $yaml;
54             }
55              
56 22424     22424   25225 sub _process($self, $parent, $node) {
  22424         25983  
  22424         22581  
  22424         22711  
  22424         21489  
57 22424   100     47495 my $type = $node->{type} || '';
58             # warn __PACKAGE__.':'.__LINE__.": ======== _process($parent, $node) $type\n";
59 22424 100       37071 if ($node->{flow}) {
60 975         3761 $self->_process_flow($parent, $node);
61 975         1994 return;
62             }
63 21449         27102 my $level = $node->{level};
64 21449         31348 my $indent = $self->cfg->indent;
65 21449         28542 my $lines = $self->{lines};
66 21449 50       32408 return unless @$lines;
67              
68 21449 100 100     43895 if ($level == -1 and $type eq 'DOC') {
69 3347         8344 $self->_process_doc($parent, $node);
70             }
71 21449         37820 my $start = $node->start;
72              
73              
74 21449         24366 my $indenttoplevelscalar = 1;
75 21449         28533 my $trimtrailing = $self->cfg->trimtrailing;
76              
77 21449         38760 my $col = $node->indent;
78 21449 100       46455 my $lastcol = $parent ? $parent->indent : -99;
79 21449         29659 my $realindent = $col - $lastcol;
80 21449         35501 my $startline = $node->line;
81 21449         33406 my $line = $lines->[ $startline ];
82 21449 50       33140 unless (defined $line) {
83 0         0 die "Line $startline not found";
84             }
85 21449         44939 my $before = substr($line, 0, $col);
86              
87              
88 21449 100       37205 if ($node->is_collection) {
89 10329   100     16783 my $ignore_firstlevel = ($self->partial and $level == 0);
90 10329 100 100     24957 if ($level < 0 or $ignore_firstlevel) {
91 6372         7082 for my $c (@{ $node->{children} }) {
  6372         11364  
92 6696         11075 $self->_process($node, $c);
93             }
94 6372         12322 return;
95             }
96              
97 3957 100       7101 if ($level == 0) {
98 2274         3321 $indent = 0;
99             }
100 3957 100       9036 if ($type eq 'MAP') {
    50          
101 2492 100       5745 if ($before =~ tr/ //c) {
102 317 100       923 if ($indent == 1) {
103 12         21 $indent = 2;
104             }
105             }
106             }
107             elsif ($type eq 'SEQ') {
108 1465 100       2875 if ($before =~ tr/ //c) {
109 247 100       638 if ($indent == 1) {
110 12         17 $indent = 2;
111             }
112             }
113             else {
114 1218 100 100     4582 if ($parent->{type} eq 'MAP' and not $node->{index} % 2) {
115             # zero indented sequence?
116 370         839 $indent = $self->cfg->indent_seq_in_map;
117             }
118             }
119              
120             }
121 3957         7239 my $diff = $indent - $realindent;
122 3957 100       6578 if ($diff) {
123 588         1890 $self->_fix_indent($node, $diff, $col);
124 588         2013 $node->fix_node_indent($diff);
125             }
126 3957         5001 for my $c (@{ $node->{children} }) {
  3957         6889  
127 12704         20713 $self->_process($node, $c);
128             }
129 3957         8892 return;
130             }
131             else {
132 11120   100     17355 my $ignore_firstlevel = ($self->partial and $level == 0);
133 11120 100       19735 if ($node->empty_scalar) {
134 282         695 return;
135             }
136 10838 100       19054 if ($node->{name} eq 'alias_event') {
137 261         715 return;
138             }
139 10577 100 100     30269 if ($parent->{type} eq 'MAP' and ($node->{index} % 2 and not $node->multiline)) {
      100        
140 4395         9596 $self->_replace_quoting($node);
141 4395         10568 return;
142             }
143 6182         10912 my $new_indent = $parent->indent + $indent;
144 6182         12562 my $new_spaces = ' ' x $new_indent;
145              
146 6182         12602 my ($anchor, $tag, $comments, $scalar) = $self->_find_scalar_start($node);
147 6182         9593 my $explicit_indent = 0;
148 6182 100       15519 if ($scalar->[2] =~ m/[>|]/) {
149 901         2105 my $l = $lines->[ $scalar->[0] ];
150 901         4005 my ($ind) = substr($l, $scalar->[1]) =~ m/^[|>][+-]?([0-9]*)/;
151 901         1798 $explicit_indent = $ind;
152             }
153 6182         7395 my $skipfirst = 0;
154 6182         10380 my $before = substr($line, 0, $col);
155 6182 100       12533 if ($before =~ tr/ \t//c) {
156             # same line as key
157 5311         6053 my $remove = 0;
158 5311 50       22960 $before =~ s/([\t ]+)$/ / and $remove = -1 + length $1;
159 5311         12876 $node->open->{column} -= $remove;
160 5311 100       9647 unless ($node->multiline) {
161 4140         7359 $node->close->{column} -= $remove;
162             }
163 5311         10853 $line = $before . substr($line, $col);
164 5311         9378 $lines->[ $startline ] = $line;
165 5311         7043 $skipfirst = 1;
166             }
167 6182         8754 my $realstart = $scalar->[0];
168 6182 100       10183 unless ($ignore_firstlevel) {
169 6180         10731 for my $i ($startline .. $realstart) {
170 6331         8562 my $line = $lines->[ $i ];
171 6331 100 100     18825 if ($i == $startline and $col > 0) {
172 5591         8891 my $before = substr($line, 0, $col);
173 5591 100       10186 if ($before =~ tr/ //c) {
174 5311         9431 next;
175             }
176             }
177 1020 50       2904 unless ($line =~ tr/ //c) {
178 0         0 next;
179             }
180 1020         1533 my $remove = 0;
181 1020 50       5517 $line =~ s/^( *)/$new_spaces/ and $remove = length($1) - length($new_spaces);
182 1020 100       2822 if ($i == $startline) {
183 869         2320 $node->open->{column} -= $remove;
184 869 100       1882 unless ($node->multiline) {
185 409         1214 $node->close->{column} -= $remove;
186             }
187             }
188 1020         2357 $lines->[ $i] = $line;
189             }
190             }
191             # leave alone explicitly indented block scalars
192 6182 100       9879 return if $explicit_indent;
193              
194 6027         6854 $startline = $realstart;
195 6027         10916 my $endline = $node->realendline;
196             # warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$startline], ['startline']);
197             # warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$endline], ['endline']);
198              
199 6027         8662 my $line = $lines->[ $startline ];
200 6027         7603 my $realcol = $scalar->[1];
201 6027         7309 $col = $realcol;
202              
203 6027         8088 my $nextline = $node->{nextline};
204              
205             my $block = ($node->{style} eq YAML_LITERAL_SCALAR_STYLE
206 6027   100     15940 or $node->{style} eq YAML_FOLDED_SCALAR_STYLE);
207 6027 100 100     19233 if ($block) {
    50 66        
208              
209 746         1270 $startline++;
210 746   100     3832 while ($startline < $endline and $lines->[ $startline ] !~ tr/ //c) {
211 73 100       200 if ($trimtrailing) {
212 68         135 $self->_trim($startline, $startline);
213             }
214 73         238 $startline++;
215             }
216 746 100       1946 if ($nextline > $endline + 1) {
217 68         119 $endline = $nextline - 1;
218             }
219 746         2231 my @slice = @$lines[$startline .. $endline ];
220 746         3463 my ($sp) = $lines->[ $startline ] =~ m/^( *)/;
221 746 100 100     4174 if (not $ignore_firstlevel and length($sp) != $new_indent) {
    100          
222 373         842 for my $line (@slice) {
223 1179 100       2586 unless (length $line) {
224 274         448 next;
225             }
226 905 100 100     2493 if ($line !~ tr/ //c and length($line) <= length($sp)) {
227 132 100       315 if ($trimtrailing) {
228 124         226 $line = '';
229             }
230 132         224 next;
231             }
232 773 100       1886 if ($line =~ m/^( *)\#/) {
233 42         86 my $cindent = length $1;
234 42         84 my $diff = $new_indent - length $sp;
235 42         60 $cindent += $diff;
236 42 100       87 if ($diff > 0) {
    50          
237 31         114 $line = (' ' x $diff) . $line;
238             }
239             elsif ($diff < 0) {
240 11 50       18 if ($cindent < 0) {
241 0         0 $cindent = 0;
242             }
243 11         16 $new_spaces = ' ' x $cindent;
244 11         39 $line =~ s/^ */$new_spaces/;
245             }
246             }
247             else {
248 731         4806 $line =~ s/^$sp/$new_spaces/;
249             }
250             }
251 373         2333 @$lines[$startline .. $endline ] = @slice;
252             }
253             elsif ($trimtrailing) {
254 348         671 for my $line (@slice) {
255 917 100 100     2738 if ($line !~ tr/ //c and length($line) <= length($sp)) {
256 228         435 $line = '';
257             }
258             }
259 348         1797 @$lines[$startline .. $endline ] = @slice;
260             }
261             }
262             elsif ($node->{style} == YAML_PLAIN_SCALAR_STYLE or
263             $node->{style} == YAML_SINGLE_QUOTED_SCALAR_STYLE or
264             $node->{style} == YAML_DOUBLE_QUOTED_SCALAR_STYLE) {
265 5281 50       9639 if ($node->empty_scalar) {
266 0         0 return;
267             }
268 5281         6935 my $remove = 0;
269 5281 100 100     12145 if (not $skipfirst or $node->multiline) {
270 1141         1674 my $startline = $startline;
271 1141 100       2315 $startline++ if $skipfirst;
272 1141         2364 $endline = $node->close->{line};
273 1141 50       2864 return if $startline >= @$lines;
274 1141         1801 my $line = $lines->[ $startline ];
275 1141         4076 my ($sp) = $line =~ m/^( *)/;
276 1141 100       2477 if ($ignore_firstlevel) {
277 1         2 $new_indent = length $sp;
278 1         4 $new_spaces = ' ' x $new_indent;
279             }
280 1141         3317 my @slice = @$lines[$startline .. $endline ];
281 1141 50 66     3604 if ($level == 0 and not $indenttoplevelscalar) {
282 0         0 $new_spaces = ' ' x ($new_indent - $indent);
283             }
284 1141         2007 for my $line (@slice) {
285 2048 100       4457 if ($line =~ tr/ //c) {
286 1747 50       8591 $line =~ s/^([\t ]*)/$new_spaces/
287             and $remove = length($1) - length($new_spaces);
288             }
289             }
290 1141         2749 $node->close->{column} -= $remove;
291 1141         3238 @$lines[$startline .. $endline ] = @slice;
292             }
293 5281 100       9945 if (not $node->multiline) {
294 4549         8976 $self->_replace_quoting($node);
295             }
296             }
297             }
298             }
299              
300             my $RE_INT_CORE = qr{^([+-]?(?:[0-9]+))$};
301             my $RE_FLOAT_CORE = qr{^([+-]?(?:\.[0-9]+|[0-9]+(?:\.[0-9]*)?)(?:[eE][+-]?[0-9]+)?)$};
302             my $RE_INT_OCTAL = qr{^0o([0-7]+)$};
303             my $RE_INT_HEX = qr{^0x([0-9a-fA-F]+)$};
304             my @null = (qw/ null NULL Null ~ /, '');
305             my @true = qw/ true TRUE True /;
306             my @false = qw/ false FALSE False /;
307             my @inf = qw/ .inf .Inf .INF +.inf +.Inf +.INF -.inf -.Inf -.INF /;
308             my @nan = qw/ .nan .NaN .NAN /;
309             my @re = ($RE_INT_CORE, $RE_INT_OCTAL, $RE_INT_HEX, $RE_FLOAT_CORE);
310             my $re = join '|', @re;
311             my @all = (@null, @true, @false, @inf, @nan);
312              
313 11294     11294   11920 sub _replace_quoting($self, $node) {
  11294         12335  
  11294         12443  
  11294         12405  
314 11294 100       20040 return if $node->{tag};
315 10419         16056 my $default_style = $self->cfg->default_scalar_style;
316             # single line flow scalars
317 10419 100 100     32272 if (defined $default_style and $node->{style} != $default_style) {
318 1508         2761 my ($changed, $new_string, $new_style) = $self->_change_style($node, $default_style);
319 1508 100       3283 if ($changed) {
320 1341         2118 my $lines = $self->{lines};
321 1341         3353 my $line = $lines->[ $node->open->{line} ];
322 1341         2787 my ($from, $to) = ($node->open->{column}, $node->close->{column});
323 1341 100 66     5055 if (defined $node->{anchor} or $node->{tag}) {
324 58         161 my ($anchor, $tag, $comments, $scalar) = $self->_find_scalar_start($node);
325 58         148 $from = $scalar->[1];
326             }
327 1341         3860 substr($line, $from, $to - $from, $new_string);
328 1341         1812 my $diff = length($new_string) - ($to - $from);
329 1341 100       2154 if ($diff) {
330 1314         2730 $self->{tree}->_move_columns($node->open->{line}, $node->close->{column} + 1, $diff);
331             }
332 1341         2359 $node->{style} = $new_style;
333 1341         2307 $node->close->{column} += $diff;
334 1341         2501 $lines->[ $node->open->{line} ] = $line;
335             }
336             }
337             }
338              
339 1508     1508   1710 sub _change_style($self, $node, $style) {
  1508         1808  
  1508         1564  
  1508         2132  
  1508         1662  
340 1508         2409 my $value = $node->{value};
341 1508 100 100     2767 if (grep { $_ eq $value } @all or $value =~ m/($re)/) {
  34684         53351  
342             # leave me alone
343 150 100 100     596 if ($node->{style} eq YAML_PLAIN_SCALAR_STYLE or $style eq YAML_PLAIN_SCALAR_STYLE) {
344 149         428 return (0);
345             }
346             }
347              
348 1359         2807 my $emit = $self->_emit_value($value, $style);
349 1359         2996 chomp $emit;
350 1359 50       2993 return (0) if $emit =~ tr/\n//;
351 1359         2332 my $first = substr($emit, 0, 1);
352 1359 100       3178 my $new_style =
    100          
353             $first eq "'" ? YAML_SINGLE_QUOTED_SCALAR_STYLE
354             : $first eq '"' ? YAML_DOUBLE_QUOTED_SCALAR_STYLE
355             : YAML_PLAIN_SCALAR_STYLE;
356 1359 100       2892 if ($new_style eq $style) {
357 1341         4746 return (1, $emit, $new_style);
358             }
359              
360 18         51 return (0);
361             }
362              
363 1359     1359   1497 sub _emit_value($self, $value, $style) {
  1359         1460  
  1359         1561  
  1359         1687  
  1359         1354  
364 1359         1812 my $options = {};
365 1359         7902 my $events = [
366             { name => 'stream_start_event' },
367             { name => 'document_start_event', implicit => 1 },
368             { name => 'scalar_event', style => $style, value => $value },
369             { name => 'document_end_event', implicit => 1 },
370             { name => 'stream_end_event' },
371             ];
372 1359         23870 return YAML::LibYAML::API::XS::emit_string_events($events, $options);
373             }
374              
375 3347     3347   3917 sub _process_doc($self, $parent, $node) {
  3347         4108  
  3347         4369  
  3347         3984  
  3347         3551  
376 3347         3451 DEBUG and say STDERR "_process_doc($node)";
377 3347         5045 my $lines = $self->{lines};
378 3347         5605 my $open = $node->open;
379 3347         6091 my $close = $node->close;
380 3347 100 100     5706 if ($node->open->{implicit} and $self->cfg->addheader and not $self->partial) {
    100 66        
      100        
      100        
      66        
381             # add ---
382 339         962 splice @$lines, $open->{start}->{line}, 0, '---';
383 339         1154 $self->{tree}->fix_lines($open->{start}->{line}, +1);
384 339         501 $open->{start}->{line}--;
385 339         530 $open->{end}->{line}--;
386 339         561 $open->{end}->{column} = 3;
387 339         430 $open->{implicit} = 0;
388 339         448 DEBUG and say STDERR "$node";
389             }
390             elsif ($node->{index} == 1 and not $open->{implicit} and $self->cfg->removeheader and not $self->partial) {
391             # remove first ---
392 159         323 my $child = $node->{children}->[0];
393 159 100 100     1129 if ($open->{version_directive} or $open->{tag_directives} or not $child->is_collection and $child->empty_scalar) {
      100        
      100        
394             }
395             else {
396 138         300 my $startline = $open->{start}->{line};
397 138         291 my $line = $lines->[ $startline ];
398 138 100       913 if ($line =~ m/^---[ \t]*$/) {
    50          
399 99         228 splice @$lines, $startline, 1;
400 99         493 $self->{tree}->fix_lines($open->{start}->{line}+1, -1);
401 99         177 DEBUG and say STDERR "$node";
402 99         223 $open->{implicit} = 1;
403             }
404             elsif ($line =~ s/^---[ \t]+(?=#)//) {
405 0         0 $lines->[ $startline ] = $line;
406 0         0 DEBUG and say STDERR "$node";
407 0         0 $open->{implicit} = 1;
408             }
409             }
410             }
411 3347 100 100     9907 if ($close->{implicit} and $self->cfg->addfooter and not $self->partial) {
    100 66        
      100        
      66        
412             # add ...
413 531         1354 splice @$lines, $close->{start}->{line}, 0, '...';
414 531         1514 $self->{tree}->fix_lines($close->{start}->{line}, +1);
415 531         839 $close->{end}->{column} = 3;
416 531         974 $close->{implicit} = 0;
417 531         803 DEBUG and say STDERR "$node";
418             }
419             elsif (not $close->{implicit} and $self->cfg->removefooter and not $self->partial) {
420             # remove ...
421 27         88 my $next = $parent->{children}->[ $node->{index} ];
422 27 100 66     97 if ($next and ($next->open->{version_directive} or $next->open->{tag_directives})) {
      66        
423             }
424             else {
425 12         40 my $startline = $close->{start}->{line};
426 12         27 my $line = $lines->[ $startline ];
427 12 50       81 if ($line =~ m/^\.\.\.[ \t]*$/) {
    0          
428 12         39 splice @$lines, $startline, 1;
429 12         68 $self->{tree}->fix_lines($close->{start}->{line}+1, -1);
430 12         43 $close->{implicit} = 1;
431             }
432             elsif ($line =~ s/^\.\.\.[ \t]+(?=#)//) {
433 0         0 $lines->[ $startline ] = $line;
434 0         0 $close->{implicit} = 1;
435             }
436 12         30 DEBUG and say STDERR "$node";
437             }
438             }
439             }
440              
441 24415     24415   23658 sub _trimspaces($self, $from, $node) {
  24415         24765  
  24415         24596  
  24415         24133  
  24415         23007  
442 24415 100       37732 if ($node->is_collection) {
    100          
443 11171         13423 my $level = $node->{level};
444 11171         11547 for my $c (@{ $node->{children} }) {
  11171         15801  
445 21559         31777 $self->_trimspaces($from, $c);
446             }
447 11171 100       19942 if ($level == -1) {
448 6017         13588 $self->_trim($$from, $node->end->{line});
449             }
450             }
451             elsif (defined $node->{style}) {
452             # Only spaces in block scalars must be left alone
453 12988 100 100     43919 if ($node->{style} eq YAML_LITERAL_SCALAR_STYLE
454             or $node->{style} eq YAML_FOLDED_SCALAR_STYLE) {
455 847         2560 my ($anchor, $tag, $comments, $scalar) = $self->_find_scalar_start($node);
456 847         2895 $self->_trim($$from, $scalar->[0]);
457 847         2427 $$from = $node->end->{line};
458             }
459             }
460             }
461              
462 3996     3996   4775 sub _process_flow($self, $parent, $node, $block_indent = undef) {
  3996         4538  
  3996         4591  
  3996         4644  
  3996         4865  
  3996         4304  
463 3996 50       8605 return unless $parent;
464 3996         7069 my $level = $node->{level};
465 3996   50     8182 my $flow = $node->{flow} || 0;
466 3996   66     8107 $block_indent //= $parent->indent + $self->cfg->indent;
467 3996 100       7706 $block_indent = 0 if $level == 0;
468              
469 3996 100       7328 unless ($node->is_collection) {
470 2591         6208 $self->_process_flow_scalar($parent, $node, $block_indent);
471 2591         6300 return;
472             }
473 1405 100 100     4980 if ($parent->{type} eq 'MAP' and $node->{index} % 2) {
474 97         204 return;
475             }
476 1308         2348 my $lines = $self->{lines};
477 1308         2950 my $startline = $node->start->{line};
478 1308         2731 my $end = $node->end;
479 1308         2383 my $endline = $end->{line};
480              
481 1308         2803 my $before = substr($lines->[ $startline ], 0, $node->start->{column});
482 1308 100       3539 if ($before =~ tr/ \t//c) {
483 919         1294 $startline++;
484             }
485 1308         2877 my @lines = ($startline .. $node->open->{end}->{line});
486 1308         3991 my $before_end = substr($lines->[ $endline ], 0, $end->{column} - 1);
487 1308 100       3190 unless ($before_end =~ tr/ \t//c) {
488 294         559 push @lines, $endline;
489             }
490 1308         2607 for my $i (@lines) {
491 699         1517 my $new_spaces = ' ' x $block_indent;
492 699         3567 $lines->[ $i ] =~ s/^([ \t]*)/$new_spaces/;
493 699         2111 my $old = length $1;
494 699         2271 $node->_fix_flow_indent(line => $i, diff => $block_indent - $old);
495             }
496              
497 1308         1759 for my $c (@{ $node->{children} }) {
  1308         2630  
498 3021         5061 $self->_process_flow($node, $c, $block_indent + $self->cfg->indent);
499             }
500             }
501              
502 2591     2591   2995 sub _process_flow_scalar($self, $parent, $node, $block_indent) {
  2591         3005  
  2591         2761  
  2591         2802  
  2591         2847  
  2591         2815  
503 2591 100       4611 if ($node->empty_scalar) {
504 128         246 return;
505             }
506 2463         4689 my $startline = $node->line;
507 2463         3951 my $lines = $self->{lines};
508 2463         4140 my $line = $lines->[ $startline ];
509 2463         3886 my $col = $node->start->{column};
510 2463         5984 my $before = substr($line, 0, $col);
511 2463 100       5841 if ($before =~ tr/ \t//c) {
512 2101         2459 $startline++;
513             }
514 2463         4570 my $endline = $node->end->{line};
515 2463         5092 for my $i ($startline .. $endline) {
516 466         1015 my $line = $lines->[ $i ];
517 466         1052 my $new_spaces = ' ' x $block_indent;
518 466         2342 $line =~ s/^([ \t]*)/$new_spaces/;
519 466         1179 my $old = length $1;
520 466 100       1282 if ($block_indent != $old) {
521 415         1248 $self->{tree}->_fix_flow_indent(line => $i, diff => $block_indent - $old);
522             }
523 466         1341 $lines->[ $i ] = $line;
524             }
525 2463 100       4417 if (not $node->multiline) {
526 2359         5262 $self->_check_adjacency($node, $parent);
527 2359 100       5562 if ($node->{name} eq 'scalar_event') {
528 2350         4576 $self->_replace_quoting($node);
529             }
530             }
531             }
532              
533 2359     2359   2637 sub _check_adjacency($self, $node, $parent) {
  2359         2716  
  2359         2586  
  2359         2670  
  2359         2485  
534 2359 50       4185 return unless $node->{flow};
535 2359 100       4948 return unless $node->is_mapping_value($parent);
536             # allowed: "foo":bar, "foo":*alias
537             # not allowed: foo:bar, foo:*alias
538 749         2286 my $prev = $parent->sibling($node, -1);
539 749         1573 my $tidy_adjacency = $self->cfg->adjacency;
540 749 100 100     1637 if (not $prev->is_collection and not $prev->is_quoted) {
541 527         843 $tidy_adjacency = 0; # adjacency would be invalid here
542             }
543 749         1573 my $start = $node->open;
544 749         1093 my $adjacent = 0;
545 749         1646 my $line = $self->{lines}->[ $start->{line} ];
546 749 100 66     4154 if ($start->{column} > 0 and substr($line, $start->{column} - 1, 1) eq ':') {
547 56         124 $adjacent = 1;
548             }
549 749 100       1879 return unless defined $tidy_adjacency; # keep as is
550 527 50       1113 if ($tidy_adjacency) {
551 0         0 die "Not implemented yet: enforce adjacency";
552             }
553 527 100       1496 return unless $adjacent;
554 2         9 substr($line, $start->{column}, 0, ' ');
555 2         10 $self->{tree}->_move_columns($start->{line}, $start->{column} + 1, +1);
556 2         9 $self->{lines}->[ $start->{line} ] = $line;
557             }
558              
559 7087     7087   7656 sub _find_scalar_start($self, $node) {
  7087         7769  
  7087         7173  
  7087         7034  
560             # warn __PACKAGE__.':'.__LINE__.": ========= _find_scalar_start $node\n";
561 7087         9245 my $lines = $self->{lines};
562 7087         12129 my $from = $node->line;
563 7087         12440 my $to = $node->realendline;
564 7087         11908 my $col = $node->indent;
565 7087         11711 my $end = $node->end;
566 7087         9102 my $endcol = $end->{column};
567 7087         17726 my @slice = @$lines[ $from .. $to ];
568 7087         21473 my $anchor;
569             my $tag;
570 7087         0 my @comments;
571 7087         0 my $start;
572 7087         0 my $scalar;
573 7087         14023 for my $i (0 .. $#slice) {
574 7253         10048 my $line = $slice[ $i ];
575 7253 100       11999 my $f = $i == 0 ? $col : 0;
576 7253 100 33     15697 my $t = $i == $#slice ? ($endcol || length($line)) : length($line);
577 7253         15250 my $part = substr($line, $f, $t - $f);
578 7253 50       17973 if ($part =~ m/^ *(\#.*)$/g) {
579 0         0 my $comment = $1;
580 0         0 my $pos1 = length($line) - length($comment);
581 0         0 push @comments, [$i + $from, $pos1, $comment];
582 0         0 next;
583             }
584 7253         8182 my $cur;
585 7253         24934 while ($part =~ m/\G\s*([&!])(\S*)/g) {
586 1354         3060 my $type = $1;
587 1354         2159 my $name = $2;
588 1354         2037 $cur = pos $part;
589 1354         1927 my $pos = $cur - 1;
590 1354         1948 my $pos1 = $pos - length $name;
591 1354         2457 my $prop = substr($part, $pos1, 1+ length $name);
592 1354 100       3336 if ($type eq '&') {
    50          
593 501         1889 $anchor = [$i + $from, $pos1 + $f, $prop];
594             }
595             elsif ($type eq '!') {
596 853         3750 $tag = [$i + $from, $pos1 + $f, $prop];
597             }
598             }
599 7253         14682 pos($part) = $cur;
600 7253 50       16816 if ($part =~ m/\G *(\#.*)$/g) {
601 0         0 my $comment = $1;
602 0         0 $cur = pos $part;
603 0         0 my $pos1 = length($line) - length($comment);
604 0         0 push @comments, [$i + $from, $pos1, $comment];
605 0         0 next;
606             }
607 7253         10784 pos($part) = $cur;
608 7253 100       21552 if ($part =~ m/\G *(\S)/g) {
609 6911         13549 $scalar = $1;
610 6911         9658 my $pos1 = (pos $part) - 1;
611 6911         14050 $scalar = [$i + $from, $pos1 + $f, $scalar];
612 6911         13562 last;
613             }
614             }
615 7087   100     12839 $scalar ||= [$to, length($slice[ -1 ]), ''];
616             # warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$scalar], ['scalar']);
617 7087         21232 return ($anchor, $tag, \@comments, $scalar);
618             }
619              
620 6932     6932   8309 sub _trim($self, $from, $to) {
  6932         7611  
  6932         7432  
  6932         7274  
  6932         6826  
621 6932         8753 my $lines = $self->{lines};
622 6932         13334 for my $line (@$lines[ $from .. $to ]) {
623 32434         60570 $line =~ s/[\t ]+$//;
624             }
625             }
626              
627 588     588   844 sub _fix_indent($self, $node, $fix, $offset) {
  588         815  
  588         862  
  588         794  
  588         784  
  588         700  
628 588   100     1390 $offset ||= 0;
629 588         1524 my $startline = $node->line;
630 588         1112 my $lines = $self->{lines};
631 588         1273 my $endline = $node->realendline;
632 588         2037 my @slice = @$lines[$startline .. $endline];
633 588         1416 for my $line (@slice) {
634 1449 100       3154 next unless length $line;
635 1430 100       2274 if ($fix < 0) {
636 953         1126 my $offset = $offset;
637 953         1196 my $fix = -$fix;
638 953 50       1766 if ($offset > length $line) {
639 0         0 $offset = -1 + length $line;
640             }
641 953 50       1777 if ($line =~ tr/ //c) {
642 953 100       2232 if ($line =~ m/^ *\#/) {
643 18         190 $line =~ s/ {1,$fix}//;
644 18         58 next;
645             }
646             }
647             else {
648 0         0 $line =~ s/ {1,$fix}//;
649 0         0 next;
650             }
651 935         1634 my $before = substr($line, 0, $offset);
652 935         5192 $before =~ s/ {$fix,$fix}$//;
653 935         2697 $line = $before . substr($line, $offset);
654             }
655             else {
656 477 50       1138 unless ($line =~ tr/ //c) {
657 0         0 next;
658             }
659 477         1498 substr($line, $offset, 0, ' ' x $fix);
660             }
661             }
662 588         2288 @$lines[$startline .. $endline] = @slice;
663             }
664              
665 3037     3037   4499 sub _tree($self, $yaml, $lines) {
  3037         4295  
  3037         4655  
  3037         4125  
  3037         3696  
666 3037         6481 my $events = $self->_parse($yaml);
667 3037         15234 $self->{events} = $events;
668 3037         5684 my $first = shift @$events;
669 3037         4861 my $end = pop @$events;
670 3037         10161 $_->{level} = -1 for ($first, $end);
671 3037         5291 $first->{id} = -1;
672 3037         4054 _pp($first) if DEBUG;
673 3037         4286 my @stack;
674              
675 3037         4020 my $level = -1;
676 3037         24292 my $docs = YAML::Tidy::Node::Collection->new(
677             type => 'STR',
678             children => [],
679             indent => -1,
680             line => 0,
681             level => $level,
682             start => YAML::Tidy::Node::Collection->new(%$first),
683             end => YAML::Tidy::Node::Collection->new(%$end),
684             );
685 3037         5803 my $ref = $docs;
686 3037         4418 my $id = 0;
687 3037         4091 my $flow = 0;
688 3037         7900 for my $i (0 .. $#$events) {
689 31507         35813 my $event = $events->[ $i ];
690 31507         36772 my $name = $event->{name};
691 31507         31123 $id++;
692              
693 31507         31742 my $type;
694 31507 100       77100 if ($name =~ m/document_start/) {
    100          
    100          
695 3347         5060 $type = 'DOC';
696             }
697             elsif ($name =~ m/sequence_start/) {
698 2203         2708 $type = 'SEQ';
699             }
700             elsif ($name =~ m/mapping_start/) {
701 3224         4390 $type = 'MAP';
702             }
703              
704 31507         37872 $event->{id} = $id;
705 31507 100       59590 if ($name =~ m/_start_event/) {
    100          
706 8774         11397 $event->{level} = $level;
707 8774 100       15936 if ($name eq 'sequence_start_event') {
708             # inconsistency in libyaml events?
709 2203         3476 my $col = $event->{end}->{column};
710 2203 100       4291 if ($col > 0) {
711 1469         3378 my $line = $lines->[ $event->{end}->{line} ];
712 1469         4113 my $chr = substr($line, $col - 1, 1);
713 1469 100       3840 if ($chr eq '-') {
714 121         304 $event->{end}->{column}--;
715             }
716             }
717             }
718 8774 100 100     47976 if ($flow or ($event->{style} // -1) == YAML_FLOW_SEQUENCE_STYLE
      100        
      100        
      66        
719             or ($event->{style} // -1) == YAML_FLOW_MAPPING_STYLE) {
720 1469         2075 $flow++;
721             }
722 8774         20839 my $node = YAML::Tidy::Node::Collection->new(
723             children => [],
724             type => $type,
725             level => $level,
726             start => $event,
727             flow => $flow,
728             );
729 8774         11590 push @{ $ref->{children} }, $node;
  8774         15116  
730 8774         14877 $ref->{elements}++;
731 8774         12003 $node->{index} = $ref->{elements};
732 8774         11483 push @stack, $ref;
733 8774         9788 $ref = $node;
734 8774         10483 $level++;
735             }
736             elsif ($name =~ m/_end_event/) {
737 8774         11627 my $last = pop @stack;
738              
739 8774         15913 $ref->{end} = $event;
740              
741 8774         9839 $ref = $last;
742              
743 8774         9329 $level--;
744 8774         10093 $event->{level} = $level;
745 8774 100       14076 $flow-- if $flow;
746             }
747             else {
748 13959         44994 $event = YAML::Tidy::Node::Scalar->new(%$event, flow => $flow);
749 13959         20862 $ref->{elements}++;
750 13959         24107 $event->{index} = $ref->{elements};
751 13959         17004 $event->{level} = $level;
752 13959         14372 push @{ $ref->{children} }, $event;
  13959         19635  
753             }
754 31507         38125 $event->{nextline} = -1;
755 31507 100       48485 if ($i < $#$events) {
756 28509         33006 my $next = $events->[ $i + 1 ];
757 28509         34419 my $nextline = $next->{start}->{line};
758 28509         32875 $event->{nextline} = $nextline;
759             }
760 31507         39845 _pp($event) if DEBUG;
761             }
762 3037         5451 $end->{id} = $id + 1;
763 3037         3644 _pp($end) if DEBUG;
764 3037         54117 $self->{tree} = $docs;
765 3037         10488 return $docs;
766             }
767              
768 6071     6071   5210172 sub _parse($self, $yaml) {
  6071         8577  
  6071         7925  
  6071         6984  
769 6071         8063 my @events;
770 6071         20192 YAML::LibYAML::API::XS::parse_events($yaml, \@events);
771 6071         271371 return \@events;
772             }
773              
774 0     0   0 sub _pp($event) {
  0         0  
  0         0  
775 0         0 my $name = $event->{name};
776 0         0 my $level = $event->{level};
777 0         0 $name =~ s/_event$//;
778 0         0 my $fmt = '%2d %-10s) %-14s';
779 0         0 my $indent = $level*2+2;
780 0         0 my $lstr = (' ' x $indent) . $level;
781             my @args = (
782             $event->{id}, $lstr,
783             $event->{start}->{line}, $event->{start}->{column},
784             $event->{end}->{line}, $event->{end}->{column},
785 0         0 $name,
786             );
787 0 0       0 if ($name =~ m/scalar|alias/) {
    0          
788 0         0 local $Data::Dumper::Useqq = 1;
789 0         0 my $str = Data::Dumper->Dump([$event->{value}], ['value']);
790 0         0 chomp $str;
791 0         0 $str =~ s/^\$value = //;
792 0         0 $fmt .= " %s";
793 0         0 push @args, $str;
794             }
795             elsif ($name =~ m/end/) {
796             }
797             else {
798             }
799 0         0 $fmt .= "\n";
800 0         0 printf $fmt, @args;
801             }
802              
803 0     0   0 sub _debug_lines($self) {
  0         0  
  0         0  
804 0         0 say "====================================";
805 0         0 say for @{ $self->{lines} };
  0         0  
806 0         0 say "====================================";
807             }
808              
809 6068     6068 1 31037745 sub highlight($self, $yaml, $type = 'ansi') {
  6068         9445  
  6068         8746  
  6068         8280  
  6068         6941  
810 6068         26959 my ($error, $tokens) = YAML::PP::Parser->yaml_to_tokens(string => $yaml);
811 6068 100       16439973 if ($error) {
812 242         1929 $tokens = [];
813 242         2162 my @lines = split m/(?<=\n)/, $yaml;
814 242         744 for my $line (@lines) {
815 694 50       1740 if ($line =~ s/( +\n)//) {
816 0         0 push @$tokens, { value => $line, name => 'PLAIN' };
817 0         0 push @$tokens, { value => $1, name => 'TRAILING_SPACE' };
818 0         0 next;
819             }
820 694         1883 push @$tokens, { value => $line, name => 'PLAIN' };
821             }
822             }
823 6068 50       14972 if ($type eq 'html') {
824 0         0 return YAML::PP::Highlight->htmlcolored($tokens);
825             }
826 6068         26329 return YAML::PP::Highlight->ansicolored($tokens);
827             }
828              
829             1;
830              
831             __END__