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