0: package JavaScript::Dumper;
1: use strict;
2: 
3: =head1 NAME
4: 
5: JavaScript::Dumper - Dump a set of objects into JavaScript code
6: 
7: =head1 SYNOPSIS
8: 
9:  use JavaScript::Dumper qw(JSDump);
10: 
11:  JavaScript::Dumper::config(object_mode => 1);
12:  print JSDump(@objects);
13: 
14:  # OO invocation
15: 
16:  use JavaScript::Dumper;
17: 
18:  my $jsd = JavaScript::Dumper->new(object_mode => 1);
19:  print $jsd->Dump(@objects);
20: 
21:  $jsd->set_variable_name("bert");
22:  print $jsd->Dump($bert);
23: 
24: =head1 DESCRIPTION
25: 
26: This module performs a task analogous to the standard C<Data::Dumper>
27: module (see L<Data::Dumper>), but the idea is that the resultant data
28: structure is to be reconstituted within an ECMAScript interpreter.
29: 
30: =cut
31: 
32: use Exporter;
33: use Class::Tangram;
34: use Set::Object;
35: 
36: use vars qw(@ISA @EXPORT @EXPORT_OK $class_obj $fields);
37: 
38: BEGIN {
39:     @ISA = qw(Class::Tangram Exporter);
40: 
41:     @EXPORT    = qw(&JSDump);
42:     @EXPORT_OK = qw(&Dumper &JSDump);
43: 
44:     $fields =
45: 	{
46:      int => {
47: 	     # whether or not this dumper assumes you have JS classes
48: 	     # for all the objects available
49: 	     object_mode => undef,
50: 
51: 	     # whether or not this dumper will recurse deeply into
52: 	     # objects; this is off by default
53: 	     deep_recurse => undef,
54: 
55: 	     # internal - the count after while a variable name
56: 	     # becomes an extras name
57: 	     count => undef,
58: 	    },
59:      string => {
60: 		# the variable name to use for output
61: 		variable_name => {
62: 				  init_default => "objects",
63: 				 },
64: 		extra_name => {
65: 			       init_default => "extras",
66: 			       },
67: 	       },
68:      set => {
69: 	     # Dump only these objects (used internally)
70: 	     dump_only => undef,
71: 
72: 	     # thingies that have already been dumped (Set::Objects
73: 	     # are not actually Set::Objects, they are Set::RVs so can
74: 	     # hold hashes, arrays etc. as long as they are
75: 	     # references.  They don't need to be blessed.)
76: 	     already_dumped => undef,
77: 	    },
78: 
79:      flat_hash => {
80: 		   # dump locations of blessed objects
81: 		   dump_positions => undef,
82: 		  },
83: 
84:      array => {
85: 	       dump_these => undef,
86: 	      },
87: 
88:      flat_array => {
89: 		    # the actual output lines
90: 		    output_lines => undef,
91: 		    # stitching calls
92: 		    output_stitching => undef,
93: 		   },
94: 	};
95: 
96:     $class_obj = __PACKAGE__->new();
97: 
98:     no strict 'refs';
99:     *{__PACKAGE__."::$_"} = \&{"Class::Tangram::$_"}
100: 	foreach qw(reftype blessed ish_int is_double is_string memid);
101: }
102: 
103: sub _obj {
104:     my $stackref = shift;
105:     if ( ref $stackref->[0] &&
106: 	 UNIVERSAL::isa($stackref->[0], __PACKAGE__ ) ) {
107: 	return shift @$stackref;
108:     } elsif ( UNIVERSAL::isa($stackref->[0], __PACKAGE__ ) ) {
109: 	no strict "refs";
110: 	my $class = shift @$stackref;
111: 	return (${$class."::class_obj"} || $class_obj);
112:     } else {
113: 	return $class_obj;
114:     }
115: }
116: 
117: sub config {
118:     my $self = _obj(\@_);
119:     return $self->set(@_);
120: }
121: 
122: =head2 JSDumper(@objects)
123: 
124: Dumps the passed objects as ECMAScript.
125: 
126: =cut
127:     # this function the item number of the passed object/array
128: sub _pos {
129:     my $self = shift;
130:     my $item = shift;
131:     my $key = memid($item);
132:     if ( !$self->already_dumped->includes($item) ) {
133: 	push @{$self->dump_these}, $item;
134: 	$self->dump_positions->{$key} =
135: 	    (@{$self->output_lines} + @{$self->dump_these});
136: 	$self->already_dumped->insert($item);
137:     }
138:     #print "Pos of ".ref($item)." is ".$self->dump_positions->{$key}."\n";
139:     return($self->dump_positions->{$key});
140: }
141: 
142: sub JSDump {
143:     return JSDumper(@_);
144: }
145: 
146: sub JSDumper {
147:     my $self = _obj(\@_);
148: 
149:     $self->already_dumped_clear();
150: 
151:     $self->set_dump_only(grep { ref($_) } @_)
152: 	unless $self->deep_recurse;
153: 
154:     $self->set_count(scalar(@_));
155: 
156:     $self->set_dump_these([ @_ ]);
157:     $self->set_dump_positions({});
158: 
159:     $self->already_dumped->insert($_) foreach (grep { ref($_) } @_);
160:     my $n = 0;
161:     for my $item (@_) {
162: 	if (ref $item) {
163: 	    ${ $self->dump_positions }{ memid($item) } = $n;
164: 	}
165: 	$n++;
166:     }
167: 
168:     # data is the list of objects, plus surplus objects & arrays
169:     $self->set_output_lines([]);
170: 
171:     # structure is a list of statements to link up what is necessary
172:     $self->set_output_stitching([]);
173: 
174: 
175:     while ( my $thingy = shift @{$self->dump_these} ) {
176: 
177: 	if ( ref $thingy ) {
178: 
179: 	    if ( blessed($thingy) and !$thingy->isa("Set::Object") ) {
180: 		if ( $self->object_mode ) {
181: 		   $self->js_object($thingy);
182: 		} else {
183: 		   $self->js_structure($thingy);
184: 		}
185: 	    } else {
186: 		$self->js_structure($thingy);
187: 	    }
188: 	} else {
189: 	    #print "Dumping `$thingy'\n";
190: 	    push @{ $self->output_lines}, $self->js_scalar($thingy);
191: 	}
192:     }
193: 
194:     my $x = 0;
195:     return join ("",
196: 		 (map { $_ = "\$_ = $_;\n";
197: 			s/\$_/$self->varname($x)/eg;
198: 			++$x; $_; }
199: 		  @{$self->output_lines}),
200: 		 (map { "$_;\n" }
201: 		  @{$self->output_stitching})
202: 		);
203: }
204: 
205: sub varname {
206:     my $self = shift;
207:     my $x = shift;
208: 
209:     if ( $x >= $self->count ) {
210: 	return $self->extra_name."[".($x-$self->count)."]";
211:     } else {
212: 	return $self->variable_name."[".$x."]";
213:     }
214: }
215: 
216: #---------------------------------------------------------------------
217: #  $self->js_structure($thingy)
218: # Process the passed thingy as if it were an unblessed reference.
219: #---------------------------------------------------------------------
220: sub js_structure {
221:     my $self = shift;
222:     my $thingy = shift;
223: 
224:     my $is_set = 0;
225: 
226:     # must be an array or hash reference
227:     if ( reftype($thingy) eq "ARRAY"
228: 	 or (blessed($thingy) && $thingy->isa("Set::Object")
229: 	     && ($is_set = 1))) {
230: 
231: 	# an array reference; go through the array and dump each
232: 	# member, setting forward references where necessary.
233: 	my @array;
234: 	my $x = 0;
235: 
236: 	for my $item ( $is_set ? $thingy->members() : @$thingy ) {
237: 
238: 	    if ( ref($item) ) {
239: 
240: 		if ( $self->get_deep_recurse or
241: 		     $self->dump_only->includes($item)
242: 		   ) {
243: 		    # it's an object - set a forward
244: 		    # reference
245: 		    my $n = $self->_pos($item);
246: 		    push @array, "'_o$n'";
247: 		    push @{ $self->output_stitching },
248: 			($self->varname(scalar(@{$self->output_lines}))
249: 			 ."[$x] = ".$self->varname($n) );
250: 		} else {
251: 		    # stringify it & hope for the best :-)
252: 		    push @array, "'$item'";
253: 		}
254: 
255: 	    } else {
256: 		push @array, $self->js_scalar($item);
257: 	    }
258: 
259: 	    $x++;
260: 	}
261: 	push @{ $self->output_lines },
262: 	    "[ ".join(", ", @array)." ]";
263: 
264:     } elsif ( reftype($thingy) eq "HASH" ) {
265: 
266: 	# a hash; iterate over it, 
267: 	my @array;
268: 	my $x = 0;
269: 
270: 	while ( my ($key, $item) = each %$thingy ) {
271: 
272: 	    if ( ref($item) ) {
273: 
274: 		if ( $self->get_deep_recurse or
275: 		     $self->dump_only->includes($item)
276: 		   ) {
277: 
278: 		    # it's an object - set a forward
279: 		    # reference
280: 		    my $n = $self->_pos($item);
281: 		    push @array, quoscape($key).":'_o$n'";
282: 		    push @{ $self->output_stitching },
283: 			($self->varname(scalar(@{ $self->output_lines }))
284: 			 ."[".quoscape($key)."] = "
285: 			 .$self->varname($n) );
286: 		} else {
287: 		    # stringify it & hope for the best :-)
288: 		    push @array, (quoscape($key).":"
289: 				  .quoscape($item));
290: 		}
291: 	    } else {
292: 		push @array, quoscape($key).":"
293: 		    .$self->js_scalar($item);
294: 	    }
295: 
296: 	    $x++;
297: 	}
298: 	push @{ $self->output_lines }, "{ ".join(", ", @array)." }";
299: 
300:     } elsif ( reftype($thingy) eq "SCALAR" ) {
301: 	# hmm.  to be consistent let's do it this way
302: 	my $item = $$thingy;
303: 	if ( $self->get_deep_recurse or
304: 	     $self->dump_only->includes($item) ) {
305: 	    my $n = $self->_pos($item);
306: 	    push @{ $self->output_lines }, "'_o$n'";
307: 	    push @{ $self->output_stitching },
308: 		($self->varname(scalar(@{ $self->output_lines }))." = "
309: 		 .$self->varname($n));
310: 	} else {
311: 	    push @{ $self->output_lines }, "'$item'";
312: 	}
313:     } else {
314: 	# eh?
315: 	die("Don't know how to JS'ify `".reftype($thingy)."'");
316:     }
317: 
318: }
319: 
320: #---------------------------------------------------------------------
321: #  $self->js_object($thingy)
322: # Process the passed thingy as if it were a blessed reference.
323: #---------------------------------------------------------------------
324: sub js_object {
325:     my $self = shift;
326:     my $thingy = shift;
327: 
328:     # must be an array or hash reference
329:     if ( reftype($thingy) eq "ARRAY" ) {
330: 
331: 	die "Sorry, blessed arrays are too wierd for this code";
332: 
333:     } elsif ( reftype($thingy) eq "HASH" ) {
334: 
335: 	# a hash; iterate over it, 
336: 	my @array;
337: 	my $x = 0;
338: 
339: 	while ( my ($key, $item) = each %$thingy ) {
340: 
341: 	    if ( ref($item) ) {
342: 
343: 		if ( $self->get_deep_recurse or
344: 		     $self->dump_only->includes($item)
345: 		   ) {
346: 
347: 		    # it's an object - set a forward
348: 		    # reference
349: 		    my $n = $self->_pos($item);
350: 		    #push @array, quoscape($key).":'_o$n'";
351: 		    push @{ $self->output_stitching },
352: 			($self->varname(scalar(@{ $self->output_lines }))
353: 			 .".set_"
354: 			 .$key."(".$self->varname($n).")");
355: 		} else {
356: 		    # stringify it & hope for the best :-)
357: 		    push @array, (quoscape($key).":"
358: 				  .quoscape($item));
359: 		}
360: 	    } else {
361: 		push @array, quoscape($key).":"
362: 		    .$self->js_scalar($item);
363: 	    }
364: 
365: 	    $x++;
366: 	}
367: 	push @{ $self->output_lines }, "new ".ref($thingy).'(); $_.set'
368: 	    ."({ ".join(", ", @array)." })";
369: 
370:     } elsif ( reftype($thingy) eq "SCALAR" ) {
371: 
372: 	die "Sorry.  Blessed scalars are too wierd for this dumper";
373: 
374:     } else {
375: 	# eh?
376: 	die("Don't know how to JS'ify `".reftype($thingy)."'");
377:     }
378: 
379: }
380: 
381: sub js_scalar {
382:     my $self = _obj(\@_);
383: 
384:     my $thingy = shift;
385:     die "js_scalar passed reference" if ( ref($thingy) );
386: 
387:     if ( defined(ish_int($thingy)) ) {
388: 	return $thingy."";
389:     } elsif ( is_double($thingy) ) {
390:         return sprintf("%.e", $thingy);
391:     } elsif ( is_string($thingy) ) {
392: 	return quoscape($thingy);
393:     } elsif ( !defined($thingy) ) {
394: 	return "null",
395:     } else {
396: 	die("Don't know how to JS'ify scalar `$thingy'");
397:     }
398: }
399: 
400: sub quoscape {
401:     my $string = shift;
402:     $string =~ s/\\/\\\\/g;
403:     $string =~ s/"/\\"/g;
404:     $string =~ s/\n/\\n/g;
405:     $string =~ s/\r/\\r/g;
406:     # I assume JavaScript supports C-style escaping of
407:     # control characters...
408:     $string =~ s/[\0-\037\200-\377]/
409: 	"\\".sprintf('%.3o',ord($&))/eg;
410:     return qq{"$string"};
411: }
412: 
413: 1;