nsbin/nottoomuch-addresses.sh

#!/bin/sh
# -*- cperl -*-

case $* in (''|--*) exec perl -x "$0" "$@" ;; (???*) ;; (*) exit 0 ;; esac
grep -aiF "$*" "${XDG_CONFIG_HOME:-$HOME/.config}/nottoomuch/addresses.active"
case $? in 0|1) exit 0; esac
exit $?

# $ nottoomuch-addresses.sh $
#
# Created: Thu 27 Oct 2011 17:38:46 EEST too
# Last modified: Sat 29 Mar 2014 17:12:14 +0200 too

# Add this to your notmuch elisp configuration file:
#
# (require 'notmuch-address)
# (setq notmuch-address-command "/path/to/nottoomuch-addresses.sh")
# (notmuch-address-message-insinuate)

# Documentation at the end. Encoding: utf-8.

#!perl
# line 24
# - 24 -^

# HISTORY
#
# Version 2.2  2014-03-29 15:12:14 UTC
#   * In case there is both {phrase} and (comment) in an email address,
#     append comment to the phrase. This will make more duplicates to be
#     removed. Now there can be:
#	<user@host>
#	"phrase" <user@host>
#	"phrase (comment)" <user@host>
#	<user@host> (comment)
#   * In case email address is in form "someuser@somehost" <someuser@somehost>
#     i.e. the phrase is exactly the same as <address>, phrase is dropped.
#
# Version 2.1  2012-02-22 14:58:58 UTC
#   * Fixed a bug where decoding matching but unknown or malformed =?...?=-
#     encoded parts in email addresses lead to infinite loop.
#
# Version 2.0  2012-01-14 03:45:00 UTC
#   * Added regexp-based ignores using /regexp/[i] syntax in ignore file.
#   * Changed addresses file header to v4; 'addresses' file now contains all
#     found addresses plus some metainformation added at the end of the file.
#     Filtered (by ignores) address list is now in new 'addresses.active'
#     file and the fgrep code at the beginning now uses this "active" file.
#     Addresses file with header v2 and v3 are supported for reading.
#   * Encoded address content is now recursively decoded.
#
# Version 1.6  2011-12-29 06:42:42 UTC
#   * Fixed 'encoded-text' recognition and concatenations, and underscore
#     to space replacements. Now quite RFC 2047 "compliant".
#
# Version 1.5  2011-12-22 20:20:32 UTC
#   * Changed search to exit with zero value (also) if no match found.
#   * Changed addresses file header (v3) to use \t as separator. Addresses
#     file containing previous version header (v2) can also be read.
#   * Removed outdated information about sorting in ASCII order.
#
# Version 1.4  2011-12-14 19:24:28 UTC
#   * Changed to run notmuch search --sort=newest-first --output=files ...
#     (instead of notmuch show ...) and read headers from files internally.
#   * Fixed away joining uninitialized $phrase value to address line.
#
# Version 1.3  2011-12-12 15:41:05 UTC
#   * Changed to store/show addresses in 'newest first' order.
#   * Changed addresses file header to force address file rebuild.
#
# Version 1.2  2011-12-06 18:00:00 UTC
#   * Changed search work case-insensitively -- grep(1) does it locale-aware.
#   * Changed this program execute from /bin/sh (wrapper).
#
# Version 1.1  2011-12-02 17:11:33 UTC
#   * Removed Naïve assumption that no-one runs update on 'dumb' terminal.
#   * Check address database file first line whether it is known to us.
#
#   Thanks to Bart Bunting for providing a good bug report.
#
# Version 1.0  2011-11-30 20:56:10 UTC
#   * Initial release.

use 5.8.1;
use strict;
use warnings;

use Encode qw/encode_utf8 find_encoding/;
use MIME::Base64 'decode_base64';
use MIME::QuotedPrint 'decode_qp';

no encoding;

my $configdir = ($ENV{XDG_CONFIG_HOME}||$ENV{HOME}.'/.config').'/nottoomuch';
my $adbpath = $configdir . '/addresses';
my $ignpath = $configdir . '/addresses.ignore';
my $actpath = $configdir . '/addresses.active';

unless (@ARGV)
{
    require Pod::Usage;
    Pod::Usage::pod2usage( -verbose => 0, -exitval => 0 );
    exit 1;
}

if ($ARGV[0] eq '--help')
{
    $SIG{__DIE__} = sub {
     	$SIG{__DIE__} = 'DEFAULT';
     	require Pod::Usage;
     	Pod::Usage::pod2usage( -verbose => 2, -exitval => 0, -noperldoc => 1 );
     	exit 1;
    };
    require Pod::Perldoc;
    $SIG{__DIE__} = 'DEFAULT';
    # in case PAGER is not set, perldoc runs /usr/bin/perl -isr ...
    if ( ($ENV{PAGER} || '') eq 'less') {
	$ENV{LESS} .= 'R' if ($ENV{LESS} || '') !~ /[rR]/;
    }
    @ARGV = ( $0 );
    exit ( Pod::Perldoc->run() );
}

my @list;

if ($ARGV[0] eq '--update')
{
    sub mkdirs($);
    sub mkdirs($) {
	die "'$_[0]': not a (writable) directory\n" if -e $_[0];
	return if mkdir $_[0]; # no mode: 0777 & ~umask used
	local $_ = $_[0];
	mkdirs $_ if s|/?[^/]+$|| and $_;
	mkdir $_[0] or die "Cannot create '$_[0]': $!\n";
    }

    mkdirs $configdir unless -d $configdir;

    unlink $adbpath if defined $ARGV[1] and $ARGV[1] eq '--rebuild';

    my ($sstr, $acount) = (0, 0);
    if (-s $adbpath) {
	die "Cannot open '$adbpath': $!\n" unless open I, '<', $adbpath;
	sysread I, $_, 18;
	# new header: "v4/dd/dd/dd/dd/dd\n" where / == '\t' (but match also v2)
	if (/^v[234]\s(\d\d)\s(\d\d)\s(\d\d)\s(\d\d)\s(\d\d)\n$/) {
	    $sstr = "$1$2$3$4$5" - 86400 * 7; # one week extra to (re)look.
	    $sstr = 0 if $sstr < 0;
	}
	close I if $sstr == 0;
    }
    if ($sstr > 0) {
	print "Updating '$adbpath', since $sstr.\n";
	$sstr .= '..';
    }
    else {
	print "Creating '$adbpath'. This may take some time...\n";
	$sstr = '*';
    }
    my (%ign_hash, @ign_relist);
    if (-f $ignpath) {
	die "Cannot open '$ignpath': $!\n" unless open J, '<', $ignpath;
	while (<J>) {
	    next if /^\s*#/;
	    if (m|^/(.*)/(\w*)\s*$|) {
		if ($2 eq 'i') {
		    push @ign_relist, qr/$1/i;
		}
		else {
		    push @ign_relist, qr/$1/;
		}
	    }
	    else {
		s/\s+$/\n/;
		$ign_hash{$_} = 1;
	    }
	}
	close J;
    }

    my $sometime = time;
    die "Cannot open '$adbpath.new': $!\n" unless open O, '>', $adbpath.'.new';
    die "Cannot open '$actpath.new': $!\n" unless open A, '>', $actpath.'.new';
    $_ = $sometime; s/(..)\B/$1\t/g; # FYI: s/..\B\K/\t/g requires perl 5.10.
    print O "v4\t$_\n";

    # The following code block is from Email::Address, almost verbatim.
    # The reasons to snip code I instead of just 'use Email::Address' are:
    #  1) Some systems ship Mail::Address instead of Email::Address
    #  2) Every user doesn't have ability to install Email::Address
    # --8<----8<----8<----8<----8<----8<----8<----8<----8<----8<----8<--

    ## no critic RequireUseWarnings
    # support pre-5.6

    #$VERSION             = '1.889';
    my $COMMENT_NEST_LEVEL = 2;

    my $CTL            = q{\x00-\x1F\x7F};
    my $special        = q{()<>\\[\\]:;@\\\\,."};

    my $text           = qr/[^\x0A\x0D]/;

    my $quoted_pair    = qr/\\$text/;

    my $ctext          = qr/(?>[^()\\]+)/;
    my ($ccontent, $comment) = (q{})x2;
    for (1 .. $COMMENT_NEST_LEVEL) {
	$ccontent = qr/$ctext|$quoted_pair|$comment/;
	$comment  = qr/\s*\((?:\s*$ccontent)*\s*\)\s*/;
    }
    my $cfws           = qr/$comment|\s+/;

    my $atext          = qq/[^$CTL$special\\s]/;
    my $atom           = qr/$cfws*$atext+$cfws*/;
    my $dot_atom_text  = qr/$atext+(?:\.$atext+)*/;
    my $dot_atom       = qr/$cfws*$dot_atom_text$cfws*/;

    my $qtext          = qr/[^\\"]/;
    my $qcontent       = qr/$qtext|$quoted_pair/;
    my $quoted_string  = qr/$cfws*"$qcontent+"$cfws*/;

    my $word           = qr/$atom|$quoted_string/;

# XXX: This ($phrase) used to just be: my $phrase = qr/$word+/; It was changed
# to resolve bug 22991, creating a significant slowdown.  Given current speed
# problems.  Once 16320 is resolved, this section should be dealt with.
# -- rjbs, 2006-11-11
    #my $obs_phrase     = qr/$word(?:$word|\.|$cfws)*/;

# XXX: ...and the above solution caused endless problems (never returned) when
# examining this address, now in a test:
#   admin+=E6=96=B0=E5=8A=A0=E5=9D=A1_Weblog-- ATAT --test.socialtext.com
# So we disallow the hateful CFWS in this context for now.  Of modern mail
# agents, only Apple Web Mail 2.0 is known to produce obs-phrase.
# -- rjbs, 2006-11-19
    my $simple_word    = qr/$atom|\.|\s*"$qcontent+"\s*/;
    my $obs_phrase     = qr/$simple_word+/;

    my $phrase         = qr/$obs_phrase|(?:$word+)/;

    my $local_part     = qr/$dot_atom|$quoted_string/;
    my $dtext          = qr/[^\[\]\\]/;
    my $dcontent       = qr/$dtext|$quoted_pair/;
    my $domain_literal = qr/$cfws*\[(?:\s*$dcontent)*\s*\]$cfws*/;
    my $domain         = qr/$dot_atom|$domain_literal/;

    my $display_name   = $phrase;

    my $addr_spec  = qr/$local_part\@$domain/;
    my $angle_addr = qr/$cfws*<$addr_spec>$cfws*/;
    my $name_addr  = qr/$display_name?$angle_addr/;
    my $mailbox    = qr/(?:$name_addr|$addr_spec)$comment*/;

    # --8<----8<----8<----8<----8<----8<----8<----8<----8<----8<----8<--

    # In this particular purpose the cache code used in...
    my %seen; # ...Email::Address is "replaced" by %seen & %hash.
    my %hash;

    my $ptime = $sometime + 5;
    my $addrcount = 0;
    $| = 1;
    open P, '-|', qw/notmuch search --sort=newest-first --output=files/, $sstr;
    while (<P>) {
      chomp;
      open M, '<', $_ or next;

      while (<M>) {
	last if /^\s*$/;
	next unless s/^(From|To|Cc|Bcc):\s+//i;
	s/\s+$//;
	my @a = ( $_ );
	while (<M>) {
	    # XXX leaks to body in case empty line is found in this loop...
	    # XXX Note that older code leaked to mail body always...
	    if (s/^\s+// or s/^(From|To|Cc|Bcc):\s+/,/i) {
		s/\s+$//;
		push @a, $_;
		next;
	    }
	    last;
	}
	$_ = join ' ', @a;

	if (time > $ptime) {
	    my $c = qw(/ - \ |)[int ($ptime / 5) % 4];
	    print $c, ' active addresses gathered: ', $addrcount, "\r";
	    $ptime += 5;
	}

	# The parse function from Email::Address heavily modified
	# to fit ok in this particular purpose. New bugs are mine!
	# --8<----8<----8<----8<----8<----8<----8<----8<----8<----8<----8<--

	s/[ \t]+/ /g;
	s/\?= =\?/\?==\?/g;
	my (@mailboxes) = (/$mailbox/go);
	L: foreach (@mailboxes) {
	    next if $seen{$_};
	    $seen{$_} = 1;

	    my @comments = /($comment)/go;
	    s/$comment//go if @comments;

	    my ($user, $host);
	    ($user, $host) = ($1, $2) if s/<($local_part)\@($domain)>//o;
	    if (! defined($user) || ! defined($host)) {
		s/($local_part)\@($domain)//o;
		($user, $host) = ($1, $2);
	    }

	    sub decode_substring ($) {
		my $t = lc $2;
		my $s;
		if ($t eq 'b') { $s = decode_base64($3); }
		elsif ($t eq 'q') { $s = decode_qp($3);	}
		else {
		    $_[0] = 0;
		    return "=?$1?$2?$3?=";
		}
		$s =~ tr/_/ /;

		return $s if lc $1 eq 'utf-8';

		my $o = find_encoding($1);
		$_[0] = 0, return "=?$1?$2?$3?=" unless ref $o;
		return encode_utf8($o->decode($s));
	    }
	    sub decode_data () {
		my $loopmax = 5;
		while ( s{ =\?([^?]+)\?(\w)\?(.*?)\?= }
			 { decode_substring($loopmax) }gex ) {
		    last if --$loopmax <= 0;
		};
	    }

	    my @phrase       = /($display_name)/o;
	    decode_data foreach (@phrase);

	    for ( @phrase, $host, $user, @comments ) {
		next unless defined $_;
		s/^[\s'"]+//; ## additions 20111123 too
		s/[\s'"]+$//; ## additions 20111123 too
		$_ = undef unless length $_;
	    }
	    # here we want to have email address always // 20111123 too
	    next unless defined $user and defined $host;

	    my $userhost = lc "<$user\@$host>";
	    #my $userhost = "<$user\@$host>";

	    @comments = grep { defined or return 0; decode_data; 1; } @comments;

	    # "trim" phrase, if equals to user@host after trimming, drop it.
	    if (defined $phrase[0]) {
		#$phrase[0] =~s/\A"(.+)"\z/$1/;
		$phrase[0] =~ tr/\\//d; ## 20111124 too
		$phrase[0] =~ s/\"/\\"/g;
		@phrase = () if lc "<$phrase[0]>" eq $userhost;
	    }

	    # In case we would have {phrase} <user@host> (comment),
	    # make that "{phrase} (comment)" <user@host> ...
	    if (defined $phrase[0]) {
		if (@comments) {
		    $phrase[0] = qq/"$phrase[0] / . join(' ', @comments) . '"';
		    @comments = ();
		}
		else {
		    $phrase[0] = qq/"$phrase[0]"/;
		}
	    }
	    else {
		@phrase = ();
	    }
	    $_ = join(' ', @phrase, $userhost, @comments) . "\n";
	    next if defined $hash{$_};
	    print O $_;
	    $hash{$_} = 1;
	    next if defined $ign_hash{$_};
	    foreach my $re (@ign_relist) {
		next L if $_ =~ $re;
	    }
	    print A $_;
	    $addrcount++;
	}
	# --8<----8<----8<----8<----8<----8<----8<----8<----8<----8<----8<--
      }
      close M;
    }
    undef %seen;
    close P;
    my $oldaddrcount = 0;
    if ($sstr ne '*') {
	L: while (<I>) {
	    last if /^---/;
	    next if defined $hash{$_};
	    print O $_;
	    next if defined $ign_hash{$_};
	    foreach my $re (@ign_relist) {
		next L if $_ =~ $re;
	    }
	    print A $_;
	    $addrcount++;
	}
	while (<I>) {
	    $oldaddrcount = ($1 + 0), next if /^active:\s+(\d+)\s*$/;
	}
	close I;
    }
    print O "---\n";
    print O "active: ", $addrcount, "\n";
    close O;
    close A;
    undef %hash;
    #link $adbpath, $adbpath . '.' . $sometime;
    rename $adbpath . '.new', $adbpath or
      die "Cannot rename '$adbpath.new' to '$adbpath': $!\n";
    rename $actpath . '.new', $actpath or
      die "Cannot rename '$actpath.new' to '$actpath': $!\n";
    if ($oldaddrcount or $sstr eq '*') {
	$sometime = time - $sometime;
	my $new = $addrcount - $oldaddrcount;
	print "Added $new active addresses in $sometime seconds.\n";
    }
    print "Total number of active addresses: $addrcount.\n";
    exit 0;
}

die "$0: '$ARGV[0]': unknown option.\n";

__END__

=encoding utf8

=head1 NAME

nottoomuch-addresses.sh -- address completion/matching (for notmuch)

=head1 SYNOPSIS

nottoomuch-addresses.sh ( --update [--rebuild] | <search string> )

B<nottoomuch-addresses.sh --help>  for more help

=head1 VERSION

2.2 (2014-03-29)

=head1 OPTIONS

=head2 B<--update>

This option is used to initially create the "address database" for
searches to be done, and then incrementally update it with new
addresses that are available in mails received since last update.

In case you want to rebuild the database from scratch, add
B<--rebuild> after --update on command line. This is necessary if some
of the new emails received have Date: header point too much in the
past (one week before last update). Update used emails Date:
information to go through new emails to be checked for new addresses
with one week's overlap. Other reason for rebuild could be
enhancements in new versions of this program which change the email
format in database.

=head2 <SEARCH STRING>

In case no option argument is given on command line, the command line
arguments are used as fixed search string. Search goes through all
email addresses in database and outputs every address (separated by
newline) where a substring match with the given search string is
found. No wildcard of regular expression matching is used.

Search is not done unless there is at least 3 octets in search string.

=head1 IGNORE FILE

Some of the addresses collected may be valid but those still seems to
be noisy junk. One may additionally want to just hide some email
addresses.

When running B<--update> the output shows the path of address database
file (usually C<$HOME/.config/nottoomuch/addresses>). If there is file
C<addresses.ignore> in the same directory that file is read as
newline-separated list of addresses which are not to be included in
address database file.

Use your text editor to open both of these files. Then move address
lines to be ignored from B<addresses> to B<addresses.ignore>. After
saving these 2 files the moved addresses will not reappear in
B<addresses> file again.

Version 2.0 of nottoomuch-addresses.sh supports regular expressions in
ignore file. Lines in format I</regexp/> or I</regexp/i> defines (perl)
I<regexp>s which are used to match email addresses for ignoring. The
I</i> format makes regular expression case-insensitive -- although this
is only applied to characters in ranges I<A-Z> and I<a-z>. Remember that
I</^.*regexp.*$/> and I</regexp/> provides same set of matching lines.

=head1 LICENSE

This program uses code from Email::Address perl module. Inclusion of
that makes it easy to define license for the whole of this code base:

Terms of Perl itself

a) the GNU General Public License as published by the Free
   Software Foundation; either version 1, or (at your option) any
   later version, or

b) the "Artistic License"

=head1 SEE ALSO

L<notmuch>, L<Email::Address>

=head1 AUTHOR

Tomi Ollila -- too ät iki piste fi

=head1 ACKNOWLEDGMENTS

This program uses code from Email::Address, Copyright (c) by Casey West
and maintained by Ricardo Signes. Thank you. All new bugs are mine,
though.