git://git.jankratochvil.net
/
PerlMail.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Turn off caching on the server side.
[PerlMail.git]
/
perlmail-submit
diff --git
a/perlmail-submit
b/perlmail-submit
index
b367979
..
4711b74
100755
(executable)
--- a/
perlmail-submit
+++ b/
perlmail-submit
@@
-38,25
+38,34
@@
use POSIX qw(mktime);
use Fcntl qw(:flock);
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;
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(): $!";
"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)=@_;
# $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
}
sub initdb
@@
-68,7
+77,7
@@
sub initdb
"retries int null default 0", # null=>done, 0=not yet tried to submit
],
);
"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;
}
print "done.\n";
exit 0;
}
@@
-85,7
+94,7
@@
sub store
"message"=>$message,
# assume "retries"=>0,
);
"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";
." values (".join(",",map("?",keys(%row))).")");
$prep->execute(values(%row));
print $prep->{"mysql_insertid"}."\n";
@@
-95,6
+104,7
@@
sub forkoff
{
my $pid=fork();
confess if !defined $pid;
{
my $pid=fork();
confess if !defined $pid;
+ $DBI=undef(); # Prevent: Server has gone away
exit 0 if $pid; # parent
# child
}
exit 0 if $pid; # parent
# child
}
@@
-110,7
+120,7
@@
sub submitonce
print "LOCKED\n";
exit 0;
}
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");
# process only non-problematic mails during rerun
.($submitonce_run==1 ? "" : " and retries=0")
." order by retries asc,id asc");
@@
-119,7
+129,7
@@
sub submitonce
autoflush STDOUT 1;
my $sock;
while (my $row=$sth->fetchrow_hashref()) {
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,
if (!$sock) {
$sock=IO::Socket::INET->new(
"PeerAddr"=>$PeerAddr,
@@
-140,7
+150,7
@@
sub submitonce
undef $sock;
}
else {
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=",";
}
print $progresschar.$row->{"id"}.($got eq "1" ? "" : "=FAIL");
$progresschar=",";
@@
-162,21
+172,33
@@
sub submit
1 while submitonce();
}
1 while submitonce();
}
-sub p
ending
+sub p
rint_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";
}
}
$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
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(
$sth->execute();
while (my $row=$sth->fetchrow_hashref()) {
warn "Message time in future: ".join(",",map(
@@
-195,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 "";
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) {
." from $DB_table where retries is null and time<from_unixtime(unix_timestamp()-$sec)");
$sth->execute();
if (!$print) {
@@
-216,6
+238,7
@@
die if !GetOptions(
"forkoff",\&forkoff,
"submit" ,\&submit,
"pending",\&pending,
"forkoff",\&forkoff,
"submit" ,\&submit,
"pending",\&pending,
+ "dump" ,\&dump,
"clean:s",\&clean,
"V|version",sub { print "perlmail-submit: $VERSION\n"; exit 0; },
);
"clean:s",\&clean,
"V|version",sub { print "perlmail-submit: $VERSION\n"; exit 0; },
);