File Coverage

blib/lib/JSON/JSONFold.pm
Criterion Covered Total %
statement 537 749 71.7
branch 137 242 56.6
condition 85 139 61.1
subroutine 103 135 76.3
pod 22 32 68.7
total 884 1297 68.1


line stmt bran cond sub pod time code
1             package JSON::JSONFold ;
2              
3 5     5   521528 use strict;
  5         8  
  5         154  
4 5     5   16 use warnings;
  5         7  
  5         192  
5 5     5   90 use 5.014 ;
  5         14  
6 5     5   53 use JSON::PP qw();
  5         7  
  5         113  
7              
8 5     5   16 use Exporter 'import';
  5         10  
  5         1160  
9              
10             our $VERSION = '0.2.2'; ## VERSION
11             our @EXPORT = qw(format_json write_json fold_text write_folded) ;
12             our $BACKEND ;
13              
14             BEGIN {
15 5 50   5   42 return if defined($BACKEND) ;
16 5         11 my $backend = $ENV{JSONFOLD_BACKEND} ;
17 5 50       14 if ( defined($backend)) {
18 0 0       0 $backend = "JSON::$backend" if $backend =~ /^\w+/ ;
19             } else {
20 5 50       7 $backend = JSON::MaybeXS::JSON() if eval { require JSON::MaybeXS } ;
  5         1868  
21             }
22 5 50       46871 if ( $backend ) {
23 5 50       309 eval "require $backend" or die "cannot load '$backend'";
24             }
25 5   50     5778 $BACKEND = $backend || 'JSON::PP' ;
26             }
27              
28             our @EXPORT_OK = qw(
29             jsonfold_config
30             create_writer
31             encode_json
32             to_json
33             ) ;
34             # Object Orient Interface
35              
36             sub new {
37 19     19 1 51 my ($class, %overrides) = @_ ;
38              
39             # Required parameters
40 19         31 my $width = delete $overrides{width} ;
41 19         26 my $config = delete $overrides{config} ;
42              
43 19   100     67 my $gold = delete $overrides{gold} // 1 ;
44 19         26 my $indent = delete $overrides{indent} ;
45 19   33     53 my $json = delete $overrides{json} // _json_coder($gold, $indent, %overrides) ;
46 19         26 my $do_close = delete $overrides{do_close} ;
47 19   50     40 return bless {
48             json => $json,
49             width => $width,
50             config => _config($config, $width),
51             do_close => $do_close,
52             }, ref($class) || $class || __PACKAGE__ ;
53             }
54              
55             sub format {
56 18     18 1 24 my($self, $data) = @_ ;
57              
58 18         47 my $config = $self->{config} ;
59              
60 18         24 my $output = '' ;
61 18 50       247 open my $out, '>:utf8', \$output or die "open output: $!" ;
62              
63 18         34 my $stream = _stream($out, $config, 0) ;
64 18         24 my $json = $self->{json} ;
65 18         149 my $text = $json->encode($data) ;
66              
67 18         52 $stream->write($text);
68              
69 18 50       50 close $out or die "close output: $!" ;
70 18 50       71 $output .= "\n" unless $output =~ /\n\z/;
71 18         108 return Encode::decode('UTF-8', $output) ;
72             }
73              
74             sub fold {
75 0     0 1 0 my ($self, $text) = @_ ;
76              
77 0         0 my $config = $self->{config} ;
78              
79 0         0 my $output = '' ;
80 0 0       0 open my $out, '>', \$output or die "open output: $!" ;
81              
82 0         0 my $stream = _stream($out, $config, 0) ;
83              
84 0         0 $stream->write($text);
85              
86 0 0       0 close $out or die "close output: $!" ;
87 0 0       0 $output .= "\n" unless $output =~ /\n\z/;
88 0         0 return $output ;
89             }
90              
91             sub fold_to {
92 0     0 0 0 my ($self, $text, $fh) = @_ ;
93              
94 0         0 my $stream = _stream($fh, $self->{config}, $self->{do_close}) ;
95              
96 0         0 $stream->write($text);
97 0         0 $stream->finish ;
98 0         0 $stream->flush ;
99 0 0       0 $stream->close or die "close output: $!" ;
100 0         0 my $info = $stream->stats ;
101              
102 0         0 return $info ;
103             }
104              
105             sub format_to {
106 1     1 1 2 my($self, $data, $fh) = @_ ;
107              
108 1         30 my $stream = _stream($fh, $self->{config}, $self->{do_close}) ;
109              
110 1         11 my $text = $self->{json}->encode($data) ;
111 1         3 $stream->write($text);
112 1         4 $stream->finish;
113 1         4 $stream->flush;
114 1         5 my $info = $stream->stats ;
115 1 50       2 $stream->close or die "close output: $!" ;
116              
117 1         7 return $info ;
118             }
119              
120             # Functional Interface
121              
122             # Not exportable. Allow using DEV::JSONFold::config(...)
123             sub config {
124 0     0 0 0 my($base_config, $width, %overrides) = @_ ;
125 0   0     0 $width //= $overrides{width} ;
126 0         0 return _config($base_config, $width, %overrides) ;
127             }
128              
129             sub jsonfold_config {
130 1     1 1 5 my($base_config, $width, %overrides) = @_ ;
131 1   33     6 $width //= $overrides{width} ;
132 1         4 return _config($base_config, $width, %overrides) ;
133             }
134              
135             sub format_json {
136 0     0 1 0 my($data, $width, $config, %overrides) = @_ ;
137              
138 0         0 my $fmt = __PACKAGE__->new(width => $width, config => $config, %overrides) ;
139 0         0 my $output = $fmt->format($data) ;
140 0         0 return $output ;
141             }
142              
143             sub write_json {
144 1     1 1 3 my($data, $fh, $width, $config, %overrides) = @_ ;
145              
146 1         7 my $fmt = __PACKAGE__->new(width => $width, config => $config, %overrides) ;
147 1         4 my $info = $fmt->format_to($data, $fh) ;
148 1         10 return $info ;
149             }
150              
151             sub fold_text {
152 0     0 1 0 my($text, $width, $config) = @_ ;
153 0         0 my $fmt = __PACKAGE__->new(width => $width, config => $config) ;
154              
155 0         0 return $fmt->fold($text) ;
156             }
157              
158             sub write_folded {
159 0     0 0 0 my($text, $fh, $width, $config) = @_ ;
160 0         0 my $fmt = __PACKAGE__->new(width => $width, config => $config) ;
161              
162 0         0 return $fmt->fold_to($text, $fh) ;
163             }
164              
165              
166             sub create_writer {
167 0     0 1 0 my($fh, $width, $config, %overrides) = @_ ;
168 0         0 my $do_close = delete $overrides{close_fp} ;
169 0         0 return _stream($fh, _config($config, $width, %overrides), $do_close) ;
170             }
171              
172             # Helper for Function/OO interface methods
173              
174             sub _config {
175 20     20   31 my ($preset, $width, %overrides) = @_ ;
176 20 50       37 $overrides{width} = $width if defined $width ;
177 20         52 return JSON::JSONFold::Config::config($preset, %overrides) ;
178             }
179              
180             sub _stream {
181 19     19   31 my ($fp, $config, $close_fp) = @_ ;
182 19         89 return JSON::JSONFold::Writer->new($fp, $config, $close_fp) ;
183             }
184              
185             sub _json_coder {
186 19     19   31 my ($gold, $indent, %opt) = @_;
187             # Must have valid indent, otherwise cannot parse the data
188 19   50     152 my $json = ($BACKEND || 'JSON::PP')->new->pretty ;
189 19 50       37 if ( $gold ) {
190 19   100     44 my $sort_keys = $opt{sort_keys} // 1 ;
191             # JSON has a bug with XS implementatio, may want to
192             # $indent ||= 2 if ! ($json->is('JSON') && $json->is_XS()) ;
193 19   50     68 $indent //=2 ;
194 19         75 $json->allow_nonref->canonical($sort_keys);
195 19         42 $json->space_before(0)->space_after(1);
196             }
197             # Some JSON coder can not set indent_length (JSON::XS), which is silently ignored
198             # Defaulting to indent of 3.
199 19 50 33     128 $json->indent_length($indent) if $indent && $json->can('indent_length') ;
200 19         51 return $json;
201             }
202              
203             # JSON compatible API - OO
204              
205             sub encode {
206 0     0 1 0 my ($self, $data) = @_ ;
207 0         0 return $self->format($data) ;
208             }
209              
210              
211             # JSON compatiable API - Functional
212              
213             sub encode_json {
214 18     18 1 330686 my ($data, $opts) = @_ ;
215 18 100       71 my %overrides = %$opts if $opts ;
216 18         33 my $width = delete $overrides{width} ;
217 18         25 my $compact = delete $overrides{compact} ;
218              
219 18         91 my $fmt = __PACKAGE__->new(width => $width, config => $compact, %overrides) ;
220 18         56 my $output = $fmt->format($data) ;
221 18         774 return $output ;
222             }
223              
224             # Same as encode_json - for users of legacy "JSON" wrapper.
225              
226             sub to_json {
227 0     0 1 0 my ($data, $opts) = @_ ;
228 0 0       0 my %overrides = %$opts if $opts ;
229 0         0 my $width = delete $overrides{width} ;
230 0         0 my $compact = delete $overrides{compact} ;
231              
232 0         0 my $fmt = __PACKAGE__->new(width => $width, config => $compact, %overrides) ;
233 0         0 my $output = $fmt->format($data) ;
234 0         0 return $output ;
235             }
236            
237             sub run {
238 0     0 0 0 JSON::JSONFold::CLI::run() ;
239             }
240              
241             package JSON::JSONFold::Kind;
242              
243 5     5   38 use strict ;
  5         6  
  5         110  
244 5     5   21 use warnings ;
  5         6  
  5         223  
245 5     5   24 use Exporter 'import';
  5         10  
  5         271  
246              
247             our @EXPORT_OK = qw(
248             KIND_NONE
249             KIND_DICT
250             KIND_LIST
251             %OPENING_KIND
252             %CLOSING_KIND
253             );
254              
255 5     5   19 use constant KIND_NONE => 0;
  5         6  
  5         251  
256 5     5   29 use constant KIND_DICT => 1;
  5         5  
  5         185  
257 5     5   17 use constant KIND_LIST => 2;
  5         7  
  5         367  
258              
259             our %OPENING_KIND = (
260             '{' => KIND_DICT,
261             '[' => KIND_LIST,
262             );
263              
264             our %CLOSING_KIND = (
265             '}' => KIND_DICT,
266             '},' => KIND_DICT,
267             ']' => KIND_LIST,
268             '],' => KIND_LIST,
269             );
270              
271             # -------------------------------------------------------------------------
272             # Internal package: immutable-ish configuration record
273             # -------------------------------------------------------------------------
274              
275             package JSON::JSONFold::Config;
276              
277 5     5   32 use strict;
  5         7  
  5         88  
278 5     5   11 use warnings;
  5         6  
  5         192  
279 5     5   25 use Exporter 'import';
  5         29  
  5         116  
280              
281 5     5   13 use constant DEFAULT_WIDTH => 100 ;
  5         5  
  5         200  
282 5     5   24 use constant MAX_ARRAY_ITEMS => 1000 ;
  5         9  
  5         154  
283 5     5   14 use constant MAX_OBJ_ITEMS => 1000 ;
  5         6  
  5         143  
284 5     5   17 use constant MAX_NESTING => 10 ;
  5         6  
  5         197  
285 5     5   22 use constant MAX_GRID_LINES => 1000 ;
  5         5  
  5         222  
286 5     5   18 use constant MAX_WIDTH => 255 ;
  5         7  
  5         611  
287              
288             our $SEQ = 0 ;
289             use constant {
290 5         737 C_OFF => $SEQ++,
291             C_WIDTH => $SEQ++,
292              
293             C_PACK_ARRAY_ITEMS => $SEQ++,
294             C_PACK_OBJ_ITEMS => $SEQ++,
295             C_PACK_NESTING => $SEQ++,
296              
297             C_FOLD_ARRAY_ITEMS => $SEQ++,
298             C_FOLD_OBJ_ITEMS => $SEQ++,
299             C_FOLD_NESTING => $SEQ++,
300              
301             C_GRID_ARRAY_ITEMS => $SEQ++,
302             C_GRID_OBJ_ITEMS => $SEQ++,
303             C_GRID_MIN_LINES => $SEQ++,
304             C_GRID_MAX_LINES => $SEQ++,
305             C_GRID_ARRAY_MIN => $SEQ++,
306             C_GRID_OBJ_MIN => $SEQ++,
307              
308             C_JOIN_ARRAY_ITEMS => $SEQ++,
309             C_JOIN_OBJ_ITEMS => $SEQ++,
310             C_JOIN_NESTING => $SEQ++,
311             C_UNUSED_LAST => $SEQ++,
312 5     5   19 } ;
  5         5  
313              
314             BEGIN {
315              
316 5     5   5023 our @EXPORT = qw(
317             C_OFF
318             C_WIDTH
319             C_PACK_ARRAY_ITEMS C_PACK_OBJ_ITEMS C_PACK_NESTING
320              
321             C_FOLD_ARRAY_ITEMS C_FOLD_OBJ_ITEMS C_FOLD_NESTING
322              
323             C_GRID_ARRAY_ITEMS C_GRID_OBJ_ITEMS C_GRID_MIN_LINES
324             C_GRID_MAX_LINES C_GRID_ARRAY_MIN C_GRID_OBJ_MIN
325              
326             C_JOIN_ARRAY_ITEMS C_JOIN_OBJ_ITEMS C_JOIN_NESTING
327             ) ;
328             }
329              
330             our @FIELDS = (
331             [ 'off', C_OFF ],
332             [ 'width', C_WIDTH ],
333             [ 'pack_array_items', C_PACK_ARRAY_ITEMS ],
334             [ 'pack_obj_items', C_PACK_OBJ_ITEMS ],
335             [ 'pack_nesting', C_PACK_NESTING ],
336             [ 'fold_array_items', C_FOLD_ARRAY_ITEMS ],
337             [ 'fold_obj_items', C_FOLD_OBJ_ITEMS ],
338             [ 'fold_nesting', C_FOLD_NESTING ],
339             [ grid_array_items => C_GRID_ARRAY_ITEMS ],
340             [ grid_obj_items => C_GRID_OBJ_ITEMS ],
341             [ grid_min_lines => C_GRID_MIN_LINES ],
342             [ grid_max_lines => C_GRID_MAX_LINES ],
343             [ grid_array_min => C_GRID_ARRAY_MIN ],
344             [ grid_obj_min => C_GRID_OBJ_MIN ],
345             [ 'join_array_items', C_JOIN_ARRAY_ITEMS ],
346             [ 'join_obj_items', C_JOIN_OBJ_ITEMS ],
347             [ 'join_nesting', C_JOIN_NESTING ],
348             ) ;
349              
350             our %NAME_TO_INDEX = map { @$_ } @FIELDS ;
351             our %PRESETS ;
352             our ($NONE, $DEFAULT) ;
353              
354             sub as_hash {
355 0     0 0 0 my ($self) = @_ ;
356 0         0 map { my ($name, $idx) = @$_ ; ($name => $self->[$idx]) ; } @FIELDS ;
  0         0  
  0         0  
357             }
358              
359             sub _make {
360 15     15   48 my ($class, %arg) = @_;
361 15         17 my @d;
362 15         34 $#d = $SEQ;
363 15         20 $d[C_OFF] = $arg{off} ;
364 15         15 $d[C_WIDTH] = $arg{width};
365              
366 15         31 $d[C_PACK_ARRAY_ITEMS] = $arg{pack_array_items};
367 15         18 $d[C_PACK_OBJ_ITEMS] = $arg{pack_obj_items};
368 15         19 $d[C_PACK_NESTING] = $arg{pack_nesting};
369              
370 15         20 $d[C_FOLD_ARRAY_ITEMS] = $arg{fold_array_items};
371 15         20 $d[C_FOLD_OBJ_ITEMS] = $arg{fold_obj_items};
372 15         13 $d[C_FOLD_NESTING] = $arg{fold_nesting};
373              
374 15         21 $d[C_GRID_ARRAY_ITEMS] = $arg{grid_array_items} ;
375 15         20 $d[C_GRID_OBJ_ITEMS] = $arg{grid_obj_items} ;
376 15         15 $d[C_GRID_MIN_LINES] = $arg{grid_min_lines} ;
377 15         29 $d[C_GRID_MAX_LINES] = $arg{grid_max_lines} ;
378 15         25 $d[C_GRID_ARRAY_MIN] = $arg{grid_array_min} ;
379 15         25 $d[C_GRID_OBJ_MIN] = $arg{grid_obj_min} ;
380              
381 15         26 $d[C_JOIN_ARRAY_ITEMS] = $arg{join_array_items};
382 15         23 $d[C_JOIN_OBJ_ITEMS] = $arg{join_obj_items};
383 15         19 $d[C_JOIN_NESTING] = $arg{join_nesting};
384 15         44 return bless \@d, $class;
385             }
386              
387             sub _replace {
388 84     84   114 my ($base, $validate) = (shift, shift) ;
389 84 50       116 return $base unless @_ ;
390 84 100 66     252 my $overrides = @_ == 1 && ref($_[0]) ? $_[0] : { @_ } ;
391 84 100       246 return $base unless %$overrides ;
392              
393 46         110 my @d = @$base ;
394 46         118 for my $key (keys %$overrides) {
395 276 100       362 unless (exists $NAME_TO_INDEX{$key}) {
396 1 50       2 die "unknown JSON::JSONFold config key: $key\n" if $validate ;
397 1         2 next ;
398             }
399 275         316 $d[$NAME_TO_INDEX{$key}] = $overrides->{$key} ;
400             }
401 46   50     220 return bless \@d, ref($base) || __PACKAGE__ ;
402             }
403              
404             sub _resolve_config {
405 39     39   55 my ($config) = @_ ;
406 39 100       80 return $config if ref($config) ;
407              
408 19   100     31 my $name = $config // '' ;
409             die "unknown JSON::JSONFold preset: $name\n"
410 19 50       48 unless exists $PRESETS{$name} ;
411 19         70 return $PRESETS{$name} ;
412             }
413              
414             sub config {
415 39     39 0 50 my ($preset, %overrides) = @_ ;
416 39         57 return _replace(_resolve_config($preset), 0, \%overrides) ;
417             }
418              
419             sub new {
420 0     0 0 0 my ($class, $config, @args) = @_ ;
421 0         0 return config($config, @args) ;
422             }
423              
424             sub _new_preset {
425 45     45   39 my $base = shift ;
426 45         64 return _replace($base, 1, @_) ;
427             }
428              
429             sub _class_init {
430 5     5   9 my $class = shift ;
431              
432 5         22 $DEFAULT = $class->_make(
433             width => DEFAULT_WIDTH,
434              
435             pack_array_items => 10,
436             pack_obj_items => 5,
437             pack_nesting => 1,
438              
439             fold_array_items => 10,
440             fold_obj_items => 5,
441             fold_nesting => 2,
442              
443             grid_array_items => MAX_ARRAY_ITEMS,
444             grid_obj_items => MAX_OBJ_ITEMS,
445             grid_min_lines => 3,
446             grid_max_lines => 100,
447             grid_array_min => 3,
448             grid_obj_min => 3,
449              
450             join_array_items => 8,
451             join_obj_items => 4,
452             join_nesting => 1,
453             ) ;
454              
455 5         15 $NONE = $class->_make(
456             width => DEFAULT_WIDTH,
457              
458             pack_array_items => 0,
459             pack_obj_items => 0,
460             pack_nesting => 0,
461              
462             fold_array_items => 0,
463             fold_obj_items => 0,
464             fold_nesting => 0,
465              
466             grid_array_items => 0,
467             grid_obj_items => 0,
468             grid_min_lines => 0,
469             grid_max_lines => 0,
470             grid_array_min => 0,
471             grid_obj_min => 0,
472              
473             join_array_items => 0,
474             join_obj_items => 0,
475             join_nesting => 0,
476             ) ;
477              
478 5         11 my %pack_max = (
479             pack_array_items => MAX_ARRAY_ITEMS,
480             pack_obj_items => MAX_OBJ_ITEMS,
481             pack_nesting => MAX_NESTING,
482             ) ;
483 5         9 my %fold_max = (
484             fold_array_items => MAX_ARRAY_ITEMS,
485             fold_obj_items => MAX_OBJ_ITEMS,
486             fold_nesting => MAX_NESTING,
487             ) ;
488 5         9 my %join_max = (
489             join_array_items => MAX_ARRAY_ITEMS,
490             join_obj_items => MAX_OBJ_ITEMS,
491             join_nesting => MAX_NESTING,
492             ) ;
493 5         12 my %grid_max = (
494             grid_array_items => MAX_ARRAY_ITEMS,
495             grid_obj_items => MAX_OBJ_ITEMS,
496             grid_min_lines => 3,
497             grid_max_lines => MAX_GRID_LINES,
498             ) ;
499              
500 5         10 %PRESETS = (
501             off => $class->_make(off => 1),
502             '' => $DEFAULT,
503             default => $DEFAULT,
504             none => $NONE,
505              
506             low => _new_preset($DEFAULT,
507             fold_nesting => 0,
508             join_nesting => 0,
509             grid_max_lines => 0,
510             ),
511             med => _new_preset($DEFAULT,
512             join_nesting => 0,
513             grid_max_lines => 0,
514             ),
515             classic => _new_preset($DEFAULT,
516             grid_max_lines => 0,
517             ),
518             high => _new_preset($DEFAULT,
519             pack_array_items => 20, pack_obj_items => 10, pack_nesting => 4,
520             fold_array_items => 20, fold_obj_items => 10, fold_nesting => 4,
521             grid_array_min => 4, grid_obj_min => 4,
522             join_array_items => 16, join_obj_items => 8, join_nesting => 2,
523             ),
524             max => _new_preset($DEFAULT,
525             width => MAX_WIDTH,
526             %pack_max, %fold_max, %join_max, %grid_max,
527             grid_array_min => 4,
528             grid_obj_min => 4,
529             ),
530             pack => _new_preset($NONE, %pack_max),
531             fold => _new_preset($NONE, %fold_max),
532             grid => _new_preset($NONE, %pack_max, %fold_max, %grid_max),
533             join => _new_preset($NONE,
534             %fold_max,
535             join_array_items => MAX_ARRAY_ITEMS,
536             join_obj_items => MAX_OBJ_ITEMS,
537             join_nesting => MAX_NESTING,
538             ),
539             ) ;
540             }
541              
542             __PACKAGE__->_class_init ;
543              
544             # -------------------------------------------------------------------------
545             # Internal package: one physical pretty-printed line
546             # -------------------------------------------------------------------------
547              
548             package JSON::JSONFold::Line ;
549              
550 5     5   32 use strict ;
  5         6  
  5         105  
551 5     5   16 use warnings ;
  5         10  
  5         223  
552 5     5   21 use Exporter 'import' ;
  5         10  
  5         204  
553              
554 5     5   19 use constant KIND_NONE => $JSON::JSONFold::Kind::KIND_NONE ;
  5         7  
  5         293  
555 5     5   37 use constant KIND_DICT => $JSON::JSONFold::Kind::KIND_DICT ;
  5         6  
  5         202  
556 5     5   26 use constant KIND_LIST => $JSON::JSONFold::Kind::KIND_LIST ;
  5         7  
  5         456  
557              
558             our $SEQ = 0 ;
559             use constant {
560 5         560 L_INDENT => $SEQ++,
561             L_PARTS => $SEQ++,
562             L_PARTS_LENGTH => $SEQ++,
563             L_KIND => $SEQ++,
564             L_ITEMS => $SEQ++,
565             L_LEAFS => $SEQ++,
566             L_CHILD_NESTING => $SEQ++,
567             L_OPENER => $SEQ++,
568             L_CLOSER => $SEQ++,
569             L_CAN_JOIN => $SEQ++,
570             L_CAN_PACK => $SEQ++,
571             L_CAN_GRID => $SEQ++,
572 5     5   23 } ;
  5         6  
573              
574             BEGIN {
575 5     5   4931 our @EXPORT = qw(
576             L_INDENT
577             L_PARTS
578             L_PARTS_LENGTH
579             L_KIND
580             L_ITEMS
581             L_LEAFS
582             L_CHILD_NESTING
583             L_OPENER
584             L_CLOSER
585             L_CAN_JOIN
586             L_CAN_PACK
587             L_CAN_GRID
588             ) ;
589             }
590              
591             my $KEY_RE = qr/^\s*(?:(?:"[^"\\]*")|(?:'[^'\\]*')|(?:[A-Za-z_\$][A-Za-z0-9_\$]*)|)\s*:/ ;
592              
593             sub _calc_parts_length {
594 0     0   0 my ($parts) = @_ ;
595 0 0       0 return 0 unless @$parts ;
596 0         0 my $n = -1 ;
597 0         0 $n += 1 + length($_) for @$parts ;
598 0         0 return $n ;
599             }
600              
601             sub parse {
602 169     169   224 my ($class, $s) = @_ ;
603              
604 169         467 my ($spaces) = $s =~ /^(\s*)/;
605 169         327 my $body = substr($s, length($spaces));
606 169         329 $body =~ s/\s+\z//;
607              
608 169 50       285 my $last = length($body) ? substr($body, -1, 1) : '' ;
609 169   100     362 my $opener = $JSON::JSONFold::Kind::OPENING_KIND{$last} // KIND_NONE ;
610 169   100     344 my $closer = $JSON::JSONFold::Kind::CLOSING_KIND{$body} // KIND_NONE ;
611 169 100 100     319 my $is_body = !$opener && !$closer ? 1 : 0;
612              
613 169         177 my @d ;
614 169         287 $#d = $SEQ ;
615 169         199 $d[L_INDENT] = length($spaces);
616            
617 169         257 $d[L_PARTS] = [ $body ] ;
618 169         173 $d[L_PARTS_LENGTH] = length($body) ;
619 169         171 $d[L_KIND] = KIND_NONE ;
620 169 100       221 $d[L_ITEMS] = $is_body ? 1 : 0 ;
621 169 100       236 $d[L_LEAFS] = $is_body ? 1 : 0 ;
622 169         236 $d[L_CHILD_NESTING] = -1;
623 169         168 $d[L_OPENER] = $opener;
624 169         184 $d[L_CLOSER] = $closer;
625 169         159 $d[L_CAN_JOIN] = $is_body;
626 169         183 $d[L_CAN_PACK] = $is_body;
627 169         169 $d[L_CAN_GRID] = 0 ;
628              
629 169         410 return bless \@d, $class ;
630             }
631              
632             sub raw {
633 60     60   87 return (' ' x $_[0][L_INDENT]) . join(' ', @{ $_[0][L_PARTS] }) . "\n"
  60         205  
634             }
635              
636             sub width {
637 106     106   228 return $_[0][L_INDENT] + $_[0][L_PARTS_LENGTH]
638             }
639              
640             sub can_merge {
641 45     45   60 my ($self, $other, $item_limit, $width_limit) = @_ ;
642 45   33     218 return $self->[L_INDENT] == $other->[L_INDENT]
643             && $self->[L_ITEMS] + $other->[L_ITEMS] <= $item_limit
644             && $self->[L_INDENT] + $self->[L_PARTS_LENGTH] + 1 + $other->[L_PARTS_LENGTH] <= $width_limit ;
645             }
646              
647             sub merge_line {
648 45     45   59 my ($self, $other) = @_;
649 45         39 push @{ $self->[L_PARTS] }, @{ $other->[L_PARTS] } ;
  45         56  
  45         96  
650 45 50       48 $self->[L_PARTS_LENGTH] += 1 + $other->[L_PARTS_LENGTH] if @{ $other->[L_PARTS] } ;
  45         81  
651 45         62 $self->[L_ITEMS] += $other->[L_ITEMS];
652 45         69 $self->[L_LEAFS] += $other->[L_LEAFS];
653 45 50       61 if ($other->[L_CHILD_NESTING] > $self->[L_CHILD_NESTING]) {
654 0         0 $self->[L_CHILD_NESTING] = $other->[L_CHILD_NESTING];
655 0         0 $self->[L_CAN_PACK] = 0;
656             }
657 45         51 return $self;
658             }
659              
660             sub set_parts {
661 0     0   0 my ($self, $parts) = @_ ;
662 0         0 $self->[L_PARTS] = $parts ;
663 0         0 $self->[L_PARTS_LENGTH] = _calc_parts_length($parts) ;
664 0         0 return $self ;
665             }
666              
667             sub dict_signature {
668 0     0   0 my ($self) = @_ ;
669 0         0 my @parts = @{ $self->[L_PARTS] } ;
  0         0  
670 0 0       0 return undef if @parts < 3 ;
671              
672 0         0 my @signature ;
673 0         0 for my $part (@parts[1 .. $#parts - 1]) {
674 0 0       0 return undef unless $part =~ /($KEY_RE)/ ;
675 0         0 push @signature, $1 ;
676             }
677 0         0 return join("\x1e", @signature) ;
678             }
679              
680             sub _format_parts {
681 0     0   0 my ($parts, $widths) = @_ ;
682 0         0 my $last = $#$widths ;
683 0         0 my @out ;
684 0         0 for my $i (0 .. $#$parts) {
685 0         0 my $part = $parts->[$i] ;
686 0         0 my $w = $widths->[$i] ;
687 0 0       0 if ($part =~ /^[\-0-9]/) {
    0          
688 0         0 push @out, sprintf("%*s", $w, $part) ;
689             }
690             elsif ($i < $last) {
691 0         0 push @out, sprintf("%-*s", $w, $part) ;
692             }
693             else {
694 0         0 push @out, $part ;
695             }
696             }
697 0         0 return \@out ;
698             }
699              
700             sub apply_grid {
701 0     0   0 my ($self, $widths) = @_ ;
702 0         0 return $self->set_parts(_format_parts($self->[L_PARTS], $widths)) ;
703             }
704              
705             # -------------------------------------------------------------------------
706             # Internal package: stack frame for a currently open JSON container
707             # -------------------------------------------------------------------------
708              
709              
710              
711             package JSON::JSONFold::Frame;
712 5     5   34 use strict;
  5         13  
  5         108  
713 5     5   14 use warnings;
  5         10  
  5         246  
714 5     5   19 use Exporter 'import' ;
  5         6  
  5         138  
715              
716             BEGIN {
717 5     5   716 JSON::JSONFold::Line->import() ;
718             }
719              
720             our $SEQ = 0 ;
721             use constant {
722 5         751 F_KIND => $SEQ++,
723             F_INDENT => $SEQ++,
724             F_DEPTH => $SEQ++,
725             F_LINES => $SEQ++,
726             F_PARTS_LENGTH => $SEQ++,
727             F_PACK_LIMIT => $SEQ++,
728             F_FOLD_LIMIT => $SEQ++,
729             F_JOIN_LIMIT => $SEQ++,
730             F_GRID_LIMIT => $SEQ++,
731             F_GRID_MIN_ITEMS => $SEQ++,
732             F_CONTENT_LINES => $SEQ++,
733             F_ITEMS => $SEQ++,
734             F_LEAFS => $SEQ++,
735             F_FOLD_OK => $SEQ++,
736             F_GRID_OK => $SEQ++,
737             F_CHILD_NESTING => $SEQ++,
738 5     5   27 } ;
  5         8  
739              
740             BEGIN {
741 5     5   3592 our @EXPORT = qw(
742             F_KIND F_INDENT F_DEPTH F_LINES F_PARTS_LENGTH
743             F_PACK_LIMIT F_FOLD_LIMIT F_JOIN_LIMIT F_GRID_LIMIT F_GRID_MIN_ITEMS
744             F_CONTENT_LINES F_ITEMS F_LEAFS F_FOLD_OK F_GRID_OK F_CHILD_NESTING
745             ) ;
746             }
747              
748             sub new {
749 47     47   182 my ($class, %arg) = @_;
750 47         52 my @d ;
751 47         70 $#d = $SEQ ;
752 47   50     136 $d[F_KIND] = $arg{kind} // 0 ;
753 47   50     75 $d[F_INDENT] = $arg{indent} // 0 ;
754 47   50     70 $d[F_DEPTH] = $arg{depth} // 0;
755 47   50     109 $d[F_LINES] = $arg{lines} // [];
756 47         53 $d[F_PARTS_LENGTH] = 0 ;
757 47   50     82 $d[F_PACK_LIMIT] = $arg{pack_limit} // 0;
758 47   50     73 $d[F_FOLD_LIMIT] = $arg{fold_limit} // 0;
759 47   50     75 $d[F_JOIN_LIMIT] = $arg{join_limit} // 0;
760 47   50     81 $d[F_GRID_LIMIT] = $arg{grid_limit} // 0 ;
761 47   50     69 $d[F_GRID_MIN_ITEMS] = $arg{grid_min_items} // 0 ;
762 47         50 $d[F_CONTENT_LINES] = 0;
763 47         69 $d[F_ITEMS] = 0;
764 47         61 $d[F_LEAFS] = 0;
765 47         43 $d[F_FOLD_OK] = 1;
766 47         63 $d[F_GRID_OK] = 0 ;
767 47         58 $d[F_CHILD_NESTING] = -1;
768 47         118 return bless \@d, $class;
769             }
770              
771 124     124   113 sub is_empty { return @{ $_[0][F_LINES] } == 0 }
  124         281  
772 90     90   100 sub last_line { return $_[0][F_LINES][-1] }
773              
774             sub update_stats {
775 205     205   271 my ($self, $line) = @_ ;
776 205         205 $self->[F_ITEMS] += $line->[L_ITEMS];
777 205         198 $self->[F_LEAFS] += $line->[L_LEAFS];
778 205 100       266 $self->[F_PARTS_LENGTH] += $line->[L_PARTS_LENGTH] + ($self->[F_PARTS_LENGTH] ? 1 : 0) ;
779 205 100       270 if ($line->[L_CHILD_NESTING] >= $self->[F_CHILD_NESTING]) {
780 61         70 $self->[F_CHILD_NESTING] = $line->[L_CHILD_NESTING] + 1;
781             }
782 205         228 return ;
783             }
784              
785             sub add_line {
786 166     166   217 my ($self, $line) = @_ ;
787 166         175 push @{ $self->[F_LINES] }, $line ;
  166         227  
788 166 100 100     344 if (!$line->[L_OPENER] && !$line->[L_CLOSER]) {
789 62         64 $self->[F_CONTENT_LINES]++ ;
790             }
791 166         283 $self->update_stats($line) ;
792 166         152 return ;
793             }
794              
795             sub check_fold_limits {
796 101     101   141 my ($self, $cfg) = @_ ;
797 101 50       136 return 0 if $self->[F_PARTS_LENGTH] > $cfg->[JSON::JSONFold::Config::C_WIDTH] ;
798 101 100       169 return 0 if $self->[F_ITEMS] > $self->[F_FOLD_LIMIT] ;
799 97 100       133 return 0 if $self->[F_CHILD_NESTING] >= $cfg->[JSON::JSONFold::Config::C_FOLD_NESTING] ;
800 92         170 return 1 ;
801             }
802              
803             sub fold_lines {
804 32     32   42 my ($self, $cfg) = @_ ;
805 32         36 my @parts = map { @{ $_->[L_PARTS] } } @{ $self->[F_LINES] } ;
  96         89  
  96         193  
  32         48  
806              
807 32         38 my @d ;
808 32         49 $#d = $JSON::JSONFold::Line::SEQ ;
809 32         43 $d[L_INDENT] = $self->[F_INDENT] ;
810 32         36 $d[L_PARTS] = \@parts ;
811 32         36 $d[L_PARTS_LENGTH] = $self->[F_PARTS_LENGTH] ;
812 32         43 $d[L_KIND] = $self->[F_KIND] ;
813 32         35 $d[L_ITEMS] = 1 ;
814 32         40 $d[L_LEAFS] = $self->[F_LEAFS] ;
815 32         34 $d[L_CHILD_NESTING] = $self->[F_CHILD_NESTING] ;
816 32         35 $d[L_OPENER] = JSON::JSONFold::Kind::KIND_NONE ;
817 32         34 $d[L_CLOSER] = JSON::JSONFold::Kind::KIND_NONE ;
818 32         33 $d[L_CAN_PACK] = 0 ;
819 32 100       50 $d[L_CAN_JOIN] = $self->[F_CHILD_NESTING] < $cfg->[JSON::JSONFold::Config::C_JOIN_NESTING] ? 1 : 0 ;
820 32 100 66     113 $d[L_CAN_GRID] = ($cfg->[JSON::JSONFold::Config::C_GRID_MAX_LINES] > 0
821             && $self->[F_ITEMS] <= $self->[F_GRID_LIMIT]) ? 1 : 0 ;
822              
823 32         64 @{ $self->[F_LINES] } = (bless \@d, 'JSON::JSONFold::Line') ;
  32         98  
824 32         39 return ;
825             }
826              
827             sub join_lines {
828 10     10   14 my ($self, $cfg) = @_ ;
829 10         13 my $lines = $self->[F_LINES] ;
830 10         11 my $n = @$lines ;
831 10 50       17 return if $n < 2 ;
832              
833 10         29 my $prev = $lines->[0] ;
834 10         13 my $write_pos = 1 ;
835              
836 10         22 for (my $read_pos = 1; $read_pos < $n; $read_pos++) {
837 26         28 my $line = $lines->[$read_pos] ;
838 26 100 100     83 if ($prev->[L_CAN_JOIN]
      66        
839             && $line->[L_CAN_JOIN]
840             && $prev->can_merge($line, $self->[F_JOIN_LIMIT], $cfg->[JSON::JSONFold::Config::C_WIDTH])) {
841 6         13 $prev->merge_line($line) ;
842 6         12 $prev->[L_CAN_PACK] = 0 ;
843             }
844             else {
845 20 100       38 $lines->[$write_pos] = $line if $read_pos != $write_pos ;
846 20         20 $prev = $line ;
847 20         32 $write_pos++ ;
848             }
849             }
850              
851 10 100       28 splice(@$lines, $write_pos) if $write_pos < @$lines ;
852 10         16 $self->[F_CONTENT_LINES] -= ($n - $write_pos) ;
853 10         13 return ;
854             }
855              
856             # -------------------------------------------------------------------------
857             # Internal package: counters
858             # -------------------------------------------------------------------------
859              
860             package JSON::JSONFold::Stats;
861 5     5   31 use strict;
  5         5  
  5         258  
862 5     5   33 use warnings;
  5         12  
  5         816  
863              
864             sub new {
865 19     19 0 37 my ($class) = @_;
866 19         68 return bless {
867             bytes_in => 0,
868             bytes_out => 0,
869             lines_in => 0,
870             lines_out => 0,
871             }, $class;
872             }
873              
874 0     0 1 0 sub bytes_in { $_[0]{bytes_in} }
875 0     0 1 0 sub bytes_out { $_[0]{bytes_out} }
876 0     0 1 0 sub lines_in { $_[0]{lines_in} }
877 0     0 1 0 sub lines_out { $_[0]{lines_out} }
878              
879 0     0 0 0 sub as_hash { return %{ $_[0] } }
  0         0  
880              
881             # -------------------------------------------------------------------------
882             # Internal package: streaming folding filter/writer
883             # -------------------------------------------------------------------------
884              
885             package JSON::JSONFold::Writer;
886 5     5   24 use strict;
  5         11  
  5         98  
887 5     5   12 use warnings;
  5         11  
  5         157  
888 5     5   1750 use Encode ;
  5         50902  
  5         520  
889              
890             BEGIN {
891 5     5   185 JSON::JSONFold::Line->import() ;
892 5         175 JSON::JSONFold::Frame->import() ;
893 5         530 JSON::JSONFold::Config->import() ;
894             }
895              
896             our $SEQ = 0 ;
897             use constant {
898 5         13701 W_UNUSED_FIRST => $SEQ++,
899             W_FH => $SEQ++,
900             W_CFG => $SEQ++,
901             W_PENDING => $SEQ++,
902             W_STACK => $SEQ++,
903             W_STATS => $SEQ++,
904             W_DO_CLOSE => $SEQ++,
905             W_UNUSED_LAST => $SEQ++,
906 5     5   28 } ;
  5         5  
907              
908             sub new {
909 19     19 1 46 my ($class, $fh, $config, $do_close) = @_;
910              
911 19         23 my $cfg = JSON::JSONFold::Config::config($config) ;
912 19         54 my @d ;
913 19         56 $#d = $SEQ ;
914 19         26 $d[W_FH] = $fh;
915 19 100       62 $d[W_CFG] = $cfg unless $cfg->[C_OFF] ;
916 19         34 $d[W_PENDING] = '';
917 19         35 $d[W_STACK] = [];
918 19         82 $d[W_STATS] = JSON::JSONFold::Stats->new;
919 19         32 $d[W_DO_CLOSE] = $do_close;
920 19         45 return bless \@d, $class;
921             }
922              
923 1     1 1 2 sub stats { return $_[0][W_STATS] }
924              
925             sub write {
926 19     19 1 41 my ($self, $s) = @_;
927 19 50       34 $s = '' unless defined $s;
928 19         44 my $len = length($s);
929 19         59 $self->[W_STATS]{bytes_in} += $len;
930              
931 19 100       44 unless ($self->[W_CFG]) {
932 1         4 $self->[W_STATS]{lines_in} += _count_newlines($s);
933 1         4 return $self->_write_str($s);
934             }
935              
936 18         48 my $nl = index($s, "\n");
937 18 50       39 if ($nl < 0) {
938 0         0 $self->[W_PENDING] .= $s;
939 0         0 return $len;
940             }
941              
942 18         49 my $nl2 = index($s, "\n", $nl + 1);
943 18 100       31 if ($nl2 < 0) {
944 2         5 $self->[W_STATS]{lines_in}++;
945 2         6 my $line_text = $self->[W_PENDING] . substr($s, 0, $nl);
946 2         19 $self->[W_PENDING] = substr($s, $nl + 1);
947 2         10 $self->_feed(JSON::JSONFold::Line->parse($line_text));
948 2         10 return $len;
949             }
950              
951             # We have multiple lines - at least 2 new lines in the new buffer
952 16         98 my @lines = split("\n", $s, -1) ;
953 16         28 $lines[0] = $self->[W_PENDING] . $lines[0] ;
954 16         32 $self->[W_PENDING] = pop @lines ;
955 16         26 for my $part ( @lines ) {
956 167         311 $self->_feed(JSON::JSONFold::Line->parse($part));
957              
958             }
959 16         25 $self->[W_STATS]{lines_in} += @lines;
960              
961 16         43 return $len;
962             }
963              
964             sub write_bytes {
965 0     0 0 0 my ($self, $s) = @_;
966 0 0       0 $s = '' unless defined $s;
967 0         0 my $len = length($s);
968 0         0 $self->[W_STATS]{bytes_in} += $len;
969              
970 0 0       0 unless ($self->[W_CFG]) {
971 0         0 $self->[W_STATS]{lines_in} += _count_newlines($s);
972 0         0 return $self->_write_str($s);
973             }
974              
975 0         0 my $nl = index($s, "\n");
976 0 0       0 if ($nl < 0) {
977 0         0 $self->[W_PENDING] .= $s;
978 0         0 return $len;
979             }
980              
981 0         0 my $nl2 = index($s, "\n", $nl + 1);
982 0 0       0 if ($nl2 < 0) {
983 0         0 $self->[W_STATS]{lines_in}++;
984 0         0 my $line_data = $self->[W_PENDING] . substr($s, 0, $nl);
985 0         0 my $line_text = Encode::decode('UTF-8', $line_data) ;
986 0         0 $self->[W_PENDING] = substr($s, $nl + 1);
987 0         0 $self->_feed(JSON::JSONFold::Line->parse($line_text));
988 0         0 return $len;
989             }
990              
991             # We have multiple lines - at least 2 new lines in the new buffer
992 0         0 $s = $self->[W_PENDING] . $s ;
993 0         0 my $last_nl = rindex($s, "\n") ;
994             # Move last partial lines to pending, remove from $s
995 0         0 $self->[W_PENDING] = substr(substr($s, $last_nl, length($s)-$last_nl, ""), 1) ;
996 0         0 my @lines = split("\n", Encode::decode('UTF-8', $s), -1) ;
997 0         0 for my $part ( @lines ) {
998 0         0 $self->_feed(JSON::JSONFold::Line->parse($part));
999              
1000             }
1001 0         0 $self->[W_STATS]{lines_in} += @lines;
1002              
1003 0         0 return $len;
1004             }
1005              
1006              
1007              
1008             sub finish {
1009 2     2 1 3 my ($self) = @_;
1010 2 50       5 if (length $self->[W_PENDING]) {
1011 0         0 $self->_feed(JSON::JSONFold::Line->parse($self->[W_PENDING], $self->_parent_kind));
1012 0         0 $self->[W_PENDING] = '';
1013             }
1014              
1015 2         3 for my $frame (@{ $self->[W_STACK] }) {
  2         3  
1016 0         0 $self->_write_line($_) for @{ $frame->[F_LINES] };
  0         0  
1017             }
1018 2         3 @{ $self->[W_STACK] } = ();
  2         4  
1019             }
1020              
1021             sub flush {
1022 2     2 1 3 my ($self) = @_;
1023 2         3 my $fh = $self->[W_FH];
1024 2 50 33     50 $fh->flush if $fh && $fh->can('flush');
1025             }
1026              
1027             sub close {
1028 1     1 1 2 my ($self) = @_;
1029 1         4 $self->finish;
1030 1         2 $self->flush;
1031 1 50       3 $self->[W_FH]->close if $self->[W_DO_CLOSE] ;
1032 1         2 return 1;
1033             }
1034              
1035             sub _feed {
1036 169     169   232 my ($self, $line) = @_;
1037             # Opener
1038 169 100       264 if ($line->[L_OPENER]) {
1039             my $frame = JSON::JSONFold::Frame->new(
1040             kind => $line->[L_OPENER],
1041             indent => $line->[L_INDENT],
1042 47         65 depth => scalar(@{ $self->[W_STACK] }),
  47         121  
1043             pack_limit => $self->_pack_limit($line->[L_OPENER]),
1044             fold_limit => $self->_fold_limit($line->[L_OPENER]),
1045             join_limit => $self->_join_limit($line->[L_OPENER]),
1046             grid_limit => $self->_grid_limit($line->[L_OPENER]),
1047             grid_min_items => $self->_grid_min_items($line->[L_OPENER]),
1048             ) ;
1049 47         110 $frame->add_line($line) ;
1050 47         45 push @{ $self->[W_STACK] }, $frame ;
  47         56  
1051              
1052 47 50       75 $self->_mark_no_fold if $line->width > $self->[W_CFG][C_WIDTH] ;
1053 47         122 return ;
1054             }
1055              
1056 122 100       122 unless (@{ $self->[W_STACK] }) {
  122         221  
1057 2         7 $self->_write_line($line) ;
1058 2         3 return ;
1059             }
1060              
1061 120         137 my $frame = $self->[W_STACK][-1] ;
1062              
1063 120 100       164 if ($line->[L_CLOSER]) {
1064 47 50       73 if ($frame->[F_KIND] != $line->[L_CLOSER]) {
1065 0         0 $frame->[F_FOLD_OK] = 0 ;
1066 0         0 $frame->[F_GRID_OK] = 0 ;
1067             }
1068 47         80 $frame->add_line($line) ;
1069 47         82 $self->_close_frame ;
1070 47         179 return ;
1071             }
1072              
1073 73 100       105 $line->[L_CAN_PACK] = 0 if $line->[L_ITEMS] >= $frame->[F_PACK_LIMIT] ;
1074 73 100       99 $line->[L_CAN_JOIN] = 0 if $line->[L_ITEMS] >= $frame->[F_JOIN_LIMIT] ;
1075 73         133 $self->_add_to_frame($frame, $line) ;
1076 73         139 return ;
1077             }
1078              
1079             sub _emit_lines {
1080 62     62   82 my ($self, $lines, $depth) = @_;
1081 62 50       85 return unless @$lines;
1082 62 100       77 $depth = @{ $self->[W_STACK] } - 1 unless defined $depth;
  47         58  
1083              
1084 62 100       118 if ($depth < 0) {
1085 24         55 $self->_write_line($_) for @$lines;
1086             return
1087 24         30 }
1088              
1089 38         46 my $frame = $self->[W_STACK][$depth];
1090 38         70 $self->_add_to_frame($frame, $_) for @$lines;
1091             return
1092 38         44 }
1093              
1094             sub _add_to_frame {
1095 124     124   147 my ($self, $frame, $line) = @_;
1096              
1097 124 100 66     158 if (!$frame->is_empty) {
    100          
1098 107 100       138 unless ($frame->[F_GRID_OK]) {
1099 90         124 my $prev = $frame->last_line ;
1100 90 100 100     239 return if $line->[L_CAN_PACK] && $prev->[L_CAN_PACK] && $self->_try_pack($frame, $prev, $line) ;
      66        
1101 55 100 100     120 return if $line->[L_CAN_JOIN] && $prev->[L_CAN_JOIN] && $self->_try_join($frame, $prev, $line) ;
      66        
1102             }
1103             # If frame is empty, may be it's in "streaming" mode, which
1104             # mean that lines that can not be packed/joined can be sent
1105             # directly to the output:
1106             } elsif (
1107             !$frame->[F_FOLD_OK] && !$line->[L_CAN_PACK] && !$line->[L_CAN_JOIN]
1108             ) {
1109 13         24 $self->_write_line($line);
1110 13         20 return;
1111             }
1112              
1113 72         123 $frame->add_line($line) ;
1114              
1115 72 50 66     139 if ( $frame->[F_FOLD_OK] && $line->width > $self->[W_CFG][C_WIDTH] ) {
1116 0         0 $self->_mark_no_fold ;
1117             }
1118              
1119 72 100       104 unless ($line->[L_CLOSER]) {
1120 67 100 100     158 if ($frame->[F_FOLD_OK] && !$frame->check_fold_limits($self->[W_CFG])) {
1121 8         12 $self->_mark_no_fold ;
1122             }
1123              
1124 67 50 66     125 if ($frame->[F_GRID_OK] && !$line->[L_CAN_GRID]) {
1125 0         0 $self->_mark_no_grid ;
1126 0         0 $frame->join_lines($self->[W_CFG]) ;
1127             }
1128             }
1129              
1130 72 100 100     143 $self->_stream_frame($frame) unless $frame->[F_FOLD_OK] || $frame->[F_GRID_OK] ;
1131 72         114 return ;
1132             }
1133              
1134             sub _merge_into_frame {
1135 39     39   59 my ($self, $frame, $prev, $line) = @_;
1136 39         71 $prev->merge_line($line) ;
1137              
1138 39 100 66     99 $prev->[L_CAN_PACK] = 0
1139             if $prev->[L_ITEMS] >= $frame->[F_PACK_LIMIT]
1140             || $prev->[L_CHILD_NESTING] >= $self->[W_CFG][C_PACK_NESTING] ;
1141              
1142 39 100 66     95 $prev->[L_CAN_JOIN] = 0
1143             if $prev->[L_ITEMS] >= $frame->[F_JOIN_LIMIT]
1144             || $prev->[L_CHILD_NESTING] >= $self->[W_CFG][C_JOIN_NESTING] ;
1145              
1146 39         62 $frame->update_stats($line) ;
1147              
1148 39 50 66     93 if ($frame->[F_FOLD_OK] && !$frame->check_fold_limits($self->[W_CFG])) {
1149 0         0 $self->_mark_no_fold ;
1150 0         0 $self->_stream_frame($frame) ;
1151             }
1152             }
1153              
1154             sub _try_pack {
1155 35     35   48 my ($self, $frame, $prev, $line) = @_ ;
1156 35 50       60 return 0 if $frame->[F_PACK_LIMIT] <= 1 ;
1157 35 50       67 return 0 unless $prev->can_merge($line, $frame->[F_PACK_LIMIT], $self->[W_CFG][C_WIDTH]) ;
1158 35         84 $self->_merge_into_frame($frame, $prev, $line);
1159 35 50       76 $prev->[L_CAN_JOIN] = 0 unless $prev->[L_CAN_PACK] ;
1160 35         79 return 1;
1161             }
1162              
1163             sub _try_grid {
1164 10     10   15 my ($self, $frame) = @_ ;
1165 10 100       25 return 0 if $frame->[F_KIND] != JSON::JSONFold::Kind::KIND_LIST ;
1166              
1167 1         1 my $line_count = @{ $frame->[F_LINES] } - 2 ;
  1         3  
1168 1 50 33     5 return 0 if $line_count < 2
      33        
1169             || $line_count < $self->[W_CFG][C_GRID_MIN_LINES]
1170             || $line_count > $self->[W_CFG][C_GRID_MAX_LINES] ;
1171              
1172 0         0 my @lines = @{ $frame->[F_LINES] }[1 .. @{ $frame->[F_LINES] } - 2] ;
  0         0  
  0         0  
1173 0 0       0 return 0 unless @lines ;
1174              
1175 0         0 my $first = $lines[0] ;
1176 0         0 my $part_count = @{ $first->[L_PARTS] } ;
  0         0  
1177 0 0 0     0 return 0 if $part_count < 4 || ($part_count - 2) < $frame->[F_GRID_MIN_ITEMS] ;
1178              
1179 0         0 for my $line (@lines) {
1180 0 0       0 return 0 if @{ $line->[L_PARTS] } != $part_count ;
  0         0  
1181             }
1182              
1183 0 0       0 if ($first->[L_KIND] == JSON::JSONFold::Kind::KIND_DICT) {
1184 0         0 my $sig = $first->dict_signature ;
1185 0 0       0 return 0 unless defined $sig ;
1186 0         0 for my $line (@lines) {
1187 0         0 my $line_sig = $line->dict_signature ;
1188 0 0 0     0 return 0 unless defined $line_sig && $line_sig eq $sig ;
1189             }
1190             }
1191              
1192 0         0 my @widths ;
1193 0         0 for my $i (0 .. $part_count - 1) {
1194 0         0 my $max = 0 ;
1195 0         0 for my $line (@lines) {
1196 0         0 my $len = length($line->[L_PARTS][$i]) ;
1197 0 0       0 $max = $len if $len > $max ;
1198             }
1199 0         0 push @widths, $max ;
1200             }
1201              
1202 0         0 my $grided_length = -1 ;
1203 0         0 $grided_length += 1 + $_ for @widths ;
1204 0 0       0 return 0 if $frame->[F_LINES][0][L_INDENT] + $grided_length > $self->[W_CFG][C_WIDTH] ;
1205              
1206 0         0 for my $line (@lines) {
1207 0         0 $line->apply_grid(\@widths) ;
1208 0         0 $line->[L_CAN_PACK] = 0 ;
1209 0         0 $line->[L_CAN_JOIN] = 0 ;
1210 0         0 $line->[L_CAN_GRID] = 0 ;
1211             }
1212 0         0 return 1 ;
1213             }
1214              
1215             sub _try_join {
1216 4     4   6 my ($self, $frame, $prev, $line) = @_;
1217 4 50       7 return 0 if $frame->[F_JOIN_LIMIT] <= 1 ;
1218 4 50       10 return 0 unless $prev->can_merge($line, $frame->[F_JOIN_LIMIT], $self->[W_CFG][C_WIDTH]) ;
1219 4         22 $self->_merge_into_frame($frame, $prev, $line);
1220 4         10 return 1;
1221             }
1222              
1223              
1224              
1225             sub _close_frame {
1226 47     47   54 my ($self) = @_ ;
1227              
1228 47         80 my $frame = pop @{ $self->[W_STACK] };
  47         75  
1229              
1230 47 100       71 if ($frame->[F_GRID_OK]) {
1231 10 50       24 if ($self->_try_grid($frame)) {
1232 0         0 $self->_mark_no_grid ;
1233             }
1234             else {
1235 10         23 $self->_mark_no_grid ;
1236 10         24 $frame->join_lines($self->[W_CFG]) ;
1237 10         24 $frame->[F_FOLD_OK] = $frame->check_fold_limits($self->[W_CFG]) ;
1238             }
1239             }
1240              
1241 47 100       75 if ($frame->[F_FOLD_OK]) {
1242 35 100       56 if ($self->_try_fold($frame)) {
1243 32 100 100     45 if (@{ $self->[W_STACK] } && $frame->[F_LINES][0][L_CAN_GRID]) {
  32         79  
1244 18         20 my $parent = $self->[W_STACK][-1] ;
1245 18 100       37 $parent->[F_GRID_OK] = 1 if $parent->[F_CONTENT_LINES] == 0 ;
1246             }
1247             }
1248             }
1249              
1250 47         101 $self->_emit_lines($frame->[F_LINES]) ;
1251 47         50 return ;
1252             }
1253              
1254             sub _try_fold {
1255 35     35   40 my ($self, $frame) = @_ ;
1256             return 0 if !$frame->[F_FOLD_OK]
1257             || $frame->[F_CONTENT_LINES] != 1
1258 35 50 66     91 || @{ $frame->[F_LINES] } != 3
  32   66     125  
      66        
1259             || $frame->[F_INDENT] + $frame->[F_PARTS_LENGTH] > $self->[W_CFG][C_WIDTH] ;
1260              
1261 32         62 $frame->fold_lines($self->[W_CFG]) ;
1262 32         60 return 1 ;
1263             }
1264              
1265             sub _stream_frame {
1266 19     19   21 my ($self, $frame) = @_;
1267 19         21 my $lines = $frame->[F_LINES];
1268 19 50       25 return unless @$lines ;
1269              
1270 19         23 my $last = $lines->[-1] ;
1271 19   66     30 my $keep_last = $last->[L_CAN_PACK] || $last->[L_CAN_JOIN] ;
1272 19 100       26 pop @$lines if $keep_last ;
1273 19 100       29 if ( @$lines ) {
1274 15         53 $self->_emit_lines($lines, $frame->[F_DEPTH] - 1) ;
1275 15         40 @$lines = ();
1276             }
1277 19 100       26 push @$lines, $last if $keep_last ;
1278             return
1279 19         24 }
1280              
1281             sub _mark_no_fold {
1282 8     8   14 my ($self) = @_;
1283 8         8 $_->[F_FOLD_OK] = 0 for @{ $self->[W_STACK] };
  8         19  
1284             }
1285              
1286             sub _mark_no_grid {
1287 10     10   14 my ($self) = @_ ;
1288 10         12 $_->[F_GRID_OK] = 0 for @{ $self->[W_STACK] } ;
  10         18  
1289 10         11 return ;
1290             }
1291              
1292             sub _write_line {
1293 60     60   91 my ($self, $line) = @_ ;
1294 60         70 $self->[W_STATS]{lines_out} ++ ;
1295 60         88 return $self->_write_str($line->raw) ;
1296             }
1297              
1298             sub _write_str {
1299 61     61   82 my ($self, $s) = @_;
1300              
1301 61         424 $self->[W_FH]->print($s) ;
1302 61         28704 $self->[W_STATS]{bytes_out} += length($s);
1303 61         104 return length($s);
1304             }
1305              
1306              
1307             sub _choose_limit {
1308 235     235   258 my ($kind, $list, $dict) = @_;
1309 235 50       527 return $kind == JSON::JSONFold::Kind::KIND_LIST() ? $list
    100          
1310             : $kind == JSON::JSONFold::Kind::KIND_DICT() ? $dict
1311             : 0;
1312             }
1313              
1314 47     47   100 sub _pack_limit { _choose_limit($_[1], $_[0][W_CFG][C_PACK_ARRAY_ITEMS], $_[0][W_CFG][C_PACK_OBJ_ITEMS]) }
1315 47     47   84 sub _fold_limit { _choose_limit($_[1], $_[0][W_CFG][C_FOLD_ARRAY_ITEMS], $_[0][W_CFG][C_FOLD_OBJ_ITEMS]) }
1316 47     47   90 sub _join_limit { _choose_limit($_[1], $_[0][W_CFG][C_JOIN_ARRAY_ITEMS], $_[0][W_CFG][C_JOIN_OBJ_ITEMS]) }
1317 47     47   75 sub _grid_limit { _choose_limit($_[1], $_[0][W_CFG][C_GRID_ARRAY_ITEMS], $_[0][W_CFG][C_GRID_OBJ_ITEMS]) }
1318 47     47   65 sub _grid_min_items { _choose_limit($_[1], $_[0][W_CFG][C_GRID_ARRAY_MIN], $_[0][W_CFG][C_GRID_OBJ_MIN]) }
1319 1     1   4 sub _count_newlines { return ($_[0] =~ tr/\n//) }
1320              
1321             # -------------------------------------------------------------------------
1322             # CLI
1323             # -------------------------------------------------------------------------
1324              
1325             package JSON::JSONFold::CLI ;
1326              
1327 5     5   34 use strict ;
  5         8  
  5         122  
1328 5     5   17 use warnings ;
  5         44  
  5         210  
1329 5     5   33 use Exporter 'import';
  5         7  
  5         4282  
1330              
1331             our @EXPORT_OK = qw(
1332             demo_data
1333             run
1334             ) ;
1335              
1336             sub setup {
1337 0     0     require Carp ;
1338              
1339             $SIG{__DIE__} = sub {
1340 0 0   0     return if $^S;
1341 0           local $SIG{__DIE__};
1342 0           Carp::confess(@_);
1343 0           };
1344              
1345             $SIG{__WARN__} = sub {
1346 0     0     local $SIG{__WARN__};
1347 0           Carp::cluck(@_);
1348 0           };
1349              
1350 0           require Getopt::Long ;
1351              
1352             }
1353              
1354             sub demo_data {
1355             return {
1356             meta => { version => 1, ok => JSON::PP::true, name => "jsonfold demo" },
1357             ids => [ 1, 2, 3, 4, 5, 6 ],
1358             items => [ { id => 1, name => "alpha" }, { id => 2, name => "beta" }, ],
1359             matrix => [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
1360             long => [
1361             "this is a long message that may force the block to stay expanded",
1362             "second",
1363             "third",
1364             "fourth",
1365             ],
1366             "single-array" => [1],
1367             "single-obj" => { x => 2 },
1368 0           long_array => [ map { "a$_" } 1..50 ],
1369 0           wide_array => [ map { "abcdefghijklmnopqrstuvwxyz$_" } 1 .. 9 ],
1370 0     0     wide_object => { map { ; "abcdefghijk$_" => "lmnopqrstuvwxyz$_" } 1 .. 9 },
  0            
1371              
1372             };
1373             }
1374              
1375             sub parse_options {
1376 0     0     my %opt = (
1377             compact => 'default',
1378             indent => 2,
1379             sort_keys => 1,
1380             );
1381              
1382             Getopt::Long::GetOptions(
1383             'demo' => \$opt{demo},
1384             'verbose|v' => \$opt{verbose},
1385             'help|h' => \$opt{help},
1386             'input|i=s' => \$opt{input},
1387             'compact=s' => \$opt{compact},
1388             'indent=i' => \$opt{indent},
1389             'sort-keys!' => \$opt{sort_keys},
1390 0           );
1391              
1392 0           return \%opt ;
1393             }
1394              
1395             sub usage {
1396 0     0     my $out = shift ;
1397 0           $out->print(<<___
1398             Usage: json-jsonfold [options] < input.json
1399              
1400             --demo
1401             --compact=default|classic|none|low|med|high|max|grid|pack|fold|join|off
1402             --width=N
1403             --indent=N
1404             --sort-keys
1405             --input=FILE
1406             ___
1407             ) ;
1408             }
1409              
1410             sub read_input {
1411 0     0     my ($input) = @_ ;
1412              
1413 0           my $json_text;
1414 0 0         if (defined $input) {
1415 0 0         open my $fh, '<', $input or die "$input: $!\n";
1416 0           local $/;
1417 0           $json_text = <$fh>;
1418 0 0         close $fh or die "$input: $!\n";
1419             } else {
1420 0           local $/;
1421 0           $json_text = ;
1422             }
1423              
1424 0           return JSON::PP->new->allow_nonref->decode($json_text);
1425             }
1426              
1427             sub show_verbose {
1428 0     0     require Data::Dumper ;
1429              
1430 0           my ($label) = shift ;
1431 0           my $dumper = new Data::Dumper([])->Terse(1)->Indent(1)->Sortkeys(1)->Pair('=')->Quotekeys(0) ;
1432              
1433 0           my $s = $dumper->Values( \@_)->Dump ;
1434 0           $s =~ s/\s+/ /gsm ;
1435              
1436 0           print STDERR "$label: $s\n" ;
1437              
1438             }
1439              
1440             sub run {
1441 0     0     setup() ;
1442 0           my $opt = parse_options();
1443              
1444 0 0         if ($opt->{help}) {
1445 0           usage(\*STDOUT);
1446 0           return 0;
1447             }
1448              
1449 0           binmode STDOUT, ':encoding(UTF-8)' ;
1450 0 0         my $data = $opt->{demo} ? demo_data() : read_input($opt->{input});
1451 0           my %cfg ;
1452 0           my $config = JSON::JSONFold::config($opt->{compact}, $opt->{width}, %cfg);
1453 0           my $verbose = $opt->{verbose} ;
1454              
1455 0 0 0       print STDERR "Backend: ", $JSON::JSONFold::BACKEND || "-", "\n" if $verbose ;
1456 0 0         show_verbose("config", { $config->as_hash } ) if $verbose ;
1457              
1458 0           my $info = JSON::JSONFold::write_json($data, \*STDOUT, $opt->{width}, $config, sort_keys => $opt->{sort_keys}, indent => $opt->{indent} );
1459              
1460 0 0         show_verbose("stats", { % $info }) if $verbose ;
1461 0           return 0;
1462             }
1463              
1464             run() unless caller() ;
1465              
1466             1;
1467              
1468             __END__