package JavaScript::Dumper;
use strict;

=head1 NAME

JavaScript::Dumper - Dump a set of objects into JavaScript code

=head1 SYNOPSIS

 use JavaScript::Dumper qw(JSDump);

 JavaScript::Dumper::config(object_mode => 1);
 print JSDump(@objects);

 # OO invocation

 use JavaScript::Dumper;

 my $jsd = JavaScript::Dumper->new(object_mode => 1);
 print $jsd->Dump(@objects);

 $jsd->set_variable_name("bert");
 print $jsd->Dump($bert);

=head1 DESCRIPTION

This module performs a task analogous to the standard C<Data::Dumper>
module (see L<Data::Dumper>), but the idea is that the resultant data
structure is to be reconstituted within an ECMAScript interpreter.

=cut

use Exporter;
use Class::Tangram;
use Set::Object;

use vars qw(@ISA @EXPORT @EXPORT_OK $class_obj $fields);

BEGIN {
    @ISA = qw(Class::Tangram Exporter);

    @EXPORT    = qw(&JSDump);
    @EXPORT_OK = qw(&Dumper &JSDump);

    $fields =
	{
     int => {
	     # whether or not this dumper assumes you have JS classes
	     # for all the objects available
	     object_mode => undef,

	     # whether or not this dumper will recurse deeply into
	     # objects; this is off by default
	     deep_recurse => undef,

	     # internal - the count after while a variable name
	     # becomes an extras name
	     count => undef,
	    },
     string => {
		# the variable name to use for output
		variable_name => {
				  init_default => "objects",
				 },
		extra_name => {
			       init_default => "extras",
			       },
	       },
     set => {
	     # Dump only these objects (used internally)
	     dump_only => undef,

	     # thingies that have already been dumped (Set::Objects
	     # are not actually Set::Objects, they are Set::RVs so can
	     # hold hashes, arrays etc. as long as they are
	     # references.  They don't need to be blessed.)
	     already_dumped => undef,
	    },

     flat_hash => {
		   # dump locations of blessed objects
		   dump_positions => undef,
		  },

     array => {
	       dump_these => undef,
	      },

     flat_array => {
		    # the actual output lines
		    output_lines => undef,
		    # stitching calls
		    output_stitching => undef,
		   },
	};

    $class_obj = __PACKAGE__->new();

    no strict 'refs';
    *{__PACKAGE__."::$_"} = \&{"Class::Tangram::$_"}
	foreach qw(reftype blessed ish_int is_double is_string memid);
}

sub _obj {
    my $stackref = shift;
    if ( ref $stackref->[0] &&
	 UNIVERSAL::isa($stackref->[0], __PACKAGE__ ) ) {
	return shift @$stackref;
    } elsif ( UNIVERSAL::isa($stackref->[0], __PACKAGE__ ) ) {
	no strict "refs";
	my $class = shift @$stackref;
	return (${$class."::class_obj"} || $class_obj);
    } else {
	return $class_obj;
    }
}

sub config {
    my $self = _obj(\@_);
    return $self->set(@_);
}

=head2 JSDumper(@objects)

Dumps the passed objects as ECMAScript.

=cut
    # this function the item number of the passed object/array
sub _pos {
    my $self = shift;
    my $item = shift;
    my $key = memid($item);
    if ( !$self->already_dumped->includes($item) ) {
	push @{$self->dump_these}, $item;
	$self->dump_positions->{$key} =
	    (@{$self->output_lines} + @{$self->dump_these});
	$self->already_dumped->insert($item);
    }
    #print "Pos of ".ref($item)." is ".$self->dump_positions->{$key}."\n";
    return($self->dump_positions->{$key});
}

sub JSDump {
    return JSDumper(@_);
}

sub JSDumper {
    my $self = _obj(\@_);

    $self->already_dumped_clear();

    $self->set_dump_only(grep { ref($_) } @_)
	unless $self->deep_recurse;

    $self->set_count(scalar(@_));

    $self->set_dump_these([ @_ ]);
    $self->set_dump_positions({});

    $self->already_dumped->insert($_) foreach (grep { ref($_) } @_);
    my $n = 0;
    for my $item (@_) {
	if (ref $item) {
	    ${ $self->dump_positions }{ memid($item) } = $n;
	}
	$n++;
    }

    # data is the list of objects, plus surplus objects & arrays
    $self->set_output_lines([]);

    # structure is a list of statements to link up what is necessary
    $self->set_output_stitching([]);


    while ( my $thingy = shift @{$self->dump_these} ) {

	if ( ref $thingy ) {

	    if ( blessed($thingy) and !$thingy->isa("Set::Object") ) {
		if ( $self->object_mode ) {
		   $self->js_object($thingy);
		} else {
		   $self->js_structure($thingy);
		}
	    } else {
		$self->js_structure($thingy);
	    }
	} else {
	    #print "Dumping `$thingy'\n";
	    push @{ $self->output_lines}, $self->js_scalar($thingy);
	}
    }

    my $x = 0;
    return join ("",
		 (map { $_ = "\$_ = $_;\n";
			s/\$_/$self->varname($x)/eg;
			++$x; $_; }
		  @{$self->output_lines}),
		 (map { "$_;\n" }
		  @{$self->output_stitching})
		);
}

sub varname {
    my $self = shift;
    my $x = shift;

    if ( $x >= $self->count ) {
	return $self->extra_name."[".($x-$self->count)."]";
    } else {
	return $self->variable_name."[".$x."]";
    }
}

#---------------------------------------------------------------------
#  $self->js_structure($thingy)
# Process the passed thingy as if it were an unblessed reference.
#---------------------------------------------------------------------
sub js_structure {
    my $self = shift;
    my $thingy = shift;

    my $is_set = 0;

    # must be an array or hash reference
    if ( reftype($thingy) eq "ARRAY"
	 or (blessed($thingy) && $thingy->isa("Set::Object")
	     && ($is_set = 1))) {

	# an array reference; go through the array and dump each
	# member, setting forward references where necessary.
	my @array;
	my $x = 0;

	for my $item ( $is_set ? $thingy->members() : @$thingy ) {

	    if ( ref($item) ) {

		if ( $self->get_deep_recurse or
		     $self->dump_only->includes($item)
		   ) {
		    # it's an object - set a forward
		    # reference
		    my $n = $self->_pos($item);
		    push @array, "'_o$n'";
		    push @{ $self->output_stitching },
			($self->varname(scalar(@{$self->output_lines}))
			 ."[$x] = ".$self->varname($n) );
		} else {
		    # stringify it & hope for the best :-)
		    push @array, "'$item'";
		}

	    } else {
		push @array, $self->js_scalar($item);
	    }

	    $x++;
	}
	push @{ $self->output_lines },
	    "[ ".join(", ", @array)." ]";

    } elsif ( reftype($thingy) eq "HASH" ) {

	# a hash; iterate over it, 
	my @array;
	my $x = 0;

	while ( my ($key, $item) = each %$thingy ) {

	    if ( ref($item) ) {

		if ( $self->get_deep_recurse or
		     $self->dump_only->includes($item)
		   ) {

		    # it's an object - set a forward
		    # reference
		    my $n = $self->_pos($item);
		    push @array, quoscape($key).":'_o$n'";
		    push @{ $self->output_stitching },
			($self->varname(scalar(@{ $self->output_lines }))
			 ."[".quoscape($key)."] = "
			 .$self->varname($n) );
		} else {
		    # stringify it & hope for the best :-)
		    push @array, (quoscape($key).":"
				  .quoscape($item));
		}
	    } else {
		push @array, quoscape($key).":"
		    .$self->js_scalar($item);
	    }

	    $x++;
	}
	push @{ $self->output_lines }, "{ ".join(", ", @array)." }";

    } elsif ( reftype($thingy) eq "SCALAR" ) {
	# hmm.  to be consistent let's do it this way
	my $item = $$thingy;
	if ( $self->get_deep_recurse or
	     $self->dump_only->includes($item) ) {
	    my $n = $self->_pos($item);
	    push @{ $self->output_lines }, "'_o$n'";
	    push @{ $self->output_stitching },
		($self->varname(scalar(@{ $self->output_lines }))." = "
		 .$self->varname($n));
	} else {
	    push @{ $self->output_lines }, "'$item'";
	}
    } else {
	# eh?
	die("Don't know how to JS'ify `".reftype($thingy)."'");
    }

}

#---------------------------------------------------------------------
#  $self->js_object($thingy)
# Process the passed thingy as if it were a blessed reference.
#---------------------------------------------------------------------
sub js_object {
    my $self = shift;
    my $thingy = shift;

    # must be an array or hash reference
    if ( reftype($thingy) eq "ARRAY" ) {

	die "Sorry, blessed arrays are too wierd for this code";

    } elsif ( reftype($thingy) eq "HASH" ) {

	# a hash; iterate over it, 
	my @array;
	my $x = 0;

	while ( my ($key, $item) = each %$thingy ) {

	    if ( ref($item) ) {

		if ( $self->get_deep_recurse or
		     $self->dump_only->includes($item)
		   ) {

		    # it's an object - set a forward
		    # reference
		    my $n = $self->_pos($item);
		    #push @array, quoscape($key).":'_o$n'";
		    push @{ $self->output_stitching },
			($self->varname(scalar(@{ $self->output_lines }))
			 .".set_"
			 .$key."(".$self->varname($n).")");
		} else {
		    # stringify it & hope for the best :-)
		    push @array, (quoscape($key).":"
				  .quoscape($item));
		}
	    } else {
		push @array, quoscape($key).":"
		    .$self->js_scalar($item);
	    }

	    $x++;
	}
	push @{ $self->output_lines }, "new ".ref($thingy).'(); $_.set'
	    ."({ ".join(", ", @array)." })";

    } elsif ( reftype($thingy) eq "SCALAR" ) {

	die "Sorry.  Blessed scalars are too wierd for this dumper";

    } else {
	# eh?
	die("Don't know how to JS'ify `".reftype($thingy)."'");
    }

}

sub js_scalar {
    my $self = _obj(\@_);

    my $thingy = shift;
    die "js_scalar passed reference" if ( ref($thingy) );

    if ( defined(ish_int($thingy)) ) {
	return $thingy."";
    } elsif ( is_double($thingy) ) {
        return sprintf("%.e", $thingy);
    } elsif ( is_string($thingy) ) {
	return quoscape($thingy);
    } elsif ( !defined($thingy) ) {
	return "null",
    } else {
	die("Don't know how to JS'ify scalar `$thingy'");
    }
}

sub quoscape {
    my $string = shift;
    $string =~ s/\\/\\\\/g;
    $string =~ s/"/\\"/g;
    $string =~ s/\n/\\n/g;
    $string =~ s/\r/\\r/g;
    # I assume JavaScript supports C-style escaping of
    # control characters...
    $string =~ s/[\0-\037\200-\377]/
	"\\".sprintf('%.3o',ord($&))/eg;
    return qq{"$string"};
}

1;