File Coverage

blib/lib/Authen/DigestMD5.pm

Criterion	Covered	Total	%
statement	27	108	25.0
branch	0	28	0.0
condition	0	3	0.0
subroutine	9	25	36.0
pod			n/a
total	36	164	21.9

package Authen::DigestMD5;

use 5.006;

our $VERSION = '0.04';

package Authen::DigestMD5::Packet;
use strict;
use warnings;

my %quote=map{$_=>1} qw(username realm nonce cnonce digest-uri qop cipher);

sub _quote($$) {
    shift;
    my ($k, $v)=@_;
    return () unless defined $v;
    if ($quote{$k}) {
	$v =~ s/([\\"])/\\$1/g;
	return qq|$k="$v"|;
    }
    "$k=$v";
}

sub _split {
    shift;
    my $str=shift;
    my %pair;
    while ($str=~/\G\s*([\w\-]+)\s*=\s*("([^\\"]+|\\.)*"|[^,]+)\s*(?:,|$)/g) {
	$pair{$1}=$2;
    }
    my ($k, $v);
    while(($k, $v)=each %pair) {
	if ($v=~/^"(.*)"$/) {
	    $v=$1;
	    $v=~s/\\(.)/$1/g;
	    $pair{$k}=$v;
	}
    }
    %pair
}

sub _join {
    my $this=shift;
    my %pair=@_;
    delete $pair{password};
    join(',', map { $this->_quote($_, $pair{$_}) } sort keys %pair)
}

sub new {
    my $class=shift;
    my $input=shift if @_ & 1;
    my $this={ @_ };
    bless $this, $class;
    $this->input($input) if defined $input;
    return $this;
}

sub clone {
    my $this=shift;
    my $clone={ %$this };
    bless $clone, ref($this);
}

sub _public {
    my $this=shift;
    return grep /^[a-z]/i, keys(%$this);
}

sub input {
    my ($this, $str)=@_;
    return unless defined $str;
    $this->set($this->_split($str));
}

sub output {
    my $this=shift;
    return $this->_join(map { $_, $this->{$_} } $this->_public);
}

sub set {
    my $this=shift;
    while (@_) {
	my $k=shift;
	my $v=shift;
	$this->{$k}=$v;
    }
}

sub get {
    my $this=shift;
    return wantarray
	? (map { $this->{$_} } @_)
	    : $this->{$_[0]};
}

sub reset {
    my $this=shift;
    for my $k ($this->_public) {
	delete $this->{$k}
    }
}

package Authen::DigestMD5::Request;
our @ISA=qw(Authen::DigestMD5::Packet);

use strict;
use warnings;

sub auth_ok {
    my $this=shift;
    return defined $this->{rspauth};
}

package Authen::DigestMD5::Response;
our @ISA=qw(Authen::DigestMD5::Packet);

use strict;
use warnings;

use Digest::MD5 qw(md5_hex md5);
use Carp;

sub new {
    my $this=shift->SUPER::new(@_);
    $this->{_nc}={};
    return $this;
}

sub _public {
    my $this=shift;
    return grep { $_=~/^[a-z]/i and
		      $_ ne 'password' } keys(%$this);
}

sub got_request {
    my $this=shift;
    my $req=shift;
    # $this->{_r}=$req;
    for my $k (qw(nonce realm charset)) {
	$this->{$k}=$req->{$k} if exists $req->{$k};
    }
    #$this->{nc}=sprintf("%08d", ++$this->{_nc}{$req->{nonce}})
    #  if exists $req->{nonce};
    if (exists $req->{qop}) {
	my @qop=split(/\s*,\s*/, $req->{qop});
	if (grep {$_ eq 'auth-int'} @qop) {
	    $this->{qop}='auth-int'
	}
	elsif (grep {$_ eq 'auth'} @qop) {
	    $this->{qop}='auth'
	}
	else { croak "not supported qop found ($req->{qop})" }
    }
}

sub add_digest {
    my $this=shift;

    $this->{cnonce}=md5_hex(join(':', time, rand, $$));
      # unless defined $this->{cnonce};

    $this->{nc}=sprintf("%08d", ++$this->{_nc}{$this->{nonce}})
	if exists $this->{nonce};

    my %pair=((map { $_, $this->{$_} } $this->_public), @_);

    my $A1=join (":",
		 md5(join (":", @pair{qw(username realm password)}, )),
		 @pair{qw(nonce cnonce)} );

    my $A2 = "AUTHENTICATE:" . $pair{'digest-uri'};

    $A2 .= ":00000000000000000000000000000000"
	if (defined $pair{'qop'} and
	    $pair{'qop'} =~ /^auth-(conf|int)$/);

    $this->{response} =
	md5_hex(join (":", md5_hex($A1),
		      @pair{qw(nonce nc cnonce qop)},
		      md5_hex($A2)) );
}


1;
__END__