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