File Coverage

blib/lib/Data/JavaScript.pm

Criterion	Covered	Total	%
statement	83	87	95.4
branch	31	38	81.5
condition	8	12	66.6
subroutine	8	9	88.8
pod	2	2	100.0
total	132	148	89.1

package Data::JavaScript;
require 5;
use vars qw(@EXPORT @EXPORT_OK %OPT $VERSION);
%OPT = (JS=>1.3);
$VERSION = 1.13;

@EXPORT = qw(jsdump hjsdump);
@EXPORT_OK = '__quotemeta';

use strict;
require Encode unless $] < 5.007;

sub import{
  my $package = shift;

  foreach( @_ ){
    if(ref($_) eq 'HASH'){
      $OPT{JS} = $$_{JS} if exists($$_{JS});
      $OPT{UNDEF} = $$_{UNDEF} if exists($$_{UNDEF});
    }
  }
  $OPT{UNDEF} ||=  $OPT{JS} > 1.2 ? 'undefined' : q('');

  #use (); #imports nothing, as package is not supplied
  if( defined $package ){
    no strict 'refs';

    #Remove options hash
    my @import = grep { ! length ref } @_;

    if( scalar @import ){
      if( grep {/^:all$/} @import ){
	@import = (@EXPORT, @EXPORT_OK) }
      else{
	#only user-specfied subset of @EXPORT, @EXPORT_OK
	my $q = qr/@{[join('|', @EXPORT, @EXPORT_OK)]}/;
	@import = grep { $_ =~ /$q/ } @import;
      }
    }
    else{
      @import = @EXPORT;
    }

    my $caller = caller;
    for my $func (@import) {
      *{"$caller\::$func"} = \&$func;
    }
  }
}

sub hjsdump {
    my @res = (qq(), </td>
</tr>

<tr>
<td  class="h" >
<a name="53">53</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	       '<!--', &jsdump(@_), '// -->', '');
    wantarray ? @res : join("\n", @res, "");
}

sub jsdump {
    my $sym  = shift;
    return "var $sym;\n" unless (@_);
    my $elem  = shift;
    my $undef = shift;
    my %dict;
    my @res   = __jsdump($sym, $elem, \%dict, $undef);
    $res[0]   = "var " . $res[0];
    wantarray ? @res : join("\n", @res, "");
}


my $QMver;
if( $] < 5.007 ){
  $QMver=<<'EO5';
    s<([^ \x21-\x5B\x5D-\x7E]+)>{sprintf(join('', '\x%02X' x length$1), unpack'C*',$1)}ge;
EO5
}
else{
  $QMver=<<'EO58';
    if( $OPT{JS} >= 1.3 && Encode::is_utf8($_) ){
        s<([\x{0080}-\x{fffd}]+)>{sprintf '\u%0*v4X', '\u', $1}ge;
    }

    {
      use bytes;
      s<((?:[^ \x21-\x7E]|(?:\\(?!u)))+)>{sprintf '\x%0*v2X', '\x', $1}ge;
    }
EO58
}

eval 'sub __quotemeta {local $_ = shift;' . $QMver . <<'EOQM';

    #This is kind of ugly/inconsistent output for munged UTF-8
    #tr won't work because we need the escaped \ for JS output
    s/\\x09/\\t/g;
    s/\\x0A/\\n/g;
    s/\\x0D/\\r/g;
    s/"/\\"/g;
    s/\\x5C/\\\\/g;

    #Escape  for stupid browsers that stop parsing
    s%%\\x3C\\x2Fscript\\x3E%g;

    return $_;
  }
EOQM


sub __jsdump {
    my ($sym, $elem, $dict, $undef) = @_;
    my $ref;

    unless( $ref = ref($elem) ){
      unless( defined($elem) ){
	return "$sym = @{[defined($undef) ? $undef : $OPT{UNDEF}]};";
      }

      #Translated from $Regexp::Common::RE{num}{real}
      if( $elem =~ /^[+-]?(?:(?=\d|\.)\d*(?:\.\d{0,})?)$/ ){
#                                                      (?:[eE][+-]?\d+)?
	  return qq($sym = "$elem";) if $elem =~ /^0\d+$/;
	  return "$sym = $elem;";
      }

      #Fall-back to quoted string
      return qq($sym = ") . __quotemeta($elem) . '";';
    }

    #Circular references
    if ($dict->{$elem}) {
        return "$sym = " . $dict->{$elem} . ";";
    }
    $dict->{$elem} = $sym;

    #isa over ref in case we're given objects
    if( $ref eq 'ARRAY' || UNIVERSAL::isa($elem, 'ARRAY') ){
        my @list = ("$sym = new Array;");
        my $n = 0;
        foreach (@$elem) {
            my $newsym = "$sym\[$n]";
            push(@list, __jsdump($newsym, $_, $dict, $undef));
            $n++;
        }
        return @list;
    }
    elsif(  $ref eq 'HASH' || UNIVERSAL::isa($elem, 'HASH') ){
        my @list = ("$sym = new Object;");
        my ($k, $old_k, $v);
        foreach $k (sort keys %$elem) {
	  $k = __quotemeta($old_k=$k);
	  my $newsym = qq($sym\["$k"]);
	  push(@list, __jsdump($newsym, $elem->{$old_k}, $dict, $undef));
        }
        return @list;
    }
    else{
      return "//Unknown reference: $sym=$ref";
    }
}


1;
__END__