File Coverage

blib/lib/Net/STOMP/Client/Version.pm
Criterion Covered Total %
statement 24 68 35.2
branch 1 32 3.1
condition n/a
subroutine 8 13 61.5
pod 2 2 100.0
total 35 115 30.4


line stmt bran cond sub pod time code
1             #+##############################################################################
2             # #
3             # File: Net/STOMP/Client/Version.pm #
4             # #
5             # Description: Version support for Net::STOMP::Client #
6             # #
7             #-##############################################################################
8              
9             #
10             # module definition
11             #
12              
13             package Net::STOMP::Client::Version;
14 1     1   4 use strict;
  1         0  
  1         23  
15 1     1   3 use warnings;
  1         1  
  1         60  
16             our $VERSION = "2.3";
17             our $REVISION = sprintf("%d.%02d", q$Revision: 2.3 $ =~ /(\d+)\.(\d+)/);
18              
19             #
20             # used modules
21             #
22              
23 1     1   3 use No::Worries::Die qw(dief);
  1         1  
  1         11  
24 1     1   67 use No::Worries::Export qw(export_control);
  1         1  
  1         4  
25 1     1   59 use Params::Validate qw(validate_pos :types);
  1         1  
  1         591  
26              
27             #
28             # global variables
29             #
30              
31             our(
32             %Supported, # hash of the supported STOMP protocol versions
33             );
34              
35             foreach my $version (qw(1.0 1.1 1.2)) {
36             $Supported{$version}++;
37             }
38              
39             #
40             # check a list of acceptable versions
41             #
42              
43             sub _check ($) {
44 0     0   0 my($value) = @_;
45              
46 0 0       0 unless (defined($value)) {
47             # undef: accept all supported
48 0         0 return(sort(keys(%Supported)));
49             }
50 0 0       0 if (ref($value) eq "") {
51             # scalar
52 0 0       0 if ($value =~ /,/) {
53             # assume a comma separated list
54 0         0 $value = [ split(/,/, $value) ];
55             # (will be checked further down)
56             } else {
57             # assume a single version
58             dief("unsupported STOMP version: %s", $value)
59 0 0       0 unless $Supported{$value};
60 0         0 return($value);
61             }
62             }
63 0 0       0 if (ref($value) eq "ARRAY") {
64             # array reference: accept all given
65 0         0 foreach my $version (@{ $value }) {
  0         0  
66             dief("unsupported STOMP version: %s", $version)
67 0 0       0 unless $Supported{$version};
68             }
69 0         0 return(@{ $value });
  0         0  
70             }
71 0         0 dief("unexpected STOMP version: %s", $value);
72             }
73              
74             #
75             # get/set the acceptable versions
76             #
77              
78             sub accept_version : method {
79 0     0 1 0 my($self);
80              
81 0         0 $self = shift(@_);
82 0 0       0 return(@{ $self->{"accept_version"} }) if @_ == 0;
  0         0  
83 0 0       0 if (@_ == 1) {
84 0         0 $self->{"accept_version"} = [ _check($_[0]) ];
85 0         0 return($self);
86             }
87             # otherwise complain...
88 0         0 validate_pos(@_, { optional => 1, type => UNDEF|SCALAR|ARRAYREF });
89             }
90              
91             #
92             # get the negotiated version
93             #
94              
95             sub version : method {
96 0     0 1 0 my($self) = @_;
97              
98 0         0 return($self->{"version"});
99             }
100              
101             #
102             # setup
103             #
104              
105             sub _setup ($) {
106 1     1   1 my($self) = @_;
107              
108             # additional options for new()
109             return(
110 1 50       8 "accept_version" => { optional => 1, type => UNDEF|SCALAR|ARRAYREF },
111             "version" => { optional => 1, type => UNDEF|SCALAR|ARRAYREF },
112             ) unless $self;
113             # FIXME: compatibility hack for Net::STOMP::Client 1.x (to be removed)
114 0 0       0 if (exists($self->{"version"})) {
115             dief("options version and accept_version are mutually exclusive")
116 0 0       0 if exists($self->{"accept_version"});
117 0         0 $self->{"accept_version"} = delete($self->{"version"});
118             }
119             # check the accept_version option (and set defaults)
120 0         0 $self->accept_version($self->{"accept_version"});
121             }
122              
123             #
124             # hook for the CONNECT frame
125             #
126              
127             sub _connect_hook ($$) {
128 0     0   0 my($self, $frame) = @_;
129 0         0 my(@list);
130              
131             # do not override what the user did put in the frame
132 0 0       0 return if defined($frame->header("accept-version"));
133             # do nothing when only STOMP 1.0 is asked
134 0         0 @list = $self->accept_version();
135 0 0       0 return unless grep($_ ne "1.0", @list);
136             # add the appropriate header
137 0         0 $frame->header("accept-version", join(",", @list));
138             }
139              
140             #
141             # hook for the CONNECTED frame
142             #
143              
144             sub _connected_hook ($$) {
145 0     0   0 my($self, $frame) = @_;
146 0         0 my(@list, $version);
147              
148 0         0 @list = $self->accept_version();
149 0         0 $version = $frame->header("version");
150 0 0       0 if (defined($version)) {
151             # the server must have chosen an acceptable version
152 0 0       0 dief("unexpected STOMP version: %s", $version)
153             unless grep($_ eq $version, @list);
154             } else {
155             # no version header present so assume 1.0
156 0         0 $version = "1.0";
157 0 0       0 dief("server only supports STOMP 1.0")
158             unless grep($_ eq $version, @list);
159             }
160             # so far so good
161 0         0 $self->{"version"} = $version;
162             }
163              
164             #
165             # register the setup and hooks
166             #
167              
168             {
169 1     1   4 no warnings qw(once);
  1         1  
  1         141  
170             $Net::STOMP::Client::Setup{"version"} = \&_setup;
171             $Net::STOMP::Client::Hook{"CONNECT"}{"version"} = \&_connect_hook;
172             $Net::STOMP::Client::Hook{"CONNECTED"}{"version"} = \&_connected_hook;
173             }
174              
175             #
176             # export control
177             #
178              
179             sub import : method {
180 1     1   2 my($pkg, %exported);
181              
182 1         1 $pkg = shift(@_);
183 1         3 grep($exported{$_}++, qw(accept_version version));
184 1         4 export_control(scalar(caller()), $pkg, \%exported, @_);
185             }
186              
187             1;
188              
189             __END__