1package Net::AMQP::Common;
2use 5.006;
3
4=head1 NAME
5
6Net::AMQP::Common - A collection of exportable tools for AMQP (de)serialization
7
8=head1 SYNOPSIS
9
10  use Net::AMQP::Common qw(:all)
11
12=head1 EXPORTABLE METHODS
13
14The following are available for exporting by name or by ':all'.  All the 'pack_*' methods take a single argument and return a binary string.  All the 'unpack_*' methods take a scalar ref and return a perl data structure of some type, consuming some data from the scalar ref.
15
16=over 4
17
18=item I<pack_octet>
19
20=item I<unpack_octet>
21
22=item I<pack_short_integer>
23
24=item I<unpack_short_integer>
25
26=item I<pack_long_integer>
27
28=item I<unpack_long_integer>
29
30=item I<pack_long_long_integer>
31
32=item I<unpack_long_long_integer>
33
34=item I<pack_unsigned_short_integer>
35
36=item I<unpack_unsigned_short_integer>
37
38=item I<pack_unsigned_long_integer>
39
40=item I<unpack_unsigned_long_integer>
41
42=item I<pack_unsigned_long_long_integer>
43
44=item I<unpack_unsigned_long_long_integer>
45
46=item I<pack_timestamp>
47
48=item I<unpack_timestamp>
49
50=item I<pack_boolean>
51
52=item I<unpack_boolean>
53
54=item I<pack_short_string>
55
56=item I<unpack_short_string>
57
58=item I<pack_field_table>
59
60=item I<unpack_field_table>
61
62=item I<pack_field_array>
63
64Tables and arrays sometimes require explicit typing.  See
65L<Net::AMQP::Value>.  Also, in tables and arrays booleans from the
66L<boolean> module are sent as AMQP booleans.
67
68=item I<unpack_field_array>
69
70=item I<%data_type_map>
71
72A mapping of the XML spec's data type names to our names ('longstr' => 'long_string')
73
74=item I<show_ascii>
75
76A helper routine that, given a binary string, returns a string of each byte represented by '\###', base 10 numbering.
77
78=back
79
80=cut
81
82use strict;
83use warnings;
84use Scalar::Util qw( blessed reftype );
85use Net::AMQP::Value;
86use base qw(Exporter);
87
88BEGIN {
89    *_big = (pack('n', 1) eq pack('s', 1))
90      ? sub { shift }
91      : sub { scalar reverse shift };
92}
93
94our @EXPORT_OK = qw(
95    pack_octet                      unpack_octet
96    pack_short_integer              unpack_short_integer
97    pack_long_integer               unpack_long_integer
98    pack_long_long_integer          unpack_long_long_integer
99    pack_unsigned_short_integer     unpack_unsigned_short_integer
100    pack_unsigned_long_integer      unpack_unsigned_long_integer
101    pack_unsigned_long_long_integer unpack_unsigned_long_long_integer
102    pack_timestamp                  unpack_timestamp
103    pack_boolean                    unpack_boolean
104    pack_short_string               unpack_short_string
105    pack_long_string                unpack_long_string
106    pack_field_table                unpack_field_table
107    pack_field_array                unpack_field_array
108    show_ascii
109    %data_type_map
110);
111
112our %EXPORT_TAGS = (
113    'all' => [@EXPORT_OK],
114);
115
116# The XML spec uses a abbreviated name; map this to my name
117our %data_type_map = (
118    bit       => 'bit',
119    octet     => 'octet',
120    short     => 'short_integer',
121    long      => 'long_integer',
122    longlong  => 'long_long_integer',
123    shortstr  => 'short_string',
124    longstr   => 'long_string',
125    timestamp => 'timestamp',
126    table     => 'field_table',
127    array     => 'field_array',
128);
129
130sub pack_boolean                       {      pack 'C', shift() ? 1 : 0 }
131sub pack_octet                         {      pack 'C', shift || 0 }
132sub pack_short_integer                 { _big pack 's', shift || 0 }
133sub pack_long_integer                  { _big pack 'l', shift || 0 }
134sub pack_long_long_integer             { _big pack 'q', shift || 0 }
135sub pack_unsigned_short_integer        {      pack 'n', shift || 0 }
136sub pack_unsigned_long_integer         {      pack 'N', shift || 0 }
137sub pack_unsigned_long_long_integer    { _big pack 'Q', shift || 0 }
138
139sub unpack_boolean                     { unpack 'C',      substr ${+shift}, 0, 1, '' }
140sub unpack_octet                       { unpack 'C',      substr ${+shift}, 0, 1, '' }
141sub unpack_short_integer               { unpack 's', _big substr ${+shift}, 0, 2, '' }
142sub unpack_long_integer                { unpack 'l', _big substr ${+shift}, 0, 4, '' }
143sub unpack_long_long_integer           { unpack 'q', _big substr ${+shift}, 0, 8, '' }
144sub unpack_unsigned_short_integer      { unpack 'n',      substr ${+shift}, 0, 2, '' }
145sub unpack_unsigned_long_integer       { unpack 'N',      substr ${+shift}, 0, 4, '' }
146sub unpack_unsigned_long_long_integer  { unpack 'Q', _big substr ${+shift}, 0, 8, '' }
147
148sub pack_timestamp   { goto &pack_unsigned_long_long_integer }
149sub unpack_timestamp { goto &unpack_unsigned_long_long_integer }
150
151sub pack_short_string {
152    my $str = shift;
153    $str = '' unless defined $str;
154    return pack('C', length $str) . $str;
155}
156
157sub unpack_short_string {
158    my $input_ref = shift;
159    my $string_length = unpack 'C', substr $$input_ref, 0, 1, '';
160    return substr $$input_ref, 0, $string_length, '';
161}
162
163sub pack_long_string {
164    if (ref $_[0] && ref $_[0] eq 'HASH') {
165        # It appears that, for fields that are long-string, in some cases it's
166        # necessary to pass a field-table object, which behaves similarly.
167        # Here for Connection::StartOk->response
168        return pack_field_table(@_);
169    }
170    my $str = shift;
171    $str = '' unless defined $str;
172    return pack('N', length $str) . $str;
173}
174
175sub unpack_long_string {
176    my $input_ref = shift;
177    my $string_length = unpack 'N', substr $$input_ref, 0, 4, '';
178    return substr $$input_ref, 0, $string_length, '';
179}
180
181sub pack_field_table {
182    my $table = shift;
183    $table = {} unless defined $table;
184
185    my $table_packed = '';
186    foreach my $key (sort keys %$table) { # sort so I can compare raw frames
187        my $value = $table->{$key};
188        $table_packed .= pack_short_string($key);
189        $table_packed .= _pack_field_value($table->{$key});
190    }
191    return pack('N', length $table_packed) . $table_packed;
192}
193
194sub pack_field_array {
195    my $array = shift;
196    $array = [] unless defined $array;
197
198    my $array_packed = '';
199    foreach my $value (@$array) {
200        $array_packed .= _pack_field_value($value);
201    }
202
203    return pack('N', length $array_packed) . $array_packed;
204}
205
206sub _pack_field_value {
207    my ($value) = @_;
208    if (not defined $value) {
209        'V'
210    }
211    elsif (not ref $value) {
212        if ($value =~ /^-?\d+\z/) {
213            'I' . pack_long_integer($value);
214        } else {
215            # FIXME - assuming that all other values are string values
216            'S' . pack_long_string($value);
217        }
218    }
219    elsif (ref($value) eq 'HASH') {
220        'F' . pack_field_table($value);
221    }
222    elsif (ref($value) eq 'ARRAY') {
223        'A' . pack_field_array($value);
224    }
225    elsif (ref($value) eq 'boolean') {
226        't' . pack_boolean($value);
227    }
228    elsif (blessed($value) && $value->isa('Net::AMQP::Value')) {
229        $value->field_packed;
230    }
231    else {
232        die "No way to pack $value into AMQP array or table";
233    }
234}
235
236my %_unpack_field_types = (
237    V => sub { undef },
238    S => \&unpack_long_string,
239    I => \&unpack_long_integer,
240    D => sub {
241        my $input_ref = shift;
242        my $exp = unpack_octet($input_ref);
243        my $num = unpack_long_integer($input_ref);
244        $num / 10.0 ** $exp;
245    },
246    F => \&unpack_field_table,
247    A => \&unpack_field_array,
248    T => \&unpack_timestamp,
249    t => \&unpack_boolean,
250);
251
252sub unpack_field_table {
253    my $input_ref = shift;
254
255    my ($table_length) = unpack 'N', substr $$input_ref, 0, 4, '';
256
257    my $table_input = substr $$input_ref, 0, $table_length, '';
258
259    my %table;
260    while (length $table_input) {
261        my $field_name = unpack_short_string(\$table_input);
262
263        my ($field_value_type) = substr $table_input, 0, 1, '';
264        my $field_value_subref = $_unpack_field_types{$field_value_type};
265        die "No way to unpack field '$field_name' type '$field_value_type'" unless defined $field_value_subref;
266
267        my $field_value = $field_value_subref->(\$table_input);
268        die "Failed to unpack field '$field_name' type '$field_value_type' ('$table_input')" unless defined $field_value;
269
270        $table{ $field_name } = $field_value;
271    }
272
273    return \%table;
274}
275
276sub unpack_field_array {
277    my $input_ref = shift;
278
279    my ($array_length) = unpack 'N', substr $$input_ref, 0, 4, '';
280
281    my $array_input = substr $$input_ref, 0, $array_length, '';
282
283    my @array;
284    while (length $array_input) {
285        my $field_value_type = substr $array_input, 0, 1, '';
286        my $field_value_subref = $_unpack_field_types{$field_value_type};
287        die "No way to unpack field array element ".@array." type '$field_value_type'" unless defined $field_value_subref;
288
289        my $field_value = $field_value_subref->(\$array_input);
290        die "Failed to unpack field array element ".@array." type '$field_value_type' ('$array_input')" unless defined $field_value;
291
292        push @array, $field_value;
293    }
294
295    return \@array;
296}
297
298sub show_ascii {
299    my $input = shift;
300
301    my $return = '';
302
303    foreach my $char (split(//, $input)) {
304        my $num = unpack 'C', $char;
305        if (0 && $char =~ m{^[0-9A-Za-z]$}) {
306            $return .= $char;
307        }
308        else {
309            $return .= sprintf '\%03d', $num;
310        }
311    }
312
313    return $return;
314}
315
316=head1 SEE ALSO
317
318L<Net::AMQP>
319
320=head1 COPYRIGHT
321
322Copyright (c) 2009 Eric Waters and XMission LLC (http://www.xmission.com/).  All rights reserved.  This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
323
324The full text of the license can be found in the LICENSE file included with this module.
325
326=head1 AUTHOR
327
328Eric Waters <ewaters@gmail.com>
329
330=cut
331
3321;
333