From: Jeff Ober <jober@ziprecruiter.com>
Date: Wed, 8 Jan 2020 21:06:03 +0000 (-0500)
Subject: Add support for generating TOML from a data structure
X-Git-Tag: nailing-cargo/1.0.0~234^2~65
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?a=commitdiff_plain;h=dc9c052cbc9de00ae6fd34bec8d9fed485d1d0fe;p=nailing-cargo.git

Add support for generating TOML from a data structure
---

diff --git a/cpanfile b/cpanfile
index f3e9b04..ad0bd74 100644
--- a/cpanfile
+++ b/cpanfile
@@ -1,4 +1,5 @@
 requires 'perl' => '>= 5.014';
+requires 'Scalar::Util' => '>= 1.14';
 
 recommends 'Types::Serialiser' => 0;
 
diff --git a/lib/TOML/Tiny.pm b/lib/TOML/Tiny.pm
index ef1b562..b67199b 100644
--- a/lib/TOML/Tiny.pm
+++ b/lib/TOML/Tiny.pm
@@ -3,7 +3,11 @@ package TOML::Tiny;
 
 use strict;
 use warnings;
+use feature qw(switch);
+no warnings qw(experimental);
+
 use TOML::Tiny::Parser;
+use TOML::Tiny::Writer;
 
 use parent 'Exporter';
 
@@ -16,11 +20,16 @@ sub from_toml {
   my $source = shift;
   my $parser = TOML::Tiny::Parser->new(@_);
   my $toml = eval{ $parser->parse($source) };
-  return ($toml, $@);
+  if (wantarray) {
+    return ($toml, $@);
+  } else {
+    die $@ if $@;
+    return $toml;
+  }
 }
 
 sub to_toml {
-  my $data = shift;
+  goto \&TOML::Tiny::Writer::to_toml;
 }
 
 1;
diff --git a/lib/TOML/Tiny/Writer.pm b/lib/TOML/Tiny/Writer.pm
new file mode 100644
index 0000000..11e2bb3
--- /dev/null
+++ b/lib/TOML/Tiny/Writer.pm
@@ -0,0 +1,146 @@
+package TOML::Tiny::Writer;
+
+use strict;
+use warnings;
+
+use feature qw(switch state);
+no warnings qw(experimental);
+
+use Data::Dumper;
+use Scalar::Util qw(looks_like_number);
+use TOML::Tiny::Grammar;
+
+my @KEYS;
+
+sub to_toml {
+  my $data = shift;
+  my @buff;
+
+  for (ref $data) {
+    when ('HASH') {
+      for my $k (grep{ ref($data->{$_}) !~ /HASH|ARRAY/ } sort keys %$data) {
+        my $key = to_toml_key($k);
+        my $val = to_toml($data->{$k});
+        push @buff, "$key=$val";
+      }
+
+      for my $k (grep{ ref $data->{$_} eq 'ARRAY' } sort keys %$data) {
+        my @inline;
+        my @table_array;
+
+        for my $v (@{$data->{$k}}) {
+          if (ref $v eq 'HASH') {
+            push @table_array, $v;
+          } else {
+            push @inline, $v;
+          }
+        }
+
+        if (@inline) {
+          my $key = to_toml_key($k);
+          my $val = to_toml(\@inline);
+          push @buff, "$key=$val";
+        }
+
+        if (@table_array) {
+          push @KEYS, $k;
+
+          for (@table_array) {
+            push @buff, '', '[[' . join('.', map{ to_toml_key($_) } @KEYS) . ']]';
+
+            for my $k (sort keys %$_) {
+              my $key = to_toml_key($k);
+              my $val = to_toml($_->{$k});
+              push @buff, "$key=$val";
+            }
+          }
+
+          pop @KEYS;
+        }
+      }
+
+      for my $k (grep{ ref $data->{$_} eq 'HASH' } sort keys %$data) {
+        push @KEYS, $k;
+        push @buff, '', '[' . join('.', map{ to_toml_key($_) } @KEYS) . ']';
+        push @buff, to_toml($data->{$k});
+        pop @KEYS;
+      }
+
+    }
+
+    when ('ARRAY') {
+      push @buff, '[' . join(', ', map{ to_toml($_) } @$data) . ']';
+    }
+
+    when ('SCALAR') {
+      if ($$_ eq '1') {
+        return 'true';
+      } elsif ($$_ eq '0') {
+        return 'false';
+      } else {
+        push @buff, to_toml($$_);
+      }
+    }
+
+    when (/JSON::PP::Boolean/) {
+      return $$data ? 'true' : 'false';
+    }
+
+    when ('') {
+      for ($data) {
+        when (looks_like_number($_)) {
+          return $data;
+        }
+
+        when (/(?&DateTime) $TOML/x) {
+          return $data;
+        }
+
+        default{
+          return to_toml_string($data);
+        }
+      }
+    }
+
+    when (defined) {
+      die 'unhandled: '.Dumper($_);
+    }
+
+    default{
+      die 'unhandled: '.Dumper($_);
+    }
+  }
+
+  join "\n", @buff;
+}
+
+sub to_toml_key {
+  my $str = shift;
+
+  if ($str =~ /^[-_A-Za-z0-9]+$/) {
+    return $str;
+  }
+
+  return qq{"$str"};
+}
+
+sub to_toml_string {
+  state $escape = {
+    "\n" => '\n',
+    "\r" => '\r',
+    "\t" => '\t',
+    "\f" => '\f',
+    "\b" => '\b',
+    "\"" => '\"',
+    "\\" => '\\\\',
+    "\'" => '\\\'',
+  };
+
+  my ($arg) = @_;
+  $arg =~ s/([\x22\x5c\n\r\t\f\b])/$escape->{$1}/g;
+  $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
+
+  return '"' . $arg . '"';
+}
+
+1;
diff --git a/t/writer.t b/t/writer.t
new file mode 100644
index 0000000..e6bdf7c
--- /dev/null
+++ b/t/writer.t
@@ -0,0 +1,58 @@
+use Test2::V0;
+use TOML::Tiny;
+
+my $src  = do{ local $/; <DATA> };
+my $data = from_toml($src);
+my $toml = to_toml($data);
+my $got  = from_toml($toml);
+
+is $got, $data, 'to_toml <=> from_toml';
+
+done_testing;
+
+__DATA__
+# This is a TOML document.
+
+title = "TOML Example"
+
+[owner]
+name = "Tom Preston-Werner"
+dob = 1979-05-27T07:32:00-08:00 # First class dates
+
+[database]
+server = "192.168.1.1"
+ports = [ 8001, 8001, 8002 ]
+connection_max = 5000
+enabled = true
+options = {"quote-keys"=false}
+
+[servers]
+
+  # Indentation (tabs and/or spaces) is allowed but not required
+  [servers.alpha]
+  ip = "10.0.0.1"
+  dc = "eqdc10"
+
+  [servers.beta]
+  ip = "10.0.0.2"
+  dc = "eqdc10"
+
+[clients]
+data = [ ["gamma", "delta"], [1, 2] ]
+
+# Line breaks are OK when inside arrays
+hosts = [
+  "alpha",
+  "omega"
+]
+
+[[products]]
+name = "Hammer"
+sku = 738594937
+
+[[products]]
+
+[[products]]
+name = "Nail"
+sku = 284758393
+color = "gray"