File Coverage

blib/lib/Authen/SASL.pm
Criterion Covered Total %
statement 36 54 66.7
branch 12 32 37.5
condition 2 9 22.2
subroutine 8 14 57.1
pod 5 10 50.0
total 63 119 52.9


line stmt bran cond sub pod time code
1             # Copyright (c) 2004-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
2             # This program is free software; you can redistribute it and/or
3             # modify it under the same terms as Perl itself.
4              
5             package Authen::SASL;
6              
7 8     8   179 use strict;
  8         73  
  8         299  
8 8     8   115 use vars qw($VERSION @Plugins);
  8         74  
  8         111  
9 8     8   240 use Carp;
  8         93  
  8         159  
10              
11             $VERSION = "2.10";
12              
13             @Plugins = qw(
14             Authen::SASL::Cyrus
15             Authen::SASL::Perl
16             );
17              
18              
19             sub import {
20 8     8   75   shift;
21 8 50       104   return unless @_;
22              
23 8         127   local $SIG{__DIE__};
24 8 50       86   @Plugins = grep { /^[:\w]+$/ and eval "require $_" } map { /::/ ? $_ : "Authen::SASL::$_" } @_
  8 50       436  
  8 50       135  
25                 or croak "no valid Authen::SASL plugins found";
26             }
27              
28              
29             sub new {
30 22     22 0 277   my $pkg = shift;
31 22 50       319   my %opt = ((@_ % 2 ? 'mechanism' : ()), @_);
32              
33 22   33     4711   my $self = bless {
34                 mechanism => $opt{mechanism} || $opt{mech},
35                 callback => {},
36               }, $pkg;
37              
38 22 50       691   $self->callback(%{$opt{callback}}) if ref($opt{callback}) eq 'HASH';
  22         1040  
39              
40             # Compat
41 22 50       303   $self->callback(user => ($self->{user} = $opt{user})) if exists $opt{user};
42 22 50       272   $self->callback(pass => $opt{password}) if exists $opt{password};
43 22 50       233   $self->callback(pass => $opt{response}) if exists $opt{response};
44              
45 22         251   $self;
46             }
47              
48              
49             sub mechanism {
50 44     44 1 405   my $self = shift;
51 44 50       1742   @_ ? $self->{mechanism} = shift
52                  : $self->{mechanism};
53             }
54              
55             sub callback {
56 44     44 1 729   my $self = shift;
57              
58 44 50       574   return $self->{callback}{$_[0]} if @_ == 1;
59              
60 44         527   my %new = @_;
61 44         681   @{$self->{callback}}{keys %new} = values %new;
  44         564  
62              
63 44         1079   $self->{callback};
64             }
65              
66             # The list of packages should not really be hardcoded here
67             # We need some way to discover what plugins are installed
68              
69             sub client_new { # $self, $service, $host, $secflags
70 22     22 1 199   my $self = shift;
71              
72 22         526   foreach my $pkg (@Plugins) {
73 22 50 33     1290     if (eval "require $pkg" and $pkg->can("client_new")) {
74 22         385       return ($self->{conn} = $pkg->client_new($self, @_));
75                 }
76               }
77              
78 0             croak "Cannot find a SASL Connection library";
79             }
80              
81             sub server_new { # $self, $service, $host, $secflags
82 0     0 1     my $self = shift;
83              
84 0             foreach my $pkg (@Plugins) {
85 0 0 0           if (eval "require $pkg" and $pkg->can("server_new")) {
86 0                 return ($self->{conn} = $pkg->server_new($self, @_));
87                 }
88               }
89 0             croak "Cannot find a SASL Connection library for server-side authentication";
90             }
91              
92             sub error {
93 0     0 1     my $self = shift;
94 0 0           $self->{conn} && $self->{conn}->error;
95             }
96              
97             # Compat.
98             sub user {
99 0     0 0     my $self = shift;
100 0             my $user = $self->{callback}{user};
101 0 0           $self->{callback}{user} = shift if @_;
102 0             $user;
103             }
104              
105             sub challenge {
106 0     0 0     my $self = shift;
107 0             $self->{conn}->client_step(@_);
108             }
109              
110             sub initial {
111 0     0 0     my $self = shift;
112 0             $self->client_new($self)->client_start;
113             }
114              
115             sub name {
116 0     0 0     my $self = shift;
117 0 0           $self->{conn} ? $self->{conn}->mechanism : ($self->{mechanism} =~ /(\S+)/)[0];
118             }
119              
120             1;
121