Re: [Sqlgrey-users] Improved dynamic/one-shot email address regex

[Michael S. <Mic...@lr...>]

On Fri, 23 Sep 2005 py...@fi... wrote:

> I have rewriten the regexs a bit more, to do away with the loop.  If anyone
> is interested in testing this on their email mix, I would be happy to share
> it.
>
> Jeff
>

Sure, I would like to see, what you changed. Actually I use my own version
of deverp_user, which includes a patch about metachars for the first
version I send Lionel and which he included in 1.7.1. It does not include
the bo|bounce matching yet.

Michael Storz
-------------------------------------------------
Leibniz-Rechenzentrum   !   <mailto:St...@lr...>
Barer Str. 21           !   Fax: +49 89 2809460
80333 Muenchen, Germany !   Tel: +49 89 289-28840
-------------------------------------------------------------------------------
sub deverp_user {
    my ($user, $rcpt) = @_;

    ### Try to match single-use addresses
    # SRS (first and subsequent levels of forwarding)
    $user =~ s/^srs0=[^=]+=[^=]+=([^=]+)=([^=]+)$/srs0=#=#=$1=$2/;
    $user =~ s/^srs1=[^=]+=([^=]+)(=+)[^=]+=[^=]+=([^=]+)=([^=]+)$/srs1=#=$1$2#=#=$3=$4/;

    ### strip extension, used sometimes for mailing-list VERP
    $user =~ s/\+.*//;

    ### eliminate recipient put in originator
    my $dot_sep_re = '[\.\*-]+';
    my $at_sep_re = '[=\?\*~\.]+';
    my ($rcpt_lhs, $rcpt_rhs) = split /\@/, $rcpt, 2;

    # quote all pattern metacharacters and replace '.' with match of possible separators
    $rcpt_lhs = join $dot_sep_re, map { "\Q$_\E"}  split /\./, $rcpt_lhs;
    $rcpt_rhs = join $dot_sep_re, map { "\Q$_\E"}  split /\./, $rcpt_rhs;

    # build pattern with the 3 alternatives to match recipient in originator
    # BATV implementations use third or first alternative (first by abuse.net)
    my $pat = qr/$rcpt_lhs$at_sep_re$rcpt_rhs|$rcpt_rhs$at_sep_re$rcpt_lhs|$rcpt_lhs/;

    # replace address with capital RCPT to be save with deletes
    # (MySQL matches case insensitive unfortunately)
    $user =~ s/(?<=[\*=\.-])$pat|$pat(?=[\*=\.-])/RCPT/;

    ### strip hexadecimal sequences
    # at the beginning only if user will contain at least 4 consecutive alpha chars
    $user =~ s/^[0-9a-f]{2,}(?=[._\/=-].*[a-zA-Z]{4,})|(?<=[._\/=-])[0-9a-f]+(?=[._\/=-]|$)/#/g;

    #### big german list provider fagms.de, Falk eSolution
    $user =~ s/-emid[0-9a-z]+$/-emid/;

    return $user;
} # deverp_user