lib/TOML/Tiny/Writer.pm

   1 package TOML::Tiny::Writer;
   2
   3 use strict;
   4 use warnings;
   5 no warnings qw(experimental);
   6 use v5.18;
   7
   8 use Data::Dumper;
   9 use Scalar::Util qw(looks_like_number);
  10 use TOML::Tiny::Grammar;
  11 use TOML::Tiny::Util qw(is_strict_array);
  12
  13 my @KEYS;
  14
  15 sub to_toml {
  16   my $data = shift;
  17   my %param = @_;
  18   my @buff;
  19
  20   for (ref $data) {
  21     when ('HASH') {
  22       # Generate simple key/value pairs for scalar data
  23       for my $k (grep{ ref($data->{$_}) !~ /HASH|ARRAY/ } sort keys %$data) {
  24         my $key = to_toml_key($k);
  25         my $val = to_toml($data->{$k}, %param);
  26         push @buff, "$key=$val";
  27       }
  28
  29       # For values which are arrays, generate inline arrays for non-table
  30       # values, array-of-tables for table values.
  31       ARRAY: for my $k (grep{ ref $data->{$_} eq 'ARRAY' } sort keys %$data) {
  32         # Empty table
  33         if (!@{$data->{$k}}) {
  34           my $key = to_toml_key($k);
  35           push @buff, "$key=[]";
  36           next ARRAY;
  37         }
  38
  39         my @inline;
  40         my @table_array;
  41
  42         # Sort table and non-table values into separate containers
  43         for my $v (@{$data->{$k}}) {
  44           if (ref $v eq 'HASH') {
  45             push @table_array, $v;
  46           } else {
  47             push @inline, $v;
  48           }
  49         }
  50
  51         # Non-table values become an inline table
  52         if (@inline) {
  53           my $key = to_toml_key($k);
  54           my $val = to_toml(\@inline, %param);
  55           push @buff, "$key=$val";
  56         }
  57
  58         # Table values become an array-of-tables
  59         if (@table_array) {
  60           push @KEYS, $k;
  61
  62           for (@table_array) {
  63             push @buff, '', '[[' . join('.', map{ to_toml_key($_) } @KEYS) . ']]';
  64             push @buff, to_toml($_);
  65           }
  66
  67           pop @KEYS;
  68         }
  69       }
  70
  71       # Sub-tables
  72       for my $k (grep{ ref $data->{$_} eq 'HASH' } sort keys %$data) {
  73         if (!keys(%{$data->{$k}})) {
  74           # Empty table
  75           my $key = to_toml_key($k);
  76           push @buff, "$key={}";
  77         } else {
  78           # Generate [table]
  79           push @KEYS, $k;
  80           push @buff, '', '[' . join('.', map{ to_toml_key($_) } @KEYS) . ']';
  81           push @buff, to_toml($data->{$k}, %param);
  82           pop @KEYS;
  83         }
  84       }
  85     }
  86
  87     when ('ARRAY') {
  88       if (@$data && $param{strict_arrays}) {
  89         my ($ok, $err) = is_strict_array($data);
  90         die "toml: found heterogenous array, but strict_arrays is set ($err)\n" unless $ok;
  91       }
  92
  93       push @buff, '[' . join(', ', map{ to_toml($_, %param) } @$data) . ']';
  94     }
  95
  96     when ('SCALAR') {
  97       if ($$_ eq '1') {
  98         return 'true';
  99       } elsif ($$_ eq '0') {
 100         return 'false';
 101       } else {
 102         push @buff, to_toml($$_, %param);
 103       }
 104     }
 105
 106     when (/JSON::PP::Boolean/) {
 107       return $$data ? 'true' : 'false';
 108     }
 109
 110     when (/DateTime/) {
 111       return $data->stringify;
 112     }
 113
 114     when ('Math::BigInt') {
 115       return $data->bstr;
 116     }
 117
 118     when ('Math::BigFloat') {
 119       return $data->bnstr;
 120     }
 121
 122     when ('') {
 123       for ($data) {
 124         when (looks_like_number($_)) {
 125           return $data;
 126         }
 127
 128         when (/$DateTime/) {
 129           return $data;
 130         }
 131
 132         default{
 133           return to_toml_string($data);
 134         }
 135       }
 136     }
 137
 138     default{
 139       die 'unhandled: '.Dumper($_);
 140     }
 141   }
 142
 143   join "\n", @buff;
 144 }
 145
 146 sub to_toml_key {
 147   my $str = shift;
 148
 149   if ($str =~ /^[-_A-Za-z0-9]+$/) {
 150     return $str;
 151   }
 152
 153   if ($str =~ /^"/) {
 154     return qq{'$str'};
 155   } else {
 156     return qq{"$str"};
 157   }
 158 }
 159
 160 sub to_toml_string {
 161   state $escape = {
 162     "\n" => '\n',
 163     "\r" => '\r',
 164     "\t" => '\t',
 165     "\f" => '\f',
 166     "\b" => '\b',
 167     "\"" => '\"',
 168     "\\" => '\\\\',
 169     "\'" => '\\\'',
 170   };
 171
 172   my ($arg) = @_;
 173   $arg =~ s/([\x22\x5c\n\r\t\f\b])/$escape->{$1}/g;
 174   $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
 175
 176   return '"' . $arg . '"';
 177 }
 178
 179 1;