File Coverage

blib/lib/Data/JavaScript/Anon.pm

Criterion	Covered	Total	%
statement	85	128	66.4
branch	27	60	45.0
condition	7	18	38.8
subroutine	14	23	60.8
pod	12	12	100.0
total	145	241	60.1

package Data::JavaScript::Anon;

# This package provides a mechanism to convert the main basic Perl
# structures into JavaScript structures, making it easier to transfer
# data from Perl to JavaScript.

use 5.006;
use strict;
use warnings;
use Params::Util   qw{ _STRING _SCALAR0 _ARRAY0 _HASH0 };
use Class::Default ();

use vars qw{@ISA $VERSION $errstr $RE_NUMERIC $RE_NUMERIC_HASHKEY %KEYWORD};
BEGIN {
	$VERSION = '1.03';
	@ISA     = 'Class::Default';
	$errstr  = '';

	# Attempt to define a single, all encompasing,
	# regex for detecting a legal JavaScript number.
	# We do not support the exotic values, such as Infinite and NaN.
	my $_sci = qr/[eE](?:\+|\-)?\d+/;                   # The scientific notation exponent ( e.g. 'e+12' )
	my $_dec = qr/\.\d+/;                               # The decimal section ( e.g. '.0212' )
	my $_int = qr/(?:[1-9]\d*|0)/;                      # The integers section ( e.g. '2312' )
	my $real = qr/(?:$_int(?:$_dec)?|$_dec)(?:$_sci)?/; # Merge the integer, decimal and scientific parts
	my $_hex = qr/0[xX][0-9a-fA-F]+/;                   # Hexidecimal notation
	my $_oct = qr/0[0-7]+/;                             # Octal notation

	# The final combination of all posibilities for a straight number
	# The string to match must have no extra characters
	$RE_NUMERIC = qr/^(?:\+|\-)??(?:$real|$_hex|$_oct)\z/;

	# The numeric for of the hash key is similar, but without the + or - allowed
	$RE_NUMERIC_HASHKEY = qr/^(?:$real|$_hex|$_oct)\z/;

	%KEYWORD = map { $_ => 1 } qw{
		abstract boolean break byte case catch char class const
		continue debugger default delete do double else enum export
		extends false final finally float for function goto if
		implements import in instanceof int interface long native new
		null package private protected public return short static super
		switch synchronized this throw throws transient true try typeof
		var void volatile while with
	};
}





#####################################################################
# Top Level Dumping Methods

sub new {
	my $proto = shift;
	my $class = ref $proto || $proto;
	my $opts  = _HASH0($_[0]) ? shift : { @_ };

	# Create the object
	my $self = bless {
		quote_char => '"',
	}, $class;

	## change the default quote character
	if ( defined $opts->{quote_char} && length $opts->{quote_char} ) {
		$self->{quote_char} = $opts->{quote_char};
	}

	return $self;
}

sub _create_default_object {
	my $class = shift;
	my $self  = $class->new();
	return $self;
}

sub anon_dump {
	my $class     = shift;
	my $something = shift;
	my $processed = shift || {};

	# Handle the undefined case
	return 'undefined' unless defined $something;

	# Handle the basic non-reference case
	return $class->anon_scalar( $something ) unless ref $something;

	# Check to see if we have processed this reference before.
	# This should catch circular, cross-linked, or otherwise complex things
	# that we can't handle.
	if ( $processed->{$something} ) {
		return $class->_err_found_twice( $something );
	} else {
		$processed->{$something} = 1;
	}

	# Handle the SCALAR reference case, which in our case we treat
	# like a normal scalar.
	if ( _SCALAR0($something) ) {
		return $class->anon_scalar( $something );
	}

	# Handle the array case by generating an anonymous array
	if ( _ARRAY0($something) ) {
		# Create and return the array
		my $list = join ', ', map { $class->anon_dump($_, $processed) } @$something;
		return "[ $list ]";
	}

	# Handle the hash case by generating an anonymous object/hash
	if ( _HASH0($something) ) {
		# Create and return the anonymous hash
		my $pairs = join ', ', map {
			$class->anon_hash_key($_)
				. ': '
				. $class->anon_dump( $something->{$_}, $processed )
		} keys %$something;
		return "{ $pairs }";
	}

	$class->_err_not_supported( $something );
}

# Same thing, but creating a variable
sub var_dump {
	my $class = shift;
	my $name  = shift or return undef;
	my $value = $class->anon_dump( shift );
	"var $name = $value;";
}

# Wrap some JavaScript in a HTML script tag
sub script_wrap {
	"\n$_[1]\n";
}

# Is a particular string a legal JavaScript number.
# Returns true if a legal JavaScript number.
# Returns false otherwise.
sub is_a_number {
	my $class  = shift;
	my $number = (defined $_[0] and ! ref $_[0]) ? shift : '';
	$number =~ m/$RE_NUMERIC/ ? 1 : '';
}





#####################################################################
# Basic Variable Creation Statements

# Create a JavaScript scalar given the javascript variable name
# and a reference to the scalar.
sub var_scalar {
	my $class      = shift;
	my $name       = shift or return undef;
	my $scalar_ref = _SCALAR0(shift) or return undef;
	my $value      = $class->js_value( $$scalar_ref ) or return undef;
	"var $name = $value;";
}

# Create a JavaScript array given the javascript array name
# and a reference to the array.
sub var_array {
	my $class     = shift;
	my $name      = shift or return undef;
	my $array_ref = _ARRAY0(shift) or return undef;
	my $list      = join ', ', map { $class->anon_dump($_) } @$array_ref;
	"var $name = new Array( $list );";
}

# Create a JavaScript hash ( which is just an object ), given
# the variable name, and a reference to a hash.
sub var_hash {
	my $class    = shift;
	my $name     = shift or return undef;
	my $hash_ref = _HASH0(shift) or return undef;
	my $struct   = $class->anon_hash( $name, $hash_ref ) or return undef;
	"var $name = $struct;";
}





#####################################################################
# Basic Serialisation And Escaping Methods

# Turn a single perl value into a single javascript value
sub anon_scalar {
	my $class = shift;
	my $value = _SCALAR0($_[0]) ? ${shift()} : shift;
	return 'null' unless defined $value;

	# Don't quote if it is numeric
	return $value if $value =~ /$RE_NUMERIC/;

	my $quote_char = $class->_self->{quote_char};

	# Escape and quote
	$quote_char . $class->_escape($value) . $quote_char;
}

# Turn a single perl value into a javascript hash key
sub anon_hash_key {
	my $class = shift;
	my $value = defined($_[0]) && !ref($_[0]) ? shift : return undef;

	my $quote_char = $class->_self->{quote_char};

	# Quote if it's a keyword
	return $quote_char . $value . $quote_char if $KEYWORD{$value};

	# Don't quote if it is just a set of word characters or numeric
	return $value if $value =~ /^[^\W\d]\w*\z/;
	return $value if $value =~ /$RE_NUMERIC_HASHKEY/;

	# Escape and quote
	$quote_char . $class->_escape($value) . $quote_char;
}

# Create a JavaScript array given the javascript array name
# and a reference to the array.
sub anon_array {
	my $class     = shift;
	my $name      = shift or return undef;
	my $array_ref = _ARRAY0(shift) or return undef;
	my $list      = join ', ', map { $class->anon_scalar($_) } @$array_ref;
	"[ $list ]";
}

# Create a JavaScript hash ( which is just an object ), given
# the variable name, and a reference to a hash.
sub anon_hash {
	my $class    = shift;
	my $name     = shift or return undef;
	my $hash_ref = _HASH0(shift) or return undef;
	my $pairs    = join ', ', map {
		$class->anon_hash_key( $_ )
			. ': '
			. $class->anon_scalar( $hash_ref->{$_} )
	} keys %$hash_ref;
	"{ $pairs }";
}





#####################################################################
# Utility and Error Methods

sub _escape {
	my $class = shift;
	my $text  = shift;
	my $char  = $class->_self->{quote_char};
	$text =~ s/(\Q$char\E|\\)/\\$1/g;                       # Escape quotes and backslashes
	$text =~ s/\n/\\n/g;                                    # Escape newlines in a readable way
	$text =~ s/\r/\\r/g;                                    # Escape CRs in a readable way
	$text =~ s/\t/\\t/g;                                    # Escape tabs in a readable way
	$text =~ s/([\x00-\x1F])/sprintf("\\%03o", ord($1))/ge; # Escape other control chars as octal
	$text;
}

sub _err_found_twice {
	my $class     = shift;
	my $something = ref $_[0] || 'a reference';
	$errstr = "Found $something in your dump more than once. "
		. "Data::JavaScript::Anon does not support complex, "
		. "circular, or cross-linked data structures";
	undef;
}

sub _err_not_supported {
	my $class     = shift;
	my $something = ref $_[0] || 'A reference of unknown type';
	$errstr = "$something was found in the dump struct. "
		. "Data::JavaScript::Anon only supports objects based on, "
		. "or references to SCALAR, ARRAY and HASH type variables.";
	undef;
}

1;

__END__