File Coverage

blib/lib/Data/Taxi.pm

Criterion	Covered	Total	%
statement	153	188	81.3
branch	59	88	67.0
condition	9	18	50.0
subroutine	15	15	100.0
pod	2	5	40.0
total	238	314	75.8

package Data::Taxi;
use strict;
use vars qw[@ISA $VERSION $FORMAT_VERSION %HANDLE_FORMATS @EXPORT_OK %EXPORT_TAGS];
use Carp 'croak';
use Exporter;
use Debug::ShowStuff ':all';
@ISA = 'Exporter';
use 5.006;


=head1 NAME

Data::Taxi - Taint-aware, XML-ish data serialization

PLEASE NOTE: Data::Taxi is no longer being developed or supported.

=head1 SYNOPSIS

  use Data::Taxi ':all';
  my ($ob, $str);

  $ob = MyClass->new();
  $str = freeze($ob);
  $ob = thaw($str);



=head1 INSTALLATION

Data::Taxi can be installed with the usual routine:

	perl Makefile.PL
	make
	make test
	make install

You can also just copy Taxi.pm into the Data/ directory of one of your library trees.


=head1 DESCRIPTION

Taxi (Baint-Bware BML-Bsh) is a data serializer with several handy features:

=over

=item Taint aware

Taxi does not force you to trust the data you are serializing.
None of the input data is executed.

=item Human readable

Taxi produces a human-readable string that simplifies checking the
output of your objects.

=item XML-ish

While I don't (currently) promise full XML compliance, Taxi produces a block
of XML-ish data that could probably be read in by other XML parsers.

=back


=cut

#------------------------------------------------------------------------
# import/export
#

=head1 EXPORT

None by default.  freeze and thaw with ':all':

   use Data::Taxi ':all';

=cut

@EXPORT_OK = qw[freeze thaw];
%EXPORT_TAGS = ('all' => [@EXPORT_OK]);
#
# import/export
#------------------------------------------------------------------------


# version
$VERSION = '0.96';
$FORMAT_VERSION = '1.00';
undef $HANDLE_FORMATS{$FORMAT_VERSION};


# constants
use constant HASHREF  => 1;
use constant ARRREF   => 2;
use constant SCAREF   => 3;
use constant SCALAR   => 4;


=head1 Subroutines

=cut




#-----------------------------------------------------------------------------------
# freeze
#

=head2 freeze($ob, %opts)

C serializes a single scalar, hash reference, array reference, or
scalar reference into an XML string, C can recurse any number of
levels of a nested tree and preserve multiple references to the same object.
Let's look at an example:

	my ($tree, $format, $members, $bool, $mysca);

	# anonymous hash
	$format = {
		'app'=>'trini',
		'ver'=>'0.9',
		'ver'=>'this & that',
	};

	# anonymous array
	$members = ['Starflower', 'Mary', 'Paul', 'Hallie', 'Ryan'];

	# blessed object
	$bool = Math::BooleanEval->new('whatever');

	# scalar reference (to an anonymous hash, no less)
	$mysca = {'name'=>'miko', 'email'=>'[e-mail]', };

	# the whole thing
	$tree = {
		'dataformat' => $format,
		'otherdataformat' => $format,
		'bool' => $bool,
		'members' => $members,
		'myscaref' => \$mysca,
	};

	$frozen = freeze($tree);

C accepts one object as input.  The code above results in the following
XML-ish string:


































=cut

# Golly, and after all that POD, the subroutine is only a few lines
# long. All the work is done in obtag(), which recurses through the
# data to build the data string.

sub freeze {
	my ($ob, %opts) = @_;
	my $rv = '';

	# if a declaration is wanted
	if (
		$opts{'declaration'} ||
		(! defined $opts{'declaration'})
		) {
		$rv .= qq|\n|;
	}

	$rv .=
		'\n" .
		join('',  obtag($ob, {}, 1, %opts)) .
		"\n";

	return $rv;
}
#
# freeze
#-----------------------------------------------------------------------------------


#-----------------------------------------------------------------------------------
# obtag
#
# Private subroutine: recurses through data structure building the data string.
#
sub obtag {
	my ($ob, $ids, $depth, %opts) = @_;
	my (@rv, $indent, $allowed);

	# hash of allowed fields to save
	$allowed = get_allowed(\%opts);


	# get tied class
	if (defined $opts{'tied'})
		{$opts{'tied'} =~ s|\=.*||}

	# build the indentation string for this recursion.
	$indent = "\t" x $depth;

	# if reference
	if (my $ref = ref($ob)) {
		my $tagname = "$ob";
		my $org = $tagname;
		my ($tie);

		$tagname =~ s|^[^\=]*\=||;
		$tagname =~ s|\(.*||;
		$tagname = lc($tagname) . 'ref';

		# open tag
		push @rv, $indent, '<', $tagname;

		if (defined $opts{'name'} )
			{push @rv, ' name="', mlesc( $opts{'name'} ), '"'}

		# if in $ids
		if ($ids->{$ob})
			{return @rv, ' id="', $ids->{$ob}, '" redundant="1"/>', "\n"}

		# store object in objects hash
		# $ids->{$ob} = 1;
		$ids->{$ob} = keys(%{$ids});


		# output ID
		# push @rv, ' id="', mlesc($ob), '"';
		push @rv, ' id="', $ids->{$ob}, '"';

		# class
		if ($ref !~ m/^(HASH|ARRAY|REF|SCALAR)$/)
			{push @rv, ' class="', mlesc($ref), '"'}

		# tied hash
		if ($ref eq 'HASH') {
			if (my $tie = tied(%{$ob}) ) {
				$tie =~ s|\=.*||;
				push @rv, ' tied="', mlesc($tie), '"';
			}
		}

		# tied array
		elsif ($ref eq 'ARRAY') {
			if (my $tie = tied(@{$ob}) ) {
				$tie =~ s|\=.*||;
				push @rv, ' tied="', mlesc($tie), '"';
			}
		}

		# close tag
		push @rv, ">\n";

		# output children: hashref
		if ($tagname eq 'hashref') {
			HASHLOOP:
			foreach my $k (keys %{$ob} ){
				# if not allowed
				if ($allowed && (! exists $allowed->{$k}) )
					{next HASHLOOP}

				push @rv, obtag($ob->{$k}, $ids, $depth + 1, 'name'=>$k, 'tied'=>tied($ob->{$k}));
			}
		}

		# output children: arrayref
		elsif ($tagname eq 'arrayref') {
			foreach my $v ( @{$ob} )
				{push @rv, obtag($v, $ids, $depth + 1)}
		}

		# output children: scalarref
		elsif ($tagname eq 'scalarref')
			{ push @rv, obtag(${$ob}, $ids, $depth + 1, 'tied'=>tied(${$ob})   ) }

		# else don't know this type of reference
		else
			{ croak "don't know this type of reference: $tagname" }

		# close tag
		push @rv, $indent, '\n";
	}

	# else output tag with self-ender
	else {
		push @rv, $indent, '

		if (defined $opts{'name'} )
			{push @rv, ' name="', mlesc( $opts{'name'} ), '"'}

		if (defined $opts{'tied'} )
			{push @rv, ' tied="', mlesc( $opts{'tied'} ), '"'}

		if (defined $ob)
			{push @rv, ' value="', mlesc($ob), '"'}

		push @rv, "/>\n";
	}

	return @rv;
}
#
# obtag
#-----------------------------------------------------------------------------------



#------------------------------------------------------------------------------
# thaw data
#

=head2  thaw

C accepts one argument, the serialized data string, and returns a single
value, the reconstituted data, rebuilding the entire data structure including
blessed references.

   $tree = thaw($frozen);

=cut

sub thaw {
	my ($raw) = @_;
	my (@els, @stack, %ids, %esc, $quote, $left, $right, $amp, $firstdone);

	# remove XML document header, we're not s'fisticaded 'nuff for that
	# kinda thang yet. XML gurus will wince at this code.
	if ($raw =~ s|^\<\?||)
		{$raw =~ s|^[^\>]*>||}


	#-------------------------------------------------------------
	# placeholders for un-escaping
	#
	# I'm sure this could be done more gracefully.  Feel free to
	# to tidy up the unescaping routine and submit back your code.
	# :-) Miko
	#
	while (keys(%esc) < 4) {
		my $str = rand;
		$str =~ s|^0\.||;

		unless ($raw =~ m|$str|)
			{undef $esc{$str}}
	}

	($quote, $left, $right, $amp) = keys(%esc);

	$raw =~ s|"|$quote|g;
	$raw =~ s|<|$left|g;
	$raw =~ s|>|$right|g;
	$raw =~ s|&|$amp|g;
	#
	# placeholders for un-escaping
	#-------------------------------------------------------------


	# split into tags
	$raw =~ s|^\s*\<||;
	$raw =~ s|\s*\>$||;
	@els = split(m|\>\s*\<|, $raw);
	undef $raw; # don't need this anymore, might as well clean up now

	# loop through tags
	TAGLOOP:
	foreach my $el (@els) {
		# if end tag
		if ($el =~ m|^/|) {
			# if stack is down to 1 element, we're done
			(@stack == 1) && return $stack[0]->[0];

			pop @stack;
			next TAGLOOP;
		}

		# variables
		my ($type, $new, $selfender, %atts, $ref, $tagname);

		# self-ender?
		$selfender = $el =~ s|\s*\/$||s;

		# get tagname
		$el =~ s|^\s*||;
		$el =~ s|\s*$||;
		$el =~ s|^([^\s\"]+)\s*||s
			or die "invalid tag: $el";
		$tagname = lc($1) . ($el x 0);


		#-------------------------------------------------------------
		# parse into hash
		#
		$el =~ s|(\S+)\s*\=\s*"([^"]*)"\s*|\L$1\E\<$2\<|g;

		%atts = grep {
			s|$quote|"|g;
			s|$left|<|g;
			s|$right|>|g;
			s|$amp|&|g;
			1;
			} split('<', $el);
		#
		# parse into hash
		#-------------------------------------------------------------


		#-------------------------------------------------------------
		# hashrefs
		#
		if ($tagname eq 'hashref') {
			$type = HASHREF;

			# if tied
			if (defined $atts{'tied'}) {
				my %hash;
				tie %hash, $atts{'tied'};
				$new = \%hash;
			}

			# else not tied
			else
				{$new = {}}

			$ref = 1;
		}
		#
		# hashrefs
		#-------------------------------------------------------------


		#-------------------------------------------------------------
		# array refs
		#
		elsif ($tagname eq 'arrayref') {
			$type = ARRREF;

			# if tied
			if (defined $atts{'tied'}) {
				my @arr;
				tie @arr, $atts{'tied'};
				$new = \@arr;
			}

			# else not tied
			else
				{$new = []}

			$ref = 1;
		}
		#
		# array refs
		#-------------------------------------------------------------


		#-------------------------------------------------------------
		# scalarref
		#
		elsif ($tagname eq 'scalarref') {
			$type = SCAREF;
			$ref = 1;
		}
		#
		# scalarref
		#-------------------------------------------------------------


		#-------------------------------------------------------------
		# scalar
		#
		elsif ($tagname eq 'scalar') {
			$type = SCALAR;
		}
		#
		# scalar
		#-------------------------------------------------------------


		#-------------------------------------------------------------
		# taxi
		#
		elsif ( (! $firstdone) && ($tagname eq 'taxi') ) {
			# do nothing
		}
		#
		# taxi
		#-------------------------------------------------------------


		# else I don't know this tag
		else
			{croak "do not understand tag: $tagname $el"}

		# if first tag
		if (! $firstdone) {
			# version check
			unless (exists $Data::Taxi::HANDLE_FORMATS{$atts{'ver'}})
				{croak "Do not know this format version: $atts{'ver'}"}

			$firstdone = 1;
			next TAGLOOP;
		}

		# if ID, and ID already exists, that's the new object
		if (  defined($atts{'id'})  &&  $ids{$atts{'id'}}   )
			{$new = $ids{$atts{'id'}} }

		# if blessed reference
		elsif (defined $atts{'class'})
			{bless $new, $atts{'class'}}

		# if scalar
		elsif ($type == SCALAR)
			{$new = $atts{'value'}}

		# if scalar reference
		elsif ($type == SCAREF) {
			my $val;
			$new = \$val;
		}

		# if reference
		if ($ref)
			{$ids{$atts{'id'}} = $new}

		if ( @stack ) {
			# get prev and prevtype
			my($prev, $prevtype) = @{$stack[$#stack]};

			# if prevtype is array, push into prev
			if ($prevtype == HASHREF) {


				$prev->{$atts{'name'}} = $new;
			}

			# if prevtype is array, push into prev
			elsif ($prevtype == ARRREF)
				{push @{$prev}, $new}

			# else set scalar reference
			else
				{$prev = \$new}
		}

		# if this is a selfender
		elsif ($selfender)
			{return $new}

		# if ! self ender and current is hash or arr
		if (  (! $selfender)  &&  ( ($type == HASHREF) || ($type == ARRREF) || ($type == SCAREF) )  )
			{push @stack, [$new, $type]}
	}

	# if we get this far, that's an error
	die 'invalid FreezDry data format';
}
#
# thaw data
#------------------------------------------------------------------------------


#-----------------------------------------------------------------------------------
# mlesc
# Private sub. Escapes &, <, >, and " so that they don't mess up my parser.
#
sub mlesc {
        my ($rv) = @_;
        return '' unless defined($rv);
        $rv =~ s|&|&|g;
        $rv =~ s|"|"|g;
        $rv =~ s|<|<|g;
        $rv =~ s|>|>|g;
        return $rv;
}
#
# mlesc
#-----------------------------------------------------------------------------------


#-----------------------------------------------------------------------------------
# get_allowed
#
# Private sub. Returns a hash ref of allowed fields if such an options was sent.
#
sub get_allowed {
        my ($opts) = @_;
		exists($opts->{'allowed'}) or return undef;

		my ($rv, %alluse);
		ref($opts->{'allowed'}) or $opts->{'allowed'} = [$opts->{'allowed'}];

		@alluse{@{$opts->{'allowed'}}} = ();
		$rv = \%alluse;
		delete $opts->{'allowed'};
		return $rv;
}
#
# get_allowed
#-----------------------------------------------------------------------------------


# return true
1;

__END__