package MIME::OpenSSL;
use warnings;
use strict;

use Carp;
use MIME::Parser;


our $VERSION="0.1";
our $Debug       =0; 
our $Test_On_Load=0; # will try to opne a test *.eml (S/MIME) on modul
+e load, for autochecking


=head1 NAME

MIME::OpenSSL - MIME OpenSSL Utility class

=head1 SYNOPSIS

    my $ssl=MIME::OpenSSL->new();

    my $ent=$ssl->SMIME_Open('/somepath/028923246130161DEVFP0.eml');
    print $ssl->error_str;
    my $atch=$ssl->SMIME_attachments;
    print "->".join(",",@$atch) if $atch;

=head1 DESCRIPTION

=head1 Constructors

=head2 new()

Creates a new MIME::OpenSSL object.  Can be called with a list of atri
+bute value pairs,
where each attribute will be set.

This applies also to ANY other published method. Using a non-existant 
+method will raise a
fatal run-time error.

=cut

my %Defaults=(
        temp_root       => "",                # Where to put temp file
+s
        ssl_name        => "OpenSSL",         # name of OpenSSL execut
+able
        ssl_bin_path    => "bin/",            # Path to the OpenSSL ex
+ecutable
        ssl_cert_path   => "certs/",          # Path to the cert bundl
+e

        ssl_ca_file     => "ca-bundle.crt",   # root certs

        cert_file        => $OpenSSL_CertFile, # for signing
        cert_pwd        => $OpenSSL_PWD,

        sig_file        => "SMIME-signer.pk7",   
        x509_file       => "SMIME-signer.x509",
        payload_file    => "SMIME-payload.smime",
        source_file        => "Source_File.txt",
        signed_file        => "SMIME-signed.smime",

        mail_spec       => "",
        mail_attribs    => undef,

        sig_email       => "",
        error_str       => "",

        last_result     => "",
        history         => [],
        errors            => [],
        auto_purge      => 1,
        mime_entity        => undef,
        mime_parser     => undef,


         );

{

    no strict 'refs';
    foreach my $key (sort keys %Defaults) {
        if (0) {
            print "\n=head2 $key()\n\n=cut\n";
        }
        *$key=sub {
                my $self=shift;

                return (ref($self))
                        ? ((!@_) ? $self->{$key}
                                 : ($self->{$key}=shift,$self))
                        : ((!@_) ? $Defaults{$key}
                             : ($Defaults{$key}=shift,$self))
              };
    }

    local $Debug=0;
    __PACKAGE__->Version("0.9.6"); # replace with the apropriate versi
+on of OpenSSL
}

sub new {
    my $proto=shift;
    my $class=ref($proto) || $proto;
    my %params=@_;
    my %self=%Defaults;
    my $self=bless \%self,$class;
    foreach my $key (keys %params) {
        $self->$key($params{$key});# if exists($self{$key});
    }
    return $self;
}

=head1 SSL Specific Properties

=head2 ssl_name()

Currently 'OpenSSL'

=head2 ssl_bin_path()

The path for the OpenSSL executable

=head2 ssl_cert_path()

The path for locating the ssl_ca_file

=head2 ssl_ca_file()

The name of Certificate Authority file to be used. Set the path throug
+h ssl_cert_path!

=head1 Intermediate Files and Paths

=head2 temp_root()

The root of the temp dir to be used for various OpenSSL intermediate f
+iles.

=head2 payload_file()

The filename the signed payload should be placed in.

=head2 sig_file()

The signature file to be used when parsing an EML file.

=head2 x509_file()

The filename for the x509 form of the signature, currently NOT used, m
+ay be removed.

=head1 Result Properties

=head2 mail_spec()

The last EML files parsed through SMIME_Open or Verify_EML

=head2 error_str()

Empty string or the last 'simple' error string returned from OpenSSL

=head2 last_result()

Last 'simple' result string from a call to Execute()

=head2 sig_email()

The mail spec contained in a Certificate. Currently only set after a c
+all to
Verify_EML() was successfull

=head2 history()

Transaction of calls to OpenSSL and their entire results. Not produced
+ when $Debug is
not set.

=head1 SMIME_Open Properties

=head2 mime_parser()

An SMIME_Open::mime_parser object. Produced by SMIME_Open() through SM
+IME_parser

=head2 mime_entity()

Root level MIME::mime_entity object from the last use of SMIME_Open(),
+ or undef if there was none.

=head2 auto_purge()

When set to 1 a call to SMIME_Open will result in the last parsed mail
+ being purged.
If its is set to 0 then the mail wil not be purged and -1 will result 
+in a fatal error if
the last parse has NOT been purged first.

=cut

######################################################################
+####################



=head1 Methods

=head2 Version($min_version)

Returns or optionally checks the underlying OpenSSL version.

=cut

sub Version {
    my $self=shift;
    my $min=shift;

    my $version=$self->Execute("version");

    my $v_str=$1 if $version=~/\s((\d+\.)+\d)\s/;
    die "Expecting OpenSSL version $min but found $v_str"
        if $min && $v_str lt $min;
    return $v_str;
}


sub debug_print {
    my $self=shift;
    my $dirsymb=shift;

    my $str=scalar($self).$dirsymb.join("",@_);
    $str.="\n" unless ($str=~/\n$/);
    warn $str;
    chomp($str);
    return if !ref($self);
    push @{$self->{history}},$str;
}

sub debug_out {
    my $self=shift;
    return unless $Debug;

    $self->debug_print(" >>> ",@_);
}

sub debug_in {
    my $self=shift;
    return unless $Debug;

    $self->debug_print(" <<< ",@_);
}

=head2 Execute_Params(LIST)

Takes a list of individual commands and options to feed OpenSSL.  This
+ list
is joined by a space and passed on to Execute().  Provided for cleaner
+ interfacing.

=cut

sub pretty_params {
    my @params=@_;

    return "No Params" unless @params;
    my %ptree;
    my $p={};
    $ptree{shift @params}=$p;
    while (@params) {
        my $tag=shift @params;
        if ($params[0]=~/^-/o) {
            $p->{$tag}++;
        } else {
            $p->{$tag}=shift @params;
        }
    }
    return DumpHash(\%ptree);
}


sub Execute_Params {
    my $self=shift;

    warn pretty_params(@_)."\n" if $Debug<0;

    my $paramstr=join(" ",@_);
    return $self->Execute($paramstr);
}

=head2 Execute(STR)

Takes a string to pass to OpenSSL.
A log of the transaction is maintained in the C<history()> attribute w
+hen C<$Debug> is true.
Any 'simple' results from openssl, defined to be ones that do B<NOT> m
+atch
C</([[:xdigit:]]+):error:([[:xdigit:]]+):/>, will be returned.

=cut

sub parse_response {
    my $self =shift;
    my $errstr  =shift;

    my $err=MIME::OpenSSL::Error->new($errstr);
    push @{$self->errors},$err;
    return $err;
}

sub Execute {
    my $self  =shift;
    my $params=shift;

    my $cmd=$self->ssl_bin_path.$self->ssl_name." ".$params." 2>&1 |";
    $self->debug_out($cmd);
    $self->last_result("");
    $self->errors([]);
    if (open(EXE,$cmd)) {
        while (<EXE>) {

            $self->debug_in($_);
            if (/[[:xdigit:]]+:error:[[:xdigit:]]+:/) {
                #This should be called parse error
                $self->parse_response($_);
            } else {
                chomp;
                $self->last_result($_) if !$self->last_result($_);
            }
        }
    }
    if ($self->errors()->[0]) {
        $self->last_result($self->last_result." *** Error:".$self->err
+ors()->[0]->string());
    }
    return $self->last_result;
}

=head1 SMIME_Open related methods


=head2 Verify_EML($eml_file_spec)

Uses OpenSSL to verify a mail. Returns B<false> if no errors occured, 
+or a string
containing the B<simple> error message returned by OpenSSL.  The C<err
+or_str()> property
will also contain the result.

If everything works out then the property C<payload_spec()> will conta
+in the file
that was digitally signed, and the C<sig_email> property will contain 
+the email address
of the owner of the certificate.

The array stored in history() contains a full log of the transaction t
+hat occured
with the OpenSSL executable.

B<Note> It is the callers responsibility to make sure that files are c
+leaned up and
that they dont conflict with or overwrite needed files

=cut


sub Verify_EML {
    my $self=shift;
    my $eml =shift;

    $self->mail_spec($eml);
    $self->history([]);
    $self->error_str("");

    my $res=$self->Execute_Params("smime",
                      "-signer",$self->sig_spec,
                      "-verify",
                      "-CAfile",$self->ca_spec,
                      "-in"    ,$self->mail_spec,
                      "-out"   ,$self->payload_spec);
    if ($res eq "Verification Successful") {
        $res=$self->Execute_Params("x509","-email",
                       "-in", $self->sig_spec,
                       "-out","NULL"); #$self->x509_spec);
    }
    if ($res=~/^[^@]+\@[^@]+$/) {
        $self->sig_email($res);
    } else {
        $self->error_str($res);
    }

    return $self->error_str();
}

=head2 SMIME_Open()

SMIME_Open is the preferred method for checking an SMIME file (EML fil
+e at this time).
Unlike Verify_EML (which it calls) SMIME_Open handles cleaning up file
+s and directories
as well as actually parsing the mail, checking if the signatures email
+ is the same as
the purported sender, not just validating its signature.

Returns a MIME::mime_entity object on success, undef on failure. (leav
+es mime_entity() set to the same
result.)

In the case of success it is up to the caller to use SMIME_purge prior
+ to the next
parse.

See SMIME_purge(),SMIME_parser(),SMIME_attachments(),mime_entity(),mim
+e_parser()

=cut

sub SMIME_Open {
    my $self=shift;
    my $file=shift;

    warn "SMIME_Open($file)\n" if $Debug;

    #First get a parser...
    my $mime_parser=$self->SMIME_parser;
    $self->mail_attribs(undef);
    #Grab the filename
    my $fn=($file=~/[\\\/]([^\\\/.]+)\..*$/)[0];



    #Check up on purgables..
    die "Auto Purge is < 0, and there are the following files left in 
+cache.\n>\t".
        join("\n>\t",@{$mime_parser->filer->purgable()})
            if ($self->auto_purge<0 && @{$mime_parser->filer->purgable
+()});

    #Setup the filer for this mail
    $mime_parser->output_under($self->temp_root,
                               DirName=>"SMIME-$$-$fn");
                               #Purge=>$self->auto_purge);
    $mime_parser->filer->output_prefix("SMIME-$fn");

    #And parse away
    my $mime_entity;
    eval ('$mime_entity=$mime_parser->parse_open($file);');
    if ($@) {
        my $errstr=$@;
        chomp $errstr;
        $errstr=~s/:/;/gms;
        $self->error_str($errstr);
        $self->last_result($errstr);
        #we fake an OpenSSL error... 02001002 is for a bad or missing 
+file..
        $self->parse_response(".:.:02001002:.:.:$errstr:."); #dont ask
+....
        return undef;
    }

    #find out who its from...
    my $fr=$mime_entity->head->get('From');
    chomp($fr);
    #and other details
    {
        my $subj=$mime_entity->head->get('Subject');
        my $date=$mime_entity->head->get('Date');
        my $mlto=$mime_entity->head->get('To');
        chomp $subj;
        chomp $date;
        chomp $mlto;
        my %attribs=(subject=>$subj || "",
                 date   =>$date || "",
                 to     =>$mlto || "",
                 from   =>$fr   || "");
        $self->mail_attribs(\%attribs);
    }

    $self->mime_entity($mime_entity);                #store for later 
+external use
    $self->temp_dir($mime_parser->filer->output_dir.'\\'); #use the fi
+lers temp directory

    $mime_entity->dump_skeleton if $Debug;
    #verfiy the mail
    unless  ($self->{no_verify}) {
        $self->Verify_EML($file);
    }

    # Get the MIME::Parser::FileUnder object to do our dirtywork
    $mime_parser->filer->purgeable($self->payload_spec);
    $mime_parser->filer->purgeable($self->sig_spec);
    $self->temp_dir(undef);

    return $mime_entity if $self->{no_verify};

    if ($self->Last_Secure) {
        if ($fr ne $self->sig_email) {
            my $e_str="Mail not from sender it says it is. ".
                     $fr." ne ".$self->sig_email;
            $self->error_str($e_str);
            $self->last_result($e_str);
            $self->parse_response(".:.:02001002:.:.:$e_str:."); #dont 
+ask....
            #$self->mime_entity(undef);
            return undef;
        }
        return $mime_entity;
    } else {
        $self->SMIME_purge;
        $self->mime_entity(undef);
        return undef;
    }
}

=head2 SMIME_parser()

Create on demand property that maps to mime_parser()

=cut

sub SMIME_parser {
    my $self=shift;

    if (@_) {
        return $self->mime_parser(@_);
    } elsif (!$self->mime_parser()) {
        $self->mime_parser(MIME::Parser->new());
    }
    return $self->mime_parser;
}

=head2 SMIME_purge()

Removes any files or directories created by SMIME_Open()

=cut

sub SMIME_purge {
    my $self=shift;
    if ($self->mime_parser) {
        my $root=$self->mime_parser->filer->output_dir;
        $self->mime_parser->filer->purge();
        warn "Removing $root..." if $Debug;
        rmdir($root) if $root;
    }
}

=head2 Last_Secure()

Maps on to error_str(), but returns the inverse, and in numeric format
+ (0 or 1).

C<< if ($ssl->error_str)... >> is logicially equivelent to C<< unless 
+($ssl->Last_Secure)... >>

=cut

sub Last_Secure {
    my $self=shift;

    return ($self->error_str) ? 0 : 1;
}



sub recurse_count_attach {
    my $e=shift;
    my $a=shift || [];
    my $d=shift || 0;
    my @prts=$e->parts;
    #print "Depth=>$d\n---------------------------\n";
    #$e->dump_skeleton;
    foreach my $p (@prts) {
        recurse_count_attach($p,$a,$d+1) if $p->parts;
        push @$a,$p->bodyhandle->path
            if ($p->head->recommended_filename
                   &&
               $p->head->recommended_filename!~/^smime/i);

    }
    return $a;
}

=head2 SMIME_attachments()

Returns a reference to a list of attachments contained in last correct
+ly signed email (or mime_entity object
if provided) or an empty list if the mail was correctly signed but had
no attachments. Note that the term attachment applies only to files th
+at have a recomended-filename
and where that filename does not match C<< $fn=~/^SMIME/i >> This is t
+o avoid counting the signature
file as an attachment.

Returns undef if there was no mime_entity available, indicating the la
+st mail (if there was one)
was bad.

=cut


sub SMIME_attachments {
    my $self=shift;
    my $ent=shift || $self->mime_entity || return undef;

    return recurse_count_attach($ent);
}

#openssl smime -sign -in $infile -out $outfile  -signer $OpenSSL_CERT

#sub SMIME_Write {
#    my $self=shift;
#    my $ent=shift || $self->mime_entity || return undef;
#
#    Execute_Params("-sign","-in",$infile,"-signer",$cert);
#
#}
#
#sub SMIME_Sign {
#    my $self   =shift;
#    my $infile =shift || $self->source_spec;
#    my $outfile=shift || $self->signed_spec;
#
#
#
#}


=head1 Derived Properties

=head2 temp_dir()

Allows temp_root to be overriden temporarily.

=head2 I<file>_spec()

=over 4

=item sig_spec()

=item payload_spec()

=item x509_spec()

=item CA_spec()

=back

Returns the approriately named file along with the appropriate path, m
+ostly temp_dir.

=cut

sub temp_dir {
    my $self=shift;
    return (@_) ? ($self->{temp_dir}=shift,$self)
            : ($self->{temp_dir}) ? $self->{temp_dir} : $self->temp_ro
+ot;
}

sub sig_spec {
    my $self=shift;
    return $self->temp_dir.$self->sig_file;
}

sub payload_spec {
    my $self=shift;
    return $self->temp_dir.$self->payload_file;
}

sub x509_spec {
    my $self=shift;
    return $self->temp_dir.$self->x509_file;
}


sub ca_spec {
    my $self=shift;
    return $self->ssl_cert_path.$self->ssl_ca_file;
}

sub cert_spec {
    my $self=shift;
    return $self->ssl_cert_path.$self->ssl_cert_file;
}

sub signed_spec {
    my $self=shift;
    return $self->temp_dir.$self->signed_file;
}

sub source_spec {
    my $self=shift;
    return $self->temp_dir.$self->source_file;
}

DESTROY {
    my $self=shift;
    $self->SMIME_purge if $self->mime_parser;
}

if ($Test_On_Load) {
    require Data::Dumper;
    my $test=__PACKAGE__->new();
    $test->SMIME_Open(''); # some file
    #print $test->Version."\n";
    print Dumper($test)."\n";

}
1;

package MIME::OpenSSL::Error;

sub new {
    my $proto=shift;
    my $class=ref($proto) || $proto;
    my ($code,$str);
    if (@_==1) {
        ($code,$str)=(split(/:/,shift))[2,5];
    } elsif (@_==2) {
        ($code,$str)=@_;
    } else {
        die "Wrong number of params..";
    }


    my $self={
            code   =>$code,
            string =>$str
         };
    return bless $self,$class;
}

sub code {
    return shift->{code};
}

sub string {
    return shift->{string};
}

=head1 Author

Yves Orton / Demerphq

demerphq@hotmail.com

=head1 Copyright

This module is released under the Perl Artistic License.  However I wo
+uld _really_ appreciate recieving copies of any
improvements/enhancements made to the software.

=Cut

1;
[download]

Yves / DeMerphq
--
When to use Prototypes?

Edit Masem 2002-02-19 - Added READMORE tag before code