File Coverage

blib/lib/XAS/Lib/Stomp/Utils.pm
Criterion Covered Total %
statement 12 162 7.4
branch 0 80 0.0
condition 0 3 0.0
subroutine 4 18 22.2
pod 13 13 100.0
total 29 276 10.5


line stmt bran cond sub pod time code
1             package XAS::Lib::Stomp::Utils;
2              
3             our $VERSION = '0.03';
4              
5 1     1   4 use XAS::Lib::Stomp::Frame;
  1         1  
  1         24  
6 1     1   3 use XAS::Constants ':stomp';
  1         2  
  1         5  
7              
8             use XAS::Class
9 1         13 debug => 0,
10             version => $VERSION,
11             base => 'XAS::Base',
12             utils => ':validation',
13             vars => {
14             PARAMS => {
15             -target => { optional => 1, default => undef, regex => STOMP_LEVELS },
16             }
17             }
18 1     1   203 ;
  1         1  
19              
20             #use Data::Dumper;
21              
22             # -----------------------------------------------------------
23             # Public Methods
24             # -----------------------------------------------------------
25              
26             sub connect {
27 0     0 1   my $self = shift;
28 0           my $p = validate_params(\@_, {
29             -login => { optional => 1, default => undef },
30             -passcode => { optional => 1, default => undef },
31             -host => { optional => 1, default => 'localhost' },
32             -heart_beat => { optional => 1, default => '0,0', regex => qr/\d+,\d+/ },
33             -acceptable => { optional => 1, default => '1.0,1.1,1.2',
34             callbacks => {
35             'valid target' => \&_match
36             }
37             }
38             });
39              
40 0           my $frame;
41 0           my $header = {};
42              
43 0 0         $header->{'login'} = $p->{'login'} if (defined($p->{'login'}));
44 0 0         $header->{'passcode'} = $p->{'passcode'} if (defined($p->{'passcode'}));
45              
46 0 0         if ($self->target > 1.0) {
47              
48 0           $header->{'host'} = $p->{'host'};
49 0           $header->{'heart-beat'} = $p->{'heart_beat'};
50 0           $header->{'accept-version'} = $p->{'acceptable'};
51              
52             }
53              
54 0           $frame = XAS::Lib::Stomp::Frame->new(
55             -command => 'CONNECT',
56             -headers => $header,
57             -body => ''
58             );
59              
60 0           return $frame;
61              
62             }
63              
64             sub stomp {
65 0     0 1   my $self = shift;
66 0           my $p = validate_params(\@_, {
67             -login => { optional => 1, default => undef },
68             -passcode => { optional => 1, default => undef },
69             -prefetch => { optional => 1, default => undef },
70             -host => { optional => 1, default => 'localhost' },
71             -heart_beat => { optional => 1, default => '0,0', regex => qr/\d+,\d+/ },
72             -acceptable => {
73             optional => 1,
74             default => '1.0,1.1,1.2',
75             callbacks => {
76             'valid target' => \&_match
77             }
78             }
79             });
80              
81 0           my $frame;
82 0           my $header = {};
83              
84 0 0         if ($self->target == 1.0) {
85              
86 0           $self->throw_msg(
87             'xas.lib.stomp.utils.stomp.nosup',
88             'stomp_no_support',
89             $self->target,
90             'stomp'
91             );
92              
93             }
94              
95 0 0         $header->{'login'} = $p->{'login'} if (defined($p->{'login'}));
96 0 0         $header->{'passcode'} = $p->{'passcode'} if (defined($p->{'passcode'}));
97 0 0         $header->{'prefetch-size'} = $p->{'prefetch'} if (defined($p->{'prefetch'}));
98              
99 0 0         if ($self->target > 1.0) {
100              
101 0           $header->{'host'} = $p->{'host'};
102 0           $header->{'heart-beat'} = $p->{'heart_beat'};
103 0           $header->{'accept-version'} = $p->{'acceptable'};
104              
105             }
106              
107 0           $frame = XAS::Lib::Stomp::Frame->new(
108             -command => 'STOMP',
109             -headers => $header,
110             -body => ''
111             );
112              
113 0           return $frame;
114              
115             }
116              
117             sub subscribe {
118 0     0 1   my $self = shift;
119 0           my $p = validate_params(\@_, {
120             -destination => 1,
121             -prefetch => { optional => 1, default => 0 },
122             -id => { optional => 1, default => undef },
123             -receipt => { optional => 1, default => undef },
124             -ack => { optional => 1, default => 'auto', regex => qr/auto|client|client\-individual/ },
125             });
126              
127 0           my $frame;
128 0           my $header = {};
129              
130 0           $header->{'ack'} = $p->{'ack'};
131 0           $header->{'prefetch-count'} = $p->{'prefetch'};
132 0           $header->{'destination'} = $p->{'destination'};
133 0 0         $header->{'receipt'} = $p->{'receipt'} if (defined($p->{'receipt'}));
134              
135 0 0         if (defined($p->{'id'})) {
136              
137 0           $header->{'id'} = $p->{'id'};
138              
139             } else {
140              
141             # v1.1 and greater must have an id header
142              
143 0 0         if ($self->target > 1.0) {
144              
145 0           $self->throw_msg(
146             'xas.lib.stomp.utils.subscribe',
147             'stomp_no_id',
148             $self->target
149            
150             );
151              
152             }
153              
154             }
155              
156 0           $frame = XAS::Lib::Stomp::Frame->new(
157             -command => 'SUBSCRIBE',
158             -headers => $header,
159             -body => ''
160             );
161              
162 0           return $frame;
163              
164             }
165              
166             sub unsubscribe {
167 0     0 1   my $self = shift;
168 0           my $p = validate_params(\@_, {
169             -id => { optional => 1, default => undef },
170             -destination => { optional => 1, default => undef },
171             -receipt => { optional => 1, default => undef },
172             });
173              
174 0           my $frame;
175 0           my $header = {};
176              
177 0 0         $header->{'receipt'} = $p->{'receipt'} if (defined($p->{'receipt'}));
178              
179             # v1.0 should have either a destination and/or id header
180             # v1.1 and greater may have a destination header
181              
182 0 0 0       if (defined($p->{'destination'}) && defined($p->{'id'})) {
    0          
    0          
183              
184 0           $header->{'id'} = $p->{'id'};
185 0           $header->{'destination'} = $p->{'destination'};
186              
187             } elsif (defined($p->{'destination'})) {
188              
189 0           $header->{'destination'} = $p->{'destination'};
190              
191             } elsif (defined($p->{'id'})) {
192              
193 0           $header->{'id'} = $p->{'id'};
194              
195             } else {
196              
197 0           $self->throw_msg(
198             'xas.lib.stomp.utils.unsubscribe.invparams',
199             'stomp_invalid_params',
200             $self->target
201             );
202              
203             }
204              
205 0 0         if ($self->target > 1.0) {
206              
207             # v1.1 and greater must have an id header
208              
209 0 0         unless (defined($header->{'id'})) {
210              
211 0           $self->throw_msg(
212             'xas.lib.stomp.utils.unsubscribe.noid',
213             'stomp_no_id',
214             $self->target
215             );
216              
217             }
218              
219             }
220              
221 0           $frame = XAS::Lib::Stomp::Frame->new(
222             -command => 'UNSUBSCRIBE',
223             -headers => $header,
224             -body => ''
225             );
226              
227 0           return $frame;
228              
229             }
230              
231             sub begin {
232 0     0 1   my $self = shift;
233 0           my $p = validate_params(\@_, {
234             -transaction => 1,
235             -receipt => { optional => 1, default => undef },
236             });
237              
238 0           my $frame;
239 0           my $header = {};
240              
241 0           $header->{'transaction'} = $p->{'transaction'};
242 0 0         $header->{'receipt'} = $p->{'receipt'} if (defined($p->{'receipt'}));
243              
244 0           $frame = XAS::Lib::Stomp::Frame->new(
245             -command => 'BEGIN',
246             -headers => $header,
247             -body => ''
248             );
249              
250 0           return $frame;
251              
252             }
253              
254             sub commit {
255 0     0 1   my $self = shift;
256 0           my $p = validate_params(\@_, {
257             -transaction => 1,
258             -receipt => { optional => 1, default => undef },
259             });
260              
261 0           my $frame;
262 0           my $header = {};
263              
264 0           $header->{'transaction'} = $p->{'transaction'};
265 0 0         $header->{'receipt'} = $p->{'receipt'} if (defined($p->{'receipt'}));
266              
267 0           $frame = XAS::Lib::Stomp::Frame->new(
268             -command => 'COMMIT',
269             -headers => $header,
270             -body => ''
271             );
272              
273 0           return $frame;
274              
275             }
276              
277             sub abort {
278 0     0 1   my $self = shift;
279 0           my $p = validate_params(\@_, {
280             -transaction => 1,
281             -receipt => { optional => 1, default => undef },
282             });
283              
284 0           my $frame;
285 0           my $header = {};
286              
287 0           $header->{'transaction'} = $p->{'transaction'};
288 0 0         $header->{'receipt'} = $p->{'receipt'} if (defined($p->{'receipt'}));
289              
290 0           $frame = XAS::Lib::Stomp::Frame->new(
291             -command => 'ABORT',
292             -headers => $header,
293             -body => ''
294             );
295              
296 0           return $frame;
297              
298             }
299              
300             sub ack {
301 0     0 1   my $self = shift;
302 0           my $p = validate_params(\@_, {
303             -message_id => 1,
304             -subscription => { optional => 1, default => undef },
305             -receipt => { optional => 1, default => undef },
306             -transaction => { optional => 1, default => undef },
307             });
308              
309 0           my $frame;
310 0           my $header = {};
311              
312 0 0         $header->{'receipt'} = $p->{'receipt'} if (defined($p->{'receipt'}));
313 0 0         $header->{'transaction'} = $p->{'transaction'} if (defined($p->{'transaction'}));
314              
315 0 0         if ($self->target < 1.2) {
316              
317 0           $header->{'message-id'} = $p->{'message_id'};
318              
319             } else {
320              
321 0           $header->{'id'} = $p->{'message_id'};
322              
323             }
324              
325 0 0         if (defined($p->{'subscription'})) {
326              
327 0           $header->{'subscription'} = $p->{'subscription'};
328              
329             } else {
330              
331 0 0         if ($self->target > 1.0) {
332              
333 0           $self->throw_msg(
334             'xas.lib.stomp.utils.ack.nosup',
335             'stomp_no_subscription',
336             $self->target
337             );
338              
339             }
340              
341             }
342              
343 0           $frame = XAS::Lib::Stomp::Frame->new(
344             -command => 'ACK',
345             -headers => $header,
346             -body => ''
347             );
348              
349 0           return $frame;
350              
351             }
352              
353             sub nack {
354 0     0 1   my $self = shift;
355 0           my $p = validate_params(\@_, {
356             -message_id => 1,
357             -receipt => { optional => 1, default => undef },
358             -subscription => { optional => 1, default => undef },
359             -transaction => { optional => 1, default => undef },
360             });
361              
362 0           my $frame;
363 0           my $header = {};
364              
365 0 0         $header->{'receipt'} = $p->{'receipt'} if (defined($p->{'receipt'}));
366 0 0         $header->{'transaction'} = $p->{'transaction'} if (defined($p->{'transaction'}));
367              
368 0 0         if ($self->target == 1.0) {
369              
370 0           $self->throw_msg(
371             'xas.lib.stomp.utils.nack',
372             'stomp_no_support',
373             $self->target,
374             'nack'
375             );
376              
377             }
378              
379 0 0         if ($self->target < 1.2) {
380              
381 0           $header->{'message-id'} = $p->{'message_id'};
382              
383             } else {
384              
385 0           $header->{'id'} = $p->{'message_id'};
386              
387             }
388              
389 0 0         if (defined($p->{'subscription'})) {
390              
391 0           $header->{'subscription'} = $p->{'subscription'};
392              
393             } else {
394              
395 0 0         if ($self->target > 1.0) {
396              
397 0           $self->throw_msg(
398             'xas.lib.stomp.utils.nact',
399             'stomp_no_support',
400             $self->target,
401             'nack'
402             );
403              
404             }
405              
406             }
407              
408 0           $frame = XAS::Lib::Stomp::Frame->new(
409             -command => 'NACK',
410             -headers => $header,
411             -body => ''
412             );
413              
414 0           return $frame;
415              
416             }
417              
418             sub disconnect {
419 0     0 1   my $self = shift;
420 0           my $p = validate_params(\@_, {
421             -receipt => { optional => 1, default => undef }
422             });
423              
424 0           my $frame;
425 0           my $header = {};
426              
427 0 0         $header->{'receipt'} = $p->{'receipt'} if (defined($p->{'receipt'}));
428              
429 0           $frame = XAS::Lib::Stomp::Frame->new(
430             -command => 'DISCONNECT',
431             -headers => $header,
432             -body => ''
433             );
434              
435 0           return $frame;
436              
437             }
438              
439             sub send {
440 0     0 1   my $self = shift;
441 0           my $p = validate_params(\@_, {
442             -destination => 1,
443             -message => 1,
444             -receipt => { optional => 1, default => undef },
445             -persistent => { optional => 1, default => undef },
446             -transaction => { optional => 1, default => undef },
447             -length => { optional => 1, default => undef },
448             -type => { optional => 1, default => 'text/plain' },
449             });
450              
451 0           my $frame;
452 0           my $header = {};
453 0           my $body = $p->{'message'};
454              
455 0           $header->{'destination'} = $p->{'destination'};
456 0 0         $header->{'receipt'} = $p->{'receipt'} if (defined($p->{'receipt'}));
457 0 0         $header->{'persistent'} = $p->{'persistent'} if (defined($p->{'presistent'}));
458 0 0         $header->{'transaction'} = $p->{'transaction'} if (defined($p->{'transaction'}));
459             {
460 1     1   1681 use bytes;
  1         1  
  1         6  
  0            
461 0 0         $header->{'content-length'} = defined($p->{'length'}) ? $p->{'length'} : length($body);
462             }
463              
464 0 0         if ($self->target > 1.0) {
465              
466 0           $header->{'content-type'} = $p->{'type'};
467              
468             }
469              
470 0           $frame = XAS::Lib::Stomp::Frame->new(
471             -command => 'SEND',
472             -headers => $header,
473             -body => $body
474             );
475              
476 0           return $frame;
477              
478             }
479              
480             sub noop {
481 0     0 1   my $self = shift;
482              
483 0           my $frame;
484              
485 0 0         if ($self->target == 1.0) {
486              
487 0           $self->throw_msg(
488             'xas.lib.stomp.utils.noop.nosup',
489             'stomp_no_support',
490             $self->target,
491             'noop'
492             );
493              
494             }
495              
496 0           $frame = XAS::Lib::Stomp::Frame->new(
497             -command => 'NOOP',
498             -headers => {},
499             -body => ''
500             );
501              
502 0           return $frame;
503              
504             }
505              
506             # -----------------------------------------------------------
507             # Private Methods
508             # -----------------------------------------------------------
509              
510             sub init {
511 0     0 1   my $class = shift;
512              
513 0           my $self = $class->SUPER::init(@_);
514              
515 0 0         unless (defined($self->{target})) {
516              
517 0           $self->{target} = $self->env->mqlevel;
518              
519             }
520              
521 0           return $self;
522              
523             }
524              
525             sub _match {
526 0     0     my $buffer = shift;
527              
528 0           foreach my $item (split(',', $buffer)) {
529              
530 0 0         return 0 if ($item !~ m/\d\.\d/);
531              
532             }
533              
534 0           return 1;
535              
536             }
537              
538             1;
539              
540             __END__