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

package Tk::Tree::JSON;

# Tk::Tree::JSON - JSON tree widget

# Copyright (c) 2008-2015 José Santos. All rights reserved.
# This program is free software. It can be redistributed and/or modified under
# the same terms as Perl itself.

use strict;
use warnings;
use Carp;

BEGIN {
	use vars qw($VERSION @ISA);
	require Tk::Tree;
	require JSON;
	require Tk::Derived;
	$VERSION	= '0.03';
	@ISA		= qw(Tk::Derived Tk::Tree);
}

Construct Tk::Widget 'JSON';

sub Tk::Widget::ScrolledJSON { shift->Scrolled('JSON' => @_) }

my $json_parser = undef;	# singleton JSON parser

# ConfigSpecs default values
my $VALUE_MAX_LENGTH = 80;

sub Populate {
	my ($myself, $args) = @_;
	$myself->SUPER::Populate($args);
	$myself->ConfigSpecs(
		-arraysymbol		=> ["PASSIVE", "arraySymbol",
								"ArraySymbol", '[]'],
		-objectsymbol		=> ["PASSIVE", "objectSymbol",
								"ObjectSymbol", '{}'],
		-namevaluesep		=> ["PASSIVE", "nameValueSep",
								"NameValueSep", ': '],
		-valuemaxlength		=> ["METHOD", "valueMaxLength",
								"VALUEMaxLength", $VALUE_MAX_LENGTH],
		-valuelongsymbol	=> ["PASSIVE", "valueLongSymbol",
								"VALUELongSymbol", '...'],
		-itemtype			=> ["SELF", "itemType", "ItemType", 'text']
	);
}

# ConfigSpecs methods

# get/set max number of characters for displaying of JSON text values
sub valuemaxlength {
	my ($myself, $args) = @_;
	if (@_ > 1) {
		$myself->_configure(-valuemaxlength => &_value_max_length($args));
	}
	return $myself->_cget('-valuemaxlength');
}

# validate given max number of characters for displaying of JSON text values
# return given number if it is valid, $VALUE_MAX_LENGTH otherwise
sub _value_max_length {
	$_ = shift;
	/^\+?\d+$/ ? $& : &{ sub {
		carp "Attempt to assign an invalid value to -valuemaxlength: '$_' is" .
			" not a positive integer. Default value ($VALUE_MAX_LENGTH)" .
			" will be used instead.\n";
		$VALUE_MAX_LENGTH
	}};
}

# application programming interface

sub load_json_file {	# load_json_file($json_filename)
	my ($myself, $json_file) = @_;
	if (!$myself->info('exists', '0')) {
		local $/ = undef;
		open FILE, $json_file or die "Could not open file $json_file: $!";
		my $json_string = ;
		close FILE;
		$myself->_load_json($myself->addchild(''),
			&_json_parser->decode($json_string));
		$myself->autosetmode;	# set up automatic handling of open/close events
	} else {
		carp "A JSON document has already been loaded into the tree." .
			" JSON file $json_file will not be loaded.";
	}
}

sub load_json_string {	# load_json_string($json_string)
	my ($myself, $json_string) = @_;
	if (!$myself->info('exists', '0')) {
		$myself->_load_json($myself->addchild(''),
			&_json_parser->decode($json_string));
		$myself->autosetmode;# set up automatic handling of open/close events
	} else {
		carp "A JSON document has already been loaded into the tree." .
			" JSON string will not be loaded.";
	}
}

sub get_value {	# get_value()
	my $myself = shift;
	$myself->entrycget($myself->selectionGet(), '-data');
}

# helper methods

# _json_parser(): get a JSON::Parser instance.
sub _json_parser {
	defined($json_parser) ? $json_parser : $json_parser = JSON->new
}

# _load_json($parent_path, $struct): load JSON elems under entry at $parent_path
sub _load_json {
	my ($myself, $parent_path, $struct) = ($_[0], $_[1], $_[2]);
	my $ref_type = ref $struct;
	my $text = ($myself->entrycget($parent_path, '-text') or '');
	my $entry_path;
	if ('HASH' eq $ref_type) {				# json object
		$myself->entryconfigure($parent_path,
			-text => $text . $myself->cget('-objectsymbol')
		);
		while (my ($name, $value) = each %$struct) {
			$entry_path = $myself->addchild($parent_path,
				-text => $name . $myself->cget('-namevaluesep')
			);
			$myself->_load_json($entry_path, $value);
		}
	} elsif ('ARRAY' eq $ref_type) {	# json array
		$myself->entryconfigure($parent_path,
			-text => $text . $myself->cget('-arraysymbol')
		);
		foreach (@$struct) {
			$entry_path = $myself->addchild($parent_path);
			$myself->_load_json($entry_path, $_);
		}
	} else {													# json string, number, true, false or null
		$myself->entryconfigure($parent_path, -data => $struct);
		if (defined $struct) {
			$struct = $struct ? 'true' : 'false' if JSON::is_bool($struct);
		} else {
			$struct = 'null';
		}
		$myself->entryconfigure($parent_path,
			-text => $text . $myself->_format_text($struct));
	}
}

sub _format_text { # _format_text($text): format/return text accordingly
	my ($myself, $text) = @_;
	my $value_max_length = $myself->cget('-valuemaxlength');
	length($text) > $value_max_length
		? substr($text, 0, $value_max_length) .  $myself->cget('-valuelongsymbol')
		: $text;
}

1;

__END__