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