tools/upload.cgi

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use Fcntl;
   5
   6 # this is a sample cgi script to accept darcs patches via POST
   7 # it simply takes patches and places them in a Maildir style
   8 # mailbox.
   9
  10 # set this to the maildir you wish patches to be sent to.
  11 my $maildir = "/tmp/maildir";
  12
  13 sub error_page {
  14     my ($m) = @_;
  15     print "Status: 500 Error accepting patch\n";
  16     print "Content-Type: text/plain\n\n";
  17     print($m || "There was an error processing your request");
  18     print "\n";
  19     exit 0;
  20 }
  21
  22 sub success_page {
  23     print "Content-Type: text/plain\n\n";
  24     print "Thank you for your contribution!\n";
  25     exit 0;
  26 }
  27
  28
  29 if($ENV{CONTENT_TYPE} eq 'message/rfc822') {
  30         my $m = start_message($maildir) or error_page("could not open maildir: $maildir");
  31         my $fh = $m->{fh};
  32         my ($totalbytes,$bytesread,$buffer);
  33         do {
  34             $bytesread=read(STDIN,$buffer,1024);
  35             print $fh $buffer;
  36             $totalbytes += $bytesread;
  37         } while($bytesread);
  38         my $r = end_message($m);
  39         $r ? error_page($r) : success_page();
  40 } elsif($ENV{CONTENT_TYPE}) {
  41     error_page("invalid content type, I expect something of message/rfc822");
  42 } else {
  43     error_page("This url is for accepting darcs patches");
  44 }
  45
  46
  47
  48 sub temp_file {
  49     my ($temp_dir) = @_;
  50     my $base_name = sprintf("patch-%d-%d-0000", $temp_dir, $$, time());
  51     local *FH;
  52     my $count = 0;
  53     until (defined(fileno(FH)) || $count++ > 100) {
  54         $base_name =~ s/-(\d+)$/"-" . (1 + $1)/e;
  55         sysopen(FH, "$temp_dir/$base_name", O_WRONLY|O_EXCL|O_CREAT);
  56     }
  57     defined(fileno(FH)) ? return (*FH, $base_name) : return ();
  58 }
  59
  60 sub start_message {
  61     my ($maildir) = @_;
  62     my ($fh,$fname) = temp_file("$maildir/tmp") or return undef;
  63     return { maildir => $maildir, fh => $fh, filename => $fname };
  64 }
  65
  66 sub end_message {
  67     my ($m) = @_;
  68     close $m->{fh} or return "$!: $m->{filename} - Could not close filehandle";
  69     link "$m->{maildir}/tmp/$m->{filename}", "$m->{maildir}/new/$m->{filename}" or return "$@: $m->{filename} - could not link to new";
  70     unlink "$m->{maildir}/tmp/$m->{filename}";
  71     return 0;
  72 }