Move My-Audit to PerlMail::Config.

[PerlMail.git] / perlmail-submit

diff --git a/perlmail-submit b/perlmail-submit
index 9976014..c7fe19f 100755 (executable)
--- a/perlmail-submit
+++ b/perlmail-submit
@@ -7,6 +7,12 @@ $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 +22,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 +64,7 @@ sub store
                local $/;
                $message=<STDIN>;
                }
+       close STDIN or cluck "close STDIN: $!";
        my %row=(
                        "message"=>$message,
                        # assume "retries"=>0,
@@ -75,6 +75,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 +155,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;