You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

116 lines
3.2 KiB

  1. #!/usr/bin/perl -w
  2. # Written by Bill Allombert for the Debian popularity-contest project.
  3. # This file is placed in the public domain.
  4. use strict;
  5. use IO::Socket::IP;
  6. my %opts;
  7. # Not using Getopt::Std to avoid perl-modules dependency
  8. while($#ARGV >= 0 && ($_ = $ARGV[0]) =~ /^-/) {
  9. shift @ARGV;
  10. if (/^-C$/) { $opts{'C'} = 1; next }
  11. if (/^-d$/) { $opts{'d'} = 1; next }
  12. if (/^-u$/) { $opts{'u'} = shift; next }
  13. if (/^-f$/) { $opts{'f'} = shift; next }
  14. &usage("unknown option");
  15. exit 1;
  16. }
  17. sub usage {
  18. print "popcon-upload: error: @_\n" if ($#_ >= 0);
  19. print <<"EOF";
  20. Usage: $0 [-Cd] [-u <url>] [-f <file>]
  21. -C send submissions in clear text, and not compressed
  22. -d enable debugging
  23. -u <url> submit to the given URL (default popcon.debian.org)
  24. -f <file> read popcon report from file (default stdin)
  25. EOF
  26. }
  27. my $compressed = 1; # Submit reports in a compressed form?
  28. my ($submiturl) = $opts{'u'} || "http://popcon.debian.org/cgi-bin/popcon.cgi";
  29. my ($file) = $opts{'f'} || "-";
  30. $compressed = 0 if ($opts{'C'});
  31. my ($host) = $submiturl =~ m%http://([^/]+)%;
  32. print "Unable to parse url\n" if ($opts{'d'} && ! $host);
  33. # Configure the proxy:
  34. my ($http_proxy,$proxy,$port,$remote);
  35. $http_proxy=$ENV{'http_proxy'};
  36. if (defined($http_proxy))
  37. {
  38. $http_proxy =~ m{http://([^:]*)(?::([0-9]+))?}
  39. or die ("unrecognized http_proxy");
  40. $proxy=$1; $port=$2;
  41. }
  42. $proxy=$host unless (defined($proxy));
  43. $port=80 unless (defined($port));
  44. # Compress the report:
  45. my ($str,$len);
  46. my $encoding;
  47. if ($compressed) {
  48. open FILE, "gzip -c $file |" or die "gzip -c $file";
  49. $encoding = "x-gzip";
  50. } else {
  51. open FILE, "< $file" or die "reading from '$file'";
  52. $encoding = "identity";
  53. }
  54. $str .= $_ while(<FILE>);
  55. close(FILE);
  56. $len = length($str);
  57. # 30 second timeout on http connections
  58. $SIG{ALRM} = sub { die "timeout in popcon-upload\n" };
  59. alarm(30);
  60. # Connect to server
  61. $remote = IO::Socket::IP->new(Proto => "tcp", PeerAddr => $proxy,
  62. PeerPort => $port);
  63. unless ($remote) { die "cannot connect to $proxy:$port" }
  64. my $boundary = "----------ThIs_Is_tHe_bouNdaRY_\$";
  65. #Content-Length: $len
  66. # text/plain; charset=utf-8
  67. my $ORS = "\r\n"; # Use DOS line endings to make HTTP happy
  68. my $form;
  69. $form .= "--${boundary}$ORS";
  70. $form .= "Content-Disposition: form-data; name=\"popcondata\"; filename=\"popcon-data\"$ORS";
  71. $form .= "Content-Encoding: $encoding$ORS";
  72. $form .= "Content-Type: application/octet-stream$ORS$ORS";
  73. $form .= "$str$ORS";
  74. $form .= "--${boundary}--$ORS";
  75. $form .= "$ORS";
  76. my $formlen = length($form);
  77. #Send data
  78. print $remote "POST $submiturl HTTP/1.1\r\n";
  79. print $remote "User-Agent: popcon-upload\r\n";
  80. print $remote "Host: $host\r\n";
  81. print $remote "Content-Type: multipart/form-data; boundary=$boundary\r\n";
  82. print $remote "Content-Length: $formlen\r\n";
  83. print $remote "\r\n";
  84. print $remote "$form";
  85. #Get answer
  86. my($answer)="";
  87. while(<$remote>)
  88. {
  89. $answer.=$_;
  90. m/DEBIAN POPCON HTTP-POST OK/ and last;
  91. }
  92. close ($remote);
  93. #Check answer
  94. my $status = ($answer =~ m/DEBIAN POPCON HTTP-POST OK/) ? 0 : 1;
  95. print "Failed to upload, answer '$answer'\n" if $status && $opts{'d'};
  96. exit $status;