File Coverage

blib/lib/Mail/DKIM/DkSignature.pm

Criterion	Covered	Total	%
statement	92	101	91.0
branch	26	38	68.4
condition	11	14	78.5
subroutine	22	29	75.8
pod	16	22	72.7
total	167	204	81.8

package Mail::DKIM::DkSignature;
use strict;
use warnings;
our $VERSION = '1.20240923'; # VERSION
# ABSTRACT: represents a DomainKeys-Signature header

# Copyright 2005-2006 Messiah College. All rights reserved.
# Jason Long

# Copyright (c) 2004 Anthony D. Urso. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

use Mail::DKIM::PublicKey;
use Mail::DKIM::Algorithm::dk_rsa_sha1;

use base 'Mail::DKIM::Signature';
use Carp;


sub new {
    my $type = shift;
    my %prms = @_;
    my $self = {};
    bless $self, $type;

    $self->algorithm( $prms{'Algorithm'} || 'rsa-sha1' );
    $self->signature( $prms{'Signature'} );
    $self->canonicalization( $prms{'Method'} || 'simple' );
    $self->domain( $prms{'Domain'} );
    $self->headerlist( $prms{'Headers'} );
    $self->protocol( $prms{'Query'} || 'dns' );
    $self->selector( $prms{'Selector'} );
    $self->key( $prms{'Key'} ) if defined $prms{'Key'};

    return $self;
}


sub parse {
    my $class = shift;
    croak 'wrong number of arguments' unless ( @_ == 1 );
    my ($string) = @_;

    # remove line terminator, if present
    $string =~ s/\015\012\z//;

    # remove field name, if present
    my $prefix;
    if ( $string =~ /^(domainkey-signature:)(.*)/si ) {

        # save the field name (capitalization), so that it can be
        # restored later
        $prefix = $1;
        $string = $2;
    }

    my $self = $class->Mail::DKIM::KeyValueList::parse($string);
    $self->{prefix} = $prefix;

    return $self;
}



sub as_string_without_data {
    croak 'as_string_without_data not implemented';
}

sub body_count {
    croak 'body_count not implemented';
}

sub body_hash {
    croak 'body_hash not implemented';
}


sub algorithm {
    my $self = shift;

    if (@_) {
        $self->set_tag( 'a', shift );
    }

    my $a = $self->get_tag('a');
    return defined $a && $a ne '' ? lc $a : 'rsa-sha1';
}


sub canonicalization {
    my $self = shift;
    croak 'too many arguments' if ( @_ > 1 );

    if (@_) {
        $self->set_tag( 'c', shift );
    }

    return lc( $self->get_tag('c') ) || 'simple';
}

sub DEFAULT_PREFIX {
    return 'DomainKey-Signature:';
}


sub domain {
    my $self = shift;

    if (@_) {
        $self->set_tag( 'd', shift );
    }

    my $d = $self->get_tag('d');
    return defined $d ? lc $d : undef;
}

sub expiration {
    my $self = shift;
    croak 'cannot change expiration on ' . ref($self) if @_;
    return undef;
}

use MIME::Base64;

sub check_canonicalization {
    my $self = shift;

    my $c = $self->canonicalization;

    my @known = ( 'nofws', 'simple' );
    return unless ( grep { $_ eq $c } @known );
    return 1;
}

# Returns a filtered list of protocols that can be used to fetch the
# public key corresponding to this signature. An empty list means that
# all designated protocols are unrecognized.
# Note: at this time, the only recognized protocol for DomainKey
# signatures is "dns".
#
sub check_protocol {
    my $self = shift;

    my $protocol = $self->protocol;
    return 'dns/txt' if $protocol && $protocol eq 'dns';
    return;
}

sub check_version {

    #DomainKeys doesn't have a v= tag
    return 1;
}

sub get_algorithm_class {
    my $self = shift;
    croak 'wrong number of arguments' unless ( @_ == 1 );
    my ($algorithm) = @_;

    my $class =
      $algorithm eq 'rsa-sha1'
      ? 'Mail::DKIM::Algorithm::dk_rsa_sha1'
      : undef;
    return $class;
}

# get_public_key - same as parent class

sub hash_algorithm {
    my $self      = shift;
    my $algorithm = $self->algorithm;

    return $algorithm eq 'rsa-sha1' ? 'sha1' : undef;
}


#sub headerlist
# is in Signature.pm


sub identity {
    my $self = shift;
    croak 'cannot change identity on ' . ref($self) if @_;
    return $self->{dk_identity};
}


sub identity_source {
    my $self = shift;
    croak 'unexpected argument' if @_;
    return $self->{dk_identity_source};
}

# init_identity() - initialize the DomainKeys concept of identity
#
# The signing identity of a DomainKeys signature is the sender
# of the message itself, i.e. the address in the Sender/From header.
# The sender may not be known when the signature object is
# constructed (since the signature usually precedes the From/Sender
# header), so use this method when you have the From/Sender value.
# See also finish_header() in Mail::DKIM::Verifier.
#
sub init_identity {
    my $self = shift;
    $self->{dk_identity}        = shift;
    $self->{dk_identity_source} = shift;
}

sub method {
    croak 'method not implemented (use canonicalization instead)';
}


sub protocol {
    my $self = shift;

    (@_)
      and $self->set_tag( 'q', shift );

    # although draft-delany-domainkeys-base-06 does mandate presence of a
    # q=dns tag, it is quote common that q tag is missing - be merciful
    return !defined( $self->get_tag('q') ) ? 'dns' : lc $self->get_tag('q');
}


# same as parent class


# same as parent class

sub timestamp {
    croak 'timestamp not implemented';
}

sub version {
    croak 'version not implemented';
}


1;

__END__