File Coverage

blib/lib/TOML.pm

Criterion	Covered	Total	%
statement	62	67	92.5
branch	14	18	77.7
condition	2	3	66.6
subroutine	12	12	100.0
pod	2	3	66.6
total	92	103	89.3

package TOML;

# -------------------------------------------------------------------
# TOML - Parser for Tom's Obvious, Minimal Language.
#
# Copyright (C) 2013 Darren Chamberlain
# -------------------------------------------------------------------

use 5.008005;
use strict;
use warnings;
use parent qw(Exporter);

our ($VERSION, @EXPORT, @_NAMESPACE, $PARSER);

use B;
use Carp qw(croak);
use TOML::Parser 0.03;

$VERSION = "0.95";
@EXPORT = qw(from_toml to_toml);
$PARSER = TOML::Parser->new(inflate_boolean  => sub { $_[0] });

sub to_toml {
    my $stuff = shift;
    local @_NAMESPACE = ();
    _to_toml($stuff);
}

sub _to_toml {
    my ($stuff) = @_;

    if (ref $stuff eq 'HASH') {
        my $res = '';
        my @keys = sort keys %$stuff;
        for my $key (grep { ref $stuff->{$_} ne 'HASH' } @keys) {
            my $val = $stuff->{$key};
            $res .= "$key = " . _serialize($val) . "\n";
        }
        for my $key (grep { ref $stuff->{$_} eq 'HASH' } @keys) {
            my $val = $stuff->{$key};
            local @_NAMESPACE = (@_NAMESPACE, $key);
            $res .= sprintf("[%s]\n", join(".", @_NAMESPACE));
            $res .= _to_toml($val);
        }
        return $res;
    } else {
        croak("You cannot convert non-HashRef values to TOML");
    }
}

sub _serialize {
    my $value = shift;
    my $b_obj = B::svref_2object(\$value);
    my $flags = $b_obj->FLAGS;

    return $value
        if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?

    my $type = ref($value);
    if (!$type) {
        return string_to_json($value);
    } elsif ($type eq 'ARRAY') {
        return sprintf('[%s]', join(", ", map { _serialize($_) } @$value));
    } elsif ($type eq 'SCALAR') {
        if (defined $$value) {
            if ($$value eq '0') {
                return 'false';
            } elsif ($$value eq '1') {
                return 'true';
            } else {
                croak("cannot encode reference to scalar");
            }
        }
        croak("cannot encode reference to scalar");
    }
    croak("Bad type in to_toml: $type");
}

my %esc = (
    "\n" => '\n',
    "\r" => '\r',
    "\t" => '\t',
    "\f" => '\f',
    "\b" => '\b',
    "\"" => '\"',
    "\\" => '\\\\',
    "\'" => '\\\'',
);
sub string_to_json {
    my ($arg) = @_;

    $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
    $arg =~ s/\//\\\//g if 1;
    $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;

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

sub from_toml {
    my $string = shift;
    local $@;
    my $toml = eval { $PARSER->parse($string) };
    return wantarray ? ($toml, $@) : $toml;
}

1;

__END__