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