1package TOML::Parser;
2use 5.010000;
3use strict;
4use warnings;
5use Encode;
6
7our $VERSION = "0.91";
8
9use TOML::Parser::Tokenizer qw/:constant/;
10use TOML::Parser::Tokenizer::Strict;
11use TOML::Parser::Util qw/unescape_str/;
12use Types::Serialiser;
13
14sub new {
15    my $class = shift;
16    my $args  = (@_ == 1 and ref $_[0] eq 'HASH') ? +shift : +{ @_ };
17    return bless +{
18        inflate_datetime => sub { $_[0] },
19        inflate_boolean  => sub { $_[0] eq 'true' ? Types::Serialiser::true : Types::Serialiser::false },
20        strict_mode      => 0,
21        %$args,
22    } => $class;
23}
24
25sub parse_file {
26    my ($self, $file) = @_;
27    open my $fh, '<:encoding(utf-8)', $file or die $!;
28    return $self->parse_fh($fh);
29}
30
31sub parse_fh {
32    my ($self, $fh) = @_;
33    my $src = do { local $/; <$fh> };
34    return $self->parse($src);
35}
36
37sub _tokenizer_class {
38    my $self = shift;
39    return $self->{strict_mode} ? 'TOML::Parser::Tokenizer::Strict' : 'TOML::Parser::Tokenizer';
40}
41
42our @TOKENS;
43our $ROOT;
44our $CONTEXT;
45sub parse {
46    my ($self, $src) = @_;
47
48    local $ROOT    = {};
49    local $CONTEXT = $ROOT;
50    local @TOKENS  = $self->_tokenizer_class->tokenize($src);
51    while (my $token = shift @TOKENS) {
52        $self->_parse_token($token);
53    }
54    return $ROOT;
55}
56
57sub _parse_token {
58    my ($self, $token) = @_;
59
60    my ($type, $val) = @$token;
61    if ($type eq TOKEN_TABLE) {
62        $self->_parse_table($val);
63    }
64    elsif ($type eq TOKEN_ARRAY_OF_TABLE) {
65        $self->_parse_array_of_table($val);
66    }
67    elsif (my ($key, $value) = $self->_parse_key_and_value($token)) {
68        die "Duplicate key. key:$key" if exists $CONTEXT->{$key};
69        $CONTEXT->{$key} = $value;
70    }
71    elsif ($type eq TOKEN_COMMENT) {
72        # pass through
73    }
74    else {
75        die "Unknown case. type:$type";
76    }
77}
78
79sub _parse_key_and_value {
80    my ($self, $token) = @_;
81
82    my ($type, $val) = @$token;
83    if ($type eq TOKEN_KEY) {
84        my $token = shift @TOKENS;
85
86        my $key = $val;
87        my $value = $self->_parse_value_token($token);
88        return ($key, $value);
89    }
90
91    return;
92}
93
94sub _parse_table {
95    my ($self, $keys) = @_;
96    my @keys = @$keys;
97
98    $CONTEXT = $ROOT;
99    for my $k (@keys) {
100        if (exists $CONTEXT->{$k}) {
101            $CONTEXT = ref $CONTEXT->{$k} eq 'ARRAY' ? $CONTEXT->{$k}->[-1] :
102                       ref $CONTEXT->{$k} eq 'HASH'  ? $CONTEXT->{$k}       :
103                       die "invalid structure. @{[ join '.', @keys ]} cannot be `Table`";
104        }
105        else {
106            $CONTEXT = $CONTEXT->{$k} ||= +{};
107        }
108    }
109}
110
111sub _parse_array_of_table {
112    my ($self, $keys) = @_;
113    my @keys     = @$keys;
114    my $last_key = pop @keys;
115
116    $CONTEXT = $ROOT;
117    for my $k (@keys) {
118        if (exists $CONTEXT->{$k}) {
119            $CONTEXT = ref $CONTEXT->{$k} eq 'ARRAY' ? $CONTEXT->{$k}->[-1] :
120                       ref $CONTEXT->{$k} eq 'HASH'  ? $CONTEXT->{$k}       :
121                       die "invalid structure. @{[ join '.', @keys ]} cannot be `Array of table`.";
122        }
123        else {
124            $CONTEXT = $CONTEXT->{$k} ||= +{};
125        }
126    }
127
128    $CONTEXT->{$last_key} = [] unless exists $CONTEXT->{$last_key};
129    die "invalid structure. @{[ join '.', @keys ]} cannot be `Array of table`" unless ref $CONTEXT->{$last_key} eq 'ARRAY';
130    push @{ $CONTEXT->{$last_key} } => $CONTEXT = {};
131}
132
133sub _parse_value_token {
134    my $self  = shift;
135    my $token = shift;
136
137    my ($type, $val, @args) = @$token;
138    if ($type eq TOKEN_COMMENT) {
139        return; # pass through
140    }
141    elsif ($type eq TOKEN_INTEGER || $type eq TOKEN_FLOAT) {
142        $val =~ tr/_//d;
143        return 0+$val;
144    }
145    elsif ($type eq TOKEN_BOOLEAN) {
146        return $self->inflate_boolean($val);
147    }
148    elsif ($type eq TOKEN_DATETIME) {
149        return $self->inflate_datetime($val);
150    }
151    elsif ($type eq TOKEN_STRING) {
152        my ($is_raw) = @args;
153        return $is_raw ? $val : unescape_str($val);
154    }
155    elsif ($type eq TOKEN_MULTI_LINE_STRING_BEGIN) {
156        my ($is_raw) = @args;
157        my $value = $self->_parse_value_token(shift @TOKENS);
158        $value =~ s/\A(?:\r\n|[\r\n])//msg;
159        $value =~ s/\\\s+//msg;
160        if (my $token = shift @TOKENS) {
161            my ($type) = @$token;
162            return $value if $type eq TOKEN_MULTI_LINE_STRING_END;
163            die "Unexpected token: $type";
164        }
165    }
166    elsif ($type eq TOKEN_INLINE_TABLE_BEGIN) {
167        my %data;
168        while (my $token = shift @TOKENS) {
169            last if $token->[0] eq TOKEN_INLINE_TABLE_END;
170            next if $token->[0] eq TOKEN_COMMENT;
171            my ($key, $value) = $self->_parse_key_and_value($token);
172            die "Duplicate key. key:$key" if exists $data{$key};
173            $data{$key} = $value;
174        }
175        return \%data;
176    }
177    elsif ($type eq TOKEN_ARRAY_BEGIN) {
178        my @data;
179
180        my $last_token;
181        while (my $token = shift @TOKENS) {
182            last if $token->[0] eq TOKEN_ARRAY_END;
183            next if $token->[0] eq TOKEN_COMMENT;
184            if ($self->{strict_mode}) {
185                die "Unexpected token: $token->[0]" if defined $last_token && $token->[0] ne $last_token->[0];
186            }
187            push @data => $self->_parse_value_token($token);
188            $last_token = $token;
189        }
190        return \@data;
191    }
192
193    die "Unexpected token: $type";
194}
195
196sub inflate_datetime {
197    my $self = shift;
198    return $self->{inflate_datetime}->(@_);
199}
200
201sub inflate_boolean {
202    my $self = shift;
203    return $self->{inflate_boolean}->(@_);
204}
205
2061;
207__END__
208
209=encoding utf-8
210
211=for stopwords versa
212
213=head1 NAME
214
215TOML::Parser - simple toml parser
216
217=head1 SYNOPSIS
218
219    use TOML::Parser;
220
221    my $parser = TOML::Parser->new;
222    my $data   = $parser->parse($toml);
223
224=head1 DESCRIPTION
225
226TOML::Parser is a simple toml parser.
227
228This data structure complies with the tests
229provided at L<https://github.com/toml-lang/toml/tree/v0.4.0/tests>.
230
231The v0.4.0 specification is supported.
232
233=head1 METHODS
234
235=over
236
237=item my $parser = TOML::Parser->new(\%args)
238
239Creates a new TOML::Parser instance.
240
241    use TOML::Parser;
242
243    # create new parser
244    my $parser = TOML::Parser->new();
245
246Arguments can be:
247
248=over
249
250=item * C<inflate_datetime>
251
252If use it, You can replace inflate C<datetime> process.
253The subroutine of default is C<identity>. C<e.g.) sub { $_[0] }>
254
255    use TOML::Parser;
256    use DateTime;
257    use DateTime::Format::ISO8601;
258
259    # create new parser
260    my $parser = TOML::Parser->new(
261        inflate_datetime => sub {
262            my $dt = shift;
263            return DateTime::Format::ISO8601->parse_datetime($dt);
264        },
265    );
266
267=item * C<inflate_boolean>
268
269If use it, You can replace inflate boolean process.
270The return value of default subroutine is C<Types::Serialiser::true> or C<Types::Serialiser::false>.
271
272    use TOML::Parser;
273
274    # create new parser
275    my $parser = TOML::Parser->new(
276        inflate_boolean => sub {
277            my $boolean = shift;
278            return $boolean eq 'true' ? 1 : 0;
279        },
280    );
281
282=item * C<strict_mode>
283
284TOML::Parser is using a more flexible rule for compatibility with old TOML of default.
285If make this option true value, You can parse a toml with strict rule.
286
287    use TOML::Parser;
288
289    # create new parser
290    my $parser = TOML::Parser->new(
291        strict_mode => 1
292    );
293
294=back
295
296=item my $data = $parser->parse_file($path)
297
298=item my $data = $parser->parse_fh($fh)
299
300=item my $data = $parser->parse($src)
301
302Transforms a string containing toml to a perl data structure or vice versa.
303
304=back
305
306=head1 SEE ALSO
307
308L<TOML>
309
310=head1 LICENSE
311
312Copyright (C) karupanerura.
313
314This library is free software; you can redistribute it and/or modify
315it under the same terms as Perl itself.
316
317=head1 AUTHOR
318
319karupanerura E<lt>karupa@cpan.orgE<gt>
320
321=head1 CONTRIBUTOR
322
323Olivier Mengué E<lt>dolmen@cpan.orgE<gt>
324yowcow E<lt>yowcow@cpan.orgE<gt>
325Syohei YOSHIDA E<lt>syohex@gmail.comE<gt>
326
327=cut
328