File Coverage

blib/lib/AMF/Perl/IO/Serializer.pm
Criterion Covered Total %
statement 9 129 6.9
branch 0 66 0.0
condition 0 33 0.0
subroutine 3 20 15.0
pod 3 17 17.6
total 15 265 5.6


line stmt bran cond sub pod time code
1             package AMF::Perl::IO::Serializer;
2             # Copyright (c) 2003 by Vsevolod (Simon) Ilyushchenko. All rights reserved.
3             # This program is free software; you can redistribute it and/or modify it
4             # under the same terms as Perl itself.
5             # The code is based on the -PHP project (http://amfphp.sourceforge.net/)
6              
7             =head1 NAME
8              
9             AMF::Perl::IO::Serializer
10              
11             =head1 DESCRIPTION
12              
13             Class used to convert physical perl objects into binary data.
14              
15             =head1 CHANGES
16              
17             =head2 Sun May 23 12:35:19 EDT 2004
18              
19             =item Changed deduceType() to return the value too, as it may be changed inside, and to
20             handle empty string ('') as a string.
21              
22             =head2 Wed Apr 14 11:06:28 EDT 2004
23              
24             =item Made basic data type determination work for both scalars and scalarrefs.
25              
26             =item Now we check if we are sending a recordset and setting column types accordingly.
27              
28             =head2 Sat Mar 13 16:25:00 EST 2004
29              
30             =item Patch from Tilghman Lesher that detects numbers and dates in strings
31             and sets return type accordingly.
32              
33             =item Patch from Kostas Chatzikokolakis handling encoding and sending null value.
34              
35             =head2 Sun May 11 16:43:05 EDT 2003
36              
37             =item Changed writeData to set type to "NULL" when the incoming data is undef. Previously
38             it became a String, just like other scalars.
39              
40             =item Changed PHP's writeRecordset to a generic writeAMFObject. Verified Recordset support.
41              
42             =head2 Sun Mar 9 18:20:16 EST 2003
43              
44             =item Function writeObject should return the same as writeHash. This assumes that all meaningful data
45             are stored as hash keys.
46              
47             =cut
48              
49              
50 1     1   6 use strict;
  1         1  
  1         35  
51              
52 1     1   4 use Encode qw/from_to/;
  1         2  
  1         46  
53 1     1   2613 use DBI;
  1         19231  
  1         3051  
54              
55             # holder for the data
56             my $data;
57              
58             sub new
59             {
60 0     0 0   my ($proto, $stream, $encoding) = @_;
61             # save
62 0           my $self={};
63 0           bless $self, $proto;
64 0           $self->{out} = $stream;
65 0           $self->{encoding} = $encoding;
66 0           return $self;
67             }
68              
69             sub serialize
70             {
71 0     0 0   my ($self, $d) = @_;
72 0           $self->{amfout} = $d;
73             # write the version ???
74 0           $self->{out}->writeInt(0);
75            
76             # get the header count
77 0           my $count = $self->{amfout}->numHeader();
78             # write header count
79 0           $self->{out}->writeInt($count);
80            
81 0           for (my $i=0; $i<$count; $i++)
82             {
83 0           $self->writeHeader($i);
84             }
85            
86 0           $count = $self->{amfout}->numBody();
87             # write the body count
88 0           $self->{out}->writeInt($count);
89            
90 0           for (my $i=0; $i<$count; $i++)
91             {
92             # start writing the body
93 0           $self->writeBody($i);
94             }
95             }
96              
97             sub writeHeader
98             {
99 0     0 0   my ($self, $i)=@_;
100              
101            
102             # for all header values
103             # write the header to the output stream
104             # ignoring header for now
105             }
106              
107             sub writeBody
108             {
109 0     0 0   my ($self, $i)=@_;
110 0           my $body = $self->{amfout}->getBodyAt($i);
111             # write the responseURI header
112 0           $self->{out}->writeUTF($body->{"target"});
113             # write null, haven't found another use for this
114 0           $self->{out}->writeUTF($body->{"response"});
115             # always, always there is four bytes of FF, which is -1 of course
116 0           $self->{out}->writeLong(-1);
117             # write the data to the output stream
118 0           $self->writeData($body->{"value"}, $body->{"type"});
119             }
120              
121             # writes a boolean
122             sub writeBoolean
123             {
124 0     0 0   my ($self, $d)=@_;
125             # write the boolean flag
126 0           $self->{out}->writeByte(1);
127             # write the boolean byte
128 0           $self->{out}->writeByte($d);
129             }
130             # writes a string under 65536 chars, a longUTF is used and isn't complete yet
131             sub writeString
132             {
133 0     0 0   my ($self, $d)=@_;
134             # write the string code
135 0           $self->{out}->writeByte(2);
136             # write the string value
137             #$self->{out}->writeUTF(utf8_encode($d));
138 0 0         from_to($d, $self->{encoding}, "utf8") if $self->{encoding};
139 0           $self->{out}->writeUTF($d);
140             }
141              
142             sub writeXML
143             {
144 0     0 0   my ($self, $d)=@_;
145 0           $self->{out}->writeByte(15);
146             #$self->{out}->writeLongUTF(utf8_encode($d));
147 0 0         from_to($d, $self->{encoding}, "utf8") if $self->{encoding};
148 0           $self->{out}->writeLongUTF($d);
149             }
150              
151             # must be used PHPRemoting with the service to set the return type to date
152             # still needs a more in depth look at the timezone
153             sub writeDate
154             {
155 0     0 0   my ($self, $d)=@_;
156             # write date code
157 0           $self->{out}->writeByte(11);
158             # write date (milliseconds from 1970)
159 0           $self->{out}->writeDouble($d);
160             # write timezone
161             # ?? this is wierd -- put what you like and it pumps it back into flash at the current GMT ??
162             # have a look at the amf it creates...
163 0           $self->{out}->writeInt(0);
164             }
165              
166             # write a number formatted as a double with the bytes reversed
167             # this may not work on a Win machine because i believe doubles are
168             # already reversed, to fix this comment out the reversing part
169             # of the writeDouble method
170             sub writeNumber
171             {
172 0     0 0   my ($self, $d)=@_;
173             # write the number code
174 0           $self->{out}->writeByte(0);
175             # write the number as a double
176 0           $self->{out}->writeDouble($d);
177             }
178             # write null
179             sub writeNull
180             {
181 0     0 0   my ($self)=@_;
182             # null is only a 0x05 flag
183 0           $self->{out}->writeByte(5);
184             }
185              
186             # write array
187             # since everything in php is an array this includes arrays with numeric and string indexes
188             sub writeArray
189             {
190 0     0 0   my ($self, $d)=@_;
191              
192             # grab the total number of elements
193 0           my $len = scalar(@$d);
194              
195             # write the numeric array code
196 0           $self->{out}->writeByte(10);
197             # write the count of items in the array
198 0           $self->{out}->writeLong($len);
199             # write all of the array elements
200 0           for(my $i=0 ; $i < $len ; $i++)
201             {
202             #If this is a basic data type in a recordset, consider the column type.
203 0 0 0       if (!(ref $d->[$i]) && $self->{__writingRecordset__})
204             {
205 0           my $type = $self->{__columnTypes__}->[$i];
206 0           $self->dispatchBySqlType($d->[$i], $type);
207             }
208             else
209             {
210 0           $self->writeData($d->[$i]);
211             }
212             }
213             }
214              
215             sub dispatchBySqlType
216             {
217 0     0 0   my ($self, $data, $type) = @_;
218 0 0 0       if ($type && ($type == DBI::SQL_NUMERIC) || ($type == DBI::SQL_DECIMAL) || ($type == DBI::SQL_INTEGER) || ($type == DBI::SQL_SMALLINT) || ($type == DBI::SQL_FLOAT) || ($type == DBI::SQL_DOUBLE) || ($type == DBI::SQL_REAL))
      0        
      0        
      0        
      0        
      0        
      0        
219             {
220 0           $self->writeNumber($data);
221             }
222             else
223             {
224 0           $self->writeString($data);
225             }
226             }
227            
228             sub writeHash
229             {
230 0     0 0   my ($self, $d) = @_;
231             # this is an object so write the object code
232 0           $self->{out}->writeByte(3);
233             # write the object name/value pairs
234 0           $self->writeObject($d);
235             }
236             # writes an object to the stream
237             sub writeObject
238             {
239 0     0 1   my ($self, $d)=@_;
240             # loop over each element
241 0           while ( my ($key, $data) = each %$d)
242             {
243             # write the name of the object
244 0           $self->{out}->writeUTF($key);
245 0 0 0       if ($self->{__columnTypes__} && $key eq "initialData")
246             {
247 0           $self->{__writingRecordset__} = 1;
248             }
249             # write the value of the object
250 0           $self->writeData($data);
251 0           $self->{__writingRecordset__} = 0;
252             }
253             # write the end object flag 0x00, 0x00, 0x09
254 0           $self->{out}->writeInt(0);
255 0           $self->{out}->writeByte(9);
256             }
257              
258             # write an AMF object
259             # The difference with regular object is that the code is different
260             # and the class name is explicitly sent. Good for RecordSets.
261             sub writeAMFObject
262             {
263 0     0 0   my ($self, $object)=@_;
264             # write the custom package code
265 0           $self->{out}->writeByte(16);
266             # write the package name
267 0           $self->{out}->writeUTF($object->{_explicitType});
268 0 0         $self->{__columnTypes__} = $object->{__columnTypes__} if $object->{__columnTypes__};
269             # write the package's data
270 0           $self->writeObject($object);
271 0           delete $self->{__columnTypes__};
272             }
273              
274              
275             # main switch for dynamically determining the data type
276             # this may prove to be inadequate because perl isn't a typed
277             # language and some confusion may be encountered as we discover more data types
278             # to be passed back to flash
279              
280             #All scalars are assumed to be strings, not numbers.
281             #Regular arrays and hashes are prohibited, as they are indistinguishable outside of perl context
282             #Only arrayrefs and hashrefs will work
283              
284             # were still lacking dates, xml, and strings longer than 65536 chars
285             sub writeData
286             {
287 0     0 1   my ($self, $d, $type)=@_;
288 0 0         $type = "unknown" unless $type;
289              
290             # **************** TO DO **********************
291             # Since we are now allowing the user to determine
292             # the datatype we have to validate the user's suggestion
293             # vs. the actual data being passed and throw an error
294             # if things don't check out.!!!!
295             # **********************************************
296              
297             # get the type of the data by checking its reference name
298             #if it was not explicitly passed
299 0 0         if ($type eq "unknown")
300             {
301 0 0         if (!defined $d) # convert undef to null, but not "" or 0
302             {
303 0           $type = "NULL";
304             }
305             else
306             {
307 0           my $myRef = ref $d;
308              
309 0 0 0       if (!$myRef || $myRef =~ "SCALAR")
    0          
    0          
310             {
311 0 0         if ($myRef) {
312 0           study $$myRef;
313 0           ($type, $d) = $self->deduceType($$myRef);
314             } else {
315 0           ($type, $d) = $self->deduceType($d);
316             }
317             }
318             elsif ($myRef =~ "ARRAY")
319             {
320 0           $type = "array";
321             }
322             elsif ($myRef =~ "HASH")
323             {
324 0           $type = "hash";
325             }
326             else
327             {
328 0           $type = "object";
329             }
330             }
331             }
332            
333             #BOOLEANS
334 0 0         if ($type eq "boolean")
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
335             {
336 0           $self->writeBoolean($d);
337             }
338             #STRINGS
339             elsif ($type eq "string")
340             {
341 0           $self->writeString($d);
342             }
343             # DOUBLES
344             elsif ($type eq "double")
345             {
346 0           $self->writeNumber($d);
347             }
348             # INTEGERS
349             elsif ($type eq "integer")
350             {
351 0           $self->writeNumber($d);
352             }
353             # OBJECTS
354             elsif ($type eq "object")
355             {
356 0           $self->writeHash($d);
357             }
358             # ARRAYS
359             elsif ($type eq "array")
360             {
361 0           $self->writeArray($d);
362             }
363             # HASHAS
364             elsif ($type eq "hash")
365             {
366 0           $self->writeHash($d);
367             }
368             # NULL
369             elsif ($type eq "NULL")
370             {
371 0           $self->writeNull();
372             }
373             # UDF's
374             elsif ($type eq "user function")
375             {
376            
377             }
378             elsif ($type eq "resource")
379             {
380 0           my $resource = get_resource_type($d); # determine what the resource is
381 0           $self->writeData($d, $resource); # resend with $d's specific resource type
382             }
383             # XML
384             elsif (lc($type) eq "xml")
385             {
386 0           $self->writeXML($d);
387             }
388             # Dates
389             elsif (lc($type) eq "date")
390             {
391 0           $self->writeDate($d);
392             }
393             # mysql recordset resource
394             elsif (lc($type) eq "amfobject") # resource type
395             {
396             # write the record set to the output stream
397 0           $self->writeAMFObject($d); # writes recordset formatted for Flash
398             }
399             else
400             {
401 0           print STDERR "Unsupported Datatype $type in AMF::Perl::IO::Serializer";
402 0           die;
403             }
404            
405             }
406              
407             sub deduceType
408             {
409 0     0 1   my ($self, $scalar) = @_;
410              
411 0           my $type = "string";
412              
413 0 0 0       if ($scalar =~ m/^(\d{4})\-(\d{2})\-(\d{2})( (\d{2}):(\d{2}):(\d{2}))?$/)
    0          
    0          
    0          
    0          
    0          
414             {
415             # Handle "YYYY-MM-DD" and "YYYY-MM-DD HH:MM:SS"
416 0           require POSIX;
417 0 0         if ($4) {
418 0           $scalar = POSIX::mktime($7,$6,$5,$3,$2 - 1,$1 - 1900) * 1000;
419             } else {
420 0           $scalar = POSIX::mktime(0,0,0,$3,$2 - 1,$1 - 1900) * 1000;
421             }
422 0           $type = "date";
423             } elsif ($scalar =~ m/[^0-9\.\-]/) {
424 0           $type = "string";
425             } elsif ($scalar =~ m/\..*\./) {
426             # More than 1 period (e.g. IP address)
427 0           $type = "string";
428             } elsif (($scalar =~ m/.\-/) or ($scalar eq '-')) {
429             # negative anywhere but at the beginning
430 0           $type = "string";
431             } elsif ($scalar =~ m/\./) {
432 0           $type = "double";
433             } elsif ($scalar eq '') {
434 0           $type = "string";
435             } else {
436 0           $type = "integer";
437             }
438 0           return ($type, $scalar);
439             }
440             1;