File Coverage

blib/lib/POE/XUL/Encode.pm
Criterion Covered Total %
statement 9 41 21.9
branch 0 8 0.0
condition 0 4 0.0
subroutine 3 10 30.0
pod 0 7 0.0
total 12 70 17.1


line stmt bran cond sub pod time code
1             package POE::XUL::Encode;
2             # Copyright Philip Gwyn 2007-2010. All rights reserved.
3              
4             #
5             # This was an attempt at a faster binary format for transmitting data
6             # to the browser. But JavaScript fails when it comes to binary formats
7             # so JSON is used
8             #
9              
10 19     19   72 use strict;
  19         24  
  19         439  
11 19     19   62 use warnings;
  19         19  
  19         349  
12              
13 19     19   9338 use Encode ();
  19         131865  
  19         7281  
14 0     0 0   sub content_type { return "application/vnd.poe-xul" }
15              
16             my $utf8 = Encode::find_encoding( "utf-8" );
17              
18             our $VERSION = '0.0601';
19              
20             my $ETB = "\x17"; # HASH/ARRAY end
21             my $FS = "\x1C"; # field sep
22             my $GS = "\x1D"; # HASH begin
23             my $RS = "\x1E"; # record sep
24             my $US = "\x1F"; # ARRAY begin
25              
26             sub encode
27             {
28 0     0 0   my( $package, $AofA ) = @_;
29 0           my @ret;
30 0           foreach my $A ( @$AofA ) {
31 0           push @ret, join $FS, map { $package->encode_S( $_ ) } @$A;
  0            
32             }
33 0           return Encode::encode $utf8, join $RS, @ret;
34             }
35              
36             sub encode_S
37             {
38 0     0 0   my( $package, $T ) = @_;
39 0           my $r = ref $T;
40 0 0         return $T unless $r;
41 0 0         return $GS.join( $FS, %$T ).$ETB if 'HASH' eq $r;
42 0 0         return $US.join( $FS, @$T ).$ETB if 'ARRAY' eq $r;
43 0           return $T;
44             }
45              
46             ########## Following is deprecated because JS can't handle binary data
47             sub pack_S
48             {
49 0     0 0   my( $package, $scalar ) = @_;
50 0           my $s = '' . $scalar;
51 0           return join '', $package->pack_number( length $s ), $s;
52             }
53              
54             sub pack_AofS
55             {
56 0     0 0   my( $package, $array ) = @_;
57 0   0       $array ||= [];
58 0           my @ret = $package->pack_number( 0+@$array );
59 0           foreach my $el ( @$array ) {
60 0           push @ret, $package->pack_S( $el );
61             }
62 0           return join '', @ret;
63             }
64              
65             sub pack_AofA
66             {
67 0     0 0   my( $package, $array ) = @_;
68 0   0       $array ||= [];
69 0           my @ret = $package->pack_number( 0+@$array );
70 0           foreach my $el ( @$array ) {
71 0           push @ret, $package->pack_AofS( $el );
72             }
73 0           return join '', @ret;
74             }
75              
76             sub pack_number
77             {
78 0     0 0   my( $package, $num ) = @_;
79 0 0         if( $num < 255 ) {
80 0           return pack "C", 0+$num;
81             }
82             else {
83 0           return pack "CN", 255, 0+$num;
84             }
85             }
86              
87             1;