view release on metacpan or  search on metacpan

lib/Mail/SpamAssassin/Util.pm  view on Meta::CPAN

Decodes a string that has been encoded using the Quoted-Printable
content transfer encoding.

=cut

sub qp_decode {
  my $str = $_[0];

  # RFC 2045: when decoding a Quoted-Printable body, any trailing
  # white space on a line must be deleted
  $str =~ s/[ \t]+(?=\r?\n)//gs;

  $str =~ s/=\r?\n//gs;  # soft line breaks

  # RFC 2045 explicitly prohibits lowercase characters a-f in QP encoding
  # do we really want to allow them???

  local $1;
  $str =~ s/=([0-9a-fA-F]{2})/chr(hex($1))/ge;

  return $str;
}

sub base64_encode {
  local $_ = shift;

  if (HAS_MIME_BASE64) {
    return MIME::Base64::encode_base64($_,'');
  }

  $_ = pack("u57", $_);
  s/^.//mg;
  tr| -_`|A-Za-z0-9+/A|; # -> #`# <- kluge against vim syntax issues
  s/(A+)$/'=' x length $1/e;
  return $_;
}

# Very basic Base32 encoder
our %base32_bitchr = (
  '00000'=>'A', '00001'=>'B', '00010'=>'C', '00011'=>'D', '00100'=>'E',
  '00101'=>'F', '00110'=>'G', '00111'=>'H', '01000'=>'I', '01001'=>'J',
  '01010'=>'K', '01011'=>'L', '01100'=>'M', '01101'=>'N', '01110'=>'O',
  '01111'=>'P', '10000'=>'Q', '10001'=>'R', '10010'=>'S', '10011'=>'T',
  '10100'=>'U', '10101'=>'V', '10110'=>'W', '10111'=>'X', '11000'=>'Y',
  '11001'=>'Z', '11010'=>'2', '11011'=>'3', '11100'=>'4', '11101'=>'5',
  '11110'=>'6', '11111'=>'7'
);
sub base32_encode {
  my ($str) = @_;
  return if !defined $str;
  utf8::encode($str)  if utf8::is_utf8($str); # force octets
  my $bits = unpack("B*", $str)."0000";
  my $output;
  local($1);
  $output .= $base32_bitchr{$1} while ($bits =~ /(.{5})/g);
  return $output;
}

###########################################################################

sub portable_getpwuid {
  if (defined &Mail::SpamAssassin::Util::_getpwuid_wrapper) {
    return Mail::SpamAssassin::Util::_getpwuid_wrapper(@_);
  }

  my $sts;
  if (!RUNNING_ON_WINDOWS) {
    $sts = eval ' sub _getpwuid_wrapper { getpwuid($_[0]); }; 1 ';
  } else {
    dbg("util: defining getpwuid() wrapper using 'unknown' as username");
    $sts = eval ' sub _getpwuid_wrapper { _fake_getpwuid($_[0]); }; 1 ';
  }
  if (!$sts) {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    warn "util: failed to define getpwuid() wrapper: $eval_stat\n";
  } else {
    return Mail::SpamAssassin::Util::_getpwuid_wrapper(@_);
  }
}

sub _fake_getpwuid {
  return (
    'unknown',		# name,
    'x',		# passwd,
    $_[0],		# uid,
    0,			# gid,
    '',			# quota,
    '',			# comment,
    '',			# gcos,
    '/',		# dir,
    '',			# shell,
    '',			# expire
  );
}

###########################################################################
# Get a platform specific directory for application data
# Just used for Windows for now
sub common_application_data_directory {
  return Win32::GetFolderPath(Win32::CSIDL_COMMON_APPDATA()) if (RUNNING_ON_WINDOWS);
}

###########################################################################

=item C<extract_ipv4_addr_from_string($str)>

Given a string, extract an IPv4 address from it.

=cut

# Given a string, extract an IPv4 address from it.  Required, since
# we currently have no way to portably unmarshal an IPv4 address from
# an IPv6 one without kludging elsewhere.
#
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]|[1-9]\d|\d)\.
                       (?:1\d\d|2[0-4]\d|25[0-5]|[1-9]\d|\d)\.
                       (?:1\d\d|2[0-4]\d|25[0-5]|[1-9]\d|\d)\.
                       (?:1\d\d|2[0-4]\d|25[0-5]|[1-9]\d|\d)
                     )\b/ix)
  {
    if (defined $1) { return $1; }
  }

  # ignore native IPv6 addresses;
  # TODO, eventually, once IPv6 spam starts to appear ;)
  return;
}

###########################################################################

{
  my($hostname, $fq_hostname);

# get the current host's unqalified domain name (better: return whatever
# Sys::Hostname thinks our hostname is, might also be a full qualified one)

lib/Mail/SpamAssassin/Util.pm  view on Meta::CPAN

}

sub receive_date {
  my ($header) = @_;

  $header ||= '';
  $header =~ s/\n[ \t]+/ /gs;	# fix continuation lines

  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 get_user_groups {
  my $suid = shift;
  dbg("util: get_user_groups: uid is $suid\n");
  my ($user, $gid) = (getpwuid($suid))[0,3];
  my $rgids = "$gid ";
  while (my($name,$gid,$members) = (getgrent())[0,2,3]) {
    if (grep { $_ eq $user } split(/ /, $members)) {
      $rgids .= "$gid ";
      dbg("util: get_user_groups: added $gid ($name) to group list which is now: $rgids\n");
    }
  }
  endgrent;
  chop $rgids;
  return ($rgids);
}



sub setuid_to_euid {
  return if (RUNNING_ON_WINDOWS);

  # remember the target uid, the first number is the important one
  my $touid = $>;
  my $gids = get_user_groups($touid);
  my ( $pgid, $supgs ) = split (' ',$gids,2);
  defined $supgs or $supgs=$pgid;
  my $prgid = 0 + $(; # bug 8043 - Only set rgid if it isn't already one of the euid's groups
  if ( ($prgid == 0) or not (grep { $_ == $prgid } split(/ /, ${(}))) {
    # setgid only works if euid is root, have to set that temporarily
    $> = 0;
    if ($> != 0) { warn("util: seteuid to 0 failed: $!"); }
    dbg("util: changing real primary gid from $( to $pgid and supplemental groups to $supgs to match effective uid $touid");
    $! = 0; POSIX::setgid($pgid);
    if ($!) { warn("util: POSIX::setgid $pgid failed: $!\n"); }
    $! = 0; $( = $pgid;
    if ($!) { warn("util: failed to set gid $pgid: $!\n"); }
    $! = 0; $) = "$pgid $supgs";
    if ($!) {
      # could be perl 5.30 bug #134169, let's be safe
      if (grep { $_ eq '0' } split(/ /, ${)})) {
        die("util: failed to set effective gid $pgid $supgs: $!\n");
      } else {
        warn("util: failed to set effective gid $pgid $supgs: $!\n");
      }
    }
  }
  if ($< != $touid) {
    dbg("util: changing real uid from $< to match effective uid $touid");
    # bug 3586: kludges needed to work around platform dependent behavior assigning to $<
    #  The POSIX functions deal with that so just use it here
    POSIX::setuid($touid);
    $< = $touid; $> = $touid;       # bug 5574

    # Check that we have now accomplished the setuid: catch bug 3586 if it comes back
    if ($< != $touid) {
      # keep this fatal: it's a serious security problem if it fails
      die "util: setuid $< to $touid failed!";
    }
  }
}

# helper app command-line open
sub helper_app_pipe_open {