File Coverage

blib/lib/TOML/Parser.pm
Criterion Covered Total %
statement 112 128 87.5
branch 55 72 76.3
condition 7 13 53.8
subroutine 21 23 91.3
pod 6 6 100.0
total 201 242 83.0


line stmt bran cond sub pod time code
1             package TOML::Parser;
2 20     20   1146486 use 5.010000;
  20         259  
3 20     20   106 use strict;
  20         38  
  20         426  
4 20     20   92 use warnings;
  20         43  
  20         560  
5 20     20   6531 use Encode;
  20         162124  
  20         1573  
6              
7             our $VERSION = "0.90";
8              
9 20     20   5693 use TOML::Parser::Tokenizer qw/:constant/;
  20         54  
  20         3094  
10 20     20   5103 use TOML::Parser::Tokenizer::Strict;
  20         50  
  20         920  
11 20     20   4746 use TOML::Parser::Util qw/unescape_str/;
  20         45  
  20         932  
12 20     20   5216 use Types::Serialiser;
  20         51813  
  20         25167  
13              
14             sub new {
15 56     56 1 50281 my $class = shift;
16 56 50 33     332 my $args = (@_ == 1 and ref $_[0] eq 'HASH') ? +shift : +{ @_ };
17             return bless +{
18 2     2   5 inflate_datetime => sub { $_[0] },
19 4 50   4   20 inflate_boolean => sub { $_[0] eq 'true' ? Types::Serialiser::true : Types::Serialiser::false },
20 56         619 strict_mode => 0,
21             %$args,
22             } => $class;
23             }
24              
25             sub parse_file {
26 0     0 1 0 my ($self, $file) = @_;
27 0 0       0 open my $fh, '<:encoding(utf-8)', $file or die $!;
28 0         0 return $self->parse_fh($fh);
29             }
30              
31             sub parse_fh {
32 0     0 1 0 my ($self, $fh) = @_;
33 0         0 my $src = do { local $/; <$fh> };
  0         0  
  0         0  
34 0         0 return $self->parse($src);
35             }
36              
37             sub _tokenizer_class {
38 56     56   104 my $self = shift;
39 56 100       486 return $self->{strict_mode} ? 'TOML::Parser::Tokenizer::Strict' : 'TOML::Parser::Tokenizer';
40             }
41              
42             our @TOKENS;
43             our $ROOT;
44             our $CONTEXT;
45             sub parse {
46 56     56 1 236 my ($self, $src) = @_;
47              
48 56         132 local $ROOT = {};
49 56         109 local $CONTEXT = $ROOT;
50 56         159 local @TOKENS = $self->_tokenizer_class->tokenize($src);
51 36         134 return $self->_parse_tokens();
52             }
53              
54             sub _parse_tokens {
55 93     93   137 my $self = shift;
56              
57 93         227 while (my $token = shift @TOKENS) {
58 332         619 $self->_parse_token($token);
59             }
60              
61 88         255 return $CONTEXT;
62             }
63              
64             sub _parse_token {
65 332     332   477 my ($self, $token) = @_;
66              
67 332         527 my ($type, $val) = @$token;
68 332 100       750 if ($type eq TOKEN_TABLE) {
    100          
    100          
    50          
69 40         101 $self->_parse_table($val);
70             }
71             elsif ($type eq TOKEN_ARRAY_OF_TABLE) {
72 17         37 $self->_parse_array_of_table($val);
73             }
74             elsif (my ($key, $value) = $self->_parse_key_and_value($token)) {
75 213 100       462 die "Duplicate key. key:$key" if exists $CONTEXT->{$key};
76 210         676 $CONTEXT->{$key} = $value;
77             }
78             elsif ($type eq TOKEN_COMMENT) {
79             # pass through
80             }
81             else {
82 0         0 die "Unknown case. type:$type";
83             }
84             }
85              
86             sub _parse_key_and_value {
87 319     319   472 my ($self, $token) = @_;
88              
89 319         464 my ($type, $val) = @$token;
90 319 100       513 if ($type eq TOKEN_KEY) {
91 257         325 my $token = shift @TOKENS;
92              
93 257         338 my $key = $val;
94 257         392 my $value = $self->_parse_value_token($token);
95 257         822 return ($key, $value);
96             }
97              
98 62         234 return;
99             }
100              
101             sub _parse_table {
102 40     40   64 my ($self, $keys) = @_;
103 40         71 my @keys = @$keys;
104              
105 40         54 local $CONTEXT = $ROOT;
106 40         66 for my $k (@keys) {
107 67 100       142 if (exists $CONTEXT->{$k}) {
108             $CONTEXT = ref $CONTEXT->{$k} eq 'ARRAY' ? $CONTEXT->{$k}->[-1] :
109 9 50       34 ref $CONTEXT->{$k} eq 'HASH' ? $CONTEXT->{$k} :
    100          
110 0         0 die "invalid structure. @{[ join '.', @keys ]} cannot be `Table`";
111             }
112             else {
113 58   50     194 $CONTEXT = $CONTEXT->{$k} ||= +{};
114             }
115             }
116              
117 40         93 $self->_parse_tokens();
118             }
119              
120             sub _parse_array_of_table {
121 17     17   24 my ($self, $keys) = @_;
122 17         33 my @keys = @$keys;
123 17         22 my $last_key = pop @keys;
124              
125 17         21 local $CONTEXT = $ROOT;
126 17         24 for my $k (@keys) {
127 6 50       15 if (exists $CONTEXT->{$k}) {
128             $CONTEXT = ref $CONTEXT->{$k} eq 'ARRAY' ? $CONTEXT->{$k}->[-1] :
129 6 0       15 ref $CONTEXT->{$k} eq 'HASH' ? $CONTEXT->{$k} :
    50          
130 0         0 die "invalid structure. @{[ join '.', @keys ]} cannot be `Array of table`.";
131             }
132             else {
133 0   0     0 $CONTEXT = $CONTEXT->{$k} ||= +{};
134             }
135             }
136              
137 17 100       45 $CONTEXT->{$last_key} = [] unless exists $CONTEXT->{$last_key};
138 17 50       40 die "invalid structure. @{[ join '.', @keys ]} cannot be `Array of table`" unless ref $CONTEXT->{$last_key} eq 'ARRAY';
  0         0  
139 17         20 push @{ $CONTEXT->{$last_key} } => $CONTEXT = {};
  17         37  
140              
141 17         34 $self->_parse_tokens();
142             }
143              
144             sub _parse_value_token {
145 326     326   380 my $self = shift;
146 326         365 my $token = shift;
147              
148 326         602 my ($type, $val, @args) = @$token;
149 326 50 100     1216 if ($type eq TOKEN_COMMENT) {
    100          
    100          
    100          
    100          
    100          
    100          
    50          
150 0         0 return; # pass through
151             }
152             elsif ($type eq TOKEN_INTEGER || $type eq TOKEN_FLOAT) {
153 98         180 $val =~ tr/_//d;
154 98         226 return 0+$val;
155             }
156             elsif ($type eq TOKEN_BOOLEAN) {
157 4         21 return $self->inflate_boolean($val);
158             }
159             elsif ($type eq TOKEN_DATETIME) {
160 2         5 return $self->inflate_datetime($val);
161             }
162             elsif ($type eq TOKEN_STRING) {
163 157         225 my ($is_raw) = @args;
164 157 100       376 return $is_raw ? $val : unescape_str($val);
165             }
166             elsif ($type eq TOKEN_MULTI_LINE_STRING_BEGIN) {
167 20         26 my ($is_raw) = @args;
168 20         43 my $value = $self->_parse_value_token(shift @TOKENS);
169 20         104 $value =~ s/\A(?:\r\n|[\r\n])//msg;
170 20         60 $value =~ s/\\\s+//msg;
171 20 50       46 if (my $token = shift @TOKENS) {
172 20         27 my ($type) = @$token;
173 20 50       54 return $value if $type eq TOKEN_MULTI_LINE_STRING_END;
174 0         0 die "Unexpected token: $type";
175             }
176             }
177             elsif ($type eq TOKEN_INLINE_TABLE_BEGIN) {
178 16         22 my %data;
179 16         31 while (my $token = shift @TOKENS) {
180 62 100       120 last if $token->[0] eq TOKEN_INLINE_TABLE_END;
181 46 100       72 next if $token->[0] eq TOKEN_COMMENT;
182 44         80 my ($key, $value) = $self->_parse_key_and_value($token);
183 44 50       79 die "Duplicate key. key:$key" if exists $data{$key};
184 44         120 $data{$key} = $value;
185             }
186 16         38 return \%data;
187             }
188             elsif ($type eq TOKEN_ARRAY_BEGIN) {
189 29         38 my @data;
190              
191             my $last_token;
192 29         56 while (my $token = shift @TOKENS) {
193 85 100       147 last if $token->[0] eq TOKEN_ARRAY_END;
194 56 100       87 next if $token->[0] eq TOKEN_COMMENT;
195 49 100       80 if ($self->{strict_mode}) {
196 22 50 66     56 die "Unexpected token: $token->[0]" if defined $last_token && $token->[0] ne $last_token->[0];
197             }
198 49         102 push @data => $self->_parse_value_token($token);
199 49         108 $last_token = $token;
200             }
201 29         74 return \@data;
202             }
203              
204 0         0 die "Unexpected token: $type";
205             }
206              
207             sub inflate_datetime {
208 2     2 1 3 my $self = shift;
209 2         5 return $self->{inflate_datetime}->(@_);
210             }
211              
212             sub inflate_boolean {
213 4     4 1 8 my $self = shift;
214 4         13 return $self->{inflate_boolean}->(@_);
215             }
216              
217             1;
218             __END__