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