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