view release on metacpan or  search on metacpan

lib/Mail/Make/SMIME.pm  view on Meta::CPAN

    $self->_ensure_envelope_headers( $entity ) || return( $self->pass_error );

    my $smime = $self->_make_crypt_smime || return( $self->pass_error );

    $self->_load_private_key( $smime, $opts ) || return( $self->pass_error );

    $self->_load_ca_cert( $smime, $opts );    # optional

    # Load recipient certificate(s)
    my @certs = ref( $opts->{RecipientCert} ) eq 'ARRAY'
        ? @{$opts->{RecipientCert}}
        : ( $opts->{RecipientCert} );

    my @pem_certs;
    for my $cert ( @certs )
    {
        my $pem = $self->_read_pem( $cert ) || return( $self->pass_error );
        push( @pem_certs, $pem );
    }

    local $@;
    eval{ $smime->setPublicKey( \@pem_certs ) };
    return( $self->error( "Failed to load recipient certificate(s): $@" ) ) if( $@ );

    my $raw = $self->_serialise_for_smime( $entity ) || return( $self->pass_error );

    # Crypt::SMIME has no signAndEncrypt() method. RFC 5751 sign-then-encrypt is
    # implemented by signing first, then encrypting the signed output.
    # The signed intermediate is a full RFC 2822 message string; we pass it directly to
    # encrypt() which operates on the same format.
    my $signed;
    eval{ $signed = $smime->sign( $raw ) };
    return( $self->error( "Crypt::SMIME::sign() failed: $@" ) ) if( $@ );
    unless( defined( $signed ) && CORE::length( $signed ) )
    {
        return( $self->error( 'Crypt::SMIME::sign() returned empty result.' ) );
    }

    # Re-load recipient public key(s) on a fresh instance for the encrypt step.
    # The same $smime object already has the private key loaded; calling setPublicKey()
    # again on it works, but to be explicit and avoid any state confusion we reuse $smime
    # (Crypt::SMIME accumulates public keys).
    my $result;
    eval{ $result = $smime->encrypt( $signed ) };
    return( $self->error( "Crypt::SMIME::encrypt() failed: $@" ) ) if( $@ );
    unless( defined( $result ) && CORE::length( $result ) )
    {
        return( $self->error( 'Crypt::SMIME::encrypt() returned empty result.' ) );
    }

    return( $self->_build_from_smime_output( $entity, $result ) );
}

# _build_from_smime_output( $original_mail, $smime_string ) → Mail::Make
# Parses the S/MIME output string from Crypt::SMIME (which already contains all the correct
# headers) into a new Mail::Make object that smtpsend() can use directly.
#
# Crypt::SMIME::sign() and encrypt() return a fully formed RFC 2822 message string. We
# wrap it in a Mail::Make object by parsing it into an Entity and storing it as 
# _smime_entity, mirroring what _gpg_entity does for GPG.
sub _build_from_smime_output
{
    my( $self, $original, $smime_str ) = @_;
    require Mail::Make;

    # Canonicalise line endings to CRLF
    ( my $canon = $smime_str ) =~ s/\015?\012/\015\012/g;

    # Locate the header / body separator
    my $pos = index( $canon, "\015\012\015\012" );
    if( $pos < 0 )
    {
        return( $self->error( 'No header/body separator in Crypt::SMIME output.' ) );
    }

    # Parse outer headers into a plain hash (case-insensitive, last-value wins for duplicates)
    # so that the structure test can call headers->get().
    my $hdr_block = substr( $canon, 0, $pos + 2 );
    my %hdrs;
    my $cur_name  = '';
    my $cur_value = '';
    for my $line ( split( /(?<=\015\012)/, $hdr_block ) )
    {
        if( $line =~ /^[ \t]/ )
        {
            ( my $cont = $line ) =~ s/^\015\012$//;  # strip trailing CRLF
            $cur_value .= $line if( CORE::length( $cur_name ) );
        }
        elsif( $line =~ /^([\x21-\x39\x3B-\x7E]+):\s*(.*?)\015\012$/ )
        {
            $hdrs{ $cur_name } = $cur_value if( CORE::length( $cur_name ) );
            ( $cur_name, $cur_value ) = ( $1, $2 );
        }
    }
    $hdrs{ $cur_name } = $cur_value if( CORE::length( $cur_name ) );

    # _RawEntity wraps the complete Crypt::SMIME output string and exposes just enough of
    # the Entity interface for smtpsend() and the test suite:
    #   headers->get( $name )    - used by structure tests
    #   headers->remove( $name ) - called by smtpsend() to strip Bcc
    #   as_string()              - called by smtpsend() for SMTP DATA
    #
    # We deliberately do NOT subclass Mail::Make::Entity here. Entity::print_body
    # branches on is_multipart() and iterates _parts (which would be empty), producing a
    # message with an empty body. Bypassing Entity entirely is the correct fix.
    my $entity = Mail::Make::SMIME::_RawEntity->new( \%hdrs, $canon );

    # Build the wrapper Mail::Make object
    my $new = Mail::Make->new ||
        return( $self->pass_error( Mail::Make->error ) );

    # Copy envelope headers (From, To, Subject, Date, Message-ID …) from the original
    # Mail::Make object so that smtpsend() can derive the SMTP envelope
    # (MAIL FROM / RCPT TO) without inspecting the entity.
    $original->headers->scan( sub
    {
        my( $name, $value ) = @_;
        $new->headers->set( $name => $value );
        return(1);
    });

lib/Mail/Make/SMIME.pm  view on Meta::CPAN

# _make_crypt_smime() → Crypt::SMIME instance
# Loads Crypt::SMIME and returns a new instance, with a clear error if the module is not
# installed.
sub _make_crypt_smime
{
    my $self = shift( @_ );
    $self->_load_class( 'Crypt::SMIME' ) ||
        return( $self->error( 'Crypt::SMIME is required for S/MIME operations. Install it with: cpan Crypt::SMIME' ) );

    my $smime;
    eval{ $smime = Crypt::SMIME->new };
    return( $self->error( "Failed to instantiate Crypt::SMIME: $@" ) ) if( $@ );

    return( $smime );
}

# _read_pem( $source ) → $pem_string
# Accepts either a PEM string (contains '-----BEGIN') or a file path and returns the PEM
# content as a string. Dies gracefully with a proper error.
sub _read_pem
{
    my( $self, $source ) = @_;

    unless( defined( $source ) )
    {
        return( $self->error( 'Undefined source.' ) );
    }

    # Already a PEM string
    return( $source ) if( $source =~ /-----BEGIN/ );

    # File path
    unless( -f $source )
    {
        return( $self->error( "File not found: $source" ) );
    }

    unless( -r $source )
    {
        return( $self->error( "File not readable: $source" ) );
    }

    open( my $fh, '<', $source ) ||
        return( $self->error( "Cannot open '$source': $!" ) );
    local $/;
    my $pem = <$fh>;
    close( $fh );

    unless( defined( $pem ) && $pem =~ /-----BEGIN/ )
    {
        return( $self->error( "File '$source' does not contain PEM data." ) );
    }

    return( $pem );
}

# _serialise_for_smime( $mail_make_obj ) → $string
# Serialises the Mail::Make object to a full RFC 2822 message string
# (headers + body, CRLF line endings).
# Unlike _serialise_for_gpg, we pass the COMPLETE message to Crypt::SMIME; it handles
# RFC 5751 header separation internally.
sub _serialise_for_smime
{
    my( $self, $mail ) = @_;

    unless( defined( $mail ) )
    {
        return( $self->error( 'No Mail::Make object supplied.' ) );
    }

    unless( $mail->can( 'as_entity' ) )
    {
        return( $self->error( 'Argument must be a Mail::Make object.' ) );
    }

    my $entity = $mail->as_entity || return( $self->pass_error( $mail->error ) );

    my $full = $entity->as_string || return( $self->pass_error( $entity->error ) );

    # Canonicalise line endings to CRLF
    $full =~ s/\015?\012/\015\012/g;

    return( $full );
}

# STORABLE_freeze / STORABLE_thaw both satisfy Module::Generic serialisation hooks
sub STORABLE_freeze { return( $_[0] ) }

sub STORABLE_thaw   { return( $_[0] ) }


# NOTE: package Mail::Make::SMIME::_RawEntity
##----------------------------------------------------------------------------
## Mail::Make::SMIME::_RawEntity
## Lightweight entity wrapper for Crypt::SMIME output strings.
##
## Exposes just enough of the Mail::Make::Entity interface to satisfy
## Mail::Make::smtpsend() and the test suite:
##
##   headers->get( $name )    - returns the header value
##   headers->remove( $name ) - removes a header (no-op if absent)
##   as_string()              - returns the complete RFC 2822 message verbatim
##
## We deliberately bypass Mail::Make::Entity because Entity::print_body()
## branches on is_multipart() and iterates _parts. For a multipart/signed
## entity the _parts array would be empty, producing a message with only a
## closing boundary and no body. Storing the raw Crypt::SMIME string and
## emitting it verbatim is the correct approach.
##----------------------------------------------------------------------------
# Hide it from CPAN
package
    Mail::Make::SMIME::_RawEntity;

use strict;
use warnings;

# new( \%headers, $raw_string ) → _RawEntity
sub new
{
    my( $class, $hdrs_ref, $raw ) = @_;