home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / Perl.pm < prev    next >
Encoding:
Perl POD Document  |  2004-04-10  |  2.3 KB  |  116 lines
  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. use strict;
  8. use vars qw($VERSION);
  9. use Carp;
  10.  
  11. $VERSION = "1.04";
  12.  
  13. my %secflags = (
  14.     noplaintext  => 1,
  15.     noanonymous  => 1,
  16.     nodictionary => 1,
  17. );
  18. my %have;
  19.  
  20. sub client_new {
  21.   my ($pkg, $parent, $service, $host, $secflags) = @_;
  22.  
  23.   my @sec = grep { $secflags{$_} } split /\W+/, lc($secflags || '');
  24.  
  25.   my $self = {
  26.     callback => { %{$parent->callback} },
  27.     service  => $service  || '',
  28.     host     => $host     || '',
  29.   };
  30.  
  31.   my @mpkg = sort {
  32.     $b->_order <=> $a->_order
  33.   } grep {
  34.     my $have = $have{$_} ||= (eval "require $_;" and $_->can('_secflags')) ? 1 : -1;
  35.     $have > 0 and $_->_secflags(@sec) == @sec
  36.   } map {
  37.     (my $mpkg = __PACKAGE__ . "::$_") =~ s/-/_/g;
  38.     $mpkg;
  39.   } split /[^-\w]+/, $parent->mechanism
  40.     or croak "No SASL mechanism found\n";
  41.  
  42.   $mpkg[0]->_init($self);
  43. }
  44.  
  45. sub _order   { 0 }
  46. sub code     { defined(shift->{error}) || 0 }
  47. sub error    { shift->{error}    }
  48. sub service  { shift->{service}  }
  49. sub host     { shift->{host}     }
  50.  
  51. sub set_error {
  52.   my $self = shift;
  53.   $self->{error} = shift;
  54.   return;
  55. }
  56.  
  57. # set/get property
  58. sub property {
  59.   my $self = shift;
  60.   my $prop = $self->{property} ||= {};
  61.   return $prop->{ $_[0] } if @_ == 1;
  62.   my %new = @_;
  63.   @{$prop}{keys %new} = values %new;
  64.   1;
  65. }
  66.  
  67. sub callback {
  68.   my $self = shift;
  69.  
  70.   return $self->{callback}{$_[0]} if @_ == 1;
  71.  
  72.   my %new = @_;
  73.   @{$self->{callback}}{keys %new} = values %new;
  74.  
  75.   $self->{callback};
  76. }
  77.  
  78. # Should be defined in the mechanism sub-class
  79. sub mechanism    { undef }
  80. sub client_step  { undef }
  81. 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.   my ($pkg, $href) = @_;
  88.  
  89.   bless $href, $pkg;
  90. }
  91.  
  92. sub _call {
  93.   my ($self, $name) = @_;
  94.  
  95.   my $cb = $self->{callback}{$name};
  96.  
  97.   if (ref($cb) eq 'ARRAY') {
  98.     my @args = @$cb;
  99.     $cb = shift @args;
  100.     return $cb->($self, @args);
  101.   }
  102.   elsif (ref($cb) eq 'CODE') {
  103.     return $cb->($self);
  104.   }
  105.  
  106.   return $cb;
  107. }
  108.  
  109. sub _secflags { 0 }
  110.  
  111. sub securesocket { $_[1] }
  112.  
  113. 1;
  114.  
  115.  
  116.