xlog/bin/record

   1 #!/usr/bin/perl -w
   2
   3 use strict (qw(vars));
   4 use IO::Handle;
   5 use POSIX;
   6
   7 our %f;
   8
   9 my $publish_rejections_patfile= '/dev/null';
  10 my $publish_rejections= 0;
  11
  12 for (;;) {
  13     last unless @ARGV;
  14     last unless $ARGV[0] =~ m/^-/;
  15     $_ = shift @ARGV;
  16     last if m/^--?$/;
  17     while (m/^-./) {
  18         if (s/^-P(.*)$//) {
  19             $publish_rejections= 1;
  20             $publish_rejections_patfile= $1 if length $1;
  21         } else {
  22             die "bad option $_ ?";
  23         }
  24     }
  25 }
  26
  27 our ($how) = @_;
  28
  29 my $dir= $0;
  30 $dir =~ s,/[^/]+$,,;
  31 $dir =~ s,/bin$,/log,;
  32 $dir .= "/$ARGV[1]";
  33
  34 my $message;
  35
  36 sub parse__headerline () {
  37     $f{Subject}= $' if m/^Subject:\s*/i; #';
  38     $f{MessageID}= $' if m/^Message\-ID:\s*/i; #';
  39     $f{From}= $' if m/^From:\s*/i; #';
  40 }
  41 sub parse__stumpsubject () {
  42     $f{MessageNum}=$1 if m/^Subject:.*\:\:\w+\/(\d+)$/i;
  43 }
  44
  45 sub parse_posted () {
  46     while (<STDIN>) {
  47         chomp;
  48         parse__headerline();
  49         last if m/^$/;
  50     }
  51     $f{Event}= 'post';
  52 }
  53 sub parse_submission () {
  54     my $hadng=0;
  55     my %oldf;
  56     my $had2=0;
  57     while (<STDIN>) {
  58         chomp;
  59 print STDERR "$hadng $had2|$_|\n";
  60         $hadng++ if m/^Newsgroups:/i;
  61         if (m/^$/) {
  62             last if $hadng;
  63             last if $had2++;
  64             %oldf= %f;
  65             undef %f;
  66         }
  67         last unless m/^\S+\:|^\s|^$|^From /;
  68         parse__headerline();
  69     }
  70     if ($hadng) {
  71         $f{Event}= $had2 ? 'receive newstyle' : 'receive';
  72     } else {
  73         %f= %oldf if $had2;
  74         $f{Subject}= '[suppressed]';
  75         $f{Event}= 'receive junk';
  76     }
  77 }
  78
  79 sub parse_stump2webstump () {
  80     while (<STDIN>) {
  81         chomp;
  82         parse__stumpsubject() unless exists $f{'MessageNum'};
  83         last if m/^\@{40,}$/;
  84     }
  85     while (<STDIN>) {
  86         chomp;
  87         last if m/^$/;
  88         parse__headerline();
  89     }
  90     $f{Event}= 'enqueue';
  91 }
  92
  93 sub parse_webstump2stump () {
  94     while (<STDIN>) {
  95         chomp;
  96         parse__stumpsubject();
  97         last if m/^$/;
  98     }
  99     my $cathow = '';
 100     while (<STDIN>) {
 101         chomp;
 102         if (m/^\#( \w+.*)$/) {
 103             $cathow = $1;
 104         }
 105         next unless m/^reject|^approve|^preapprove/;
 106         $f{Event}= $_.$cathow;
 107         last;
 108     }
 109 }
 110
 111 sub parse_mailout () {
 112     my $keepheader= 1;
 113     while (<STDIN>) {
 114         $keepheader= 1 unless m/^[ \t]/;
 115         $keepheader= 0
 116             if m/^(?: received
 117                    | envelope-to
 118                    )/ix;
 119         $keepheader= 'mangle'
 120             if m/^(?: to
 121                    | from
 122                    | return-path
 123                    | reply-to
 124                    | errors-to
 125                    )/ix;
 126         if ($keepheader) {
 127             my $line= $_;
 128             $line =~ s/\@.{0,2}/ at ../g if $keepheader eq 'mangle';
 129             $message .= $line;
 130         }
 131         chomp;
 132         if (m/^X-Webstump-Event:\s*(?:\[(\d+)\])?\s*/i) { #';
 133             $f{Event}= "notify $'";
 134             $f{MessageNum}= $1 if defined $1;
 135         }
 136         last if m/^$/;
 137     }
 138     while (<STDIN>) {
 139         $message .= $_;
 140         chomp;
 141         next unless s/^\> //;
 142         last if m/^$/;
 143         parse__headerline();
 144     }
 145 }
 146
 147 $f{Event}= '?';
 148 &{"parse_$ARGV[0]"};
 149 while (<STDIN>) { $message .= $_; }
 150 STDIN->error and die $!;
 151
 152 $f{Now}= time;
 153
 154 sub want_publish_rejection_kind ($) {
 155     my ($kind) = @_;
 156     return 1 if $publish_rejections_patfile eq '';
 157     if (!open PF, '<', $publish_rejections_patfile) {
 158         return 1 if $!==&ENOENT;
 159         die "$publish_rejections_patfile: $!";
 160     }
 161     while (<PF>) {
 162         s/^\s+//;
 163         s/\s+$//;
 164         next if m/^\#/;
 165         next unless m/\S/;
 166         my $yn = !s/^\!//;
 167         s/[^0-9a-zA-Z*?]/\\$&/g;
 168         s/\*/.*/g;
 169         s/\?/./g;
 170         return $yn if $kind =~ m/^$_$/;
 171     }
 172     close PF or die $!;
 173     return 1;
 174 }
 175
 176 if ($publish_rejections &&
 177     $f{Event} =~ m/^notify reject (\S+)/ &&
 178     want_publish_rejection_kind($1))
 179 {
 180     $f{CopyRef}= $f{MessageNum} || $f{MessageID};
 181     $f{CopyRef} =~ s/\W/ sprintf '-%02x', ord($&) /ge;
 182     open I, ">$dir/public/nr-$f{CopyRef}.txt" or die $!;
 183     print I $message or die $!;
 184     close I or die $!;
 185 }
 186
 187 open L, ">>$dir/event.log" or die $!;
 188
 189 my @s= map {
 190     my $v= $f{$_};
 191     $v= '' unless defined $v;
 192     $v =~ s/\t/  /g;
 193     $v =~ s/[\r\n]/?/g;
 194     $v;
 195 } qw(Now MessageNum MessageID From Subject Event CopyRef);
 196
 197 print L join("\t",@s)."\n" or die $!;
 198 close L or die $!;