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