File Coverage

blib/lib/Tk/Tree/JSON.pm
Criterion Covered Total %
statement 13 17 76.4
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 22 81.8


line stmt bran cond sub pod time code
1             package Tk::Tree::JSON;
2              
3             # Tk::Tree::JSON - JSON tree widget
4              
5             # Copyright (c) 2008-2015 José Santos. All rights reserved.
6             # This program is free software. It can be redistributed and/or modified under
7             # the same terms as Perl itself.
8              
9 1     1   50774 use strict;
  1         2  
  1         56  
10 1     1   6 use warnings;
  1         2  
  1         41  
11 1     1   7 use Carp;
  1         7  
  1         115  
12              
13             BEGIN {
14 1     1   7 use vars qw($VERSION @ISA);
  1         1  
  1         115  
15 1     1   65880 require Tk::Tree;
16 0           require JSON;
17 0           require Tk::Derived;
18 0           $VERSION = '0.02';
19 0           @ISA = qw(Tk::Derived Tk::Tree);
20             }
21              
22             Construct Tk::Widget 'JSON';
23              
24             sub Tk::Widget::ScrolledJSON { shift->Scrolled('JSON' => @_) }
25              
26             my $json_parser = undef; # singleton JSON parser
27              
28             # ConfigSpecs default values
29             my $VALUE_MAX_LENGTH = 80;
30              
31             sub Populate {
32             my ($myself, $args) = @_;
33             $myself->SUPER::Populate($args);
34             $myself->ConfigSpecs(
35             -arraysymbol => ["PASSIVE", "arraySymbol",
36             "ArraySymbol", '[]'],
37             -objectsymbol => ["PASSIVE", "objectSymbol",
38             "ObjectSymbol", '{}'],
39             -namevaluesep => ["PASSIVE", "nameValueSep",
40             "NameValueSep", ': '],
41             -valuemaxlength => ["METHOD", "valueMaxLength",
42             "VALUEMaxLength", $VALUE_MAX_LENGTH],
43             -valuelongsymbol => ["PASSIVE", "valueLongSymbol",
44             "VALUELongSymbol", '...'],
45             -itemtype => ["SELF", "itemType", "ItemType", 'text']
46             );
47             }
48              
49             # ConfigSpecs methods
50              
51             # get/set max number of characters for displaying of JSON text values
52             sub valuemaxlength {
53             my ($myself, $args) = @_;
54             if (@_ > 1) {
55             $myself->_configure(-valuemaxlength => &_value_max_length($args));
56             }
57             return $myself->_cget('-valuemaxlength');
58             }
59              
60             # validate given max number of characters for displaying of JSON text values
61             # return given number if it is valid, $VALUE_MAX_LENGTH otherwise
62             sub _value_max_length {
63             $_ = shift;
64             /^\+?\d+$/ ? $& : &{ sub {
65             carp "Attempt to assign an invalid value to -valuemaxlength: '$_' is" .
66             " not a positive integer. Default value ($VALUE_MAX_LENGTH)" .
67             " will be used instead.\n";
68             $VALUE_MAX_LENGTH
69             }};
70             }
71              
72             # application programming interface
73              
74             sub load_json_file { # load_json_file($json_filename)
75             my ($myself, $json_file) = @_;
76             if (!$myself->info('exists', '0')) {
77             local $/ = undef;
78             open FILE, $json_file or die "Could not open file $json_file: $!";
79             my $json_string = ;
80             close FILE;
81             $myself->_load_json($myself->addchild(''),
82             &_json_parser->decode($json_string));
83             $myself->autosetmode; # set up automatic handling of open/close events
84             } else {
85             carp "A JSON document has already been loaded into the tree." .
86             " JSON file $json_file will not be loaded.";
87             }
88             }
89              
90             sub load_json_string { # load_json_string($json_string)
91             my ($myself, $json_string) = @_;
92             if (!$myself->info('exists', '0')) {
93             $myself->_load_json($myself->addchild(''),
94             &_json_parser->decode($json_string));
95             $myself->autosetmode;# set up automatic handling of open/close events
96             } else {
97             carp "A JSON document has already been loaded into the tree." .
98             " JSON string will not be loaded.";
99             }
100             }
101              
102             sub get_value { # get_value()
103             my $myself = shift;
104             $myself->entrycget($myself->selectionGet(), '-data');
105             }
106              
107             # helper methods
108              
109             # _json_parser(): get a JSON::Parser instance.
110             sub _json_parser {
111             defined($json_parser) ? $json_parser : $json_parser = JSON->new
112             }
113              
114             # _load_json($parent_path, $struct): load JSON elems under entry at $parent_path
115             sub _load_json {
116             my ($myself, $parent_path, $struct) = ($_[0], $_[1], $_[2]);
117             my $ref_type = ref $struct;
118             my $text = ($myself->entrycget($parent_path, '-text') or '');
119             my $entry_path;
120             if ('HASH' eq $ref_type) { # json object
121             $myself->entryconfigure($parent_path,
122             -text => $text . $myself->cget('-objectsymbol')
123             );
124             while (my ($name, $value) = each %$struct) {
125             $entry_path = $myself->addchild($parent_path,
126             -text => $name . $myself->cget('-namevaluesep')
127             );
128             $myself->_load_json($entry_path, $value);
129             }
130             } elsif ('ARRAY' eq $ref_type) { # json array
131             $myself->entryconfigure($parent_path,
132             -text => $text . $myself->cget('-arraysymbol')
133             );
134             foreach (@$struct) {
135             $entry_path = $myself->addchild($parent_path);
136             $myself->_load_json($entry_path, $_);
137             }
138             } else { # json string, number, true, false or null
139             $myself->entryconfigure($parent_path, -data => $struct);
140             if (defined $struct) {
141             $struct = $struct ? 'true' : 'false' if JSON::is_bool($struct);
142             } else {
143             $struct = 'null';
144             }
145             $myself->entryconfigure($parent_path,
146             -text => $text . $myself->_format_text($struct));
147             }
148             }
149              
150             sub _format_text { # _format_text($text): format/return text accordingly
151             my ($myself, $text) = @_;
152             my $value_max_length = $myself->cget('-valuemaxlength');
153             length($text) > $value_max_length
154             ? substr($text, 0, $value_max_length) . $myself->cget('-valuelongsymbol')
155             : $text;
156             }
157              
158             1;
159              
160             __END__