home *** CD-ROM | disk | FTP | other *** search
/ ftp.f-secure.com / 2014.06.ftp.f-secure.com.tar / ftp.f-secure.com / support / hotfix / fsis / IS-SpamControl.fsfix / iufssc / lib / Mail / SpamAssassin / Util.pm < prev   
Text File  |  2006-11-29  |  43KB  |  1,421 lines
  1. # <@LICENSE>
  2. # Licensed to the Apache Software Foundation (ASF) under one or more
  3. # contributor license agreements.  See the NOTICE file distributed with
  4. # this work for additional information regarding copyright ownership.
  5. # The ASF licenses this file to you under the Apache License, Version 2.0
  6. # (the "License"); you may not use this file except in compliance with
  7. # the License.  You may obtain a copy of the License at:
  8. # 
  9. #     http://www.apache.org/licenses/LICENSE-2.0
  10. # 
  11. # Unless required by applicable law or agreed to in writing, software
  12. # distributed under the License is distributed on an "AS IS" BASIS,
  13. # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  14. # See the License for the specific language governing permissions and
  15. # limitations under the License.
  16. # </@LICENSE>
  17.  
  18. =head1 NAME
  19.  
  20. Mail::SpamAssassin::Util - utility functions
  21.  
  22. =head1 DESCRIPTION
  23.  
  24. A general class for utility functions.  Please use this for functions that
  25. stand alone, without requiring a $self object, Portability functions
  26. especially.
  27.  
  28. NOTE: The functions in this module are to be considered private.  Their API may
  29. change at any point, and it's expected that they'll only be used by other
  30. Mail::SpamAssassin modules. (TODO: we should probably revisit this if
  31. it's useful for plugin development.)
  32.  
  33. =over 4
  34.  
  35. =cut
  36.  
  37. package Mail::SpamAssassin::Util;
  38.  
  39. use strict;
  40. use warnings;
  41. use bytes;
  42.  
  43. use Mail::SpamAssassin::Logger;
  44.  
  45. use vars qw (
  46.   @ISA @EXPORT
  47.   $AM_TAINTED
  48. );
  49.  
  50. require Exporter;
  51.  
  52. @ISA = qw(Exporter);
  53. @EXPORT = qw(local_tz base64_decode);
  54.  
  55. use Mail::SpamAssassin;
  56. use Mail::SpamAssassin::Util::RegistrarBoundaries;
  57.  
  58. use Config;
  59. use File::Spec;
  60. use Time::Local;
  61. use Sys::Hostname (); # don't import hostname() into this namespace!
  62. use Fcntl;
  63. use POSIX (); # don't import anything unless we ask explicitly!
  64. use Text::Wrap ();
  65. use Errno qw(EEXIST);
  66.  
  67. ###########################################################################
  68.  
  69. use constant HAS_MIME_BASE64 => eval { require MIME::Base64; };
  70. use constant RUNNING_ON_WINDOWS => ($^O =~ /^(?:mswin|dos|os2)/oi);
  71.  
  72. ###########################################################################
  73.  
  74. # find an executable in the current $PATH (or whatever for that platform)
  75. {
  76.   # Show the PATH we're going to explore only once.
  77.   my $displayed_path = 0;
  78.  
  79.   sub find_executable_in_env_path {
  80.     my ($filename) = @_;
  81.  
  82.     clean_path_in_taint_mode();
  83.     if ( !$displayed_path++ ) {
  84.       dbg("util: current PATH is: ".join($Config{'path_sep'},File::Spec->path()));
  85.     }
  86.     foreach my $path (File::Spec->path()) {
  87.       my $fname = File::Spec->catfile ($path, $filename);
  88.       if ( -f $fname ) {
  89.         if (-x $fname) {
  90.           dbg("util: executable for $filename was found at $fname");
  91.           return $fname;
  92.         }
  93.         else {
  94.           dbg("util: $filename was found at $fname, but isn't executable");
  95.         }
  96.       }
  97.     }
  98.     return undef;
  99.   }
  100. }
  101.  
  102. ###########################################################################
  103.  
  104. # taint mode: delete more unsafe vars for exec, as per perlsec
  105. {
  106.   # We only need to clean the environment once, it stays clean ...
  107.   my $cleaned_taint_path = 0;
  108.  
  109.   sub clean_path_in_taint_mode {
  110.     return if ($cleaned_taint_path++);
  111.     return unless am_running_in_taint_mode();
  112.  
  113.     dbg("util: taint mode: deleting unsafe environment variables, resetting PATH");
  114.  
  115.     if (RUNNING_ON_WINDOWS) {
  116.       dbg("util: running on Win32, skipping PATH cleaning");
  117.       return;
  118.     }
  119.  
  120.     delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
  121.  
  122.     # Go through and clean the PATH out
  123.     my @path = ();
  124.     my @stat;
  125.     foreach my $dir (File::Spec->path()) {
  126.       next unless $dir;
  127.  
  128.       $dir =~ /^(.+)$/; # untaint, then clean ( 'foo/./bar' -> 'foo/bar', etc. )
  129.       $dir = File::Spec->canonpath($1);
  130.  
  131.       if (!File::Spec->file_name_is_absolute($dir)) {
  132.     dbg("util: PATH included '$dir', which is not absolute, dropping");
  133.     next;
  134.       }
  135.       elsif (!(@stat=stat($dir))) {
  136.     dbg("util: PATH included '$dir', which doesn't exist, dropping");
  137.     next;
  138.       }
  139.       elsif (!-d _) {
  140.     dbg("util: PATH included '$dir', which isn't a directory, dropping");
  141.     next;
  142.       }
  143.       elsif (($stat[2]&2) != 0) {
  144.         # World-Writable directories are considered insecure.
  145.         # We could be more paranoid and check all of the parent directories as well,
  146.         # but it's good for now.
  147.     dbg("util: PATH included '$dir', which is world writable, dropping");
  148.     next;
  149.       }
  150.  
  151.       dbg("util: PATH included '$dir', keeping");
  152.       push(@path, $dir);
  153.     }
  154.  
  155.     $ENV{'PATH'} = join($Config{'path_sep'}, @path);
  156.     dbg("util: final PATH set to: ".$ENV{'PATH'});
  157.   }
  158. }
  159.  
  160. # taint mode: are we running in taint mode? 1 for yes, 0 for no.
  161. sub am_running_in_taint_mode {
  162.   return $AM_TAINTED if defined $AM_TAINTED;
  163.  
  164.   if ($] >= 5.008) {
  165.     # perl 5.8 and above, ${^TAINT} is a syntax violation in 5.005
  166.     $AM_TAINTED = eval q(no warnings q(syntax); ${^TAINT});
  167.   }
  168.   else {
  169.     # older versions
  170.     my $blank;
  171.     for my $d ((File::Spec->curdir, File::Spec->rootdir, File::Spec->tmpdir)) {
  172.       opendir(TAINT, $d) || next;
  173.       $blank = readdir(TAINT);
  174.       closedir(TAINT);
  175.       last;
  176.     }
  177.     if (!(defined $blank && $blank)) {
  178.       # these are sometimes untainted, so this is less preferable than readdir
  179.       $blank = join('', values %ENV, $0, @ARGV);
  180.     }
  181.     $blank = substr($blank, 0, 0);
  182.     # seriously mind-bending perl
  183.     $AM_TAINTED = not eval { eval "1 || $blank" || 1 };
  184.   }
  185.   dbg("util: running in taint mode? ". ($AM_TAINTED ? "yes" : "no"));
  186.   return $AM_TAINTED;
  187. }
  188.  
  189. ###########################################################################
  190.  
  191. sub am_running_on_windows {
  192.   return RUNNING_ON_WINDOWS;
  193. }
  194.  
  195. ###########################################################################
  196.  
  197. # untaint a path to a file, e.g. "/home/jm/.spamassassin/foo",
  198. # "C:\Program Files\SpamAssassin\tmp\foo", "/home/⌡ⁿt/etc".
  199. #
  200. # TODO: this does *not* handle locales well.  We cannot use "use locale"
  201. # and \w, since that will not detaint the data.  So instead just allow the
  202. # high-bit chars from ISO-8859-1, none of which have special metachar
  203. # meanings (as far as I know).
  204. #
  205. sub untaint_file_path {
  206.   my ($path) = @_;
  207.  
  208.   return unless defined($path);
  209.   return '' if ($path eq '');
  210.  
  211.   # Barry Jaspan: allow ~ and spaces, good for Windows.  Also return ''
  212.   # if input is '', as it is a safe path.
  213.   my $chars = '-_A-Za-z\xA0-\xFF0-9\.\%\@\=\+\,\/\\\:';
  214.   my $re = qr/^\s*([$chars][${chars}~ ]*)$/o;
  215.  
  216.   if ($path =~ $re) {
  217.     return $1;
  218.   } else {
  219.     warn "util: cannot untaint path: \"$path\"\n";
  220.     return $path;
  221.   }
  222. }
  223.  
  224. sub untaint_hostname {
  225.   my ($host) = @_;
  226.  
  227.   return unless defined($host);
  228.   return '' if ($host eq '');
  229.  
  230.   # from RFC 1035, but allowing domains starting with numbers:
  231.   #   $label = q/[A-Za-z\d](?:[A-Za-z\d-]{0,61}[A-Za-z\d])?/;
  232.   #   $domain = qq<$label(?:\.$label)*>;
  233.   #   length($host) <= 255 && $host =~ /^($domain)$/
  234.   # expanded (no variables in the re) because of a tainting bug in Perl 5.8.0
  235.   if (length($host) <= 255 && $host =~ /^([a-z\d](?:[a-z\d-]{0,61}[a-z\d])?(?:\.[a-z\d](?:[a-z\d-]{0,61}[a-z\d])?)*)$/i) {
  236.     return $1;
  237.   }
  238.   else {
  239.     warn "util: cannot untaint hostname: \"$host\"\n";
  240.     return $host;
  241.   }
  242. }
  243.  
  244. # This sub takes a scalar or a reference to an array, hash, scalar or another
  245. # reference and recursively untaints all its values (and keys if it's a
  246. # reference to a hash). It should be used with caution as blindly untainting
  247. # values subverts the purpose of working in taint mode. It will return the
  248. # untainted value if requested but to avoid unnecessary copying, the return
  249. # value should be ignored when working on lists.
  250. # Bad:
  251. #  %ENV = untaint_var(\%ENV);
  252. # Better:
  253. #  untaint_var(\%ENV);
  254. #
  255. sub untaint_var {
  256.   local ($_) = @_;
  257.   return undef unless defined;
  258.  
  259.   unless (ref) {
  260.     /^(.*)$/s;
  261.     return $1;
  262.   }
  263.   elsif (ref eq 'ARRAY') {
  264.     @{$_} = map { $_ = untaint_var($_) } @{$_};
  265.     return @{$_} if wantarray;
  266.   }
  267.   elsif (ref eq 'HASH') {
  268.     while (my ($k, $v) = each %{$_}) {
  269.       if (!defined $v && $_ == \%ENV) {
  270.     delete ${$_}{$k};
  271.     next;
  272.       }
  273.       ${$_}{untaint_var($k)} = untaint_var($v);
  274.     }
  275.     return %{$_} if wantarray;
  276.   }
  277.   elsif (ref eq 'SCALAR' or ref eq 'REF') {
  278.     ${$_} = untaint_var(${$_});
  279.   }
  280.   else {
  281.     warn "util: can't untaint a " . ref($_) . "!\n";
  282.   }
  283.   return $_;
  284. }
  285.  
  286. ###########################################################################
  287.  
  288. # timezone mappings: in case of conflicts, use RFC 2822, then most
  289. # common and least conflicting mapping
  290. my %TZ = (
  291.     # standard
  292.     'UT'   => '+0000',
  293.     'UTC'  => '+0000',
  294.     # US and Canada
  295.     'NDT'  => '-0230',
  296.     'AST'  => '-0400',
  297.     'ADT'  => '-0300',
  298.     'NST'  => '-0330',
  299.     'EST'  => '-0500',
  300.     'EDT'  => '-0400',
  301.     'CST'  => '-0600',
  302.     'CDT'  => '-0500',
  303.     'MST'  => '-0700',
  304.     'MDT'  => '-0600',
  305.     'PST'  => '-0800',
  306.     'PDT'  => '-0700',
  307.     'HST'  => '-1000',
  308.     'AKST' => '-0900',
  309.     'AKDT' => '-0800',
  310.     'HADT' => '-0900',
  311.     'HAST' => '-1000',
  312.     # Europe
  313.     'GMT'  => '+0000',
  314.     'BST'  => '+0100',
  315.     'IST'  => '+0100',
  316.     'WET'  => '+0000',
  317.     'WEST' => '+0100',
  318.     'CET'  => '+0100',
  319.     'CEST' => '+0200',
  320.     'EET'  => '+0200',
  321.     'EEST' => '+0300',
  322.     'MSK'  => '+0300',
  323.     'MSD'  => '+0400',
  324.     'MET'  => '+0100',
  325.     'MEZ'  => '+0100',
  326.     'MEST' => '+0200',
  327.     'MESZ' => '+0200',
  328.     # South America
  329.     'BRST' => '-0200',
  330.     'BRT'  => '-0300',
  331.     # Australia
  332.     'AEST' => '+1000',
  333.     'AEDT' => '+1100',
  334.     'ACST' => '+0930',
  335.     'ACDT' => '+1030',
  336.     'AWST' => '+0800',
  337.     # New Zealand
  338.     'NZST' => '+1200',
  339.     'NZDT' => '+1300',
  340.     # Asia
  341.     'JST'  => '+0900',
  342.     'KST'  => '+0900',
  343.     'HKT'  => '+0800',
  344.     'SGT'  => '+0800',
  345.     'PHT'  => '+0800',
  346.     # Middle East
  347.     'IDT'  => '+0300',
  348.     );
  349.  
  350. # month mappings
  351. my %MONTH = (jan => 1, feb => 2, mar => 3, apr => 4, may => 5, jun => 6,
  352.          jul => 7, aug => 8, sep => 9, oct => 10, nov => 11, dec => 12);
  353.  
  354. sub local_tz {
  355.   # standard method for determining local timezone
  356.   my $time = time;
  357.   my @g = gmtime($time);
  358.   my @t = localtime($time);
  359.   my $z = $t[1]-$g[1]+($t[2]-$g[2])*60+($t[7]-$g[7])*1440+($t[5]-$g[5])*525600;
  360.   return sprintf("%+.2d%.2d", $z/60, $z%60);
  361. }
  362.  
  363. sub parse_rfc822_date {
  364.   my ($date) = @_;
  365.   local ($_);
  366.   my ($yyyy, $mmm, $dd, $hh, $mm, $ss, $mon, $tzoff);
  367.  
  368.   # make it a bit easier to match
  369.   $_ = " $date "; s/, */ /gs; s/\s+/ /gs;
  370.  
  371.   # now match it in parts.  Date part first:
  372.   if (s/ (\d+) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) (\d{4}) / /i) {
  373.     $dd = $1; $mon = lc($2); $yyyy = $3;
  374.   } elsif (s/ (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) +(\d+) \d+:\d+:\d+ (\d{4}) / /i) {
  375.     $dd = $2; $mon = lc($1); $yyyy = $3;
  376.   } elsif (s/ (\d+) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) (\d{2,3}) / /i) {
  377.     $dd = $1; $mon = lc($2); $yyyy = $3;
  378.   } else {
  379.     dbg("util: time cannot be parsed: $date");
  380.     return undef;
  381.   }
  382.  
  383.   # handle two and three digit dates as specified by RFC 2822
  384.   if (defined $yyyy) {
  385.     if (length($yyyy) == 2 && $yyyy < 50) {
  386.       $yyyy += 2000;
  387.     }
  388.     elsif (length($yyyy) != 4) {
  389.       # three digit years and two digit years with values between 50 and 99
  390.       $yyyy += 1900;
  391.     }
  392.   }
  393.  
  394.   # hh:mm:ss
  395.   if (s/ (\d?\d):(\d\d)(:(\d\d))? / /) {
  396.     $hh = $1; $mm = $2; $ss = $4 || 0;
  397.   }
  398.  
  399.   # numeric timezones
  400.   if (s/ ([-+]\d{4}) / /) {
  401.     $tzoff = $1;
  402.   }
  403.   # common timezones
  404.   elsif (s/\b([A-Z]{2,4}(?:-DST)?)\b/ / && exists $TZ{$1}) {
  405.     $tzoff = $TZ{$1};
  406.   }
  407.   # all other timezones are considered equivalent to "-0000"
  408.   $tzoff ||= '-0000';
  409.  
  410.   # months
  411.   if (exists $MONTH{$mon}) {
  412.     $mmm = $MONTH{$mon};
  413.   }
  414.  
  415.   $hh ||= 0; $mm ||= 0; $ss ||= 0; $dd ||= 0; $mmm ||= 0; $yyyy ||= 0;
  416.  
  417.   # Time::Local (v1.10 at least) throws warnings when the dates cause
  418.   # a 32-bit overflow.  So force a min/max for year.
  419.   if ($yyyy > 2037) {
  420.     dbg("util: year after supported range, forcing year to 2037: $date");
  421.     $yyyy = 2037;
  422.   }
  423.   elsif ($yyyy < 1970) {
  424.     dbg("util: year before supported range, forcing year to 1970: $date");
  425.     $yyyy = 1971;
  426.   }
  427.  
  428.   # Fudge invalid times so that we get a usable date.
  429.   if ($ss > 59) { 
  430.     dbg("util: second after supported range, forcing second to 59: $date");  
  431.     $ss = 59;
  432.   } 
  433.  
  434.   if ($mm > 59) { 
  435.     dbg("util: minute after supported range, forcing minute to 59: $date");
  436.     $mm = 59;
  437.   }
  438.  
  439.   if ($hh > 23) { 
  440.     dbg("util: hour after supported range, forcing hour to 23: $date"); 
  441.     $hh = 23;
  442.   }
  443.  
  444.   my $time;
  445.   eval {        # could croak
  446.     $time = timegm($ss, $mm, $hh, $dd, $mmm-1, $yyyy);
  447.   };
  448.  
  449.   if ($@) {
  450.     dbg("util: time cannot be parsed: $date, $yyyy-$mmm-$dd $hh:$mm:$ss");
  451.     return undef;
  452.   }
  453.  
  454.   if ($tzoff =~ /([-+])(\d\d)(\d\d)$/)    # convert to seconds difference
  455.   {
  456.     $tzoff = (($2 * 60) + $3) * 60;
  457.     if ($1 eq '-') {
  458.       $time += $tzoff;
  459.     } else {
  460.       $time -= $tzoff;
  461.     }
  462.   }
  463.  
  464.   return $time;
  465. }
  466.  
  467. sub time_to_rfc822_date {
  468.   my($time) = @_;
  469.  
  470.   my @days = qw/Sun Mon Tue Wed Thu Fri Sat/;
  471.   my @months = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
  472.   my @localtime = localtime($time || time);
  473.   $localtime[5]+=1900;
  474.  
  475.   sprintf("%s, %02d %s %4d %02d:%02d:%02d %s", $days[$localtime[6]], $localtime[3],
  476.     $months[$localtime[4]], @localtime[5,2,1,0], local_tz());
  477. }
  478.  
  479. ###########################################################################
  480.  
  481. # This is a wrapper for the Text::Wrap::wrap routine which makes its usage
  482. # a bit safer.  It accepts values for almost all options which can be set
  483. # in Text::Wrap.   All parameters are optional (leaving away the first one 
  484. # probably doesn't make too much sense though), either a missing or a false
  485. # value will fall back to the default.  Note that the parameter order and
  486. # default values aren't always the isame as in Text::Wrap itself.
  487. # 
  488. # The parameters are:
  489. #  1st:  The string to wrap.  Only one string is allowed (unlike the original
  490. #        wrap() routine).  (default: "")
  491. #  2nd:  The prefix to be put in front of all lines except the first one. 
  492. #        (default: "")
  493. #  3rd:  The prefix for the first line.  (default:  "")
  494. #  4th:  The number of columns available (no line will be longer than this
  495. #        parameter minus one).  See $Text::Wrap::columns.  (default:  77)
  496. #  5th:  Enable or disable overflow mode.  A false value is 'overflow', a
  497. #        true one 'wrap'; see $Text::Wrap::huge.  (default: 0)
  498. #  6th:  The sequence/expression to wrap at.  See $Text::Wrap::break
  499. #        (default: '\s');
  500. #  7th:  The string to join the lines again.  See $Text::Wrap::separator.
  501. #        (default: "\n")
  502. #  8th:  All tabs (except any in the prefix strings) are first replaced
  503. #        with 8 spaces.  This parameter controls if any 8-space sequence 
  504. #        is replaced with tabs again later.  See $Text::Wrap::unexpand but
  505. #        note that we use a different default value.  (default: 0)
  506.  
  507. sub wrap {
  508.   local($Text::Wrap::columns)   = $_[3] || 77;
  509.   local($Text::Wrap::huge)      = $_[4] ? 'overflow' : 'wrap';
  510.   local($Text::Wrap::break)     = $_[5] || '\s';
  511.   local($Text::Wrap::separator) = $_[6] || "\n";
  512.   local($Text::Wrap::unexpand)  = $_[7] || 0;
  513.   # There's a die() in there which "shouldn't happen", but better be
  514.   # paranoid.  We'll return the unwrapped string if anything went wrong.
  515.   my $text = $_[0] || "";
  516.   eval {
  517.     $text = Text::Wrap::wrap($_[2] || "", $_[1] || "", $text);
  518.   };
  519.   return $text;
  520. }
  521.  
  522. ###########################################################################
  523.  
  524. # Some base64 decoders will remove intermediate "=" characters, others
  525. # will stop decoding on the first "=" character, this one translates "="
  526. # characters to null.
  527. sub base64_decode {
  528.   local $_ = shift;
  529.   my $decoded_length = shift;
  530.  
  531.   s/\s+//g;
  532.   if (HAS_MIME_BASE64 && (length($_) % 4 == 0) &&
  533.       m|^(?:[A-Za-z0-9+/=]{2,}={0,2})$|s)
  534.   {
  535.     # only use MIME::Base64 when the XS and Perl are both correct and quiet
  536.     s/(=+)(?!=*$)/'A' x length($1)/ge;
  537.  
  538.     # If only a certain number of bytes are requested, truncate the encoded
  539.     # version down to the appropriate size and return the requested bytes
  540.     if (defined $decoded_length) {
  541.       $_ = substr $_, 0, 4 * (int($decoded_length/3) + 1);
  542.       my $decoded = MIME::Base64::decode_base64($_);
  543.       return substr $decoded, 0, $decoded_length;
  544.     }
  545.  
  546.     # otherwise, just decode the whole thing and return it
  547.     return MIME::Base64::decode_base64($_);
  548.   }
  549.   tr{A-Za-z0-9+/=}{}cd;            # remove non-base64 characters
  550.   s/=+$//;                # remove terminating padding
  551.   tr{A-Za-z0-9+/=}{ -_`};        # translate to uuencode
  552.   s/.$// if (length($_) % 4 == 1);    # unpack cannot cope with extra byte
  553.  
  554.   my $length;
  555.   my $out = '';
  556.   while ($_) {
  557.     $length = (length >= 84) ? 84 : length;
  558.     $out .= unpack("u", chr(32 + $length * 3/4) . substr($_, 0, $length, ''));
  559.     last if (defined $decoded_length && length $out >= $decoded_length);
  560.   }
  561.  
  562.   # If only a certain number of bytes are requested, truncate the encoded
  563.   # version down to the appropriate size and return the requested bytes
  564.   if (defined $decoded_length) {
  565.     return substr $out, 0, $decoded_length;
  566.   }
  567.  
  568.   return $out;
  569. }
  570.  
  571. sub qp_decode {
  572.   local $_ = shift;
  573.  
  574.   s/\=\r?\n//gs;
  575.   s/\=([0-9a-fA-F]{2})/chr(hex($1))/ge;
  576.   return $_;
  577. }
  578.  
  579. sub base64_encode {
  580.   local $_ = shift;
  581.  
  582.   if (HAS_MIME_BASE64) {
  583.     return MIME::Base64::encode_base64($_);
  584.   }
  585.  
  586.   $_ = pack("u57", $_);
  587.   s/^.//mg;
  588.   tr| -_`|A-Za-z0-9+/A|; # -> #`# <- kluge against vim syntax issues
  589.   s/(A+)$/'=' x length $1/e;
  590.   return $_;
  591. }
  592.  
  593. ###########################################################################
  594.  
  595. sub portable_getpwuid {
  596.   if (defined &Mail::SpamAssassin::Util::_getpwuid_wrapper) {
  597.     return Mail::SpamAssassin::Util::_getpwuid_wrapper(@_);
  598.   }
  599.  
  600.   if (!RUNNING_ON_WINDOWS) {
  601.     eval ' sub _getpwuid_wrapper { getpwuid($_[0]); } ';
  602.   } else {
  603.     dbg("util: defining getpwuid() wrapper using 'unknown' as username");
  604.     eval ' sub _getpwuid_wrapper { _fake_getpwuid($_[0]); } ';
  605.   }
  606.  
  607.   if ($@) {
  608.     warn "util: failed to define getpwuid() wrapper: $@\n";
  609.   } else {
  610.     return Mail::SpamAssassin::Util::_getpwuid_wrapper(@_);
  611.   }
  612. }
  613.  
  614. sub _fake_getpwuid {
  615.   return (
  616.     'unknown',        # name,
  617.     'x',        # passwd,
  618.     $_[0],        # uid,
  619.     0,            # gid,
  620.     '',            # quota,
  621.     '',            # comment,
  622.     '',            # gcos,
  623.     '/',        # dir,
  624.     '',            # shell,
  625.     '',            # expire
  626.   );
  627. }
  628.  
  629. ###########################################################################
  630.  
  631. # Given a string, extract an IPv4 address from it.  Required, since
  632. # we currently have no way to portably unmarshal an IPv4 address from
  633. # an IPv6 one without kludging elsewhere.
  634. #
  635. sub extract_ipv4_addr_from_string {
  636.   my ($str) = @_;
  637.  
  638.   return unless defined($str);
  639.  
  640.   if ($str =~ /\b(
  641.             (?:1\d\d|2[0-4]\d|25[0-5]|\d\d|\d)\.
  642.             (?:1\d\d|2[0-4]\d|25[0-5]|\d\d|\d)\.
  643.             (?:1\d\d|2[0-4]\d|25[0-5]|\d\d|\d)\.
  644.             (?:1\d\d|2[0-4]\d|25[0-5]|\d\d|\d)
  645.               )\b/ix)
  646.   {
  647.     if (defined $1) { return $1; }
  648.   }
  649.  
  650.   # ignore native IPv6 addresses; currently we have no way to deal with
  651.   # these if we could extract them, as the DNSBLs don't provide a way
  652.   # to query them!  TODO, eventually, once IPv6 spam starts to appear ;)
  653.   return;
  654. }
  655.  
  656. ###########################################################################
  657. {
  658.   my($hostname, $fq_hostname);
  659.  
  660. # get the current host's unqalified domain name (better: return whatever
  661. # Sys::Hostname thinks our hostname is, might also be a full qualified one)
  662.   sub hostname {
  663.     return $hostname if defined($hostname);
  664.  
  665.     # Sys::Hostname isn't taint safe and might fall back to `hostname`. So we've
  666.     # got to clean PATH before we may call it.
  667.     clean_path_in_taint_mode();
  668.     $hostname = Sys::Hostname::hostname();
  669.  
  670.     return $hostname;
  671.   }
  672.  
  673. # get the current host's fully-qualified domain name, if possible.  If
  674. # not possible, return the unqualified hostname.
  675.   sub fq_hostname {
  676.     return $fq_hostname if defined($fq_hostname);
  677.  
  678.     $fq_hostname = hostname();
  679.     if ($fq_hostname !~ /\./) { # hostname doesn't contain a dot, so it can't be a FQDN
  680.       my @names = grep(/^\Q${fq_hostname}.\E/o,                         # grep only FQDNs
  681.                     map { split } (gethostbyname($fq_hostname))[0 .. 1] # from all aliases
  682.                   );
  683.       $fq_hostname = $names[0] if (@names); # take the first FQDN, if any 
  684.     }
  685.  
  686.     return $fq_hostname;
  687.   }
  688. }
  689.  
  690. ###########################################################################
  691.  
  692. sub ips_match_in_16_mask {
  693.   my ($ipset1, $ipset2) = @_;
  694.   my ($b1, $b2);
  695.  
  696.   foreach my $ip1 (@{$ipset1}) {
  697.     foreach my $ip2 (@{$ipset2}) {
  698.       next unless defined $ip1;
  699.       next unless defined $ip2;
  700.       next unless ($ip1 =~ /^(\d+\.\d+\.)/); $b1 = $1;
  701.       next unless ($ip2 =~ /^(\d+\.\d+\.)/); $b2 = $1;
  702.       if ($b1 eq $b2) { return 1; }
  703.     }
  704.   }
  705.  
  706.   return 0;
  707. }
  708.  
  709. sub ips_match_in_24_mask {
  710.   my ($ipset1, $ipset2) = @_;
  711.   my ($b1, $b2);
  712.  
  713.   foreach my $ip1 (@{$ipset1}) {
  714.     foreach my $ip2 (@{$ipset2}) {
  715.       next unless defined $ip1;
  716.       next unless defined $ip2;
  717.       next unless ($ip1 =~ /^(\d+\.\d+\.\d+\.)/); $b1 = $1;
  718.       next unless ($ip2 =~ /^(\d+\.\d+\.\d+\.)/); $b2 = $1;
  719.       if ($b1 eq $b2) { return 1; }
  720.     }
  721.   }
  722.  
  723.   return 0;
  724. }
  725.  
  726. ###########################################################################
  727.  
  728. sub my_inet_aton { unpack("N", pack("C4", split(/\./, $_[0]))) }
  729.  
  730. ###########################################################################
  731.  
  732. sub parse_content_type {
  733.   # This routine is typically called by passing a
  734.   # get_header("content-type") which passes all content-type headers
  735.   # (array context).  If there are multiple Content-type headers (invalid,
  736.   # but it happens), MUAs seem to take the last one and so that's what we
  737.   # should do here.
  738.   #
  739.   my $ct = $_[-1] || 'text/plain; charset=us-ascii';
  740.  
  741.   # This could be made a bit more rigid ...
  742.   # the actual ABNF, BTW (RFC 1521, section 7.2.1):
  743.   # boundary := 0*69<bchars> bcharsnospace
  744.   # bchars := bcharsnospace / " "
  745.   # bcharsnospace :=    DIGIT / ALPHA / "'" / "(" / ")" / "+" /"_"
  746.   #               / "," / "-" / "." / "/" / ":" / "=" / "?"
  747.   #
  748.   # The boundary may be surrounded by double quotes.
  749.   # "the boundary parameter, which consists of 1 to 70 characters from
  750.   # a set of characters known to be very robust through email gateways,
  751.   # and NOT ending with white space.  (If a boundary appears to end with
  752.   # white space, the white space must be presumed to have been added by
  753.   # a gateway, and must be deleted.)"
  754.   #
  755.   # In practice:
  756.   # - MUAs accept whitespace before and after the "=" character
  757.   # - only an opening double quote seems to be needed
  758.   # - non-quoted boundaries should be followed by space, ";", or end of line
  759.   # - blank boundaries seem to not work
  760.   #
  761.   my($boundary) = $ct =~ m!\bboundary\s*=\s*("[^"]+|[^\s";]+(?=[\s;]|$))!i;
  762.  
  763.   # remove double-quotes in boundary (should only be at start and end)
  764.   #
  765.   $boundary =~ tr/"//d if defined $boundary;
  766.  
  767.   # Parse out the charset and name, if they exist.
  768.   #
  769.   my($charset) = $ct =~ /\bcharset\s*=\s*["']?(.*?)["']?(?:;|$)/i;
  770.   my($name) = $ct =~ /\b(?:file)?name\s*=\s*["']?(.*?)["']?(?:;|$)/i;
  771.  
  772.   # Get the actual MIME type out ...
  773.   # Note: the header content may not be whitespace unfolded, so make sure the
  774.   # REs do /s when appropriate.
  775.   #
  776.   $ct =~ s/^\s+//;            # strip leading whitespace
  777.   $ct =~ s/;.*$//s;            # strip everything after first ';'
  778.   $ct =~ s@^([^/]+(?:/[^/]*)?).*$@$1@s;    # only something/something ...
  779.   # strip inappropriate chars
  780.   $ct =~ tr/\000-\040\177-\377\042\050\051\054\056\072-\077\100\133-\135//d;
  781.   $ct = lc $ct;
  782.  
  783.   # bug 4298: If at this point we don't have a content-type, assume text/plain
  784.   $ct ||= "text/plain";
  785.  
  786.   # Now that the header has been parsed, return the requested information.
  787.   # In scalar context, just the MIME type, in array context the
  788.   # four important data parts (type, boundary, charset, and filename).
  789.   #
  790.   return wantarray ? ($ct,$boundary,$charset,$name) : $ct;
  791. }
  792.  
  793. ###########################################################################
  794.  
  795. sub url_encode {
  796.   my ($url) = @_;
  797.   my (@characters) = split(/(\%[0-9a-fA-F]{2})/, $url);
  798.   my (@unencoded) = ();
  799.   my (@encoded) = ();
  800.  
  801.   foreach (@characters) {
  802.     # escaped character set ...
  803.     if (/\%[0-9a-fA-F]{2}/) {
  804.       # IF it is in the range of 0x00-0x20 or 0x7f-0xff
  805.       #    or it is one of  "<", ">", """, "#", "%",
  806.       #                     ";", "/", "?", ":", "@", "=" or "&"
  807.       # THEN preserve its encoding
  808.       unless (/(20|7f|[0189a-fA-F][0-9a-fA-F])/i) {
  809.     s/\%([2-7][0-9a-fA-F])/sprintf "%c", hex($1)/e;
  810.     push(@unencoded, $_);
  811.       }
  812.     }
  813.     # other stuff
  814.     else {
  815.       # 0x00-0x20, 0x7f-0xff, ", %, <, >
  816.       s/([\000-\040\177-\377\042\045\074\076])
  817.       /push(@encoded, $1) && sprintf "%%%02x", unpack("C",$1)/egx;
  818.     }
  819.   }
  820.   if (wantarray) {
  821.     return(join("", @characters), join("", @unencoded), join("", @encoded));
  822.   }
  823.   else {
  824.     return join("", @characters);
  825.   }
  826. }
  827.  
  828. ###########################################################################
  829.  
  830. =item $module = first_available_module (@module_list)
  831.  
  832. Return the name of the first module that can be successfully loaded with
  833. C<require> from the list.  Returns C<undef> if none are available.
  834.  
  835. This is used instead of C<AnyDBM_File> as follows:
  836.  
  837.   my $module = Mail::SpamAssassin::Util::first_available_module
  838.                         (qw(DB_File GDBM_File NDBM_File SDBM_File));
  839.   tie %hash, $module, $path, [... args];
  840.  
  841. Note that C<SDBM_File> is guaranteed to be present, since it comes
  842. with Perl.
  843.  
  844. =cut
  845.  
  846. sub first_available_module {
  847.   my (@packages) = @_;
  848.   foreach my $mod (@packages) {
  849.     if (eval 'require '.$mod.'; 1; ') {
  850.       return $mod;
  851.     }
  852.   }
  853.   undef;
  854. }
  855.  
  856. ###########################################################################
  857.  
  858. =item my ($filepath, $filehandle) = secure_tmpfile();
  859.  
  860. Generates a filename for a temporary file, opens it exclusively and
  861. securely, and returns a filehandle to the open file (opened O_RDWR).
  862.  
  863. If it cannot open a file after 20 tries, it returns C<undef>.
  864.  
  865. =cut
  866.  
  867. # thanks to http://www2.picante.com:81/~gtaylor/autobuse/ for this code
  868. sub secure_tmpfile {
  869.   my $tmpdir = Mail::SpamAssassin::Util::untaint_file_path(File::Spec->tmpdir());
  870.  
  871.   if (!$tmpdir) {
  872.     # Note: we would prefer to keep this fatal, as not being able to
  873.     # find a writable tmpdir is a big deal for the calling code too.
  874.     # That would be quite a psychotic case, also.
  875.     warn "util: cannot find a temporary directory, set TMP or TMPDIR in environment";
  876.     return;
  877.   }
  878.  
  879.   my ($reportfile, $tmpfile);
  880.   my $umask = umask 077;
  881.  
  882.   for (my $retries = 20; $retries > 0; $retries--) {
  883.     # we do not rely on the obscurity of this name for security,
  884.     # we use a average-quality PRG since this is all we need
  885.     my $suffix = join('', (0..9,'A'..'Z','a'..'z')[rand 62, rand 62, rand 62,
  886.                            rand 62, rand 62, rand 62]);
  887.     $reportfile = File::Spec->catfile($tmpdir,".spamassassin${$}${suffix}tmp");
  888.  
  889.     # instead, we require O_EXCL|O_CREAT to guarantee us proper
  890.     # ownership of our file, read the open(2) man page
  891.     if (sysopen($tmpfile, $reportfile, O_RDWR|O_CREAT|O_EXCL, 0600)) {
  892.       last;
  893.     }
  894.  
  895.     if ($!{EEXIST}) {
  896.       # it is acceptable if $tmpfile already exists, try another
  897.       next;
  898.     }
  899.     
  900.     # error, maybe "out of quota" or "too many open files" (bug 4017)
  901.     warn "util: secure_tmpfile failed to create file '$reportfile': $!\n";
  902.  
  903.     # ensure the file handle is not semi-open in some way
  904.     if ($tmpfile) {
  905.       close $tmpfile;
  906.     }
  907.   }
  908.  
  909.   umask $umask;
  910.  
  911.   if (!$tmpfile) {
  912.     warn "util: secure_tmpfile failed to create file, giving up";
  913.     return;    # undef
  914.   }
  915.  
  916.   return ($reportfile, $tmpfile);
  917. }
  918.  
  919. =item my ($dirpath) = secure_tmpdir();
  920.  
  921. Generates a directory for temporary files.  Creates it securely and
  922. returns the path to the directory.
  923.  
  924. If it cannot create a directory after 20 tries, it returns C<undef>.
  925.  
  926. =cut
  927.  
  928. # stolen from secure_tmpfile()
  929. sub secure_tmpdir {
  930.   my $tmpdir = Mail::SpamAssassin::Util::untaint_file_path(File::Spec->tmpdir());
  931.  
  932.   if (!$tmpdir) {
  933.     # Note: we would prefer to keep this fatal, as not being able to
  934.     # find a writable tmpdir is a big deal for the calling code too.
  935.     # That would be quite a psychotic case, also.
  936.     warn "util: cannot find a temporary directory, set TMP or TMPDIR in environment";
  937.     return;
  938.   }
  939.  
  940.   my ($reportpath, $tmppath);
  941.   my $umask = umask 077;
  942.  
  943.   for (my $retries = 20; $retries > 0; $retries--) {
  944.     # we do not rely on the obscurity of this name for security,
  945.     # we use a average-quality PRG since this is all we need
  946.     my $suffix = join('', (0..9,'A'..'Z','a'..'z')[rand 62, rand 62, rand 62,
  947.                            rand 62, rand 62, rand 62]);
  948.     $reportpath = File::Spec->catfile($tmpdir,".spamassassin${$}${suffix}tmp");
  949.  
  950.     # instead, we require O_EXCL|O_CREAT to guarantee us proper
  951.     # ownership of our file, read the open(2) man page
  952.     if (mkdir $reportpath, 0700) {
  953.       $tmppath = $reportpath;
  954.       last;
  955.     }
  956.  
  957.     if ($!{EEXIST}) {
  958.       # it is acceptable if $reportpath already exists, try another
  959.       next;
  960.     }
  961.     
  962.     # error, maybe "out of quota" or "too many open files" (bug 4017)
  963.     warn "util: secure_tmpdir failed to create file '$reportpath': $!\n";
  964.   }
  965.  
  966.   umask $umask;
  967.  
  968.   warn "util: secure_tmpdir failed to create a directory, giving up" if (!$tmppath);
  969.  
  970.   return $tmppath;
  971. }
  972.  
  973.  
  974. ###########################################################################
  975.  
  976. sub uri_to_domain {
  977.   my ($uri) = @_;
  978.  
  979.   # Javascript is not going to help us, so return.
  980.   return if ($uri =~ /^javascript:/i);
  981.  
  982.   $uri =~ s,#.*$,,gs;            # drop fragment
  983.   $uri =~ s#^[a-z]+:/{0,2}##gsi;    # drop the protocol
  984.   $uri =~ s,^[^/]*\@,,gs;        # username/passwd
  985.  
  986.   # strip path and CGI params.  note: bug 4213 shows that "&" should
  987.   # *not* be likewise stripped here -- it's permitted in hostnames by
  988.   # some common MUAs!
  989.   $uri =~ s,[/\?].*$,,gs;              
  990.  
  991.   $uri =~ s,:\d*$,,gs;            # port, bug 4191: sometimes the # is missing
  992.  
  993.   # skip undecoded URIs if the encoded bits shouldn't be.
  994.   # we'll see the decoded version as well.  see url_encode()
  995.   return if $uri =~ /\%(?:2[1-9a-fA-F]|[3-6][0-9a-fA-f]|7[0-9a-eA-E])/;
  996.  
  997.   # keep IPs intact
  998.   if ($uri !~ /^\d+\.\d+\.\d+\.\d+$/) { 
  999.     # get rid of hostname part of domain, understanding delegation
  1000.     $uri = Mail::SpamAssassin::Util::RegistrarBoundaries::trim_domain($uri);
  1001.  
  1002.     # ignore invalid domains
  1003.     return unless
  1004.         (Mail::SpamAssassin::Util::RegistrarBoundaries::is_domain_valid($uri));
  1005.   }
  1006.   
  1007.   # $uri is now the domain only
  1008.   return lc $uri;
  1009. }
  1010.  
  1011. sub uri_list_canonify {
  1012.   my($redirector_patterns, @uris) = @_;
  1013.  
  1014.   # make sure we catch bad encoding tricks
  1015.   my @nuris = ();
  1016.   for my $uri (@uris) {
  1017.     # we're interested in http:// and so on, skip mailto: and
  1018.     # email addresses with no protocol
  1019.     next if $uri =~ /^mailto:/i || $uri =~ /^[^:]*\@/;
  1020.  
  1021.     # sometimes we catch URLs on multiple lines
  1022.     $uri =~ s/\n//g;
  1023.  
  1024.     # URLs won't have leading/trailing whitespace
  1025.     $uri =~ s/^\s+//;
  1026.     $uri =~ s/\s+$//;
  1027.  
  1028.     # CRs just confuse things down below, so trash them now
  1029.     $uri =~ s/\r//g;
  1030.  
  1031.     # Make a copy so we don't trash the original in the array
  1032.     my $nuri = $uri;
  1033.  
  1034.     # bug 4390: certain MUAs treat back slashes as front slashes.
  1035.     # since backslashes are supposed to be encoded in a URI, swap non-encoded
  1036.     # ones with front slashes.
  1037.     $nuri =~ tr@\\@/@;
  1038.  
  1039.     # http:www.foo.biz -> http://www.foo.biz
  1040.     $nuri =~ s#^(https?:)/{0,2}#$1//#i;
  1041.  
  1042.     # *always* make a dup with all %-encoding decoded, since
  1043.     # important parts of the URL may be encoded (such as the
  1044.     # scheme). (bug 4213)
  1045.     if ($nuri =~ /\%[0-9a-fA-F]{2}/) {
  1046.       $nuri = Mail::SpamAssassin::Util::url_encode($nuri);
  1047.     }
  1048.  
  1049.     # www.foo.biz -> http://www.foo.biz
  1050.     # unschemed URIs: assume default of "http://" as most MUAs do
  1051.     if ($nuri !~ /^[-_a-z0-9]+:/i) {
  1052.       if ($nuri =~ /^ftp\./) {
  1053.     $nuri =~ s@^@ftp://@g;
  1054.       }
  1055.       else {
  1056.     $nuri =~ s@^@http://@g;
  1057.       }
  1058.     }
  1059.  
  1060.     # http://www.foo.biz?id=3 -> http://www.foo.biz/?id=3
  1061.     $nuri =~ s@^(https?://[^/?]+)\?@$1/?@i;
  1062.  
  1063.     # deal with encoding of chars, this is just the set of printable
  1064.     # chars minus ' ' (that is, dec 33-126, hex 21-7e)
  1065.     $nuri =~ s/\&\#0*(3[3-9]|[4-9]\d|1[01]\d|12[0-6]);/sprintf "%c",$1/ge;
  1066.     $nuri =~ s/\&\#x0*(2[1-9]|[3-6][a-fA-F0-9]|7[0-9a-eA-E]);/sprintf "%c",hex($1)/ge;
  1067.  
  1068.     # put the new URI on the new list if it's different
  1069.     if ($nuri ne $uri) {
  1070.       push(@nuris, $nuri);
  1071.     }
  1072.  
  1073.     # deal with wierd hostname parts, remove user/pass, etc.
  1074.     if ($nuri =~ m{^(https?://)([^/]+?)((?::\d*)?\/.*)?$}i) {
  1075.       my($proto, $host, $rest) = ($1,$2,$3);
  1076.  
  1077.       # not required
  1078.       $rest ||= '';
  1079.  
  1080.       # bug 4146: deal with non-US ASCII 7-bit chars in the host portion
  1081.       # of the URI according to RFC 1738 that's invalid, and the tested
  1082.       # browsers (Firefox, IE) remove them before usage...
  1083.       if ($host =~ tr/\000-\040\200-\377//d) {
  1084.         push(@nuris, join ('', $proto, $host, $rest));
  1085.       }
  1086.  
  1087.       # deal with http redirectors.  strip off one level of redirector
  1088.       # and add back to the array.  the foreach loop will go over those
  1089.       # and deal appropriately.
  1090.       # bug 3308: redirectors like yahoo only need one '/' ... <grrr>
  1091.       if ($rest =~ m{(https?:/{0,2}.+)$}i) {
  1092.         push(@uris, $1);
  1093.       }
  1094.  
  1095.       # resort to redirector pattern matching if the generic https? check
  1096.       # doesn't result in a match -- bug 4176
  1097.       else {
  1098.     foreach (@{$redirector_patterns}) {
  1099.       if ("$proto$host$rest" =~ $_) {
  1100.         next unless defined $1;
  1101.         dbg("uri: parsed uri pattern: $_");
  1102.         dbg("uri: parsed uri found: $1 in redirector: $proto$host$rest");
  1103.         push (@uris, $1);
  1104.         last;
  1105.       }
  1106.     }
  1107.       }
  1108.  
  1109.       ########################
  1110.       ## TVD: known issue, if host has multiple combinations of the following,
  1111.       ## all permutations will be put onto @nuris.  shouldn't be an issue.
  1112.  
  1113.       # Get rid of cruft that could cause confusion for rules...
  1114.  
  1115.       # remove "www.fakehostname.com@" username part
  1116.       if ($host =~ s/^[^\@]+\@//gs) {
  1117.         push(@nuris, join ('', $proto, $host, $rest));
  1118.       }
  1119.  
  1120.       # bug 3186: If in a sentence, we might pick up odd characters ...
  1121.       # ie: "visit http://example.biz." or "visit http://example.biz!!!"
  1122.       # the host portion should end in some form of alpha-numeric, strip off
  1123.       # the rest.
  1124.       if ($host =~ s/[^0-9A-Za-z]+$//) {
  1125.         push(@nuris, join ('', $proto, $host, $rest));
  1126.       }
  1127.  
  1128.       ########################
  1129.  
  1130.       # deal with hosts which are IPs
  1131.       # also handle things like:
  1132.       # http://89.0x00000000000000000000068.0000000000000000000000160.0x00000000000011
  1133.       #    both hex (0x) and oct (0+) encoded octets, etc.
  1134.  
  1135.       if ($host =~ /^
  1136.         ((?:0x[0-9a-f]{2,}|\d+)\.)
  1137.     ((?:0x[0-9a-f]{2,}|\d+)\.)
  1138.     ((?:0x[0-9a-f]{2,}|\d+)\.)
  1139.     (0x[0-9a-f]{2,}|\d+)
  1140.     $/ix) {
  1141.         my @chunk = ($1,$2,$3,$4);
  1142.         foreach my $octet (@chunk) {
  1143.           $octet =~ s/^0x0*([0-9a-f][0-9a-f])/sprintf "%d",hex($1)/gei;
  1144.           $octet =~ s/^0+([1-3][0-7]{0,2}|[4-7][0-7]?)\b/sprintf "%d",oct($1)/ge;
  1145.       $octet =~ s/^0+//;
  1146.         }
  1147.         push(@nuris, join ('', $proto, @chunk, $rest));
  1148.       }
  1149.  
  1150.       # "http://0x7f000001/"
  1151.       elsif ($host =~ /^0x[0-9a-f]+$/i) {
  1152.         # only take last 4 octets
  1153.         $host =~ s/^0x[0-9a-f]*?([0-9a-f]{1,8})$/sprintf "%d",hex($1)/gei;
  1154.         push(@nuris, join ('', $proto, decode_ulong_to_ip($host), $rest));
  1155.       }
  1156.  
  1157.       # "http://1113343453/"
  1158.       elsif ($host =~ /^[0-9]+$/) {
  1159.         push(@nuris, join ('', $proto, decode_ulong_to_ip($host), $rest));
  1160.       }
  1161.  
  1162.     }
  1163.   }
  1164.  
  1165.   # remove duplicates, merge nuris and uris
  1166.   my %uris = map { $_ => 1 } @uris, @nuris;
  1167.  
  1168.   return keys %uris;
  1169. }
  1170.  
  1171. sub decode_ulong_to_ip {
  1172.   return join(".", unpack("CCCC",pack("H*", sprintf "%08lx", $_[0])));
  1173. }
  1174.  
  1175. ###########################################################################
  1176.  
  1177. sub first_date {
  1178.   my (@strings) = @_;
  1179.  
  1180.   foreach my $string (@strings) {
  1181.     my $time = parse_rfc822_date($string);
  1182.     return $time if defined($time) && $time;
  1183.   }
  1184.   return undef;
  1185. }
  1186.  
  1187. sub receive_date {
  1188.   my ($header) = @_;
  1189.  
  1190.   $header ||= '';
  1191.   $header =~ s/\n[ \t]+/ /gs;    # fix continuation lines
  1192.  
  1193.   my @rcvd = ($header =~ /^Received:(.*)/img);
  1194.   my @local;
  1195.   my $time;
  1196.  
  1197.   if (@rcvd) {
  1198.     if ($rcvd[0] =~ /qmail \d+ invoked by uid \d+/ ||
  1199.     $rcvd[0] =~ /\bfrom (?:localhost\s|(?:\S+ ){1,2}\S*\b127\.0\.0\.1\b)/)
  1200.     {
  1201.       push @local, (shift @rcvd);
  1202.     }
  1203.     if (@rcvd && ($rcvd[0] =~ m/\bby localhost with \w+ \(fetchmail-[\d.]+/)) {
  1204.       push @local, (shift @rcvd);
  1205.     }
  1206.     elsif (@local) {
  1207.       unshift @rcvd, (shift @local);
  1208.     }
  1209.   }
  1210.  
  1211.   if (@rcvd) {
  1212.     $time = first_date(shift @rcvd);
  1213.     return $time if defined($time);
  1214.   }
  1215.   if (@local) {
  1216.     $time = first_date(@local);
  1217.     return $time if defined($time);
  1218.   }
  1219.   if ($header =~ /^(?:From|X-From-Line:)\s+(.+)$/im) {
  1220.     my $string = $1;
  1221.     $string .= " ".local_tz() unless $string =~ /(?:[-+]\d{4}|\b[A-Z]{2,4}\b)/;
  1222.     $time = first_date($string);
  1223.     return $time if defined($time);
  1224.   }
  1225.   if (@rcvd) {
  1226.     $time = first_date(@rcvd);
  1227.     return $time if defined($time);
  1228.   }
  1229.   if ($header =~ /^Resent-Date:\s*(.+)$/im) {
  1230.     $time = first_date($1);
  1231.     return $time if defined($time);
  1232.   }
  1233.   if ($header =~ /^Date:\s*(.+)$/im) {
  1234.     $time = first_date($1);
  1235.     return $time if defined($time);
  1236.   }
  1237.  
  1238.   return time;
  1239. }
  1240.  
  1241. ###########################################################################
  1242.  
  1243. sub setuid_to_euid {
  1244.   return if (RUNNING_ON_WINDOWS);
  1245.  
  1246.   # remember the target uid, the first number is the important one
  1247.   my $touid = $>;
  1248.  
  1249.   if ($< != $touid) {
  1250.     dbg("util: changing real uid from $< to match effective uid $touid");
  1251.     $< = $touid; # try the simple method first
  1252.  
  1253.     # bug 3586: Some perl versions, typically those on a BSD-based
  1254.     # platform, require RUID==EUID (and presumably == 0) before $<
  1255.     # can be changed.  So this is a kluge for us to get around the
  1256.     # typical spamd-ish behavior of: $< = 0, $> = someuid ...
  1257.     if ( $< != $touid ) {
  1258.       dbg("util: initial attempt to change real uid failed, trying BSD workaround");
  1259.  
  1260.       $> = $<;            # revert euid to ruid
  1261.       $< = $touid;        # change ruid to target
  1262.       $> = $touid;        # change euid back to target
  1263.     }
  1264.  
  1265.     # Check that we have now accomplished the setuid
  1266.     if ($< != $touid) {
  1267.       # keep this fatal: it's a serious security problem if it fails
  1268.       die "util: setuid $< to $touid failed!";
  1269.     }
  1270.   }
  1271. }
  1272.  
  1273. # helper app command-line open
  1274. sub helper_app_pipe_open {
  1275.   if (RUNNING_ON_WINDOWS) {
  1276.     return helper_app_pipe_open_windows (@_);
  1277.   } else {
  1278.     return helper_app_pipe_open_unix (@_);
  1279.   }
  1280. }
  1281.  
  1282. sub helper_app_pipe_open_windows {
  1283.   my ($fh, $stdinfile, $duperr2out, @cmdline) = @_;
  1284.  
  1285.   # use a traditional open(FOO, "cmd |")
  1286.   my $cmd = join(' ', @cmdline);
  1287.   if ($stdinfile) { $cmd .= qq/ < "$stdinfile"/; }
  1288.   if ($duperr2out) { $cmd .= " 2>&1"; }
  1289.   return open ($fh, $cmd.'|');
  1290. }
  1291.  
  1292. sub force_die {
  1293.   my ($msg) = @_;
  1294.  
  1295.   # note use of eval { } scope in logging -- paranoia to ensure that a broken
  1296.   # $SIG{__WARN__} implementation will not interfere with the flow of control
  1297.   # here, where we *have* to die.
  1298.   eval { warn $msg; };
  1299.  
  1300.   POSIX::_exit(1);  # avoid END and destructor processing 
  1301.   kill('KILL',$$);  # still kicking? die! 
  1302. }
  1303.  
  1304. sub helper_app_pipe_open_unix {
  1305.   my ($fh, $stdinfile, $duperr2out, @cmdline) = @_;
  1306.  
  1307.   # do a fork-open, so we can setuid() back
  1308.   my $pid = open ($fh, '-|');
  1309.   if (!defined $pid) {
  1310.     # acceptable to die() here, calling code catches it
  1311.     die "util: cannot fork: $!";
  1312.   }
  1313.  
  1314.   if ($pid != 0) {
  1315.     return $pid;          # parent process; return the child pid
  1316.   }
  1317.  
  1318.   # else, child process.  
  1319.   # from now on, we cannot die(), as a parent-process eval { } scope
  1320.   # could intercept it! use force_die() instead  (bug 4370, cmt 2)
  1321.  
  1322.   # go setuid...
  1323.   setuid_to_euid();
  1324.   dbg("util: setuid: ruid=$< euid=$>");
  1325.  
  1326.   # now set up the fds.  due to some wierdness, we may have to ensure that we
  1327.   # *really* close the correct fd number, since some other code may have
  1328.   # redirected the meaning of STDOUT/STDIN/STDERR it seems... (bug 3649). use
  1329.   # POSIX::close() for that. it's safe to call close() and POSIX::close() on
  1330.   # the same fd; the latter is a no-op in that case.
  1331.  
  1332.   if (!$stdinfile) {              # < $tmpfile
  1333.     # ensure we have *some* kind of fd 0.
  1334.     $stdinfile = "/dev/null";
  1335.   }
  1336.  
  1337.   my $f = fileno(STDIN);
  1338.   close STDIN;
  1339.  
  1340.   # sanity: was that the *real* STDIN? if not, close that one too ;)
  1341.   if ($f != 0) {
  1342.     POSIX::close(0);
  1343.   }
  1344.  
  1345.   open (STDIN, "<$stdinfile") or force_die "util: cannot open $stdinfile: $!";
  1346.  
  1347.   # this should be impossible; if we just closed fd 0, UNIX
  1348.   # fd behaviour dictates that the next fd opened (the new STDIN)
  1349.   # will be the lowest unused fd number, which should be 0.
  1350.   # so die with a useful error if this somehow isn't the case.
  1351.   if (fileno(STDIN) != 0) {
  1352.     force_die "util: setuid: oops: fileno(STDIN) [".fileno(STDIN)."] != 0";
  1353.   }
  1354.  
  1355.   # ensure STDOUT is open.  since we just created a pipe to ensure this, it has
  1356.   # to be open to that pipe, and if it isn't, something's seriously screwy.
  1357.   # Update: actually, this fails! see bug 3649 comment 37.  For some reason,
  1358.   # fileno(STDOUT) can be 0; possibly because open("-|") didn't change the fh
  1359.   # named STDOUT, instead changing fileno(1) directly.  So this is now
  1360.   # commented.
  1361.   # if (fileno(STDOUT) != 1) {
  1362.   # die "setuid: oops: fileno(STDOUT) [".fileno(STDOUT)."] != 1";
  1363.   # }
  1364.  
  1365.   if ($duperr2out) {             # 2>&1
  1366.     my $f = fileno(STDERR);
  1367.     close STDERR;
  1368.  
  1369.     # sanity: was that the *real* STDERR? if not, close that one too ;)
  1370.     if ($f != 2) {
  1371.       POSIX::close(2);
  1372.     }
  1373.  
  1374.     open (STDERR, ">&STDOUT") or force_die "util: dup STDOUT failed: $!";
  1375.  
  1376.     # STDERR must be fd 2 to be useful to subprocesses! (bug 3649)
  1377.     if (fileno(STDERR) != 2) {
  1378.       force_die "util: oops: fileno(STDERR) [".fileno(STDERR)."] != 2";
  1379.     }
  1380.   }
  1381.  
  1382.   exec @cmdline;
  1383.   warn "util: exec failed: $!";
  1384.  
  1385.   # bug 4370: we really have to exit here; break any eval traps
  1386.   POSIX::_exit(1);  # avoid END and destructor processing 
  1387.   kill('KILL',$$);  # still kicking? die! 
  1388.   die;  # must be a die() otherwise -w will complain
  1389. }
  1390.  
  1391. ###########################################################################
  1392.  
  1393. # As "perldoc perlvar" notes, in perl 5.8.0, the concept of "safe" signal
  1394. # handling was added, which means that signals cannot interrupt a running OP.
  1395. # unfortunately, a regexp match is a single OP, so a psychotic m// can
  1396. # effectively "hang" the interpreter as a result, and a $SIG{ALRM} handler
  1397. # will never get called.
  1398. #
  1399. # However, by using "unsafe" signals, we can still interrupt that -- and
  1400. # POSIX::sigaction can create an unsafe handler on 5.8.x.   So this function
  1401. # provides a portable way to do that.
  1402.  
  1403. sub trap_sigalrm_fully {
  1404.   my ($handler) = @_;
  1405.   if ($] < 5.008) {
  1406.     # signals are always unsafe, just use %SIG
  1407.     $SIG{ALRM} = $handler;
  1408.   } else {
  1409.     # may be using "safe" signals with %SIG; use POSIX to avoid it
  1410.     POSIX::sigaction POSIX::SIGALRM(), new POSIX::SigAction $handler;
  1411.   }
  1412. }
  1413.  
  1414. ###########################################################################
  1415.  
  1416. 1;
  1417.  
  1418. =back
  1419.  
  1420. =cut
  1421.