package Mail::SpamAssassin::Util;
use strict;
use bytes;
use vars qw (
@ISA @EXPORT
$AM_TAINTED
);
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(local_tz base64_decode);
use Mail::SpamAssassin;
use Mail::SpamAssassin::Util::RegistrarBoundaries;
use Config;
use File::Spec;
use Time::Local;
use Sys::Hostname (); use Fcntl;
use POSIX ();
use constant HAS_MIME_BASE64 => eval { require MIME::Base64; };
use constant RUNNING_ON_WINDOWS => ($^O =~ /^(?:mswin|dos|os2)/oi);
{
my $displayed_path = 0;
sub find_executable_in_env_path {
my ($filename) = @_;
clean_path_in_taint_mode();
if ( !$displayed_path++ ) {
dbg("Current PATH is: ".join($Config{'path_sep'},File::Spec->path()));
}
foreach my $path (File::Spec->path()) {
my $fname = File::Spec->catfile ($path, $filename);
if ( -f $fname ) {
if (-x $fname) {
dbg ("executable for $filename was found at $fname");
return $fname;
}
else {
dbg("$filename was found at $fname, but isn't executable");
}
}
}
return undef;
}
}
{
my $cleaned_taint_path = 0;
sub clean_path_in_taint_mode {
return if ( $cleaned_taint_path++ );
return unless am_running_in_taint_mode();
dbg("Running in taint mode, removing unsafe env vars, and resetting PATH");
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
my @path = ();
my @stat;
foreach my $dir (File::Spec->path()) {
next unless $dir;
$dir =~ /^(.+)$/; $dir = File::Spec->canonpath($1);
if (!File::Spec->file_name_is_absolute($dir)) {
dbg("PATH included '$dir', which is not absolute, dropping.");
next;
}
elsif (!(@stat=stat($dir))) {
dbg("PATH included '$dir', which doesn't exist, dropping.");
next;
}
elsif (!-d _) {
dbg("PATH included '$dir', which isn't a directory, dropping.");
next;
}
elsif (($stat[2]&2) != 0) {
dbg("PATH included '$dir', which is world writable, dropping.");
next;
}
dbg("PATH included '$dir', keeping.");
push(@path, $dir);
}
$ENV{'PATH'} = join($Config{'path_sep'}, @path);
dbg("Final PATH set to: ".$ENV{'PATH'});
}
}
sub am_running_in_taint_mode {
return $AM_TAINTED if defined $AM_TAINTED;
if ($] >= 5.008) {
$AM_TAINTED = eval q(no warnings q(syntax); ${^TAINT});
}
else {
my $blank;
for my $d ((File::Spec->curdir, File::Spec->rootdir, File::Spec->tmpdir)) {
opendir(TAINT, $d) || next;
$blank = readdir(TAINT);
closedir(TAINT);
last;
}
if (!(defined $blank && $blank)) {
$blank = join('', values %ENV, $0, @ARGV);
}
$blank = substr($blank, 0, 0);
$AM_TAINTED = not eval { eval "1 || $blank" || 1 };
}
dbg ("running in taint mode? ". ($AM_TAINTED ? "yes" : "no"));
return $AM_TAINTED;
}
sub am_running_on_windows {
return RUNNING_ON_WINDOWS;
}
sub untaint_file_path {
my ($path) = @_;
return unless defined($path);
return '' if ($path eq '');
my $chars = '-_A-Za-z\xA0-\xFF0-9\.\@\=\+\,\/\\\:';
my $re = qr/^\s*([$chars][${chars}~ ]*)$/o;
if ($path =~ $re) {
return $1;
} else {
warn "security: cannot untaint path: \"$path\"\n";
return $path;
}
}
sub untaint_hostname {
my ($host) = @_;
return unless defined($host);
return '' if ($host eq '');
my $label = q/[A-Za-z\d](?:[A-Za-z\d-]{0,61}[A-Za-z\d])?/;
my $domain = qq<$label(?:\.$label)*>;
if (length($host) <= 255 && $host =~ /^($domain)$/) {
return $1;
}
else {
warn "security: cannot untaint hostname: \"$host\"\n";
return $host;
}
}
sub untaint_var {
local ($_) = @_;
return undef unless defined;
unless (ref) {
/^(.*)$/s;
return $1;
}
elsif (ref eq 'ARRAY') {
@{$_} = map { $_ = untaint_var($_) } @{$_};
return @{$_} if wantarray;
}
elsif (ref eq 'HASH') {
while (my ($k, $v) = each %{$_}) {
if (!defined $v && $_ == \%ENV) {
delete ${$_}{$k};
next;
}
${$_}{untaint_var($k)} = untaint_var($v);
}
return %{$_} if wantarray;
}
elsif (ref eq 'SCALAR' or ref eq 'REF') {
${$_} = untaint_var(${$_});
}
else {
warn "Can't untaint a " . ref($_) . "!\n";
}
return $_;
}
my %TZ = (
'UT' => '+0000',
'UTC' => '+0000',
'NDT' => '-0230',
'AST' => '-0400',
'ADT' => '-0300',
'NST' => '-0330',
'EST' => '-0500',
'EDT' => '-0400',
'CST' => '-0600',
'CDT' => '-0500',
'MST' => '-0700',
'MDT' => '-0600',
'PST' => '-0800',
'PDT' => '-0700',
'HST' => '-1000',
'AKST' => '-0900',
'AKDT' => '-0800',
'HADT' => '-0900',
'HAST' => '-1000',
'GMT' => '+0000',
'BST' => '+0100',
'IST' => '+0100',
'WET' => '+0000',
'WEST' => '+0100',
'CET' => '+0100',
'CEST' => '+0200',
'EET' => '+0200',
'EEST' => '+0300',
'MSK' => '+0300',
'MSD' => '+0400',
'MET' => '+0100',
'MEZ' => '+0100',
'MEST' => '+0200',
'MESZ' => '+0200',
'BRST' => '-0200',
'BRT' => '-0300',
'AEST' => '+1000',
'AEDT' => '+1100',
'ACST' => '+0930',
'ACDT' => '+1030',
'AWST' => '+0800',
'NZST' => '+1200',
'NZDT' => '+1300',
'JST' => '+0900',
'KST' => '+0900',
'HKT' => '+0800',
'SGT' => '+0800',
'PHT' => '+0800',
'IDT' => '+0300',
);
my %MONTH = (jan => 1, feb => 2, mar => 3, apr => 4, may => 5, jun => 6,
jul => 7, aug => 8, sep => 9, oct => 10, nov => 11, dec => 12);
sub local_tz {
my $time = time;
my @g = gmtime($time);
my @t = localtime($time);
my $z = $t[1]-$g[1]+($t[2]-$g[2])*60+($t[7]-$g[7])*1440+($t[5]-$g[5])*525600;
return sprintf("%+.2d%.2d", $z/60, $z%60);
}
sub parse_rfc822_date {
my ($date) = @_;
local ($_);
my ($yyyy, $mmm, $dd, $hh, $mm, $ss, $mon, $tzoff);
$_ = " $date "; s/, */ /gs; s/\s+/ /gs;
if (s/ (\d+) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) (\d{4}) / /i) {
$dd = $1; $mon = lc($2); $yyyy = $3;
} elsif (s/ (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) +(\d+) \d+:\d+:\d+ (\d{4}) / /i) {
$dd = $2; $mon = lc($1); $yyyy = $3;
} elsif (s/ (\d+) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) (\d{2,3}) / /i) {
$dd = $1; $mon = lc($2); $yyyy = $3;
} else {
dbg ("time cannot be parsed: $date");
return undef;
}
if (defined $yyyy) {
if (length($yyyy) == 2 && $yyyy < 50) {
$yyyy += 2000;
}
elsif (length($yyyy) != 4) {
$yyyy += 1900;
}
}
if (s/ (\d?\d):(\d\d)(:(\d\d))? / /) {
$hh = $1; $mm = $2; $ss = $4 || 0;
}
if (s/ ([-+]\d{4}) / /) {
$tzoff = $1;
}
elsif (s/\b([A-Z]{2,4}(?:-DST)?)\b/ / && exists $TZ{$1}) {
$tzoff = $TZ{$1};
}
$tzoff ||= '-0000';
if (exists $MONTH{$mon}) {
$mmm = $MONTH{$mon};
}
$hh ||= 0; $mm ||= 0; $ss ||= 0; $dd ||= 0; $mmm ||= 0; $yyyy ||= 0;
my $time;
eval { $time = timegm($ss, $mm, $hh, $dd, $mmm-1, $yyyy);
};
if ($@) {
dbg ("time cannot be parsed: $date, $yyyy-$mmm-$dd $hh:$mm:$ss");
return undef;
}
if ($tzoff =~ /([-+])(\d\d)(\d\d)$/) {
$tzoff = (($2 * 60) + $3) * 60;
if ($1 eq '-') {
$time += $tzoff;
} else {
$time -= $tzoff;
}
}
return $time;
}
sub time_to_rfc822_date {
my($time) = @_;
my @days = qw/Sun Mon Tue Wed Thu Fri Sat/;
my @months = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
my @localtime = localtime($time || time);
$localtime[5]+=1900;
sprintf("%s, %02d %s %4d %02d:%02d:%02d %s", $days[$localtime[6]], $localtime[3],
$months[$localtime[4]], @localtime[5,2,1,0], local_tz());
}
sub base64_decode {
local $_ = shift;
s/\s+//g;
if (HAS_MIME_BASE64 && (length($_) % 4 == 0) &&
m|^(?:[A-Za-z0-9+/=]{2,}={0,2})$|s)
{
s/(=+)(?!=*$)/'A' x length($1)/ge;
return MIME::Base64::decode_base64($_);
}
tr|A-Za-z0-9+/=||cd; s/=+$//; # remove terminating padding
tr|A-Za-z0-9+/=| -_`|; # translate to uuencode
s/.$// if (length($_) % 4 == 1); # unpack cannot cope with extra byte
my $length;
my $out = '';
while ($_) {
$length = (length >= 84) ? 84 : length;
$out .= unpack("u", chr(32 + $length * 3/4) . substr($_, 0, $length, ''));
}
return $out;
}
sub qp_decode {
local $_ = shift;
s/\=\r?\n//gs;
s/\=([0-9a-fA-F]{2})/chr(hex($1))/ge;
return $_;
}
sub base64_encode {
local $_ = shift;
if (HAS_MIME_BASE64) {
return MIME::Base64::encode_base64($_);
}
$_ = pack("u57", $_);
s/^.//mg;
tr| -_`|A-Za-z0-9+/A|;
s/(A+)$/'=' x length $1/e;
return $_;
}
sub portable_getpwuid {
if (defined &Mail::SpamAssassin::Util::_getpwuid_wrapper) {
return Mail::SpamAssassin::Util::_getpwuid_wrapper(@_);
}
if (!RUNNING_ON_WINDOWS) {
eval ' sub _getpwuid_wrapper { getpwuid($_[0]); } ';
} else {
dbg ("defining getpwuid() wrapper using 'unknown' as username");
eval ' sub _getpwuid_wrapper { fake_getpwuid($_[0]); } ';
}
if ($@) {
warn "Failed to define getpwuid() wrapper: $@\n";
} else {
return Mail::SpamAssassin::Util::_getpwuid_wrapper(@_);
}
}
sub fake_getpwuid {
return (
'unknown', 'x', $_[0], 0, '', '', '', '/', '', '', );
}
sub extract_ipv4_addr_from_string {
my ($str) = @_;
return unless defined($str);
if ($str =~ /\b(
(?:1\d\d|2[0-4]\d|25[0-5]|\d\d|\d)\.
(?:1\d\d|2[0-4]\d|25[0-5]|\d\d|\d)\.
(?:1\d\d|2[0-4]\d|25[0-5]|\d\d|\d)\.
(?:1\d\d|2[0-4]\d|25[0-5]|\d\d|\d)
)\b/ix)
{
if (defined $1) { return $1; }
}
return;
}
{
my($hostname, $fq_hostname);
sub hostname {
return $hostname if defined($hostname);
clean_path_in_taint_mode();
$hostname = Sys::Hostname::hostname();
return $hostname;
}
sub fq_hostname {
return $fq_hostname if defined($fq_hostname);
$fq_hostname = hostname();
if ($fq_hostname !~ /\./) { my @names = grep(/^\Q${fq_hostname}.\E/o, map { split } (gethostbyname($fq_hostname))[0 .. 1] );
$fq_hostname = $names[0] if (@names); }
return $fq_hostname;
}
}
sub ips_match_in_16_mask {
my ($ipset1, $ipset2) = @_;
my ($b1, $b2);
foreach my $ip1 (@{$ipset1}) {
foreach my $ip2 (@{$ipset2}) {
next unless defined $ip1;
next unless defined $ip2;
next unless ($ip1 =~ /^(\d+\.\d+\.)/); $b1 = $1;
next unless ($ip2 =~ /^(\d+\.\d+\.)/); $b2 = $1;
if ($b1 eq $b2) { return 1; }
}
}
return 0;
}
sub ips_match_in_24_mask {
my ($ipset1, $ipset2) = @_;
my ($b1, $b2);
foreach my $ip1 (@{$ipset1}) {
foreach my $ip2 (@{$ipset2}) {
next unless defined $ip1;
next unless defined $ip2;
next unless ($ip1 =~ /^(\d+\.\d+\.\d+\.)/); $b1 = $1;
next unless ($ip2 =~ /^(\d+\.\d+\.\d+\.)/); $b2 = $1;
if ($b1 eq $b2) { return 1; }
}
}
return 0;
}
sub my_inet_aton { unpack("N", pack("C4", split(/\./, $_[0]))) }
sub parse_content_type {
my $ct = $_[-1] || 'text/plain; charset=us-ascii';
my($boundary) = $ct =~ m!\bboundary\s*=\s*("[^"]+|[^\s";]+(?=[\s;]|$))!i;
# remove double-quotes in boundary (should only be at start and end)
#
$boundary =~ tr/"//d if defined $boundary;
my($charset) = $ct =~ /\bcharset\s*=\s*["']?(.*?)["']?(?:;|$)/i;
my($name) = $ct =~ /\b(?:file)?name\s*=\s*["']?(.*?)["']?(?:;|$)/i;
# Get the actual MIME type out ...
# Note: the header content may not be whitespace unfolded, so make sure the
# REs do /s when appropriate.
#
$ct =~ s/;.*$//s; # strip everything after first semi-colon
$ct =~ s@^([^/]+(?:/[^/]*)?).*$@$1@s; # only something/something ...
$ct =~ tr/\000-\040\177-\377\042\050\051\054\056\072-\077\100\133-\135//d; # strip inappropriate chars
$ct = lc $ct;
# Now that the header has been parsed, return the requested information.
# In scalar context, just the MIME type, in array context the
# four important data parts (type, boundary, charset, and filename).
#
return wantarray ? ($ct,$boundary,$charset,$name) : $ct;
}
###########################################################################
sub url_encode {
my ($url) = @_;
my (@characters) = split(/(\%[0-9a-fA-F]{2})/, $url);
my (@unencoded) = ();
my (@encoded) = ();
foreach (@characters) {
# escaped character set ...
if (/\%[0-9a-fA-F]{2}/) {
# IF it is in the range of 0x00-0x20 or 0x7f-0xff
# or it is one of "<", ">", """, "#", "%",
unless (/(20|7f|[0189a-fA-F][0-9a-fA-F])/i) {
s/\%([2-7][0-9a-fA-F])/sprintf "%c", hex($1)/e;
push(@unencoded, $_);
}
}
else {
s/([\000-\040\177-\377\074\076\042])
/push(@encoded, $1) && sprintf "%%%02x", unpack("C",$1)/egx;
}
}
if (wantarray) {
return(join("", @characters), join("", @unencoded), join("", @encoded));
}
else {
return join("", @characters);
}
}
=item $module = first_available_module (@module_list)
Return the first module that can be successfully loaded with C<require>
from the list. Returns C<undef> if none are available.
This is used instead of C<AnyDBM_File> as follows:
my $module = Mail::SpamAssassin::Util::first_available_module
(qw(DB_File GDBM_File NDBM_File SDBM_File));
tie %hash, $module, $path, [... args];
Note that C<SDBM_File> is guaranteed to be present, since it comes
with Perl.
=cut
sub first_available_module {
my (@packages) = @_;
foreach my $mod (@packages) {
if (eval 'require '.$mod.'; 1; ') {
return $mod;
}
}
undef;
}
sub secure_tmpfile {
my $tmpdir = Mail::SpamAssassin::Util::untaint_file_path(
File::Spec->tmpdir()
);
if (!$tmpdir) {
die "Cannot find a temporary directory! set TMP or TMPDIR in env";
}
my ($reportfile,$tmpfile);
my $umask = umask 077;
do {
my $suffix = join ('',
(0..9, 'A'..'Z','a'..'z')[rand 62,
rand 62,
rand 62,
rand 62,
rand 62,
rand 62]);
$reportfile = File::Spec->catfile(
$tmpdir,
join ('.',
"spamassassin",
$$,
$suffix,
"tmp",
)
);
} while (! sysopen ($tmpfile, $reportfile, O_RDWR|O_CREAT|O_EXCL, 0600));
umask $umask;
return ($reportfile, $tmpfile);
}
sub uri_to_domain {
my ($uri) = @_;
return if ($uri =~ /^javascript:/i);
$uri =~ s, $uri =~ s $uri =~ s,^[^/]*\@,,gs; $uri =~ s,[/\?\&].*$,,gs; $uri =~ s,:\d+$,,gs;
return if $uri =~ /\%/;
if ($uri !~ /^\d+\.\d+\.\d+\.\d+$/) {
$uri = Mail::SpamAssassin::Util::RegistrarBoundaries::trim_domain($uri);
return unless
(Mail::SpamAssassin::Util::RegistrarBoundaries::is_domain_valid($uri));
}
return lc $uri;
}
sub uri_list_canonify {
my(@uris) = @_;
my @nuris = ();
for my $uri (@uris) {
next if $uri =~ /^mailto:/i;
$uri =~ s/\n//g;
$uri =~ s/^\s+//;
$uri =~ s/\s+$//;
my $nuri = $uri;
$nuri =~ s
$nuri =~ s/^(https?:\/\/[^\/\?]+)\?/$1\/?/;
$nuri =~ s/\&\ $nuri =~ s/\&\
if ($nuri =~ /^(https?:\/\/)([^\/]+)(\.?\/.*)$/i) {
my ($proto, $host, $rest) = ($1,$2,$3);
$host =~ s/^[^\@]+\@//gs;
if ($host =~ /^([0-9a-fx]*\.)([0-9a-fx]*\.)([0-9a-fx]*\.)([0-9a-fx]*)$/ix)
{
my (@chunk) = ($1,$2,$3,$4);
for my $octet (0 .. 3) {
$chunk[$octet] =~ s/^0x([0-9a-f][0-9a-f])/sprintf "%d",hex($1)/gei;
}
my $parsed = join ('', $proto, @chunk, $rest);
if ($parsed ne $nuri) { push(@nuris, $parsed); }
}
if ($host =~ /^0x[0-9a-f]+$/i) {
$host =~ s/^0x([0-9a-f]+)/sprintf "%d",hex($1)/gei;
$host = decode_ulong_to_ip ($host);
my $parsed = join ('', $proto, $host, $rest);
push(@nuris, $parsed);
}
if ($host =~ /^[0-9]+$/) {
$host = decode_ulong_to_ip ($host);
my $parsed = join ('', $proto, $host, $rest);
push(@nuris, $parsed);
}
}
($nuri) = Mail::SpamAssassin::Util::url_encode($nuri);
if ($nuri ne $uri) {
push(@nuris, $nuri);
}
if ($nuri =~ m{^https?://.+?(https?:/{0,2}.+)$}i) {
push(@uris, $1);
}
}
my %uris = map { $_ => 1 } @uris, @nuris;
return keys %uris;
}
sub decode_ulong_to_ip {
return join(".", unpack("CCCC",pack("H*", sprintf "%08lx", $_[0])));
}
sub first_date {
my (@strings) = @_;
foreach my $string (@strings) {
my $time = parse_rfc822_date($string);
return $time if defined($time) && $time;
}
return undef;
}
sub receive_date {
my ($header) = @_;
$header ||= '';
$header =~ s/\n[ \t]+/ /gs;
my @rcvd = ($header =~ /^Received:(.*)/img);
my @local;
my $time;
if (@rcvd) {
if ($rcvd[0] =~ /qmail \d+ invoked by uid \d+/ ||
$rcvd[0] =~ /\bfrom (?:localhost\s|(?:\S+ ){1,2}\S*\b127\.0\.0\.1\b)/)
{
push @local, (shift @rcvd);
}
if (@rcvd && ($rcvd[0] =~ m/\bby localhost with \w+ \(fetchmail-[\d.]+/)) {
push @local, (shift @rcvd);
}
elsif (@local) {
unshift @rcvd, (shift @local);
}
}
if (@rcvd) {
$time = first_date(shift @rcvd);
return $time if defined($time);
}
if (@local) {
$time = first_date(@local);
return $time if defined($time);
}
if ($header =~ /^(?:From|X-From-Line:)\s+(.+)$/im) {
my $string = $1;
$string .= " ".local_tz() unless $string =~ /(?:[-+]\d{4}|\b[A-Z]{2,4}\b)/;
$time = first_date($string);
return $time if defined($time);
}
if (@rcvd) {
$time = first_date(@rcvd);
return $time if defined($time);
}
if ($header =~ /^Resent-Date:\s*(.+)$/im) {
$time = first_date($1);
return $time if defined($time);
}
if ($header =~ /^Date:\s*(.+)$/im) {
$time = first_date($1);
return $time if defined($time);
}
return time;
}
sub setuid_to_euid {
return if (RUNNING_ON_WINDOWS);
my $touid = $>;
if ($< != $touid) {
dbg ("changing real uid from $< to match effective uid $touid");
$< = $touid;
if ( $< != $touid ) {
dbg("initial attempt to change real uid failed, trying BSD workaround");
$> = $<; $< = $touid; $> = $touid; }
if ($< != $touid) {
die "setuid $< to $touid failed!";
}
}
}
sub helper_app_pipe_open {
if (RUNNING_ON_WINDOWS) {
return helper_app_pipe_open_windows (@_);
} else {
return helper_app_pipe_open_unix (@_);
}
}
sub helper_app_pipe_open_windows {
my ($fh, $stdinfile, $duperr2out, @cmdline) = @_;
my $cmd = join(' ', @cmdline);
if ($stdinfile) { $cmd .= " < '$stdinfile'"; }
if ($duperr2out) { $cmd .= " 2>&1"; }
return open ($fh, $cmd.'|');
}
sub helper_app_pipe_open_unix {
my ($fh, $stdinfile, $duperr2out, @cmdline) = @_;
my $pid = open ($fh, '-|');
if (!defined $pid) {
die "cannot fork: $!";
}
if ($pid != 0) {
return $pid; }
setuid_to_euid();
dbg ("setuid: helper proc $$: ruid=$< euid=$>");
if (!$stdinfile) { $stdinfile = "/dev/null";
}
my $f = fileno(STDIN);
close STDIN;
if ($f != 0) {
POSIX::close(0);
}
open STDIN, "<$stdinfile" or die "cannot open $stdinfile: $!";
if (fileno(STDIN) != 0) {
die "setuid: oops: fileno(STDIN) [".fileno(STDIN)."] != 0";
}
if ($duperr2out) { my $f = fileno(STDERR);
close STDERR;
if ($f != 2) {
POSIX::close(2);
}
open STDERR, ">&STDOUT" or die "dup STDOUT failed: $!";
if (fileno(STDERR) != 2) {
die "setuid: oops: fileno(STDERR) [".fileno(STDERR)."] != 2";
}
}
exec @cmdline;
die "exec failed: $!";
}
sub dbg { Mail::SpamAssassin::dbg (@_); }
1;