—
—

              
#!/apps/perl5/bin/perl -w
HideShow 72 lines of Pod
=head1 NAME
cpan-upload - upload one or more files to CPAN, using PAUSE
=head1 SYNOPSIS
   cpan-upload [options] file1 .. fileN
=head1 DESCRIPTION
B<cpan-upload> is a script which automates the process of uploading
a file to CPAN using PAUSE, the Perl Authors Upload SErver.
Before using this script you must register with PAUSE,
to get a username and password.
If you are a regular uploader to PAUSE, you'll probably want to
create a C<.pause> configuration file. If not, you can probably
just use the command-line options, as described below.
If everything went OK, you'll get a mail message from the PAUSE monitor.
=head1 OPTIONS
=over 4
=item -user <string>
Your PAUSE username which was registered with PAUSE.
=item -password <string>
The password for your PAUSE username.
=item -ftp_firewall <host>
Specifies the name of the host which has your ftp firewall gateway,
if you're behind a firewall. 
=item -http_proxy <URL>
Specifies the URL for a proxy to use when making HTTP requests.
=item -mailto <email>
Your email address, to include the HTTP request header.
This is also used as the password for the ftp upload to PAUSE.
=item -help
Displays a short help message.
=item -doc
Display the full documentation for B<orange>.
=item -verbose
Turns on verbose information as the script runs.
=item -debug
Turns on debugging information. Useful mainly for the developer,
it displays the HTTP request and response.
=item -version
Display the version number of the B<cpan-upload> script.
=back
=cut
use strict;
use vars qw($VERSION);
use App::Config;
use Net::FTP;
use HTTP::Request::Common qw(POST);
use LWP::UserAgent;
use HTTP::Response;
use HTTP::Status;
use File::Basename;
use Pod::Usage;
$VERSION    = '1.3';
#-----------------------------------------------------------------------
#       CONFIGURATION CONSTANTS
#-----------------------------------------------------------------------
my $PROGRAM    = 'CPAN Upload Script';
my $SITE       = 'pause.kbx.de';
my $UPLOAD_DIR = 'incoming';
use constant PAUSE_ADD_URI => 'http://pause.kbx.de/perl/user/add_uri';
my $agent;
my $config;
my $file;
#-----------------------------------------------------------------------
#       MAIN BODY
#-----------------------------------------------------------------------
initialise();
ftp_upload_files(@ARGV);
print "  Adding files via PAUSE web server...\n";
foreach $file (@ARGV)
{
    pause_add_file($file);
}
exit 0;
sub initialise
{
    my $config_file;
    my $HOME;
    #-------------------------------------------------------------------
    # Turn off buffering on STDOUT
    #-------------------------------------------------------------------
    $| = 1;
    #-------------------------------------------------------------------
    # Create an App::Config object, and define our interface
    #-------------------------------------------------------------------
    $HOME = $ENV{'HOME'} || (getpwuid($<))[7];
    $config_file = "$HOME/.pause";
    if (-e $config_file && ((stat($config_file))[2] & 36) != 0)
    {
        die "$PROGRAM: your config file $config_file is readable by others!\n";
    }
    $config = new App::Config({ GLOBAL => { CMDARG => 1, ARGCOUNT => 1}});
    $config->define('user');
    $config->define('password', { EXPAND   => 0 });
    $config->define('mailto');
    $config->define('ftp_firewall');
    $config->define('http_proxy');
    $config->define('help',    { ARGCOUNT => 0 } );
    $config->define('doc',     { ARGCOUNT => 0 });
    $config->define('debug',   { ARGCOUNT => 0 } );
    $config->define('verbose', { ARGCOUNT => 0 } );
    $config->define('version', { ARGCOUNT => 0 } );
    #-------------------------------------------------------------------
    # Read the user's config file, if they have one,
    # then parse the command-line.
    #-------------------------------------------------------------------
    if (-f $config_file)
    {
        $config->cfg_file($config_file) || exit 1;
    }
    $config->cmd_line(\@ARGV) || exit 1;
    #-------------------------------------------------------------------
    # Did they give one of the informational switches?
    #-------------------------------------------------------------------
    pod2usage(verbose => 2, exitval => 0) if $config->doc();
    pod2usage(verbose => 1, exitval => 0) if $config->help();
    show_version()                        if $config->version;
    #-------------------------------------------------------------------
    # Check we have the information we need
    #-------------------------------------------------------------------
    die "No email address (mailto) specified\n" unless $config->mailto;
    die "No PAUSE user specified\n"             unless $config->user;
    die "No password specified\n"               unless $config->password;
    #-------------------------------------------------------------------
    # Display banner at the start of the run
    #-------------------------------------------------------------------
    print "$PROGRAM v$VERSION\n";
}
#=======================================================================
# ftp_upload_files() - upload the one or more files to PAUSE ftp server
#=======================================================================
sub ftp_upload_files
{
    my @files = @_;
    my $ftp;
    my $file;
    print "\nFTP UPLOAD\n\n";
    print "    opening FTP connection to $SITE . . .";
    if ($config->ftp_firewall)
    {
        verbose("\n\t(using firewall ".$config->ftp_firewall.")");
        $ftp = Net::FTP->new($SITE, 'Firewall' => $config->ftp_firewall);
    }
    else
    {
        $ftp = Net::FTP->new($SITE);
    }
    if (not defined $ftp)
    {
        die "Failed to create FTP object: $!\n";
    }
    $ftp->login('ftp', $config->mailto);
    print "\n";
    verbose("    changing to \"$UPLOAD_DIR\" directory...");
    $ftp->cwd($UPLOAD_DIR);
    verbose("    setting binary mode.");
    $ftp->binary() || do
    {
        $ftp->quit();
        die "    failed to change type to 'binary'\n";
    };
    foreach $file (@files)
    {
        print "  uploading file \"$file\" . . .";
        $ftp->put($file) || do
        {
            warn "\n    failed to upload.\n";
            next;
        };
        print "\n";
    }
    $ftp->quit;
    print "\n";
}
#=======================================================================
# pause_add_file() - make an HTTP request to the add_uri form
#=======================================================================
sub pause_add_file
{
    my $file = shift;
    my $basename = basename($file);
    my $request;
    my $response;
    my $formbody;
    #-------------------------------------------------------------------
    # Create the agent we'll use to make the web requests
    #-------------------------------------------------------------------
    if (not defined $agent)
    {
        $agent = eval { new LWP::UserAgent };
        die "Failed to create UserAgent: $@\n" if ($@ || (not defined $agent));
        $agent->agent("CpanUpload/$VERSION");
        $agent->from($config->mailto) if $config->mailto;
        if (defined $config->http_proxy)
        {
            $agent->proxy(['http'], $config->http_proxy);
        }
    }
    #-------------------------------------------------------------------
    # Create the request to add the file
    #-------------------------------------------------------------------
    $request = POST(PAUSE_ADD_URI, { HIDDENNAME => $config->user(),
                                     upload     => $basename });
    $request->authorization_basic($config->user, $config->password);
    if ($config->debug)
    {
        print "----- REQUEST BEGIN -----\n";
        print $request->as_string();
        print "----- REQUEST END -------\n";
    }
    #-------------------------------------------------------------------
    # Make the request to the PAUSE web server
    #-------------------------------------------------------------------
    $response = $agent->request($request);
    #-------------------------------------------------------------------
    # So, how'd we do?
    #-------------------------------------------------------------------
    if (not defined $response)
    {
        die "Request completely failed - we got undef back: $!\n";
    }
    if ($response->is_error)
    {
        if ($response->code == RC_NOT_FOUND)
        {
            die "PAUSE's CGI for handling messages seems to have moved!\n",
            "(HTTP response code of 404 from the PAUSE web server)\n",
            "It used to be:\n\n\t", PAUSE_ADD_URI, "\n\n",
            "Please inform the maintainer of this script\n";
        }
        else
        {
            die "request failed\n  Error code: ", $response->code,
                "\n  Message: ", $response->message, "\n";
        }
    }
    else
    {
        if ($config->debug)
        {
            print "\nLooks OK!\n";
            print "----- RESPONSE BEGIN -----\n";
            print $response->as_string();
            print "----- RESPONSE END -------\n";
        }
        else
        {
            print "\tPAUSE add message sent ok [", $response->code, "]\n";
        }
    }
}
#=======================================================================
# show_version() - show the version of script (in response to -version)
#=======================================================================
sub show_version
{
    print STDERR "$VERSION\n";
    exit 0;
}
#=======================================================================
# verbose() - displays the message strings passed if in verbose mode
#=======================================================================
sub verbose
{
    return unless $config->verbose;
    print join("\n", @_), "\n";
}
exit 0;
#-----------------------------------------------------------------------
HideShow 113 lines of Pod
=head1 CONFIGURATION FILE
You can provide the configuration information needed
via a .pause file in your home directory.
If you upload files at all regularly you will want to
set up one of these.
=over 4
=item user <username>
This is used to specify your PAUSE username.
This just saves you from typing it every time you run the script.
=item password <password>
This is used to specify your PAUSE password.
=item ftp_firewall <HOST>
Specifies the hostname of your ftp gateway used to get through
a firewall. For example:
    ftp_proxy = ftp-gw
=item http_proxy <URL>
The URL for the proxy to use when making HTTP requests to the PAUSE
web server. For example:
    http_proxy = http://proxy/
=item mailto <EMAIL>
Specifies the email address which is passed in the header of
the HTTP request, and as the password for the anonymous ftp upload.
You must provide this.
=back
The following is a sample .pause file:
    # example .pause for user neilb
    # the user is your registered PAUSE username
    user NEILB
    password thisisnotmyrealpassword
    mailto        = neilb@cre.canon.co.uk
    ftp_firewall  = ftp-gw
    http_proxy    = http://proxy.cre.canon.co.uk/
Note that your .pause must not be readable by others,
since it can contain your PAUSE password. The b<cpan-upload> script
refuses to run if your config file can be read by others.
=cut
=head1 SEE ALSO
=over 4
=item http://www.cre.canon.co.uk/perl/
Our web page about Canon Research Europe and Perl.
=item App::Config
Andy Wardley's module for unifying command-line switches and
cofiguration files into the notion of configuration variables.
B<orange> requires version 1.07 of the module,
which is available from CPAN:
    http://www.perl.com/CPAN/modules/by-module/App/
=item Net::FTP
Graham Barr's studly module for doing that crazy ftp thang.
=item libwww-perl5
The LWP distribution which provides the modules used by this script
to talk to the PAUSE web server. You can get the latest version from:
    http://www.perl.com/CPAN/modules/by-module/LWP/
=item Pod::Usage
Brad Appleton's module for extracting usage information out
of a file's pod. This is used for the B<-doc> and B<-help> switches.
Available from CPAN:
    http://www.perl.com/CPAN/modules/by-module/Pod/
=back
=head1 VERSION
$Id: cpan-upload,v 1.4 1998/07/24 11:19:00 neilb Exp $
=head1 AUTHOR
Neil Bowers E<lt>neilb@cre.canon.co.ukE<gt>
=head1 COPYRIGHT
Copyright (c) 1998 Canon Research Centre Europe. All rights reserved.
This script is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut