File Coverage

blib/lib/Net/STOMP/Client/Auth.pm
Criterion Covered Total %
statement 18 48 37.5
branch 1 32 3.1
condition 1 6 16.6
subroutine 6 8 75.0
pod n/a
total 26 94 27.6


line stmt bran cond sub pod time code
1             #+##############################################################################
2             # #
3             # File: Net/STOMP/Client/Auth.pm #
4             # #
5             # Description: Authentication support for Net::STOMP::Client #
6             # #
7             #-##############################################################################
8              
9             #
10             # module definition
11             #
12              
13             package Net::STOMP::Client::Auth;
14 1     1   7 use strict;
  1         2  
  1         31  
15 1     1   6 use warnings;
  1         2  
  1         74  
16             our $VERSION = "2.5";
17             our $REVISION = sprintf("%d.%02d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/);
18              
19             #
20             # used modules
21             #
22              
23 1     1   488 use No::Worries::Die qw(dief);
  1         19864  
  1         7  
24 1     1   123 use Params::Validate qw(validate_pos :types);
  1         3  
  1         1123  
25              
26             #
27             # Authen::Credential is optional
28             #
29              
30             eval { require Authen::Credential };
31              
32             #
33             # check a single authentication
34             #
35              
36             sub _chkauth ($) {
37 0     0   0 my($auth) = @_;
38              
39 0 0       0 return(Authen::Credential->parse($auth))
40             if ref($auth) eq "";
41 0 0 0     0 return($auth)
42             if ref($auth) and $auth->isa("Authen::Credential");
43 0         0 dief("unexpected authentication: %s", $auth);
44             }
45              
46             #
47             # setup
48             #
49              
50             sub _setup ($) {
51 1     1   3 my($self) = @_;
52 1         3 my(@list, $scheme, $sslopts);
53              
54             # no additional options if Authen::Credential is not available!
55 1 50 33     31 return() unless $self or $Authen::Credential::VERSION;
56             # additional options for new()
57             return(
58 0 0         "auth" => { optional => 1, type => SCALAR|ARRAYREF|OBJECT },
59             ) unless $self;
60             # check the given authentication
61 0 0         return() unless $self->{"auth"};
62 0 0         if (ref($self->{"auth"}) eq "ARRAY") {
63 0           @list = map(_chkauth($_), @{ $self->{"auth"} });
  0            
64             } else {
65 0           @list = (_chkauth($self->{"auth"}));
66             }
67             # make sure we have at most one X.509 and one plain|none
68 0           foreach my $auth (@list) {
69 0           $auth->check();
70 0           $scheme = $auth->scheme();
71 0 0         if ($scheme eq "x509") {
    0          
    0          
72             dief("duplicate authentication: %s", $auth->string())
73 0 0         if exists($self->{"x509_auth"});
74 0           $self->{"x509_auth"} = $auth;
75             } elsif ($scheme eq "none") {
76             dief("duplicate authentication: %s", $auth->string())
77 0 0         if exists($self->{"plain_auth"});
78 0           $self->{"plain_auth"} = ""; # special case...
79             } elsif ($scheme eq "plain") {
80             dief("duplicate authentication: %s", $auth->string())
81 0 0         if exists($self->{"plain_auth"});
82 0           $self->{"plain_auth"} = $auth;
83             } else {
84 0           dief("unsupported authentication scheme: %s", $scheme);
85             }
86             }
87             # use the X.509 authentication via the socket options
88 0 0         if ($self->{"x509_auth"}) {
89 0           $sslopts = $self->{"x509_auth"}->prepare("IO::Socket::SSL");
90 0           while (my($name, $value) = each(%{ $sslopts })) {
  0            
91 0           $self->{"sockopts"}{$name} = $value;
92             }
93             }
94             }
95              
96             #
97             # hook for the CONNECT frame
98             #
99              
100             sub _connect_hook ($$) {
101 0     0     my($self, $frame) = @_;
102              
103 0 0         return unless $self->{"plain_auth"};
104             # do not override what the user did put in the frame
105 0 0         $frame->header("login", $self->{"plain_auth"}->name())
106             unless defined($frame->header("login"));
107 0 0         $frame->header("passcode", $self->{"plain_auth"}->pass())
108             unless defined($frame->header("passcode"));
109             }
110              
111             #
112             # register the setup and hook
113             #
114              
115             {
116 1     1   10 no warnings qw(once);
  1         2  
  1         233  
117             $Net::STOMP::Client::Setup{"auth"} = \&_setup;
118             $Net::STOMP::Client::Hook{"CONNECT"}{"auth"} = \&_connect_hook;
119             }
120              
121             1;
122              
123             __END__