lib/TOML/Tiny/Parser.pm

   1 package TOML::Tiny::Parser;
   2 # ABSTRACT: parser used by TOML::Tiny
   3
   4 use strict;
   5 use warnings;
   6 no warnings qw(experimental);
   7 use v5.18;
   8
   9 use Carp;
  10 use Data::Dumper;
  11 use TOML::Tiny::Grammar;
  12 use TOML::Tiny::Tokenizer;
  13 use TOML::Tiny::Util qw(is_strict_array);
  14
  15 our $TRUE  = 1;
  16 our $FALSE = 0;
  17
  18 eval{
  19   require Types::Serialiser;
  20   $TRUE = Types::Serialiser::true();
  21   $FALSE = Types::Serialiser::false();
  22 };
  23
  24 sub new {
  25   my ($class, %param) = @_;
  26   bless{
  27     inflate_datetime => $param{inflate_datetime} || sub{ shift },
  28     inflate_boolean  => $param{inflate_boolean}  || sub{ shift eq 'true' ? $TRUE : $FALSE },
  29     strict_arrays    => $param{strict_arrays},
  30   }, $class;
  31 }
  32
  33 sub next_token {
  34   $_[0]->{tokenizer} && $_[0]->{tokenizer}->next_token;
  35 }
  36
  37 sub parse {
  38   my ($self, $toml) = @_;
  39
  40   $self->{tokenizer} = TOML::Tiny::Tokenizer->new(source => $toml);
  41   $self->{keys}      = [];
  42   $self->{root}      = {};
  43   $self->{tables}    = {}; # "seen" hash of explicitly defined table names
  44
  45   $self->parse_table;
  46   my $result = $self->{root};
  47
  48   delete $self->{tokenizer};
  49   delete $self->{keys};
  50   delete $self->{root};
  51   delete $self->{tables};
  52
  53   return $result;
  54 }
  55
  56 sub parse_error {
  57   my ($self, $token, $msg) = @_;
  58   my $line = $token ? $token->{line} : 'EOF';
  59   if ($ENV{TOML_TINY_DEBUG}) {
  60     my $root = Dumper($self->{root});
  61     my $tok  = Dumper($token);
  62     my $src  = substr $self->{tokenizer}{source}, $self->{tokenizer}{position}, 30;
  63
  64     confess qq{
  65 toml parse error at line $line:
  66     $msg
  67
  68 Current token:
  69 $tok
  70
  71 Parse state:
  72 $root
  73
  74 Source near location of error:
  75 ...
  76 $src
  77 ...
  78
  79     };
  80   } else {
  81     die "toml parse error at line $line: $msg\n";
  82   }
  83 }
  84
  85 sub expect_type {
  86   my ($self, $token, $expected) = @_;
  87   my $actual = $token->{type};
  88   $self->parse_error($token, "expected $expected, but found $actual")
  89     unless $actual eq $expected;
  90 }
  91
  92
  93 sub push_keys {
  94   my ($self, $token) = @_;
  95   push @{ $self->{keys} }, $token->{value};
  96 }
  97
  98 sub pop_keys {
  99   my $self = shift;
 100   pop @{ $self->{keys} };
 101 }
 102
 103 sub get_keys {
 104   my $self = shift;
 105   return map{ @$_ } @{ $self->{keys} };
 106 }
 107
 108 sub set_keys {
 109   my $self  = shift;
 110   my $value = shift // $self->parse_value;
 111   my @keys  = $self->get_keys;
 112   my $key   = pop @keys;
 113   my $node  = $self->scan_to_key(\@keys);
 114   $self->parse_error(undef, 'duplicate key: '.join('.', @keys, $key))
 115     if exists $node->{$key};
 116   $node->{$key} = $value;
 117 }
 118
 119 sub scan_to_key {
 120   my $self = shift;
 121   my $keys = shift // [ $self->get_keys ];
 122   my $node = $self->{root};
 123
 124   for my $key (@$keys) {
 125     if (exists $node->{$key}) {
 126       for (ref $node->{$key}) {
 127         $node = $node->{$key}     when 'HASH';
 128         $node = $node->{$key}[-1] when 'ARRAY';
 129         default{
 130           my $full_key = join '.', @$keys;
 131           die "$full_key is already defined\n";
 132         }
 133       }
 134     }
 135     else {
 136       $node = $node->{$key} = {};
 137     }
 138   }
 139
 140   return $node;
 141 }
 142
 143
 144 sub parse_table {
 145   my $self  = shift;
 146   my $token = shift // $self->next_token // return; # may be undef on first token in empty document
 147   $self->expect_type($token, 'table');
 148   $self->push_keys($token);
 149   $self->scan_to_key;
 150
 151   my @keys = $self->get_keys;
 152   my $key = join '.', @keys;
 153   if (exists $self->{tables}{$key}) {
 154     # Tables cannot be redefined, *except* when doing so within a goddamn table
 155     # array. Gawd I hate TOML.
 156     my $in_a_stupid_table_array = 0;
 157     my $node = $self->{root};
 158     for my $key (@keys) {
 159       if (exists $node->{$key} && ref($node->{$key}) eq 'ARRAY') {
 160         $in_a_stupid_table_array = 1;
 161         last;
 162       } else {
 163         $node = $node->{$key};
 164       }
 165     }
 166
 167     $self->parse_error($token, "table $key is already defined")
 168       unless $in_a_stupid_table_array;
 169   } else {
 170     $self->{tables}{$key} = 1;
 171   }
 172
 173   TOKEN: while (my $token = $self->next_token) {
 174     for ($token->{type}) {
 175       next TOKEN when 'EOL';
 176
 177       when ('key') {
 178         $self->expect_type($self->next_token, 'assign');
 179         $self->push_keys($token);
 180         $self->set_keys;
 181         $self->pop_keys;
 182
 183         if (my $eol = $self->next_token) {
 184           $self->expect_type($eol, 'EOL');
 185         } else {
 186           return;
 187         }
 188       }
 189
 190       when ('array_table') {
 191         $self->pop_keys;
 192         @_ = ($self, $token);
 193         goto \&parse_array_table;
 194       }
 195
 196       when ('table') {
 197         $self->pop_keys;
 198         @_ = ($self, $token);
 199         goto \&parse_table;
 200       }
 201
 202       default{
 203         $self->parse_error($token, "expected key-value pair, table, or array of tables but got $_");
 204       }
 205     }
 206   }
 207 }
 208
 209 sub parse_array_table {
 210   my $self = shift;
 211   my $token = shift // $self->next_token;
 212   $self->expect_type($token, 'array_table');
 213   $self->push_keys($token);
 214
 215   my @keys = $self->get_keys;
 216   my $key  = pop @keys;
 217   my $node = $self->scan_to_key(\@keys);
 218   $node->{$key} //= [];
 219   push @{ $node->{$key} }, {};
 220
 221   TOKEN: while (my $token = $self->next_token) {
 222     for ($token->{type}) {
 223       next TOKEN when /EOL/;
 224
 225       when (/key/) {
 226         $self->expect_type($self->next_token, 'assign');
 227         $self->push_keys($token);
 228         $self->set_keys;
 229         $self->pop_keys;
 230       }
 231
 232       when (/array_table/) {
 233         $self->pop_keys;
 234         @_ = ($self, $token);
 235         goto \&parse_array_table;
 236       }
 237
 238       when (/table/) {
 239         $self->pop_keys;
 240         @_ = ($self, $token);
 241         goto \&parse_table;
 242       }
 243
 244       default{
 245         $self->parse_error($token, "expected key-value pair, table, or array of tables but got $_");
 246       }
 247     }
 248   }
 249 }
 250
 251 sub parse_key {
 252   my $self  = shift;
 253   my $token = shift // $self->next_token;
 254   $self->expect_type($token, 'key');
 255   return $token->{value};
 256 }
 257
 258 sub parse_value {
 259   my $self = shift;
 260   my $token = shift // $self->next_token;
 261
 262   for ($token->{type}) {
 263     when (/float/) {
 264       use bignum;
 265       return $token->{value} + 0;
 266     }
 267
 268     when (/integer/) {
 269       for (my $n = $token->{value}) {
 270         use bigint;
 271
 272         when ($Oct) {
 273           $n =~ s/^0o/0/; # convert to perl's octal format
 274           return oct $n;
 275         }
 276
 277         when ($Bin) {
 278           return oct $n;
 279         }
 280
 281         when ($Hex) {
 282           return hex $n;
 283         }
 284
 285         default{
 286           return $n + 0;
 287         }
 288       }
 289     }
 290
 291     return $token->{value} when /string/;
 292     return $self->{inflate_boolean}->($token->{value}) when /bool/;
 293     return $self->{inflate_datetime}->($token->{value}) when /datetime/;
 294     return $self->parse_inline_table when /inline_table/;
 295     return $self->parse_inline_array when /inline_array/;
 296
 297     default{
 298       $self->parse_error($token, "value expected (bool, number, string, datetime, inline array, inline table), but found $_");
 299     }
 300   }
 301 }
 302
 303 sub parse_inline_array {
 304   my $self = shift;
 305   my @array;
 306
 307   TOKEN: while (my $token = $self->next_token) {
 308     for ($token->{type}) {
 309       next TOKEN when /comma/;
 310       next TOKEN when /EOL/;
 311       last TOKEN when /inline_array_close/;
 312
 313       default{
 314         push @array, $self->parse_value($token);
 315       }
 316     }
 317   }
 318
 319   if (@array > 1 && $self->{strict_arrays}) {
 320     my ($ok, $err) = is_strict_array(\@array);
 321     $self->parse_error(undef, $err)
 322       unless $ok;
 323   }
 324
 325   return \@array;
 326 }
 327
 328 sub parse_inline_table {
 329   my $self  = shift;
 330   my $table = {};
 331
 332   TOKEN: while (my $token = $self->next_token) {
 333     for ($token->{type}) {
 334       next TOKEN when /comma/;
 335       last TOKEN when /inline_table_close/;
 336
 337       when (/key/) {
 338         $self->expect_type($self->next_token, 'assign');
 339         my $key = $token->{value}[0];
 340         $table->{ $key } = $self->parse_value;
 341       }
 342
 343       default{
 344         $self->parse_error($token, "inline table expected key-value pair, but found $_");
 345       }
 346     }
 347   }
 348
 349   return $table;
 350 }
 351
 352 1;