#!/usr/local/bin/perl -w

require 5.001;
use English;
use Tk;

inits();
get_article();
create_widgets();
Tk::MainLoop();
exit;

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


sub inits {
    $i = 0;
    %Messages = ( 
	'Missing references'	=>   [ $i++, '/path/foo' ],
	'Perl MetaFAQ'		=>   [ $i++, '/path/foo' ],
	'Magic MetaFAQ'		=>   [ $i++, '/path/foo' ],
	'Csh Considered Harmful'=>   [ $i++, '/path/foo' ],
	'Signature too long'	=>   [ $i++, '/path/foo' ],
	'Lines too long'		=>   [ $i++, '/path/foo' ],
	'Too much quoted text'	=>   [ $i++, '/path/foo' ],
	'Too many cross postings'	=>   [ $i++, '/path/foo' ],
    );

}

sub create_widgets {

#
# Create a MainWindow, unique to a display and from which all 
# other Tk widgets descend.
#
$topwin = new MainWindow;
title    $topwin "Annoying AutoReplies";
iconname $topwin "AA";

#
# This Frame contains one scrollable Listbox to contain "messages".
#
$frame1 = Frame $topwin -relief => "sunken", -bd => 2;

$lister = Listbox $frame1 qw{
	    -selectmode browse 
	    -font fixed 
	    -width 30 
	    -height 10
	    -relief sunken 
	    -bd 2
};

$tscroll = Scrollbar $frame1 -command 		=> ["yview", $lister], 
			     -orient  		=> "vertical", 
			     -activebackground 	=> "snow4";

configure $lister -yscrollcommand => ["set", $tscroll], 
		   -background => 'snow1';


$msg = Message $topwin  
	-font 	 	=> '-Adobe-times-medium-r-normal--*-180-*-*-*-*-*-*', 
	-relief 	=> 'raised', 
	-width 	 	=> 300,
	-justify	=> 'left',
	-borderwidth 	=> 2, 
	-background     => 'azure4',
	-text 	 	=> unformat( <<EOText );

	    Send a message from the selected list
	    to the given user up to once per few 
	    weeks.
			    
EOText


$msg->pack(-side => 'top');

$frame1 -> pack(-side => "top");
$lister -> pack(-side => "left");
$tscroll-> pack(-side => "right", -fill => "y");

@hdr_colors = qw(
    CadetBlue1
    MediumPurple1
    turquoise1
    PaleTurquoise1
    SlateBlue1
);
$hdr_color = 0;

$hdrs = Message $topwin
    -font 	 	=> '-Adobe-times-medium-r-normal--*-120-*-*-*-*-*-*', 
    -relief 		=> 'raised', 
    -width 	 	=> 350,
    -justify		=> 'left',
    -background     	=> $hdr_colors[$hdr_color],
    -borderwidth 	=> 2, 
    -text 	 	=> $hdrtext;

$hdrs->pack(-side => 'bottom');


#
# Finally, in place of a standard Menu, 
# let's just make some quit and execute buttons.
#
$frame2 = Frame $topwin;	# a second Frame for packing the buttons
$frame2->pack(-side => "top");

$execute_button = Button $frame2 -text 	   		=> "deliver", 
				 -relief   		=> "raised", 
				 -background 		=> 'PaleGreen1',
				 -activebackground 	=> 'SpringGreen4',
				 -command  		=> [
					 \&go_for_it, $lister];

$art_button     = Button $frame2 -text     		=> "article", 
			         -relief   		=> "raised", 
				 -background 		=> yellow1, 
				 -activebackground 	=> DarkOrchid1,
			         -command  		=> [ sub 
     {
	    get_article();
	    $hdr_color = ($hdr_color + 1) % @hdr_colors;
	    configure $hdrs -text 	=> $hdrtext,
			    -background	=> $hdr_colors[$hdr_color];
     }
   ]; 

$quit_button    = Button $frame2 -text     => "quit", 
			         -relief   => "raised", 
			         -command  => sub {destroy "."},
				 -background => 'orange1',
				 -activebackground => 'DarkOrange2';


$art_button     -> pack(-side => "left");
$execute_button -> pack(-side => "left");
$quit_button    -> pack(-side => "right");

# 
# OK, all widgets created and arranged...  put some stuff in the 
# Listbox (we could read them from a file just as well).
# 
foreach $msg (sort { 
		    $Messages{$a}[0] <=> $Messages{$b}[0] 
		} keys %Messages) 
{
    insert $lister "end", $msg;
} 

# 
# Create Listbox binding.  Note implicit first argument is Listbox reference.
#
$lister->bind( "<Double-Button-1>" => [\&go_for_it] );

}


##############################################################
#
# Callback for Listbox double click or execute click.
#
sub go_for_it {
    my $widget = $ARG[0];
    print "Sending mail to $Art{'From'} regarding ", $widget->get("active"), "!\n";
    configure $hdrs -background	=> 'HotPink1';
} 

sub get_article {
    my @arts = `ls -t /tmp/rrn.*`;
    chop @arts;
    clear_article();
    if (@arts) {
	unless (open(ART, "< $arts[0]")) {
	    warn "can't open $arts[0]";
	    return;
	}
	parse_article(*ART);
    } 
} 
sub clear_article { }

sub parse_article {
    local *FH = $_[0];
    local $/ = '';
    local $_ = <FH>;
    $Article = $_;
    while ( /^(From|Newsgroups|Subject|Date):\s*(\S.*)/gim ) {
	$Art{$1} = $2;
    } 
    while (<FH>) {
	$Article .= $_;
    } 
    $user = $Art{From};

    $hdrtext = '';
    for $field (sort keys %Art) {
	$hdrtext .= sprintf("%-60.60s\n", "$field: $Art{$field}");
    }
    chop $hdrtext;

    # $Art{Lines} = $Article =~ y/\n//;
} 

sub unformat {
    local $_ = shift;
    s/^\s*/ /gm;
    y/\n/ /;
    s/\s{2,}/ /g;
    return $_;
} 

sub deliver {
    my $widget = $ARG[0];
    $whatsup = $widget->get("active");

    $now = time;

    $WEEK = 7 * 24 * 60 * 60;
    $WEEK *= 4;

    chdir;
    dbmopen(%SENT, 'etc/automsg', 0644) || die "no dbm file etc/tmsg: $!";

    if ($SENT{$user, $whatsup}) {
	if ($SENT{$user} + $WEEK > $now) {
	    print "User $user already got mail about $whatsup recently\n";
	    return;
	} else {
	    print "User $user got mail about $whatsup a long time ago \n";
	    $longtime = <<'EOF';
    Hm... I see you got mail from me about this before, but it's been over a
    month since the last one, and the problem seems to be an ongoing one, so I
    (or rather, my mindless tkperlbot) thought maybe you could use a reminder.

EOF
	} 
    } else {
	$longtime = '';
    } 

    $SENT{$user, $whatsup} = time;
    dbmclose %SENT;

    open(MAILER, "|/usr/lib/sendmail -oi -t") || die;

    print MAILER <<EOEOEOEO;
To: $user
From: Tom Christiansen <tchrist\@mox.perl.com>
Subject: AutoPost on $whatsup (was: $Art{Subject})

    [The following is a manually-generated but purely generic email
     message; you should not receive more than one copy of this posting
     per week.]

EOEOEOEO
    print MAILER $longtime if $longtime;

    $fn = $Messages{$whatsup}[1];
    open (MSG, "< $fn") || die "can't open $fn: $!";
    print MAILER <MSG>;

    print MAILER <<'EOEOEOEO';

Tom Christiansen      Perl Consultant, Gamer, Hiker      tchrist@mox.perl.com

    Maintainer of the "Csh Programming Considered Harmful" FAQ, the
    comp.lang.perl FAQ, the rec.games.trading-cards.* MetaFAQ, and 
    the WWW MtG Database at http://mox.perl.com/deckmaster,

EOEOEOEO

    print MAILER "PS: Here's the article I'm talking about:\n\n";

    $Article =~ s/^/> /;

    print MAILER $Article;

    close(MAILER) || die "couldn't close mailer: $?";
    print "Mail sent to $user about $whatsup\n";
}