1#@!#!123s

��JFIF�� 1#@!#!123s
: / proc / thread-self / root / usr / share / perl5 / vendor_perl / Amavis /
Filename : Lookup.pm
back
# SPDX-License-Identifier: GPL-2.0-or-later

package Amavis::Lookup;
use strict;
use re 'taint';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&lookup &lookup2 &lookup_hash &lookup_acl);
}
use subs @EXPORT_OK;

use Amavis::Conf qw(:platform c cr ca);
use Amavis::rfc2821_2822_Tools qw(split_address make_query_keys);
use Amavis::Timing qw(section_time);
use Amavis::Util qw(ll do_log fmt_struct unique_list idn_to_ascii
                    safe_encode_utf8_inplace);

# lookup_hash() performs a lookup for an e-mail address against a hash map.
# If a match is found (a hash key exists in the Perl hash) the function returns
# whatever the map returns, otherwise undef is returned. First match wins,
# aborting further search sequence.
#
# The $addr may be a string of octets (assumed to be UTF-8 encoded)
# or a string of characters which gets first encoded to UTF-8 octets.
# International domain name (IDN) in $addr will be converted to ACE and
# lowercased. Keys of a hash table are expected to be in octets (utf8 flag
# off) and their international domain names encoded in ASCII-compatible
# encoding (ACE).
#
sub lookup_hash($$;$%) {
  my($addr, $hash_ref,$get_all,%options) = @_;
  ref($hash_ref) eq 'HASH'
    or die "lookup_hash: arg2 must be a hash ref: $hash_ref";
  local($1,$2,$3,$4); my(@matchingkey,@result); my $append_string;
  $append_string = $options{AppendStr}  if defined $options{AppendStr};
  my($keys_ref,$rhs_ref) = make_query_keys($addr,1,1,$append_string);
  for my $key (@$keys_ref) {  # do the search
    if (exists $$hash_ref{$key}) {  # got it
      push(@result,$$hash_ref{$key}); push(@matchingkey,$key);
      last  if !$get_all;
    }
  }
  # do the right-hand side replacements if any $n, ${n} or $(n) is specified
  for my $r (@result) {  # $r is just an alias to array elements
    if (defined($r) && !ref($r) && index($r,'$') >= 0) { # plain string with $
      my $any = $r =~ s{ \$ ( (\d+) | \{ (\d+) \} | \( (\d+) \) ) }
                       { my $j = $2+$3+$4; $j<1 ? '' : $rhs_ref->[$j-1] }xgse;
      # bring taintedness of input to the result
      $r .= substr($addr,0,0)  if $any;
    }
  }
  if (!ll(5)) {
    # only bother with logging when needed
  } elsif (!@result) {
    do_log(5,"lookup_hash(%s), no matches", $addr);
  } elsif (!$get_all) {  # first match wins
    do_log(5,'lookup_hash(%s) matches key "%s", result=%s',
              $addr, $matchingkey[0], !defined($result[0])?'undef':$result[0]);
  } else {  # want all matches
    do_log(5,"lookup_hash(%s) matches keys: %s", $addr,
              join(', ', map {sprintf('"%s"=>%s',$matchingkey[$_],$result[$_])}
                             (0..$#result)) );
  }
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

# lookup_acl() performs a lookup for an e-mail address against
# access control list.
#
# The $addr may be a string of octets (assumed to be UTF-8 encoded)
# or a string of characters which gets first encoded to UTF-8 octets.
# International domain name (IDN) in $addr will be converted to ACE
# and lowercased. Array elements are expected to be in octets (utf8
# flag off) and their international domain names encoded in
# ASCII-compatible encoding (ACE).
#
# The supplied e-mail address is compared with each member of the
# lookup list in turn, the first match wins (terminates the search),
# and its value decides whether the result is true (yes, permit, pass)
# or false (no, deny, drop). Falling through without a match produces
# false (undef). Search is always case-insensitive on domain part,
# local part matching depends on $localpart_is_case_sensitive setting.
#
# NOTE: lookup_acl is not aware of address extensions and they are
# not handled specially!
#
# If a list element contains a '@', the full e-mail address is compared,
# otherwise if a list element has a leading dot, the domain name part is
# matched only, and the domain as well as its subdomains can match. If there
# is no leading dot, the domain must match exactly (subdomains do not match).
#
# The presence of a character '!' prepended to a list element decides
# whether the result will be true (without a '!') or false (with '!')
# in case where this list element matches and terminates the search.
#
# Because search stops at the first match, it only makes sense
# to place more specific patterns before the more general ones.
#
# Although not a special case, it is good to remember that '.' always matches,
# so a '.' would stop the search and return true, whereas '!.' would stop the
# search and return false (0).
#
# Examples:
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'me.ac.uk' matches me.ac.uk, returns true and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'you.ac.uk' matches .ac.uk, returns false (because of '!') and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'them.co.uk' matches .uk, returns true and search stops
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk )
#   'some.com' does not match anything, falls through and returns false (undef)
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk !. )
#   'some.com' similar to previous, except it returns 0 instead of undef,
#   which would only make a difference if this ACL is not the last argument
#   in a call to lookup(), because a defined result stops further lookups
#
# given: @acl = qw( me.ac.uk !.ac.uk .uk . )
#   'some.com' matches catchall ".", and returns true. The ".uk" is redundant
#
# more complex example: @acl = qw(
#   !The.Boss@dept1.xxx.com .dept1.xxx.com
#   .dept2.xxx.com .dept3.xxx.com lab.dept4.xxx.com
#   sub.xxx.com !.sub.xxx.com
#   me.d.aaa.com him.d.aaa.com !.d.aaa.com .aaa.com
# );
#
sub lookup_acl($$%) {
  my($addr, $acl_ref,%options) = @_;
  ref($acl_ref) eq 'ARRAY'
    or die "lookup_acl: arg2 must be a list ref: $acl_ref";
  return  if !@$acl_ref;  # empty list can't match anything
  safe_encode_utf8_inplace($addr);  # to octets (if not already)
  my $lpcs = c('localpart_is_case_sensitive');
  my($localpart,$domain) = split_address($addr);
  $localpart = lc $localpart  if !$lpcs;
  local($1,$2);
  # chop off leading '@' and trailing dots
  $domain = $1  if $domain =~ /^\@?(.*?)\.*\z/s;
  $domain = idn_to_ascii($domain) if $domain ne '';  # lowercase, ToASCII
  $domain .= $options{AppendStr}  if defined $options{AppendStr};
  my($matchingkey, $result); my $found = 0;
  for my $e (@$acl_ref) {
    $result = 1; $matchingkey = $e; my $key = $e;
    if ($key =~ /^(!+)(.*)\z/s) {      # starts with an exclamation mark(s)
      $key = $2;
      $result = 1-$result  if length($1) & 1;  # negate if odd
    }
    if ($key =~ /^(.*?)\@([^\@]*)\z/s) {  # contains '@', check full address
      $found=1  if $localpart eq ($lpcs?$1:lc($1)) && $domain eq lc($2);
    } elsif ($key =~ /^\.(.*)\z/s) {   # leading dot: domain or subdomain
      my $key_t = lc($1);
      $found=1  if $domain eq $key_t || $domain =~ /(\.|\z)\Q$key_t\E\z/s;
    } else {                           # match domain (but not its subdomains)
      $found=1  if $domain eq lc($key);
    }
    last  if $found;
  }
  $matchingkey = $result = undef  if !$found;
  ll(5) && do_log(5, 'lookup_acl(%s)%s', $addr,
                  (!$found ? ", no match"
                           : " matches key \"$matchingkey\", result=$result"));
  !wantarray ? $result : ($result, $matchingkey);
}

# Perform a lookup for an e-mail address against any number of supplied maps:
# - SQL map,
# - LDAP map,
# - hash map (associative array),
# - (access control) list,
# - a list of regular expressions (an Amavis::Lookup::RE object),
# - a (defined) scalar always matches, and returns itself as the map value
#   (useful as a catchall for a final 'pass' or 'fail');
# (see lookup_hash, lookup_acl, lookup_sql and lookup_ldap for details).
#
# when $get_all is 0 (the common usage):
#   If a match is found (a defined value), returns whatever the map returns,
#   otherwise returns undef. FIRST match aborts further search sequence.
# when $get_all is true:
#   Collects a list of results from ALL matching tables, and within each
#   table from ALL matching key. Returns a ref to a list of results
#   (and a ref to a list of matching keys if returning a pair).
#   The first element of both lists is supposed to be what lookup() would
#   have returned if $get_all were 0. The order of returned elements
#   corresponds to the order of the search.
#
# traditional API, deprecated
#
sub lookup($$@) {
  my($get_all, $addr, @tables) = @_;
  lookup2($get_all, $addr, \@tables);
}

# generalized API
#
sub lookup2($$$%) {
  my($get_all, $addr, $tables_ref, %options) = @_;
  (@_ - 3) % 2 == 0 or die "lookup2: options argument not in pairs (not hash)";
  my($label, @result, @matchingkey);
  for my $tb (!$tables_ref ? () : @$tables_ref) {
    my $t = ref($tb) eq 'REF' ? $$tb : $tb;  # allow one level of indirection
    my $reft = ref($t);
    if ($reft eq 'CODE') {  # lazy evaluation
      $t = &$t($addr,$get_all,%options);
      $reft = ref($t);
    }
    if (!$reft || $reft eq 'SCALAR') {  # a scalar always matches
      my $r = $reft ? $$t : $t;  # allow direct or indirect reference
      if (defined $r) {
        ll(5) && do_log(5, 'lookup: (scalar) matches, result="%s"', $r);
        push(@result,$r); push(@matchingkey,"(constant:$r)");
      }
    } elsif ($reft eq 'HASH') {
      my($r,$mk);
      ($r,$mk) = lookup_hash($addr,$t,$get_all,%options)  if %$t;
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif ($reft eq 'ARRAY') {
      my($r,$mk);
      ($r,$mk) = lookup_acl($addr,$t,%options)  if @$t;
      if (defined $r)   { push(@result,$r);  push(@matchingkey,$mk)  }
    } elsif ($t->isa('Amavis::Lookup::Label')) {  # logging label
      # just a convenience for logging purposes, not a real lookup method
      $label = $t->display;  # grab the name, and proceed with the next table
    } elsif ($t->isa('Amavis::Lookup::Opaque') ||     # a structured constant
             $t->isa('Amavis::Lookup::OpaqueRef')) {  # ref to structured const
      my $r = $t->get;  # behaves like a constant pseudo-lookup
      if (defined $r) {
        ll(5) && do_log(5, 'lookup: (opaque) matches, result="%s"', $r);
        push(@result,$r); push(@matchingkey,"(opaque:$r)");
      }
    } elsif ($t->isa('Amavis::Lookup::RE')) {
      my($r,$mk);
      ($r,$mk) = $t->lookup_re($addr,$get_all,%options)  if @$t;
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif ($t->isa('Amavis::Lookup::SQL')) {
      my($r,$mk) = $t->lookup_sql($addr,$get_all,%options);
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } elsif ($t->isa('Amavis::Lookup::SQLfield')) {
      if ($Amavis::sql_lookups) {  # triage
        my($r,$mk) = $t->lookup_sql_field($addr,$get_all,%options);
        if (!defined $r)  {}
        elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
        elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
      }
    } elsif ($t->isa('Amavis::Lookup::LDAP')) {
      if ($Amavis::ldap_lookups && c('enable_ldap')) {  # triage
        my($r,$mk) = $t->lookup_ldap($addr,$get_all,%options);
        if (!defined $r)  {}
        elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk) }
        elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
      }
    } elsif ($t->isa('Amavis::Lookup::LDAPattr')) {
      if ($Amavis::ldap_lookups && c('enable_ldap')) {  # triage
        my($r,$mk) = $t->lookup_ldap_attr($addr,$get_all,%options);
        if (!defined $r)  {}
        elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk) }
        elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
      }
    } else {
      die "TROUBLE: lookup table is an unknown object: " . $reft;
    }
    last  if @result && !$get_all;
  }
  # pretty logging
  if (ll(4)) {  # only bother preparing log report which will be printed
    my $opt_label = $options{Label};
    my(@lbl) = grep(defined $_ && $_ ne '', ($opt_label,$label));
    $label = ' [' . join(',',unique_list(\@lbl)) . ']'  if @lbl;
    if (!$tables_ref || !@$tables_ref) {
      do_log(4, "lookup%s => undef, %s, no lookup tables",
                $label, fmt_struct($addr));
    } elsif (!@result) {
      do_log(4, "lookup%s => undef, %s does not match",
                $label, fmt_struct($addr));
    } elsif (!$get_all) {  # first match wins
      do_log(4, 'lookup%s => %-6s %s matches, result=%s, matching_key="%s"',
                $label, $result[0] ? 'true,' : 'false,',
                fmt_struct($addr), fmt_struct($result[0]), $matchingkey[0]);
    } else {  # want all matches
      do_log(4, 'lookup%s, %d matches for %s, results: %s',
                $label, scalar(@result), fmt_struct($addr),
                join(', ', map { sprintf('"%s"=>%s',
                                   $matchingkey[$_], fmt_struct($result[$_]))
                               } (0 .. $#result) ));
    }
  }
  if (!$get_all) { !wantarray ? $result[0] : ($result[0], $matchingkey[0]) }
  else           { !wantarray ? \@result   : (\@result,   \@matchingkey)   }
}

1;