X-Git-Url: http://git.jankratochvil.net/?p=PerlMail.git;a=blobdiff_plain;f=perlmail-submit;h=b367979f2612c9e4bb0a1bebf1e5b6de2c19ac3a;hp=9976014a21c711fba026b0dd4978a9d5e2c65990;hb=be8e1bc69e15a29e52d8bbcde5971214a5b8340b;hpb=02d67bd115b03e0cc7e9e76a2362050909fce6e0

diff --git a/perlmail-submit b/perlmail-submit
index 9976014..b367979 100755
--- a/perlmail-submit
+++ b/perlmail-submit
@@ -1,12 +1,34 @@
 #! /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; };
 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,13 +38,6 @@ use POSIX qw(mktime);
 use Fcntl qw(:flock);
 
 
-my $Lock_pathname="/tmp/LaceMail.lock";
-my $PeerAddr="dejhome.dyn.jankratochvil.net.:852";
-my $Socket_timeout=600;	# 15sec is NOT enough!
-my $DB_table="LaceMail_folder";
-my $DBI_database="short";
-my $DBI_user="short";
-my $DBI_pwd=$ENV{"HOME"}."/priv/mysql.".$DBI_user.".pwd";
 open DBI_PWD,$DBI_pwd or die "open \"$DBI_pwd\": $!";
 $DBI_pwd=<DBI_PWD>;
 close DBI_PWD or warn "close DBI_pwd: $!";
@@ -65,6 +80,7 @@ sub store
 		local $/;
 		$message=<STDIN>;
 		}
+	close STDIN or cluck "close STDIN: $!";
 	my %row=(
 			"message"=>$message,
 			# assume "retries"=>0,
@@ -75,6 +91,14 @@ sub store
 	print $prep->{"mysql_insertid"}."\n";
 }
 
+sub forkoff
+{
+	my $pid=fork();
+	confess if !defined $pid;
+	exit 0 if $pid;	# parent
+	# child
+}
+
 my $submitonce_run=0;
 sub submitonce
 {
@@ -147,13 +171,52 @@ sub pending
 		}
 }
 
+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 time<from_unixtime(unix_timestamp()-$sec)");
+	$sth->execute();
+	if (!$print) {
+		print $sth->rows()."\n";
+		}
+	else {
+		while (my $row=$sth->fetchrow_hashref()) {
+			print $row->{"id"},"\n";
+			}
+		}
+}
+
 
 $Getopt::Long::ignorecase=0;
 die if !GetOptions(
 		  "initdb" ,\&initdb,
 		  "store"  ,\&store,
+		  "forkoff",\&forkoff,
 		  "submit" ,\&submit,
 		  "pending",\&pending,
-		"V|version",sub { print "lacemail-submit: $VERSION\n"; exit 0; },
+		  "clean:s",\&clean,
+		"V|version",sub { print "perlmail-submit: $VERSION\n"; exit 0; },
 		);
 exit 0;