File Coverage

blib/lib/TOML/Tiny/Writer.pm

Criterion	Covered	Total	%
statement	143	154	92.8
branch	60	76	78.9
condition	4	6	66.6
subroutine	17	17	100.0
pod	0	7	0.0
total	224	260	86.1

package TOML::Tiny::Writer;
$TOML::Tiny::Writer::VERSION = '0.20';
use strict;
use warnings;
no warnings qw(experimental);
use v5.18;

use B qw(SVf_IOK SVf_NOK svref_2object);
use Data::Dumper qw(Dumper);
use TOML::Tiny::Grammar qw($BareKey $DateTime $SpecialFloat);
use TOML::Tiny::Util qw(is_strict_array);

use constant CORE_BOOL => defined &builtin::is_bool;

my @KEYS;

sub to_toml {
  my $data  = shift;
  die 'toml: data to encode must be a hashref' if ref $data ne 'HASH';
  return _to_toml( $data, { @_ } );
}

sub _to_toml ($$);
sub _to_toml ($$) {
  my $data  = shift;
  my $param = shift;

  die 'toml: found undefined value, which is unsupported by TOML' if ! defined $data;

  my $ref = ref $data;
  if ($ref eq 'HASH') {
    return to_toml_table($data, $param);
  }

  if ($ref eq 'ARRAY') {
    return to_toml_array($data, $param);
  }

  if ($ref eq 'SCALAR') {
    if ($$data eq '1') {
      return 'true';
    } elsif ($$data eq '0') {
      return 'false';
    } else {
      return _to_toml($$_, $param);
    }
  }

  if ($ref eq 'JSON::PP::Boolean') {
    return $$data ? 'true' : 'false';
  }

  if ($ref eq 'Types::Serializer::Boolean') {
    return $data ? 'true' : 'false';
  }

  if ($ref eq 'DateTime') {
    return strftime_rfc3339($data);
  }

  if ($ref eq 'Math::BigInt') {
    return $data->bstr;
  }

  if ($ref eq 'Math::BigFloat') {
    if ($data->is_inf || $data->is_nan) {
      return lc $data->bstr;
    } else {
      return $data->bstr;
    }
  }

  if ($ref eq '') {
    if (CORE_BOOL && builtin::is_bool($data)) {
        return $data ? 'true' : 'false';
    }
    # Thanks to ikegami on Stack Overflow for the trick!
    # https://stackoverflow.com/questions/12686335/how-to-tell-apart-numeric-scalars-and-string-scalars-in-perl/12693984#12693984
    # note: this must come before any regex can flip this flag off
    if (svref_2object(\$data)->FLAGS & (SVf_IOK | SVf_NOK)) {
      return 'inf'  if Math::BigFloat->new($data)->is_inf;
      return '-inf' if Math::BigFloat->new($data)->is_inf('-');
      return 'nan'  if Math::BigFloat->new($data)->is_nan;
      return $data;
    }
    return to_toml_string($data) if $param->{no_string_guessing};
    #return $data if svref_2object(\$data)->FLAGS & (SVf_IOK | SVf_NOK);
    return $data if $data =~ /^$DateTime$/;
    return lc($data) if $data =~ /^$SpecialFloat$/;

    return to_toml_string($data);
  }

  die 'unhandled: '.Dumper($ref);
}

sub to_toml_inline_table {
  my ($data, $param) = @_;
  my @buff;

  for my $k (keys %$data) {
    my $key = to_toml_key($k);
    my $val = $data->{$k};

    if (ref $val eq 'HASH') {
      push @buff, $key . '=' . to_toml_inline_table($val);
    } else {
      push @buff, $key . '=' . _to_toml($val, $param);
    }
  }

  return '{' . join(', ', @buff) . '}';
}

sub to_toml_table {
  my ($data, $param) = @_;
  my @buff_assign;
  my @buff_tables;

  # Generate simple key/value pairs for scalar data
  for my $k (grep{ ref($data->{$_}) !~ /HASH|ARRAY/ } sort keys %$data) {
    my $key = to_toml_key($k);
    my $val = _to_toml($data->{$k}, $param);
    push @buff_assign, "$key=$val";
  }

  # For arrays, generate an array of tables if all elements of the array are
  # hashes. For mixed arrays, generate an inline array.
  ARRAY: for my $k (grep{ ref $data->{$_} eq 'ARRAY' } sort keys %$data) {
    # Empty table
    if (!@{$data->{$k}}) {
      my $key = to_toml_key($k);
      push @buff_assign, "$key=[]";
      next ARRAY;
    }

    # Mixed array
    if (grep{ ref $_ ne 'HASH' } @{$data->{$k}}) {
      my $key = to_toml_key($k);
      my $val = _to_toml($data->{$k}, $param);
      push @buff_assign, "$key=$val";
    }
    # Array of tables
    else {
      push @KEYS, $k;

      for (@{ $data->{$k} }) {
        push @buff_tables, '', '[[' . join('.', map{ to_toml_key($_) } @KEYS) . ']]';
        push @buff_tables, _to_toml($_, $param);
      }

      pop @KEYS;
    }
  }

  # Sub-tables
  for my $k (grep{ ref $data->{$_} eq 'HASH' } sort keys %$data) {
    if (!keys(%{$data->{$k}})) {
      # Empty table
      my $key = to_toml_key($k);
      push @buff_assign, "$key={}";
    } else {
      # Generate [table]
      push @KEYS, $k;
      push @buff_tables, '', '[' . join('.', map{ to_toml_key($_) } @KEYS) . ']';
      push @buff_tables, _to_toml($data->{$k}, $param);
      pop @KEYS;
    }
  }

  join "\n", @buff_assign, @buff_tables;
}

sub to_toml_array {
  my ($data, $param) = @_;

  if (@$data && $param->{strict}) {
    my ($ok, $err) = is_strict_array($data);
    die "toml: found heterogenous array, but strict is set ($err)\n" unless $ok;
  }

  my @items;

  for my $item (@$data) {
    if (ref $item eq 'HASH') {
      push @items, to_toml_inline_table($item, $param);
    } else {
      push @items, _to_toml($item, $param);
    }
  }

  return "[\n" . join("\n", map{ "  $_," } @items) . "\n]";
}

sub to_toml_key {
  my $str = shift;

  if ($str =~ /^$BareKey$/) {
    return $str;
  } else {
    # Not valid as a "bare key".  Encode it as a "quoted key"
    # (in TOML terminology), using the "literal string" format.
    return to_toml_string($str);
  }
}

sub to_toml_string {
  state $escape = {
    "\n" => '\n',
    "\r" => '\r',
    "\t" => '\t',
    "\f" => '\f',
    "\b" => '\b',
    "\"" => '\"',
    "\\" => '\\\\',
    "\'" => '\\\'',
  };

  my ($arg) = @_;
  $arg =~ s/(["\\\b\f\n\r\t])/$escape->{$1}/g;
  $arg =~ s/([\p{General_Category=Control}])/'\\u00' . unpack('H2', $1)/eg;

  return '"' . $arg . '"';
}

#-------------------------------------------------------------------------------
# Adapted from DateTime::Format::RFC3339.
#-------------------------------------------------------------------------------
sub strftime_rfc3339 {
  my ($dt) = @_;
  my $tz;

  #-----------------------------------------------------------------------------
  # Calculate the time zone offset for non-UTC time zones.
  #
  # TOML uses RFC3339 for datetimes, but supports a "local datetime" which
  # excludes the timezone offset. A DateTime with a floating time zone
  # indicates a TOML local datetime.
  #
  # DateTime::Format::RFC3339 requires a time zone, however, and defaults to
  # +00:00 for floating time zones. To support local datetimes in output,
  # format the datetime as RFC3339 and strip the timezone when encountering a
  # floating time zone.
  #-----------------------------------------------------------------------------
  if ($dt->time_zone_short_name eq 'floating') {
    $tz = '';
  } elsif ($dt->time_zone->is_utc) {
    $tz = 'Z';
  } else {
    my $sign = $dt->offset < 0 ? '-' : '+';
    my $secs = abs $dt->offset;

    my $mins = int($secs / 60);
    $secs %= 60;

    my $hours = int($mins / 60);
    $mins %= 60;

    if ($secs) {
      $dt = $dt->clone;
      $dt->set_time_zone('UTC');
      $tz = 'Z';
    } else {
      $tz = sprintf '%s%02d:%02d', $sign, $hours, $mins;
    }
  }

  my $format = $dt->nanosecond ? '%Y-%m-%dT%H:%M:%S.%9N' : '%Y-%m-%dT%H:%M:%S';
  return $dt->strftime($format) . $tz;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

TOML::Tiny::Writer

=head1 VERSION

version 0.20

=head1 AUTHOR

Jeff Ober <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2025 by Jeff Ober.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut