File Coverage

blib/lib/Authen/SASL/Perl.pm
Criterion Covered Total %
statement 38 63 60.3
branch 11 20 55.0
condition 7 14 50.0
subroutine 9 20 45.0
pod 0 13 0.0
total 65 130 50.0


line stmt bran cond sub pod time code
1             # Copyright (c) 2002 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::Perl;
6              
7 8     8   103 use strict;
  8         73  
  8         114  
8 8     8   146 use vars qw($VERSION);
  8         72  
  8         109  
9 8     8   114 use Carp;
  8         135  
  8         136  
10              
11             $VERSION = "1.05";
12              
13             my %secflags = (
14             noplaintext  => 1,
15             noanonymous  => 1,
16             nodictionary => 1,
17             );
18             my %have;
19              
20             sub client_new {
21 22     22 0 249   my ($pkg, $parent, $service, $host, $secflags) = @_;
22              
23 22   100     364   my @sec = grep { $secflags{$_} } split /\W+/, lc($secflags || '');
  5         59  
24              
25 22         287   my $self = {
26 22   50     192     callback => { %{$parent->callback} },
      50        
27                 service => $service || '',
28                 host => $host || '',
29               };
30              
31 111         1688   my @mpkg = sort {
32 78 50 33     1683     $b->_order <=> $a->_order
      66        
33               } grep {
34 78         838     my $have = $have{$_} ||= (eval "require $_;" and $_->can('_secflags')) ? 1 : -1;
35 78 50       1507     $have > 0 and $_->_secflags(@sec) == @sec
36               } map {
37 22 50       308     (my $mpkg = __PACKAGE__ . "::$_") =~ s/-/_/g;
38 78         764     $mpkg;
39               } split /[^-\w]+/, $parent->mechanism
40                 or croak "No SASL mechanism found\n";
41              
42 22         497   $mpkg[0]->_init($self);
43             }
44              
45 0     0   0 sub _order { 0 }
46 0 0   0 0 0 sub code { defined(shift->{error}) || 0 }
47 0     0 0 0 sub error { shift->{error} }
48 2     2 0 30 sub service { shift->{service} }
49 2     2 0 48 sub host { shift->{host} }
50              
51             sub set_error {
52 0     0 0 0   my $self = shift;
53 0         0   $self->{error} = shift;
54 0         0   return;
55             }
56              
57             # set/get property
58             sub property {
59 0     0 0 0   my $self = shift;
60 0   0     0   my $prop = $self->{property} ||= {};
61 0 0       0   return $prop->{ $_[0] } if @_ == 1;
62 0         0   my %new = @_;
63 0         0   @{$prop}{keys %new} = values %new;
  0         0  
64 0         0   1;
65             }
66              
67             sub callback {
68 0     0 0 0   my $self = shift;
69              
70 0 0       0   return $self->{callback}{$_[0]} if @_ == 1;
71              
72 0         0   my %new = @_;
73 0         0   @{$self->{callback}}{keys %new} = values %new;
  0         0  
74              
75 0         0   $self->{callback};
76             }
77              
78             # Should be defined in the mechanism sub-class
79 0     0 0 0 sub mechanism { undef }
80 2     2 0 25 sub client_step { undef }
81 0     0 0 0 sub client_start { undef }
82              
83             # Private methods used by Authen::SASL::Perl that
84             # may be overridden in mechanism sub-calsses
85              
86             sub _init {
87 22     22   209   my ($pkg, $href) = @_;
88              
89 22         435   bless $href, $pkg;
90             }
91              
92             sub _call {
93 23     23   227   my ($self, $name) = splice(@_,0,2);
94              
95 23         232   my $cb = $self->{callback}{$name};
96              
97 23 100       231   return undef unless defined $cb;
98              
99 19         156   my $value;
100              
101 19 100       212   if (ref($cb) eq 'ARRAY') {
    100          
102 1         10     my @args = @$cb;
103 1         10     $cb = shift @args;
104 1         11     $value = $cb->($self, @args);
105               }
106               elsif (ref($cb) eq 'CODE') {
107 3         36     $value = $cb->($self, @_);
108               }
109               else {
110 15         135     $value = $cb;
111               }
112              
113 19 100       247   $self->{answer}{$name} = $value
114                 unless $name eq 'pass'; # Do not store password
115              
116 19         316   return $value;
117             }
118              
119             # TODO: Need a better name than this
120             sub answer {
121 0     0 0     my ($self, $name) = @_;
122 0             $self->{answer}{$name};
123             }
124              
125 0     0     sub _secflags { 0 }
126              
127 0     0 0   sub securesocket { $_[1] }
128              
129             1;
130              
131              
132