1package Net::AMQP::Frame::Header;
2
3=head1 NAME
4
5Net::AMQP::Frame::Header - AMQP wire-level header Frame object
6
7=head1 DESCRIPTION
8
9Inherits from L<Net::AMQP::Frame>.
10
11=cut
12
13use strict;
14use warnings;
15use base qw(Net::AMQP::Frame);
16use Net::AMQP::Common qw(:all);
17use Carp qw(croak cluck);
18
19BEGIN {
20    __PACKAGE__->mk_accessors(qw(
21        class_id
22        weight
23        body_size
24        header_frame
25    ));
26}
27__PACKAGE__->type_id(2);
28
29=head1 OBJECT METHODS
30
31Provides the following field accessors
32
33=over 4
34
35=item I<class_id>
36
37=item I<weight>
38
39=item I<body_size>
40
41=item I<header_frame>
42
43Exposes the L<Net::AMQP::Protocol::Base> object that this frame wraps
44
45=back
46
47=cut
48
49my $Registered_header_classes = {};
50
51sub register_header_class {
52    my ($self_class, $header_class) = @_;
53
54    my $class_id = $header_class->class_id;
55
56    if (exists $Registered_header_classes->{$class_id}) {
57        my $exists = $Registered_header_classes->{$class_id}->{class};
58        croak "Can't register header class for $class_id: already used by '$exists'";
59    }
60
61    my $arguments = $header_class->frame_arguments;
62    my (@frame_args, @pack_args, @unpack_args);
63
64    for (my $i = 0; $i < @$arguments; $i += 2) {
65        my ($key, $type) = ($arguments->[$i], $arguments->[$i + 1]);
66        no strict 'refs';
67        push @frame_args,  $key;
68        push @pack_args,   ($type eq 'bit') ? 'bit' : *{'Net::AMQP::Common::pack_'   . $type};
69        push @unpack_args, ($type eq 'bit') ? 'bit' : *{'Net::AMQP::Common::unpack_' . $type};
70    }
71
72    $Registered_header_classes->{$class_id} = {
73        class       => $header_class,
74        frame_args  => \@frame_args,
75        pack_args   => \@pack_args,
76        unpack_args => \@unpack_args,
77    };
78}
79
80sub parse_payload {
81    my $self = shift;
82
83    my $payload_ref = \$$self{payload};
84
85    $self->class_id(  unpack_short_integer($payload_ref) );
86    $self->weight(    unpack_short_integer($payload_ref) );
87    $self->body_size( unpack_long_long_integer($payload_ref) );
88
89    my $registered = $Registered_header_classes->{ $self->class_id } or
90                     croak "Failed to find a header class to handle ".$self->class_id;
91
92    my $header_class = $registered->{class};
93    my $arguments    = $registered->{frame_args};
94    my $unpack_args  = $registered->{unpack_args};
95    my %header_frame;
96    my @fields_set;
97
98    while (1) {
99        # Unpack property flags
100        push @fields_set, split '', unpack("B16", substr($$payload_ref, 0, 2, ''));
101        # If bit 0 is true, there are more bytes to unpack
102        last unless (pop @fields_set);
103    }
104
105    for (my $i = 0; $i < @$arguments; $i++) {
106
107        next unless ($fields_set[$i]);
108
109        # $unpack_args->[$i] is a coderef of Net::AMQP::Common::unpack_$type
110        my $value = $unpack_args->[$i]->( $payload_ref );
111
112        if (! defined $value) {
113            my ($key, $unpacker) = ($arguments->[$i], $unpack_args->[$i]);
114            die "Failed to unpack key '$key' with $unpacker for frame of type '$header_class' from input '$$payload_ref'";
115        }
116
117        $header_frame{$arguments->[$i]} = $value;
118    }
119
120    $self->header_frame($header_class->new(%header_frame));
121}
122
123sub to_raw_payload {
124    my $self = shift;
125
126    my $header_frame = $self->header_frame;
127
128    my $class_id = $self->class_id;
129    $class_id = $self->class_id( $header_frame->class_id ) unless defined $class_id;
130
131    my $response_payload = '';
132    $response_payload .= pack_short_integer($class_id);
133    $response_payload .= pack_short_integer($self->weight);
134    $response_payload .= pack_long_long_integer($self->body_size);
135
136    my $registered = $Registered_header_classes->{$class_id};
137    my $arguments  = $registered->{frame_args};
138    my $pack_args  = $registered->{pack_args};
139    my $raw_values = '';
140    my $fields_set = '';
141
142    for (my $i = 0; $i < @$arguments; $i++) {
143
144        if (! defined $header_frame->{$arguments->[$i]}) {
145            $fields_set .= '0';
146            next;
147        }
148        else {
149            $fields_set .= '1';
150        }
151
152        # $pack_args->[$i] is a coderef of Net::AMQP::Common::pack_$type
153        my $value = $pack_args->[$i]->( $header_frame->{$arguments->[$i]} );
154
155        if (! defined $value) {
156            my ($key, $packer) = ($arguments->[$i], $pack_args->[$i]);
157            die "Failed to pack key '$key' with $packer for frame of type '".ref($header_frame)."' from input '$$header_frame{$key}'";
158        }
159
160        $raw_values .= $value;
161    }
162
163    while (length $fields_set) {
164        # Pack property flags
165        my $flags = substr($fields_set, 0, 15, '');
166        $flags .= '0' x (15 - length $flags);
167        # Set bit 0 if there are more bits to pack
168        $flags .= (length $fields_set) ? '1' : '0';
169        $response_payload .= pack("B16", $flags);
170    }
171
172    $response_payload .= $raw_values;
173
174    return $response_payload;
175}
176
177=head1 SEE ALSO
178
179L<Net::AMQP::Frame>
180
181=head1 COPYRIGHT
182
183Copyright (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.
184
185The full text of the license can be found in the LICENSE file included with this module.
186
187=head1 AUTHOR
188
189Eric Waters <ewaters@gmail.com>
190
191=cut
192
1931;
194