chiark - git - mdw - misc/blob - unfwd.in

   1 #! /usr/bin/perl
   2
   3 use MIME::Parser;
   4 use MIME::Entity;
   5 use MIME::Head;
   6 use MIME::Body;
   7
   8 sub bounce {
   9   print STDERR "$0: ", @_, "\n";
  10   exit 100;
  11 }
  12
  13 sub retry {
  14   print STDERR "$0: ", @_, "\n";
  15   exit 111;
  16 }
  17
  18 $DONE = 0;
  19 $FAIL = 0;
  20
  21 sub fail {
  22   print STDERR "$0: ", @_, "\n";
  23   $FAIL = 100;
  24 }
  25
  26 sub msg {
  27   my ($body) = @_;
  28   $DONE = 1;
  29   pipe(IN, OUT);
  30   my $kid = fork();
  31   defined($kid) or retry("couldn't fork: $!");
  32   if (!$kid) {
  33     open(STDIN, "<&IN");
  34     close(OUT);
  35     close(IN);
  36     exec @ARGV;
  37     print STDERR "$0: exec `", join(" ", @ARGV), "' failed: $!\n";
  38     exit 100;
  39   }
  40   close(IN);
  41   $body->print(\*OUT) or fail "print failed: $!", last;
  42   close(OUT) or fail "close failed: $!";
  43   waitpid($kid, 0) or fail "waitpid failed: $!";
  44   $? and fail "program `", join(" ", @ARGV), "' exited with status $?";
  45 }
  46
  47 sub digest {
  48   my ($e) = @_;
  49   foreach my $i ($e->parts()) {
  50     msg($i->bodyhandle());
  51   }
  52 }
  53
  54 $SIG{__DIE__} = sub { retry "DEAD: ", @_, "!" };
  55 $SIG{PIPE} = IGN;
  56 @ARGV or retry "$0: no command given";
  57 my $pp = MIME::Parser->new();
  58 $pp->output_to_core(ALL);
  59 $pp->extract_nested_messages(0);
  60 my $top = $pp->parse(\*STDIN);
  61 if ($top->effective_type =~ m'multipart/mixed'i) {
  62   foreach my $i ($top->parts()) {
  63     if ($i->effective_type =~ m'message/rfc822'i) {
  64       msg($i->bodyhandle());
  65     } elsif ($i->effective_type =~ m'multipart/digest'i) {
  66       digest($i);
  67     }
  68   }
  69 } elsif ($top->effective_type =~ m'multipart/digest'i) {
  70   digest($top);
  71 }
  72 if (!$DONE) { bounce "no forwarded message or digest"; }
  73 exit $FAIL;