File Coverage

blib/lib/Template/Plugin/StringTree.pm

Criterion	Covered	Total	%
statement	89	97	91.7
branch	40	58	68.9
condition	7	15	46.6
subroutine	15	15	100.0
pod	7	9	77.7
total	158	194	81.4

package Template::Plugin::StringTree;

=pod

=head1 NAME

Template::Plugin::StringTree - Access tree-like groups of strings naturally in code and Templates

=head1 SYNOPSIS

  use Template::Plugin::StringTree;

  # Create a StringTree and set some values
  my $Tree = Template::Plugin::StringTree->new;
  $Tree->set('foo', 'one');
  $Tree->set('foo.bar', 'two');
  $Tree->set('you.get.the.point' => 'right?');

  # Get simple hash of these variables for the template
  my $vars = $Tree->variables;

  #######################################################
  # Later that night in a Template

  After the number [% foo %] comes the number [% foo.bar %], [% you.get.the.point %]

  #######################################################
  # Which of course produces

  After the number one comes the number two, right?

=head1 DESCRIPTION

For a couple of months, I had found it really annoying that when I wanted
to put a bunch of configuration options into a template, that I couldn't
use a natural [% IF show.pictures %][% IF show.pictures.dropshadow %] ...etc...
type of notation. Simply, to get "dot" formatting in template, you need
hashes. Which means stupid notation like [% show.pictures.at_all %]. ugh...

As the size of the config tree I wanted to use grew and grew, it finally
started getting totally out of control, so I've created
Template::Plugin::StringTree, which lets you build tree structures in which
every node can have a value. And you can get at these naturally in templates.

=head1 METHODS

=cut

use 5.005;
use strict;
use Template::Plugin::StringTree::Node ();

use vars qw{$VERSION};
BEGIN {
	$VERSION = '0.08';
}





#####################################################################
# Constructor

=pod

=head2 new

The C constructor simply creates a new ::StringTree object and
returns it.

=cut

sub new {
	bless {}, ref($_[0]) || $_[0];
}

sub clone {
	my $self = ref $_[0] ? shift : return undef;
	ref($self)->thaw( $self->freeze );
}





#####################################################################
# Main Methods

=pod

=head2 get $path

Taking a single "this.is.a.path" argument, the C method returns the
value associated with the path, if there is one.

Returns the value for the path, if one exists. Returns C if no value
exists at that path.

=cut

sub get {
	my $self = shift;
	my $path = $self->_path($_[0]) or return undef;

	# Walk the tree to find the value
	my $cursor = $self;
	foreach my $branch ( @$path ) {
		return undef unless ref $cursor; # Last branch took us to a normal value
		defined($cursor = $cursor->{$branch}) or return undef;
	}

	# We have arrived at the value we want.
	ref $cursor ? $cursor->__get : $cursor;
}

=pod

=head2 set $path, $value

The C method takes a "this.is.a.path" style path and a value for that
path. C is valid as a value, erasing a single value at the node for
the path. ( It does not remove children of that node ).

Returns true if the value is set correctly, or C on error.

=cut

sub set {
	my $self  = shift;
	my $path  = $self->_path(shift) or return undef;
	my $value = shift;

	# Walk the tree to determine the location to set
	my $cursor = $self;
	my $leaf = pop @$path;
	foreach my $branch ( @$path ) {
		if ( ! defined $cursor->{$branch} ) {
			# Create a new node for the branch
			$cursor->{$branch} = Template::Plugin::StringTree::Node->__new;
		} elsif ( ! ref $cursor->{$branch} ) {
			# Convert the existing leaf into a node
			$cursor->{$branch} = Template::Plugin::StringTree::Node->__new( $cursor->{$branch} );
		}

		# Move down into the node
		$cursor = $cursor->{$branch};
	}

	# Now set the leaf
	if ( exists $cursor->{$leaf} and ref $cursor->{$leaf} ) {
		# Replace the node's value
		$cursor->{$leaf}->__set($value);
	} else {
		# Create or replace a leaf
		$cursor->{$leaf} = $value;
	}

	1;
}

=pod

The C method is nearly identical to the normal C method,
except that the it expects there B to be an existing value in place.
Rather than overwrite an existing value, this method will return an error.

Returns true if there is no existing value, and it is successfully set,
or C if there is an existing value, or an error while setting.

=cut

sub add {
	my $self  = shift;
	my $path  = $self->_path(shift) or return undef;
	my $value = shift;

	# Walk the tree to determine the location to set
	my $cursor = $self;
	my $leaf = pop @$path;
	foreach my $branch ( @$path ) {
		if ( ! defined $cursor->{$branch} ) {
			# Create a new node for the branch
			$cursor->{$branch} = Template::Plugin::StringTree::Node->__new;
		} elsif ( ! ref $cursor->{$branch} ) {
			# Convert the existing leaf into a node
			$cursor->{$branch} = Template::Plugin::StringTree::Node->__new( $cursor->{$branch} );
		}

		# Move down into the node
		$cursor = $cursor->{$branch};
	}

	# Now set the leaf
	if ( exists $cursor->{$leaf} and ref $cursor->{$leaf} ) {
		# Fail if there is an existing value
		return undef if defined $cursor->{$leaf}->__get($value);

		# Replace the node's value
		$cursor->{$leaf}->__set($value);
	} else {
		# Fail if there is an existing value
		return undef if defined $cursor->{$leaf};

		# Create or replace a leaf
		$cursor->{$leaf} = $value;
	}

	1;
}


=pod

=head2 hash

The C method produces a flat hash equivalent to the
Template::Plugin::StringTree object, which can be passed to the template
parser. You can manually add additional elements to the hash after it has
been produced, but you should not attempt to add anything to a hash key
the same as the first element in a path already added via the C
method earlier.

Returns a reference to a HASH containing the tree of strings.

=cut

sub hash { my $hash = { %{$_[0]} }; $hash }

=pod

=head2 freeze

Ever good structure can be serialized and deserialized, and this one is
no exception. The C method takes a ::StringTree object and converts
it into a string, which just so happens to be highly useful as a config
file format!

  foo: one
  foo.bar: two
  you.get.the.point: right?

So terribly simple. To make life just a LITTLE more complicated though,
Template::Plugin::StringTree does a little bit of escaping if there's a
newline in the string. But since you'll probably never DO that, it won't
be a problem will it? :)

=cut

sub freeze {
	my $self = shift;

	# Handle the special null case
	return 'null' unless keys %$self;

	# Flatten and escape the tree
	my %flat = ();
	my @queue = ( [ '', $self ] );
	while ( my $item = shift @queue ) {
		my $base   = $item->[0];
		my $cursor = $item->[1];

		foreach my $key ( keys %$cursor ) {
			my $path = length $base ? "$base.$key" : $key;
			my $value = (ref $cursor->{$key})
				? $cursor->{$key}->__get
				: $cursor->{$key};
			if ( defined $value ) {
				# Escape and add the value to the output
				$value =~ s/([\\\n])/sprintf('\\%03d', ord($1))/ge;
				$flat{$path} = $value;
			}
			push @queue, [ $path, $cursor->{$key} ] if ref $cursor->{$key};
		}
	}

	# Now convert the flattened tree to a single string
	join '', map { "$_: $flat{$_}\n" } sort keys %flat;
}

=pod

=head2 thaw $string

The C method is the reverse of the C method, taking the same
format string turning it back into a Template::Plugin::StringTree object.
THIS is where using this module as a config file -> template mechanism
really comes into it's own. Each entry is the config file is available
using the same path in Template Toolkit templates.
Template::Plugin::StringTree takes care of all the details or making it work
across the different models transparently.

If the string is formatted correctly, returns a new
Template::Plugin::StringTree object. Returns C on error, probably
because the string wasn't formatted correctly.

=cut

sub thaw {
	my $class = ref $_[0] ? ref shift : shift;
	my $string = shift or return undef;
	my $self = $class->new;

	# Handle the special case
	return $self if $string eq 'null';

	foreach ( split /\n/, $string ) {
		return undef unless /^([\w\.]+)\:\s*(.*)$/;
		my $key = $1;
		my $value = $2;

		# Unescape the value
		$value =~ s/\\(\d\d\d)/chr($1)/ge;
		$self->set($key, $value) or return undef;
	}

	$self;
}

=pod

=head2 equal $path, $value

The C method provides a quick and convenient bit of shorthand to
let you see if a particular path equals a particular value. And the
method is totally undef-safe. You can test for a value of C,
and test a value against a path which returns C quite safely.

Returns true if the value matches the path, or false otherwise.

=cut

sub equal {
	my $self = shift;
	my $left = $self->get(shift);
	my $right = shift;
	defined $left ? (defined($right) and $left eq $right) : ! defined $right;
}





#####################################################################
# Support Methods

sub _path {
	# Check the value before we begin processing it
	my $value = (defined $_[1] and ! ref $_[1]) ? $_[1] : return undef;
	$value =~ /^[^\W\d]\w*(?:\.[^\W\d]\w*)*$/ or return undef;

	# Split the path
	my @path = split /\./, $value;
	if ( grep { $_ eq 'DESTROY' } @path ) {
		# Illegal value, clashes with the Node DESTROY method
		warn "The use of 'DESTROY' as a path node is forbidden";
		return undef;
	}

	\@path;
}

1;

=pod

=head1 SUPPORT

Bugs should be submitted via the CPAN bug tracker, located at

  http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Template-Plugin-StringTree

For other issues, contact the author

=head1 AUTHOR

Adam Kennedy [e-mail]

=head1 COPYRIGHT

Copyright 2004, 2008 Adam Kennedy.

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.

=cut