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


line stmt bran cond sub pod time code
1             package TOML;
2              
3             # -------------------------------------------------------------------
4             # TOML - Parser for Tom's Obvious, Minimal Language.
5             #
6             # Copyright (C) 2013 Darren Chamberlain
7             # -------------------------------------------------------------------
8              
9 2     2   17045 use 5.008005;
  2         8  
  2         70  
10 2     2   7 use strict;
  2         2  
  2         59  
11 2     2   21 use warnings;
  2         4  
  2         62  
12 2     2   34 use Exporter 'import';
  2         3  
  2         111  
13              
14             our ($VERSION, @EXPORT, @_NAMESPACE, $PARSER);
15              
16 2     2   7 use B;
  2         2  
  2         93  
17 2     2   9 use Carp qw(croak);
  2         3  
  2         98  
18 2     2   860 use TOML::Parser 0.03;
  2         34392  
  2         1313  
19              
20             $VERSION = "0.96";
21             @EXPORT = qw(from_toml to_toml);
22             $PARSER = TOML::Parser->new(inflate_boolean => sub { $_[0] });
23              
24             sub to_toml {
25 13     13 1 3799 my $stuff = shift;
26 13         22 local @_NAMESPACE = ();
27 13         21 _to_toml($stuff);
28             }
29              
30             sub _to_toml {
31 25     25   27 my ($stuff) = @_;
32              
33 25 50       50 if (ref $stuff eq 'HASH') {
34 25         22 my $res = '';
35 25         76 my @keys = sort keys %$stuff;
36 25         33 for my $key (grep { ref $stuff->{$_} ne 'HASH' } @keys) {
  42         85  
37 30         27 my $val = $stuff->{$key};
38 30         43 $res .= "$key = " . _serialize($val) . "\n";
39             }
40 25         33 for my $key (grep { ref $stuff->{$_} eq 'HASH' } @keys) {
  42         67  
41 12         15 my $val = $stuff->{$key};
42 12         22 local @_NAMESPACE = (@_NAMESPACE, $key);
43 12         34 $res .= sprintf("[%s]\n", join(".", @_NAMESPACE));
44 12         24 $res .= _to_toml($val);
45             }
46 25         74 return $res;
47             } else {
48 0         0 croak("You cannot convert non-HashRef values to TOML");
49             }
50             }
51              
52             sub _serialize {
53 45     45   35 my $value = shift;
54 45         103 my $b_obj = B::svref_2object(\$value);
55 45         93 my $flags = $b_obj->FLAGS;
56              
57 45 100 66     104 return $value
58             if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
59              
60 39         31 my $type = ref($value);
61 39 100       55 if (!$type) {
    100          
    50          
62 31         38 return string_to_json($value);
63             } elsif ($type eq 'ARRAY') {
64 6         9 return sprintf('[%s]', join(", ", map { _serialize($_) } @$value));
  15         22  
65             } elsif ($type eq 'SCALAR') {
66 2 50       4 if (defined $$value) {
67 2 100       6 if ($$value eq '0') {
    50          
68 1         4 return 'false';
69             } elsif ($$value eq '1') {
70 1         4 return 'true';
71             } else {
72 0         0 croak("cannot encode reference to scalar");
73             }
74             }
75 0         0 croak("cannot encode reference to scalar");
76             }
77 0         0 croak("Bad type in to_toml: $type");
78             }
79              
80             my %esc = (
81             "\n" => '\n',
82             "\r" => '\r',
83             "\t" => '\t',
84             "\f" => '\f',
85             "\b" => '\b',
86             "\"" => '\"',
87             "\\" => '\\\\',
88             "\'" => '\\\'',
89             );
90             sub string_to_json {
91 31     31 0 26 my ($arg) = @_;
92              
93 31         43 $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
94 31         31 $arg =~ s/\//\\\//g if 1;
95 31         27 $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
  0         0  
96              
97 31         111 return '"' . $arg . '"';
98             }
99              
100             sub from_toml {
101 6     6 1 7 my $string = shift;
102 6         5 local $@;
103 6         8 my $toml = eval { $PARSER->parse($string) };
  6         17  
104 6 100       3665 return wantarray ? ($toml, $@) : $toml;
105             }
106              
107             1;
108              
109             __END__