view release on metacpan or  search on metacpan

lib/Protocol/DBus/Authn/Mechanism/DBUS_COOKIE_SHA1.pm  view on Meta::CPAN

package Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1;

# https://dbus.freedesktop.org/doc/dbus-specification.html#auth-mechanisms-sha

use strict;
use warnings;

use parent qw( Protocol::DBus::Authn::Mechanism );

use Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1::Pieces ();

use File::Spec ();

my $sha_module;

use constant must_send_initial => 0;

use constant {
    DEBUG => 0,
};

sub new {
    my ($class) = @_;

    local $@;

    if ( eval { require Digest::SHA1; 1 } ) {
        $sha_module = 'Digest::SHA1';
    }
    elsif ( eval { require Digest::SHA; 1 } ) {
        $sha_module = 'Digest::SHA';
    }
    else {
        die "No SHA module available!";
    }

    return $class->SUPER::new( @_[ 1 .. $#_ ] );
}

sub INITIAL_RESPONSE {
    my ($self) = @_;

    return unpack( 'H*', ($self->_getpw())[0] );
}

sub AFTER_AUTH {
    my ($self) = @_;

    return (
        [ 1 => sub {
            _consume_data($self, @_);
        } ],
        [ 0 => \&_authn_respond_data ],
    );
}

sub _getpw {
    my ($self) = @_;

    $self->{'_pw'} ||= [ getpwuid $> ];

    return @{ $self->{'_pw'} };
}