X-Git-Url: http://git.jankratochvil.net/?p=PerlMail.git;a=blobdiff_plain;f=perlmail-submit;h=4711b746d33c0084fbe36f2fcc936a0576cb0555;hp=c7fe19fd9a69788e6ae170ecbfea3a3f9172d631;hb=3cbaf4bbe1fe5f3b9f520e057ad8ef7c4d92d9c3;hpb=9d03569bd26dfb0f54f21063445fc9d28ed1c4d3

diff --git a/perlmail-submit b/perlmail-submit
index c7fe19f..4711b74 100755
--- a/perlmail-submit
+++ b/perlmail-submit
@@ -1,6 +1,22 @@
 #! /usr/bin/perl
-#
+# 
 #	$Id$
+# Copyright (C) 2002-2003 Jan Kratochvil <project-PerlMail@jankratochvil.net>
+# 
+# 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; };
@@ -22,25 +38,34 @@ use POSIX qw(mktime);
 use Fcntl qw(:flock);
 
 
+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=<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
@@ -52,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;
 }
@@ -69,7 +94,7 @@ sub store
 			"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";
@@ -79,6 +104,7 @@ sub forkoff
 {
 	my $pid=fork();
 	confess if !defined $pid;
+	$DBI=undef();	# Prevent: Server has gone away
 	exit 0 if $pid;	# parent
 	# child
 }
@@ -94,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");
@@ -103,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,
@@ -124,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=",";
@@ -146,21 +172,33 @@ sub submit
 	1 while submitonce();
 }
 
-sub pending
+sub print_messages
 {
-	my $sth=$DBI->prepare("select message from $DB_table where retries is not null 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()");
+	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(
@@ -179,7 +217,7 @@ my($keyword,$interval)=@_;
 	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")
+	$sth=DBI()->prepare(($print ? "select id" : "delete")
 			." from $DB_table where retries is null and time<from_unixtime(unix_timestamp()-$sec)");
 	$sth->execute();
 	if (!$print) {
@@ -200,6 +238,7 @@ die if !GetOptions(
 		  "forkoff",\&forkoff,
 		  "submit" ,\&submit,
 		  "pending",\&pending,
+		  "dump"   ,\&dump,
 		  "clean:s",\&clean,
 		"V|version",sub { print "perlmail-submit: $VERSION\n"; exit 0; },
 		);