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