package Crypt::SMIME;
use warnings;
use strict;
use Exporter 'import';
use XSLoader;
our %EXPORT_TAGS = (
constants => [qw(
NO_CHECK_CERTIFICATE
FORMAT_ASN1
FORMAT_PEM
FORMAT_SMIME
)]
);
Exporter::export_ok_tags('constants');
our $VERSION = '0.17';
XSLoader::load(__PACKAGE__, $VERSION);
1;
sub sign {
my $this = shift;
my $mime = shift;
if(!defined($mime)) {
die __PACKAGE__."#sign: ARG[1] is not defined.\n";
} elsif(ref($mime)) {
die __PACKAGE__."#sign: ARG[1] is a Ref. [$mime]\n";
}
$this->_moveHeaderAndDo($mime, '_sign');
}
sub signonly {
my $this = shift;
my $mime = shift;
if(!defined($mime)) {
die __PACKAGE__."#signonly: ARG[1] is not defined.\n";
} elsif(ref($mime)) {
die __PACKAGE__."#signonly: ARG[1] is a Ref. [$mime]\n";
}
# suppose that $mime is prepared.
my $result = $this->_signonly($mime);
$result =~ s/\r?\n|\r/\r\n/g;
$result;
}
sub encrypt {
my $this = shift;
my $mime = shift;
if(!defined($mime)) {
die __PACKAGE__."#encrypt: ARG[1] is not defined.\n";
} elsif(ref($mime)) {
die __PACKAGE__."#encrypt: ARG[1] is a Ref. [$mime]\n";
}
$this->_moveHeaderAndDo($mime, '_encrypt');
}
sub isSigned {
my $this = shift;
my $mime = shift;
if(!defined($mime)) {
die __PACKAGE__."#isSigned: ARG[1] is not defined.\n";
} elsif(ref($mime)) {
die __PACKAGE__."#isSigned: ARG[1] is a Ref. [$mime]\n";
}
my $ctype = $this->_getContentType($mime);
if($ctype =~ m!^application/(?:x-)?pkcs7-mime! && $ctype =~ m!smime-type="?signed-data"?!) {
# signed-data署名
1;
} elsif($ctype =~ m!^multipart/signed! && $ctype =~ m!protocol="?application/(?:x-)?pkcs7-signature"?!) {
# 分離署名 (クリア署名)
1;
} else {
undef;
}
}
sub isEncrypted {
my $this = shift;
my $mime = shift;
if(!defined($mime)) {
die __PACKAGE__."#isEncrypted: ARG[1] is not defined.\n";
} elsif(ref($mime)) {
die __PACKAGE__."#isEncrypted: ARG[1] is a Ref. [$mime]\n";
}
my $ctype = $this->_getContentType($mime);
if($ctype =~ m!^application/(?:x-)?pkcs7-mime!
&& ($ctype !~ m!smime-type=! || $ctype =~ m!smime-type="?enveloped-data"?!)) {
# smime-typeが存在しないか、それがenveloped-dataである。
1;
} else {
undef;
}
}
sub _moveHeaderAndDo {
my $this = shift;
my $mime = shift;
my $method = shift;
# Content- または MIME- で始まるヘッダはそのままに、
# それ以外のヘッダはmultipartのトップレベルにコピーしなければならない。
# (FromやTo、Subject等)
($mime,my $headers) = $this->prepareSmimeMessage($mime);
my $result = $this->$method($mime);
$result =~ s/\r?\n|\r/\r\n/g;
# コピーしたヘッダを入れる
$result =~ s/\r\n\r\n/\r\n$headers\r\n/;
$result;
}
sub _getContentType {
my $this = shift;
my $mime = shift;
my $headkey;
my $headline = '';
$mime =~ s/\r?\n|\r/\r\n/g;
foreach my $line (split /\r\n/, $mime) {
if(!length($line)) {
return $headline;
} elsif($line =~ m/^([^:]+):\s?(.*)/) {
my ($key, $value) = ($1, $2);
$headkey = $key;
if($key =~ m/^Content-Type$/i) {
$headline = $value;
}
} else {
if($headkey =~ m/^Content-Type$/i) {
$headline .= "\r\n$line";
}
}
}
return $headline;
}
# -----------------------------------------------------------------------------
# my ($message,$movedheader) = $smime->prepareSmimeMessage($mime);
#
sub prepareSmimeMessage {
my $this = shift;
my $mime = shift;
$mime =~ s/\r?\n|\r/\r\n/g;
my $move = '';
my $rest = '';
my $is_move = 0;
my $is_rest = 1;
while($mime=~/(.*\n?)/g) {
my $line = $1;
if($line eq "\r\n") { # end of header.
$rest .= $line . substr($mime,pos($mime));
last;
}
if($line=~/^(Content-|MIME-)/i) {
($is_move, $is_rest) = (0,1);
} elsif( $line =~ /^(Subject:)/i ) {
($is_move, $is_rest) = (1,1);
} elsif( $line =~ /^\S/ ) {
($is_move, $is_rest) = (1,0);
}
$is_move and $move .= $line;
$is_rest and $rest .= $line;
}
($rest,$move);
}