X-Git-Url: http://git.jankratochvil.net/?p=PerlMail.git;a=blobdiff_plain;f=perlmail-submit;h=cc76cca9453db6d407c9e7ed3a5398a961c68d90;hp=2901153700e7d1fc56ca3791c8b9391be9573ed5;hb=b26efefc162e6deb4bf6fc7e6307e16698891d19;hpb=b68782d3f8bca18eb93a2abf167541986decedfc diff --git a/perlmail-submit b/perlmail-submit index 2901153..cc76cca 100755 --- a/perlmail-submit +++ b/perlmail-submit @@ -1,12 +1,34 @@ #! /usr/bin/perl -# +# # $Id$ +# Copyright (C) 2002-2003 Jan Kratochvil +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + use vars qw($VERSION); $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; use strict; use warnings; +use File::Basename; +BEGIN { + use lib $ENV{"PERLMAIL_BASEDIR"} || File::Basename::dirname($0); + use PerlMail::Config; + } + use Getopt::Long; use DBI; use Carp qw(cluck confess); @@ -16,32 +38,34 @@ use POSIX qw(mktime); use Fcntl qw(:flock); -my $Lock_pathname="/tmp/LaceMail.lock"; -my $PeerAddr="dejhome.dyn.jankratochvil.net.:852"; -my $Socket_timeout=15; -my $DB_table="LaceMail_folder"; -my $DBI_database="short"; -my $DBI_user="short"; -my $DBI_pwd=$ENV{"HOME"}."/priv/mysql.".$DBI_user.".pwd"; +my $DBI_CACHE=0; # Cache DBI requests - may cause: MySQL server has gone away + + open DBI_PWD,$DBI_pwd or die "open \"$DBI_pwd\": $!"; $DBI_pwd=; close DBI_PWD or warn "close DBI_pwd: $!"; chomp $DBI_pwd; -my $DBI=DBI->connect_cached("DBI:mysql:database=$DBI_database;host=","$DBI_user",$DBI_pwd,{ +my $DBI; +sub DBI +{ + return $DBI if $DBI_CACHE && $DBI; + $DBI=DBI->connect("DBI:mysql:database=$DBI_database;host=","$DBI_user",$DBI_pwd,{ "PrintError"=>0, # handled by "RaiseError" below "RaiseError"=>1, "ShowErrorStatement"=>1, "AutoCommit"=>1, }) or confess "Failed DBI->connect(): $!"; + return $DBI; +} # $name,@$cols sub create_table { my($name,$cols)=@_; - eval { $DBI->do("drop table $name"); }; - $DBI->do("create table $name (".join(",",@$cols).")"); + eval { DBI()->do("drop table $name"); }; + DBI()->do("create table $name (".join(",",@$cols).")"); } sub initdb @@ -53,7 +77,7 @@ sub initdb "retries int null default 0", # null=>done, 0=not yet tried to submit ], ); - $DBI->do("alter table $DB_table add index (retries,id)"); + DBI()->do("alter table $DB_table add index (retries,id)"); print "done.\n"; exit 0; } @@ -65,16 +89,26 @@ sub store local $/; $message=; } + close STDIN or cluck "close STDIN: $!"; my %row=( "message"=>$message, # assume "retries"=>0, ); - my $prep=$DBI->prepare_cached("insert into $DB_table (".join(",",keys(%row)).")" + my $prep=DBI()->prepare("insert into $DB_table (".join(",",keys(%row)).")" ." values (".join(",",map("?",keys(%row))).")"); $prep->execute(values(%row)); print $prep->{"mysql_insertid"}."\n"; } +sub forkoff +{ + my $pid=fork(); + confess if !defined $pid; + $DBI=undef(); # Prevent: Server has gone away + exit 0 if $pid; # parent + # child +} + my $submitonce_run=0; sub submitonce { @@ -86,7 +120,7 @@ sub submitonce print "LOCKED\n"; exit 0; } - my $sth=$DBI->prepare("select id,message from $DB_table where retries is not null" + my $sth=DBI()->prepare("select id,message from $DB_table where retries is not null" # process only non-problematic mails during rerun .($submitonce_run==1 ? "" : " and retries=0") ." order by retries asc,id asc"); @@ -95,7 +129,7 @@ sub submitonce autoflush STDOUT 1; my $sock; while (my $row=$sth->fetchrow_hashref()) { - $DBI->do("update $DB_table set retries=retries+1 where id=".$row->{"id"}); + DBI()->do("update $DB_table set retries=retries+1 where id=".$row->{"id"}); if (!$sock) { $sock=IO::Socket::INET->new( "PeerAddr"=>$PeerAddr, @@ -116,7 +150,7 @@ sub submitonce undef $sock; } else { - $DBI->do("update $DB_table set retries=null where id=".$row->{"id"}); + DBI()->do("update $DB_table set retries=null where id=".$row->{"id"}); } print $progresschar.$row->{"id"}.($got eq "1" ? "" : "=FAIL"); $progresschar=","; @@ -138,22 +172,90 @@ sub submit 1 while submitonce(); } -sub pending +sub print_messages { - my $sth=$DBI->prepare("select message from $DB_table where state='pending' order by id"); +my($cond)=@_; + + my $sth=DBI()->prepare("select message from $DB_table $cond order by id"); $sth->execute(); while (my $row=$sth->fetchrow_hashref()) { print $row->{"message"},"\n"; } } +sub pending +{ + print_messages("where retries is not null"); +} + +sub dump +{ + print_messages(""); +} + +sub clean +{ +my($keyword,$interval)=@_; + + # FIXME: SQL "now()" is raced against the block above + my $sth=DBI()->prepare("select id,time,retries from $DB_table where time>now()"); + $sth->execute(); + while (my $row=$sth->fetchrow_hashref()) { + warn "Message time in future: ".join(",",map( + "$_=".(!defined $row->{$_} ? "NULL" : $row->{$_}) + ,keys(%$row))); + } + + return if $interval eq ""; + local $_=$interval; + my $print=s/^print://; + s/(\d+)y/($1*12)."m"/ge; + s/(\d+)m/($1*30)."d"/ge; + s/(\d+)d/($1*24)."h"/ge; + s/(\d+)h/($1*60)."M"/ge; + s/(\d+)M/($1*60)."s"/ge; + my $sec=0; + $sec+=$1 while s/(\d+)s//g; + die "Interval parse error; left \"$_\", parsed: $interval" if $_ ne ""; + $sth=DBI()->prepare(($print ? "select id" : "delete") + ." from $DB_table where retries is null and timeexecute(); + if (!$print) { + print $sth->rows()."\n"; + } + else { + while (my $row=$sth->fetchrow_hashref()) { + print $row->{"id"},"\n"; + } + } +} + +my $optwrap_err; +sub optwrap +{ +my($func,@args)=@_; + + # Prevent successful return due to --forkoff in the case of failed --store when using: + # perlmail-submit --store --forkoff --submit + if (!eval { &{$func}(@args); 1; }) { + $optwrap_err||=$@||$!; + die "!FINISH"; + die "NOTREACHED"; + } +} $Getopt::Long::ignorecase=0; -die if !GetOptions( - "initdb" ,\&initdb, - "store" ,\&store, - "submit" ,\&submit, - "pending",\&pending, - "V|version",sub { print "lacemail-submit: $VERSION\n"; exit 0; }, +# &GetOptions will return success due to: die "!FINISH" +# but our error detection is done by $optwrap_err. +GetOptions( + "initdb" ,sub { optwrap \&initdb,@_; }, + "store" ,sub { optwrap \&store,@_; }, + "forkoff",sub { optwrap \&forkoff,@_; }, + "submit" ,sub { optwrap \&submit,@_; }, + "pending",sub { optwrap \&pending,@_; }, + "dump" ,sub { optwrap \&dump,@_; }, + "clean:s",sub { optwrap \&clean,@_; }, + "V|version",sub { print "perlmail-submit: $VERSION\n"; exit 0; }, ); +die $optwrap_err if defined $optwrap_err; exit 0;