File Coverage

blib/lib/dotconfig.pm
Criterion Covered Total %
statement 28 45 62.2
branch 0 4 0.0
condition n/a
subroutine 10 14 71.4
pod n/a
total 38 63 60.3


line stmt bran cond sub pod time code
1             package dotconfig;
2 14     14   38220 use strict;
  14         29  
  14         395  
3 14     14   67 use warnings;
  14         23  
  14         298  
4 14     14   64 use Carp ();
  14         28  
  14         184  
5 14     14   12118 use Encode ();
  14         164056  
  14         352  
6 14     14   101 use Exporter 'import';
  14         30  
  14         4061  
7             our $VERSION = '0.03';
8             our @EXPORT = qw( load_config decode_config );
9              
10             sub load_config {
11 0     0     my ($path, $option) = @_;
12 0 0         open my $fh, "<", $path or Carp::croak $!;
13 0           my $text = Encode::decode_utf8(do { local $/; <$fh> });
  0            
  0            
14 0           decode_config($text, $option);
15             }
16              
17             sub new {
18 0     0     my ($class, %option) = @_;
19 0           bless {
20             option => { %option },
21             }, $class;
22             }
23              
24             sub decode {
25 0     0     my ($self, $text) = @_;
26 0           decode_config($text, $self->{option});
27             }
28              
29             sub decode_config {
30 0     0     my ($text, $option) = @_;
31 0           my $decoder = dotconfig::Decoder->new($text, $option);
32 0 0         if (my $config = $decoder->config) {
33 0           return $$config;
34             } else {
35 0           die "No value found in the config";
36             }
37             }
38              
39             # sub encode {
40             # my ($self, $value) = @_;
41             # }
42             #
43             # sub encode_config {
44             # }
45              
46             package
47             dotconfig::Decoder;
48 14     14   77 use strict;
  14         25  
  14         432  
49 14     14   69 use warnings;
  14         36  
  14         428  
50 14     14   23038 use Math::BigInt;
  14         379373  
  14         68  
51 14     14   1014764 use Math::BigFloat;
  14         317654  
  14         85  
52 14     14   32750 use JSON ();
  0            
  0            
53             use constant {
54             DC_SPACE => ' ',
55             DC_TAB => "\t",
56             DC_LF => "\n",
57             DC_CR => "\r",
58             DC_FALSE => 'false',
59             DC_TRUE => 'true',
60             DC_NULL => 'null',
61             DC_BEGIN_ARRAY => '[',
62             DC_END_ARRAY => ']',
63             DC_BEGIN_MAP => '{',
64             DC_END_MAP => '}',
65             DC_NAME_SEPARATOR => ':',
66             DC_VALUE_SEPARATOR => ',',
67             DC_QUOTATION_MARK => '"',
68             DC_ESCAPE => '\\',
69             DC_SOLIDUS => '/',
70             DC_BACKSPACE => "\b",
71             DC_FORM_FEED => "\f",
72             };
73              
74             sub new {
75             my ($class, $text, $option) = @_;
76             bless {
77             tape => $text,
78             index => 0,
79             option => {
80             allow_bigint => 1,
81             %{$option // {}},
82             },
83             }, $class;
84             }
85              
86             sub _peek {
87             my ($self, $next) = @_;
88             my $eos_pos = $self->{index} + ($next // 0) + 1;
89             if (length $self->{tape} >= $eos_pos) {
90             return substr $self->{tape}, $self->{index} + $next // 0, 1;
91             }
92             }
93              
94             sub _match_str {
95             my ($self, $str) = @_;
96             my $next = substr $self->{tape}, $self->{index}, length $str;
97             if (length $next == length $str and $str eq $next) {
98             return 1;
99             }
100             }
101              
102             sub _consume {
103             my ($self, $length) = @_;
104             $self->{index} += $length // 1;
105             }
106              
107             sub _consume_if {
108             my ($self, $expected) = @_;
109             if ($self->_match_str($expected)) {
110             $self->{index} += length $expected;
111             return 1;
112             }
113             }
114              
115             sub _consume_if_space {
116             my ($self, $char) = @_;
117             if ( $char eq DC_SPACE
118             or $char eq DC_TAB
119             or $char eq DC_LF
120             or $char eq DC_CR
121             ) {
122             $self->{index} += 1;
123             return 1;
124             }
125             }
126              
127             sub config {
128             my ($self, $config) = @_;
129              
130             while (1) {
131             if (defined(my $char = $self->_peek(0))) {
132             next if $self->_consume_if_space($char);
133             if ($char eq DC_BEGIN_MAP) {
134             return $self->config(\$self->map);
135             }
136             elsif ($char eq DC_BEGIN_ARRAY) {
137             return $self->config(\$self->array);
138             }
139             elsif ($char eq DC_QUOTATION_MARK) {
140             return $self->config(\$self->string);
141             }
142             elsif ($char eq "<" and $self->_match_str("<<")) {
143             return $self->config(\$self->heredoc);
144             }
145             elsif ($char =~ /[0-9\-]/) {
146             if ($self->_match_str("0x")) {
147             return $self->config(\$self->hex);
148             }
149             elsif ($self->_match_str("0b")) {
150             return $self->config(\$self->binary);
151             }
152             elsif ($self->_match_str("0o")) {
153             return $self->config(\$self->octal);
154             }
155             else {
156             return $self->config(\$self->number);
157             }
158             }
159             elsif (my $false = $self->false) {
160             return $self->config($false);
161             }
162             elsif (my $true = $self->true) {
163             return $self->config($true);
164             }
165             elsif (my $null = $self->null) {
166             return $self->config($null);
167             }
168             elsif ($char eq DC_SOLIDUS) {
169             if ($self->_match_str("//") or $self->_match_str("/*")) {
170             $self->comment;
171             next;
172             } else {
173             die "Unexpected charcter `/`";
174             }
175             }
176             else {
177             return $config;
178             }
179             } else {
180             last; # EOF
181             }
182             }
183              
184             return $config;
185             }
186              
187             sub false { shift->_consume_if(DC_FALSE) ? \JSON::false : undef }
188             sub true { shift->_consume_if(DC_TRUE) ? \JSON::true : undef }
189             sub null { shift->_consume_if(DC_NULL) ? \JSON::null : undef }
190              
191             sub number {
192             my $self = shift;
193             my $string = "";
194              
195             # minus
196             if ($self->_consume_if("-")) {
197             $string .= "-";
198             if (defined(my $char = $self->_peek(0))) {
199             unless ($char =~ /[0-9]/) {
200             die "Unexpected number format (found `$char` after `-`)";
201             }
202             } else {
203             die "Unexpected number format (no number after `-`)";
204             }
205             }
206              
207             # int
208             if ($self->_consume_if("0")) {
209             $string .= "0";
210             if (defined(my $char = $self->_peek(0))) {
211             if ($char =~ /[0-9]/) {
212             die "Unexpected number format (found `$char` after `0`)";
213             }
214             } else {
215             return $string + 0;
216             }
217             }
218              
219             while (1) {
220             if (defined(my $char = $self->_peek(0))) {
221             if ($char =~ /[0-9.]/) { # `.` for frac
222             $string .= $char;
223             $self->_consume;
224             next;
225             } else {
226             last;
227             }
228             } else {
229             last;
230             }
231             }
232              
233             # exp
234             if ($self->_consume_if("e") or $self->_consume_if("E")) {
235             $string .= "e";
236             if ($self->_consume_if("+")) {
237             $string .= "+";
238             } elsif ($self->_consume_if("-")) {
239             $string .= "-";
240             }
241              
242             my $digit_after_exp;
243             while (1) {
244             if (defined(my $char = $self->_peek(0))) {
245             if ($char =~ /[1-9]/) {
246             $string .= $char;
247             $self->_consume;
248             $digit_after_exp = 1;
249             } else {
250             last;
251             }
252             } else {
253             last;
254             }
255             }
256              
257             unless ($digit_after_exp) {
258             die "Unexpected number format (no digit after exp)";
259             }
260             }
261              
262             if ($string =~ /[.eE]/) { # is float
263             return $self->{option}{allow_bigint} ? Math::BigFloat->new($string) : $string;
264             } else { # is integer
265             if (($string + 0) =~ /[.eE]/) {
266             return $self->{option}{allow_bigint} ? Math::BigInt->new($string) : $string;
267             } else {
268             return $string + 0;
269             }
270             }
271             }
272              
273             sub hex {
274             my $self = shift;
275             my $prefix = "0x";
276             $self->_consume_if($prefix)
277             or die "Expected `$prefix`";
278              
279             my $string = "";
280             while (1) {
281             if (defined(my $char = $self->_peek(0))) {
282             if ($char =~ /[A-F0-9]/i) {
283             $string .= $char;
284             $self->_consume;
285             next;
286             } else {
287             return oct "$prefix$string";
288             }
289             } else {
290             return oct "$prefix$string";
291             }
292             }
293             }
294              
295             sub binary {
296             my $self = shift;
297             my $prefix = "0b";
298             $self->_consume_if($prefix)
299             or die "Expected `$prefix`";
300              
301             my $string = "";
302             while (1) {
303             if (defined(my $char = $self->_peek(0))) {
304             if ($char =~ /[01]/i) {
305             $string .= $char;
306             $self->_consume;
307             next;
308             } else {
309             return oct "$prefix$string";
310             }
311             } else {
312             return oct "$prefix$string";
313             }
314             }
315             }
316              
317             sub octal {
318             my $self = shift;
319             my $prefix = "0o";
320             $self->_consume_if($prefix)
321             or die "Expected `$prefix`";
322              
323             my $string = "";
324             while (1) {
325             if (defined(my $char = $self->_peek(0))) {
326             if ($char =~ /[0-7]/i) {
327             $string .= $char;
328             $self->_consume;
329             next;
330             } else {
331             return oct "0$string";
332             }
333             } else {
334             return oct "0$string";
335             }
336             }
337             }
338              
339             sub comment {
340             my $self = shift;
341             if ($self->_match_str("//")) {
342             $self->inline_comment;
343             }
344             elsif ($self->_match_str("/*")) {
345             $self->block_comment;
346             }
347             else {
348             die "Unexpected charcter `/`";
349             }
350             }
351              
352             sub inline_comment {
353             my $self = shift;
354             $self->_consume_if(DC_SOLIDUS . DC_SOLIDUS)
355             or die "Expected `" . DC_SOLIDUS . DC_SOLIDUS . "`";
356              
357             while (1) {
358             if (defined(my $char = $self->_peek(0))) {
359             $self->_consume;
360             if ($char eq DC_LF) {
361             return;
362             } else {
363             next;
364             }
365             } else {
366             $self->_consume;
367             return;
368             }
369             }
370             }
371              
372             sub block_comment {
373             my $self = shift;
374             $self->_consume_if("/*")
375             or die "Expected `/*`";
376              
377             while (1) {
378             if ($self->_match_str("//")) {
379             $self->inline_comment;
380             }
381             elsif ($self->_match_str("/*")) {
382             $self->block_comment;
383             }
384             elsif ($self->_match_str("*/")) {
385             $self->_consume(2);
386             return;
387             }
388             else {
389             $self->_consume;
390             }
391             }
392              
393             }
394              
395             sub string {
396             my $self = shift;
397             $self->_consume_if(DC_QUOTATION_MARK)
398             or die "Expected `" . DC_QUOTATION_MARK . "`";
399              
400             my $string = "";
401             while (1) {
402             if (defined(my $char = $self->_peek(0))) {
403             if ($char eq DC_ESCAPE) {
404             if (defined(my $next_char = $self->_peek(1))) {
405             my $escapes = {
406             DC_QUOTATION_MARK() => DC_QUOTATION_MARK,
407             DC_ESCAPE() => DC_ESCAPE,
408             DC_SOLIDUS() => DC_SOLIDUS,
409             "b" => DC_BACKSPACE,
410             "f" => DC_FORM_FEED,
411             "n" => DC_LF,
412             "r" => DC_CR,
413             "t" => DC_TAB,
414             };
415             if (my $ch = $escapes->{$next_char}) {
416             $string .= $ch;
417             $self->_consume(2);
418             next;
419             } elsif ($next_char eq 'u') { # TODO UTF-16 support?
420             my $utf = "";
421             for (1..4) {
422             my $char = $self->_peek(1 + $_);
423             if (defined $char && $char =~ /[A-F0-9]/i) {
424             $utf .= $char;
425             } else {
426             die "Unexpected end of escaped UTF string";
427             }
428             }
429             $self->_consume(6);
430              
431             if ((my $hex = CORE::hex $utf) > 127) {
432             $string .= pack U => $hex;
433             } else {
434             $string .= chr $hex;
435             }
436             } else {
437             die "Unexpected escape sequence";
438             }
439             } else {
440             die "Unexpected end of string literal";
441             }
442              
443             } elsif ($char eq DC_QUOTATION_MARK) {
444             if ($self->_peek(-1) eq DC_ESCAPE) {
445             $string .= $char;
446             $self->_consume;
447             next;
448             } else {
449             $self->_consume;
450             return $string;
451             }
452             } else {
453             $string .= $char;
454             $self->_consume;
455             next;
456             }
457             } else {
458             die "Unterminated string";
459             }
460             }
461             }
462              
463             sub heredoc {
464             my $self = shift;
465              
466             $self->_consume_if("<<")
467             or die "Expected `<<`";
468              
469             my $strip_space = $self->_consume_if("-") ? 1 : 0;
470              
471             my $delimiter = "";
472             while (1) {
473             if (defined(my $char = $self->_peek(0))) {
474             $self->_consume;
475             if ($char eq DC_SPACE or $char eq DC_TAB) {
476             next;
477             } elsif ($char eq DC_LF) {
478             last;
479             } else {
480             $delimiter .= $char;
481             }
482             } else {
483             die "Unexpected end of heredoc";
484             }
485             }
486              
487             my $string = "";
488             while (1) {
489             last if $self->_consume_if($delimiter);
490             if (defined(my $char = $self->_peek(0))) {
491             $self->_consume;
492             $string .= $char;
493             next;
494             } else {
495             die "Unexpected end of heredoc";
496             }
497             }
498             chomp $string;
499              
500             if ($strip_space) {
501             my @lines = split /\n/, $string;
502             my $last_line = pop @lines;
503             my $indent = 0;
504             for (split //, $last_line) {
505             $indent++ if $_ eq DC_SPACE
506             }
507              
508             $string = join DC_LF, map { substr $_, $indent } @lines;
509             }
510              
511             return $string;
512             }
513              
514             sub array {
515             my $self = shift;
516              
517             $self->_consume_if(DC_BEGIN_ARRAY)
518             or die "Expected `" . DC_BEGIN_ARRAY . "`";
519              
520             my $array = [];
521             while (1) {
522             if (defined(my $char = $self->_peek(0))) {
523             if ($self->_consume_if(DC_END_ARRAY)) {
524             return $array;
525             }
526             elsif ($self->_consume_if(DC_VALUE_SEPARATOR)) {
527             next;
528             }
529             else {
530             if (defined(my $value = $self->config)) {
531             push @$array, $$value;
532             } else {
533             next; # trailing comma is valid
534             }
535             }
536             } else {
537             return $array;
538             }
539             }
540             }
541              
542             sub map {
543             my $self = shift;
544             $self->_consume_if(DC_BEGIN_MAP)
545             or die "Expected `" . DC_BEGIN_MAP . "`";
546              
547             my $map = [];
548              
549             while (1) {
550             if (defined(my $char = $self->_peek(0))) {
551             next if $self->_consume_if_space($char);
552             if ($self->_match_str("//") or $self->_match_str("/*")) {
553             $self->comment;
554             next;
555             }
556             elsif ($self->_consume_if(DC_END_MAP)) {
557             last;
558             }
559             else {
560             $self->map_members($map);
561             last;
562             }
563             } else {
564             last;
565             }
566             }
567              
568             return { @$map };
569             }
570              
571             sub map_members {
572             use constant { map { ($_ => $_) } qw/
573             STATE_KEY
574             STATE_KEY_SEPARATOR
575             STATE_VALUE
576             STATE_VALUE_SEPARATOR
577             / };
578              
579             my $self = shift;
580             my $members = shift;
581             my $state = shift // STATE_KEY;
582              
583             while (1) {
584             if (defined(my $char = $self->_peek(0))) {
585             next if $self->_consume_if_space($char);
586             if ($self->_match_str("//") or $self->_match_str("/*")) {
587             $self->comment;
588             next;
589             }
590             elsif ($self->_consume_if(DC_END_MAP)) {
591             return;
592             }
593             else {
594             if ($state eq STATE_KEY) {
595             if (defined(my $key = $self->map_key)) {
596             push @$members, $key;
597             $self->map_members($members, STATE_KEY_SEPARATOR);
598             return;
599             } else {
600             die "Unexpected member key name in map";
601             }
602             }
603             elsif ($state eq STATE_KEY_SEPARATOR) {
604             if ($self->_consume_if(DC_NAME_SEPARATOR)) {
605             $self->map_members($members, STATE_VALUE);
606             return;
607             } else {
608             die "Expected `" . DC_NAME_SEPARATOR . "` but got unexpected char at " . $self->{index};
609             }
610             }
611             elsif ($state eq STATE_VALUE) {
612             if (defined(my $value = $self->config)) {
613             push @$members, $$value;
614             $self->map_members($members, STATE_VALUE_SEPARATOR);
615             return;
616             } else {
617             die "Invalid value";
618             }
619             }
620             elsif ($state eq STATE_VALUE_SEPARATOR) {
621             if ($self->_consume_if(DC_VALUE_SEPARATOR)) {
622             $self->map_members($members, STATE_KEY);
623             return;
624             } else {
625             die "Expected `" . DC_VALUE_SEPARATOR . "` but got `$char` at " . $self->{index};
626             return;
627             }
628             }
629             else {
630             die "Unexpected state: `$state`";
631             }
632             }
633             } else {
634             return;
635             }
636             }
637             }
638              
639             sub map_key {
640             my $self = shift;
641              
642             use constant { map { ($_ => $_) } qw/
643             MODE_MAP_KEY_NAKED
644             MODE_MAP_KEY_QUOTED
645             / };
646              
647             my $mode = $self->_match_str(DC_QUOTATION_MARK)
648             ? MODE_MAP_KEY_QUOTED
649             : MODE_MAP_KEY_NAKED;
650              
651             my $string = "";
652             while (1) {
653             if (defined(my $char = $self->_peek(0))) {
654             if ($mode eq MODE_MAP_KEY_QUOTED) {
655             return $self->string;
656             } else {
657             if ($self->_consume_if_space($char)) {
658             next;
659             }
660             elsif ($self->_match_str("//") or $self->_match_str("/*")) {
661             $self->comment;
662             next;
663             }
664             elsif ($self->_match_str(DC_NAME_SEPARATOR)) {
665             return $string;
666             }
667             else {
668             $string .= $char;
669             $self->_consume;
670             next;
671             }
672             }
673             } else {
674             die "Unterminated string";
675             }
676             }
677             }
678              
679             1;
680             __END__