File Coverage

blib/lib/JSON/SL/Tuba.pm
Criterion Covered Total %
statement 50 56 89.2
branch 5 10 50.0
condition 2 6 33.3
subroutine 13 14 92.8
pod 2 4 50.0
total 72 90 80.0


line stmt bran cond sub pod time code
1             package JSON::SL::Tuba;
2 2     2   6540 use strict;
  2         10  
  2         53  
3 2     2   10 use warnings;
  2         4  
  2         56  
4 2     2   844 use JSON::SL;
  2         4  
  2         80  
5 2     2   11 use base qw(Exporter);
  2         3  
  2         371  
6             our @EXPORT;
7              
8             my (%ActionMap,%TypeMap);
9             my $_cg_typehash;
10             my $_cg_modehash;
11              
12             BEGIN {
13 2     2   11 %ActionMap = (
14             '+' => 'start',
15             '-' => 'end',
16             '>' => 'on'
17             );
18 2         14 %TypeMap = (
19             '{' => 'object',
20             '[' => 'list',
21             'c' => 'data',
22             'D' => 'json',
23             '#' => 'key',
24             '"' => 'string',
25             '^' => 'special',
26             '?' => 'boolean',
27             '=' => 'number',
28             '~' => 'null'
29             );
30              
31 2         11 while (my ($sym,$name) = each %ActionMap) {
32 6         22 $_cg_modehash->{uc($name)} = ord($sym);
33             }
34 2         9 while (my ($sym,$name) = each %TypeMap) {
35 20         114 $_cg_typehash->{uc($name)} = ord($sym);
36             }
37             }
38              
39 2     2   594 use Constant::Generate $_cg_typehash, prefix => "TUBA_TYPE_", export => 1;
  2         11975  
  2         7  
40 2     2   748 use Constant::Generate $_cg_modehash, prefix => "TUBA_MODE_", export =>1;
  2         4  
  2         8  
41              
42             our %CloseTokens = (
43             '{' => '}',
44             '"' => '"',
45             '[' => ']'
46             );
47              
48             sub new {
49 2     2 0 688 my ($cls,%options) = @_;
50 2         94 my $o = $cls->_initialize();
51            
52 2 50 33     13 unless (exists $options{accum_kv} and
53             not delete $options{accum_kv}) {
54 2         14 $o->accum_kv(1);
55             }
56 2 50 33     11 unless (exists $options{accum_all}and
57             not delete $options{accum_all}) {
58 2         17 $o->accum_all(1);
59             }
60 2         9 while (my ($k,$v) = each %options) {
61 0         0 $o->can($k)->($o,$v);
62             }
63 2         10 return $o;
64             }
65              
66             # TODO: I can't think why I've hidden this?
67             {
68 2     2   881 no warnings 'once';
  2         5  
  2         560  
69             *parse = *_parse;
70             }
71              
72             # set accumulator parameters:
73             sub accum {
74 3     3 1 8 my ($tuba,%modes) = @_;
75 3         13 while (my ($mode,$bool) = each %modes) {
76 15 50       37 if ($mode !~ m{[\=\~\?\#"]}) {
77 0         0 die("Invalid mode '$mode'. Mode must be one of [^#\"]");
78             }
79 15         52 $tuba->_ax_opt(ord("$mode"), $bool);
80             }
81             }
82              
83             sub accum_enabled_for {
84 5     5 0 1458 my ($tuba,$mode) = @_;
85 5 50       19 if ($mode !~ m{[\=\~\?\#"]}) {
86 0         0 die("Invalid type '$mode'. Mode must be one of [^#\"]");
87             }
88 5         26 return $tuba->_ax_opt(ord("$mode"))
89             }
90              
91             sub accum_all {
92 3     3 1 10 my ($tuba,$boolean) = @_;
93 3 50       14 if (@_ != 2) {
94 0         0 die("Must have boolean argument!");
95             }
96             my %opts = map {
97 3         8 $_, $boolean
  15         34  
98             } ('=','~','#','?','"');
99 3         14 $tuba->accum(%opts);
100             }
101              
102             #build convenience methods:
103             foreach (['key', '#'],
104             ['string', '"'],
105             ['number', '='],
106             ['boolean', '?'],
107             ['null', '~']
108             ) {
109              
110             my ($mode,$sym) = @$_;
111 2     2   13 no strict 'refs';
  2         5  
  2         148  
112             *{"accum_$mode"} = sub {
113 0     0     my ($tuba,$bool) = @_;
114 0           $tuba->_ax_opt(ord($sym), $bool);
115             }
116             }
117              
118             1;
119              
120             __END__