fork download
copy 
  1. # cpan-upload - upload one or more file to CPAN (via PAUSE)
  2. #
  3. # $Id: cpan-upload,v 2.2 2002/07/02 21:44:10 neilb Exp $
  4. #
  5.  
  6. use perl5:AppConfig::Std;
  7. use perl5:Net::FTP;
  8. use perl5:HTTP::Request::Common;
  9. use perl5:LWP::UserAgent;
  10. use perl5:HTTP::Status;
  11. use perl5:File::Basename;
  12.  
  13. #-----------------------------------------------------------------------
  14. #       Configuration constants and globals
  15. #-----------------------------------------------------------------------
  16. my $PROGRAM;
  17. my $SITE          = 'pause.perl.org';
  18. my $UPLOAD_DIR    = 'incoming';
  19. my $PAUSE_ADD_URI = 'http://p...content-available-to-author-only...l.org/pause/authenquery';
  20. my $config;
  21. my @uploaded_files;
  22.  
  23. our &POST     := HTTP::Request::Common.can('POST');
  24. our &basename := File::Basename.can('basename');
  25.  
  26. #-----------------------------------------------------------------------
  27. #       MAIN BODY
  28. #-----------------------------------------------------------------------
  29.  
  30.  
  31. my $VERSION = "Pugs $?PUGS_VERSION";
  32.  
  33. initialise();
  34.  
  35. @uploaded_files = ftp_upload_files(@*ARGS);
  36. pause_add_files(@uploaded_files) if @uploaded_files > 0;
  37. _verbose(int(@*ARGS), int(@*ARGS) == 1 ?? " file " !! " files ",
  38.          "uploaded successfully.\n");
  39.  
  40. exit 0;
  41.  
  42. #=======================================================================
  43. #
  44. # initialise()
  45. #
  46. # Create AppConfig instance, parse config file if there is one,
  47. # and command-line options.
  48. #
  49. #=======================================================================
  50. sub initialise () {
  51.     my $config_file;
  52.     my $HOME;
  53.     my $password;
  54.  
  55.  
  56.     ($PROGRAM = $*PROGRAM_NAME) ~~ s:P5[^.*/] = '';
  57.  
  58.     #-------------------------------------------------------------------
  59.     # Create an AppConfig::Std object, and define our interface
  60.     # The EXPAND flag on password tells AppConfig not to try and
  61.     # expand any embedded variables - eg if you have a $ sign
  62.     # in your password.
  63.     #-------------------------------------------------------------------
  64.     $HOME = %*ENV<HOME>;
  65.     $config_file = "$HOME/.pause";
  66.     $config = eval(q!
  67.         my $config = AppConfig::Std->new();
  68.         $config->define('user');
  69.         $config->define('directory', {ARGCOUNT => 1, ALIAS => 'dir'});
  70.         $config->define('password', { EXPAND   => 0 });
  71.         $config->define('mailto');
  72.         $config->define('ftp_gateway');
  73.         $config->define('ftp_proxy');
  74.         $config->define('http_proxy');
  75.         $config->define('non_interactive', { ALIAS => 'ni', ARGCOUNT => 0 });
  76.         $config;
  77.     !, :lang<perl5>);
  78.  
  79.     #-------------------------------------------------------------------
  80.     # Read the user's config file, if they have one,
  81.     # then parse the command-line.
  82.     #-------------------------------------------------------------------
  83.     if ($config_file ~~ :f)
  84.     {
  85.         $config.file($config_file) || exit 1;
  86.     }
  87.     $config.args(\@*ARGS)
  88.         || die "run \"$PROGRAM -help\" to see valid options\n";
  89.  
  90.     #-------------------------------------------------------------------
  91.     # Check we have the information we need
  92.     #-------------------------------------------------------------------
  93.  
  94.     die "No files specified for upload\n" unless @*ARGS > 0;
  95.  
  96.     die "No email address (mailto) specified\n" unless $config.mailto;
  97.     die "No PAUSE user specified\n"             unless $config.user;
  98.  
  99.     $config.verbose(1) if $config.debug && !$config.verbose;
  100.  
  101.     #-------------------------------------------------------------------
  102.     # Display banner at the start of the run
  103.     #-------------------------------------------------------------------
  104.     _verbose("$PROGRAM v$VERSION\n");
  105. }
  106.  
  107. #=======================================================================
  108. #
  109. # ftp_upload_files()
  110. #
  111. # upload the one or more files to PAUSE ftp server.
  112. # return a list of the files that were successfully uploaded.
  113. #
  114. #=======================================================================
  115. sub ftp_upload_files (*@files) {
  116.     my @uploaded = ();            # list of files actually uploaded
  117.     my $ftp;                      # Net::FTP instance
  118.     my @new_args;                 # arg list to pass to constructor
  119.     my ($user, $password);        # user and password for login method
  120.     my $file;
  121.  
  122.     _verbose("Using FTP to upload files to PAUSE\n");
  123.  
  124.     #-------------------------------------------------------------------
  125.     # Make the connection to the PAUSE ftp server:
  126.     # First we determine how we're going to make the connection ...
  127.     #-------------------------------------------------------------------
  128.     if $config.ftp_gateway {
  129.         _debug("  establishing connection via an FTP gateway\n");
  130.         @new_args = ($config.ftp_gateway);
  131.         ($user, $password) = ("ftp\@$SITE", $config.mailto);
  132.     }
  133.     else {
  134.         ($user, $password) = ('ftp', $config.mailto);
  135.         @new_args = ($SITE);
  136.         if $config.ftp_proxy {
  137.             _debug("  establishing connection via proxy",
  138.                      $config.ftp_proxy, "\n");
  139.             push(@new_args, Firewall => $config.ftp_proxy);
  140.         }
  141.         else {
  142.             _debug("  establishing connection\n");
  143.         }
  144.     }
  145.  
  146.     #-------------------------------------------------------------------
  147.     # ... and then we actually make the connection and log in
  148.     #-------------------------------------------------------------------
  149.     $ftp = Net::FTP.new([,] @new_args);
  150.     if (!$ftp) {
  151.         die "failed to connect to remote server: $!\n";
  152.     }
  153.  
  154.     if (!$ftp.login($user, $password)) {
  155.         $ftp.quit();
  156.         die "    failed to login as user 'ftp', password $password - ",
  157.             $ftp.message(), "[", $ftp.code(), "]\n";
  158.     }
  159.  
  160.     #-------------------------------------------------------------------
  161.     # Change to the right directory, and set binary mode
  162.     #-------------------------------------------------------------------
  163.     _debug("  changing to \"$UPLOAD_DIR\" directory...\n");
  164.     if (!$ftp.cwd($UPLOAD_DIR))
  165.     {
  166.         $ftp.quit();
  167.         die "failed to change directory to $UPLOAD_DIR!\n";
  168.     }
  169.  
  170.     _debug("  setting binary mode.\n");
  171.     unless $ftp.binary() {
  172.         $ftp.quit();
  173.         die "  failed to change type to 'binary' - ", $ftp.message(),
  174.             "[", $ftp.code(), "]\n";
  175.     }
  176.  
  177.     #-------------------------------------------------------------------
  178.     # Put the file(s)
  179.     #-------------------------------------------------------------------
  180.     for @files -> $file {
  181.  
  182.         _verbose("  uploading file \"$file\"\n");
  183.         if $ftp.put($file) {
  184.             push(@uploaded, $file);
  185.         }
  186.         else {
  187.             warn "failed to upload $file - ", $ftp.message(), "\n";
  188.             if (@files > 0 and !$config.non_interactive) {
  189.                 my $continue;
  190.  
  191.                 repeat {
  192.                     print "Do you want to continue? [y] ";
  193.                     $continue = $*IN.get;
  194.                     $continue = 'y' if $continue ~~ m:P5/^$/;
  195.                 } while $continue !~~ m:P5/^[ynYN]/;
  196.                 exit(0) if $continue ~~ m:P5/^[nN]/;
  197.             }
  198.         }
  199.     }
  200.  
  201.     #-------------------------------------------------------------------
  202.     # Close the connection with the server.
  203.     #-------------------------------------------------------------------
  204.     _debug("  closing connection with FTP server\n");
  205.     $ftp.quit;
  206.  
  207.     return @uploaded;
  208. }
  209.  
  210. #=======================================================================
  211. #
  212. # pause_add_files()
  213. #
  214. # make an HTTP request to the add_uri form
  215. #
  216. #=======================================================================
  217. sub pause_add_files (*@files) {
  218.     my $file;
  219.     my $basename;
  220.     my $request;
  221.     my $response;
  222.     my $agent;
  223.     my $argref;
  224.  
  225.  
  226.     _verbose("registering upload with PAUSE web server\n");
  227.  
  228.     #-------------------------------------------------------------------
  229.     # Create the agent we'll use to make the web requests
  230.     #-------------------------------------------------------------------
  231.     _debug("  creating instance of LWP::UserAgent\n");
  232.     $agent = LWP::UserAgent.new() orelse die "Failed to create UserAgent: $!\n";
  233.     $agent.agent("$PROGRAM/$VERSION");
  234.     $agent.from($config.mailto);
  235.     if (defined $config.http_proxy)
  236.     {
  237.         $agent.proxy(['http'], $config.http_proxy);
  238.     }
  239.  
  240.     #-------------------------------------------------------------------
  241.     # Post an upload message to the PAUSE web site for each file
  242.     #-------------------------------------------------------------------
  243.     for @files -> $file {
  244.         $basename = basename($file);
  245.  
  246.         #---------------------------------------------------------------
  247.         # Create the request to add the file
  248.         #---------------------------------------------------------------
  249.         $argref = {
  250.                     'HIDDENNAME'                    , "$config.user()",
  251.                     'pause99_add_uri_upload'        , "$basename",
  252.                     'SUBMIT_pause99_add_uri_upload' , " Upload the checked file "
  253.                    };
  254.         if ($config.directory)
  255.         {
  256.             $argref.{'pause99_add_uri_subdirtext'} = $config.directory;
  257.         }
  258.  
  259.         $request = POST($PAUSE_ADD_URI, $argref);
  260.         $request.authorization_basic("$config.user()", "$config.password()");
  261.  
  262.         _debug("----- REQUEST BEGIN -----\n",
  263.                $request.as_string(),
  264.                "----- REQUEST END -------\n");
  265.  
  266.         #---------------------------------------------------------------
  267.         # Make the request to the PAUSE web server
  268.         #---------------------------------------------------------------
  269.         _verbose("  POSTing upload for $file\n");
  270.         $response = $agent.request($request);
  271.  
  272.         #---------------------------------------------------------------
  273.         # So, how'd we do?
  274.         #---------------------------------------------------------------
  275.         if (not defined $response)
  276.         {
  277.             die "Request completely failed - we got undef back: $!\n";
  278.         }
  279.         if ($response.is_error)
  280.         {
  281.             if ($response.code == 404)
  282.             {
  283.                 die "PAUSE's CGI for handling messages seems to have moved!\n",
  284.                     "(HTTP response code of 404 from the PAUSE web server)\n",
  285.                         "It used to be:\n\n\t", $PAUSE_ADD_URI, "\n\n",
  286.                             "Please inform the maintainer of this script\n";
  287.             }
  288.             else
  289.             {
  290.                 die "request failed\n  Error code: ", $response.code,
  291.                     "\n  Message: ", $response.message, "\n";
  292.             }
  293.         }
  294.         else
  295.         {
  296.             _debug("Looks OK!\n",
  297.                    "----- RESPONSE BEGIN -----\n",
  298.                    $response.as_string(),
  299.                    "----- RESPONSE END -------\n");
  300.             _verbose("    PAUSE add message sent ok [",
  301.                      $response.code, "]\n");
  302.         }
  303.     }
  304. }
  305.  
  306.  
  307. #=======================================================================
  308. #
  309. # _verbose()
  310. #
  311. # displays the message strings passed if in verbose mode.
  312. #
  313. #=======================================================================
  314. sub _verbose
  315. {
  316.     return unless $config.verbose;
  317.     print join('', @_);
  318. }
  319.  
  320.  
  321. #=======================================================================
  322. #
  323. # _debug()
  324. #
  325. # displays the message strings passed if in debug mode.
  326. #
  327. #=======================================================================
  328. sub _debug
  329. {
  330.     return unless $config.debug;
  331.     print join('', @_);
  332. }
  333.  
  334.  
  335. __END__
  336.  
  337. #-----------------------------------------------------------------------
  338.  
Compilation error #stdin compilation error #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
compilation info 
===SORRY!===
Method 'value' not found for invocant of class 'PAST;Var'
stdout
copy 
Standard output is empty
https://ideone.com/zWi8pN
language:
Perl (perl 2018.12)
created:
11 years ago
visibility:
secret

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!