#!/usr/bin/perl -w
#
# cpan-upload-http - upload one or more file to CPAN (via PAUSE)
#

use strict;
use vars qw($VERSION);

use AppConfig::Std;
use HTTP::Request::Common qw(POST);
use LWP::UserAgent;
use HTTP::Status;
use File::Basename;

$VERSION = "2.4";

#-----------------------------------------------------------------------
#       Configuration constants and globals
#-----------------------------------------------------------------------
my $PROGRAM;
my $SITE          = 'pause.perl.org';
my $PAUSE_ADD_URI = 'http://pause.perl.org/pause/authenquery';
my $config;

#-----------------------------------------------------------------------
#       MAIN BODY
#-----------------------------------------------------------------------

initialise();

pause_add_files(@ARGV);
_verbose(int(@ARGV), int(@ARGV) == 1 ? " file " : " files ",
         "uploaded successfully.\n");

exit 0;

#=======================================================================
#
# initialise()
#
# Create AppConfig instance, parse config file if there is one,
# and command-line options.
#
#=======================================================================
sub initialise
{
    my $config_file;
    my $HOME;
    my $password;


    #-------------------------------------------------------------------
    # Turn off buffering on STDOUT
    #-------------------------------------------------------------------
    $| = 1;
    ($PROGRAM = $0) =~ s!^.*/!!;

    #-------------------------------------------------------------------
    # Create an AppConfig::Std object, and define our interface
    # The EXPAND flag on password tells AppConfig not to try and
    # expand any embedded variables - eg if you have a $ sign
    # in your password.
    #-------------------------------------------------------------------
    $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 = AppConfig::Std->new();
    $config->define('user');
    $config->define('directory', {ARGCOUNT => 1, ALIAS => 'dir'});
    $config->define('password', { EXPAND   => 0 });
    $config->define('mailto');
    $config->define('http_proxy');
    $config->define('non_interactive', { ALIAS => 'ni', ARGCOUNT => 0 });

    #-------------------------------------------------------------------
    # Read the user's config file, if they have one,
    # then parse the command-line.
    #-------------------------------------------------------------------
    if (-f $config_file)
    {
        $config->file($config_file) || exit 1;
    }
    $config->args(\@ARGV)
        || die "run \"$PROGRAM -help\" to see valid options\n";

    #-------------------------------------------------------------------
    # Check we have the information we need
    #-------------------------------------------------------------------

    die "No files specified for upload\n" unless @ARGV > 0;

    die "No email address (mailto) specified\n" unless $config->mailto;
    die "No PAUSE user specified\n"             unless $config->user;
    if (not $config->password)
    {
        if ($config->non_interactive)
        {
            die "No password specified\n";
        }
        else
        {
            require Term::ReadKey;
            $| = 1;
            print "Password: ";
            Term::ReadKey::ReadMode('noecho');
            chop($password = <STDIN>);
            Term::ReadKey::ReadMode('restore');
            $config->set('password' => $password);
            print "\n";
        }
    }

    $config->verbose(1) if $config->debug && !$config->verbose;

    #-------------------------------------------------------------------
    # Display banner at the start of the run
    #-------------------------------------------------------------------
    _verbose("$PROGRAM v$VERSION\n");
}

#=======================================================================
#
# pause_add_files()
#
# make an HTTP request to the add_uri form
#
#=======================================================================
sub pause_add_files
{
    my @files = @_;

    my $file;
    my $basename;
    my $request;
    my $response;
    my $agent;
    my $argref;


    _verbose("registering upload with PAUSE web server\n");

    #-------------------------------------------------------------------
    # Create the agent we'll use to make the web requests
    #-------------------------------------------------------------------
    _debug("  creating instance of LWP::UserAgent\n");
    $agent = LWP::UserAgent->new() || die "Failed to create UserAgent: $!\n";
    $agent->agent("$PROGRAM/$VERSION");
    $agent->from($config->mailto);
    if (defined $config->http_proxy)
    {
        $agent->proxy(['http'], $config->http_proxy);
    }

    #-------------------------------------------------------------------
    # Post an upload message to the PAUSE web site for each file
    #-------------------------------------------------------------------
    foreach $file (@files)
    {
        $basename = basename($file);

        open(my $fh, $file) or die "Failed to open $file: $!";
        my $contents = do { local $/; <$fh> };
        close($fh);

        #---------------------------------------------------------------
        # Create the request to add the file
        #---------------------------------------------------------------
        $argref = {
                    HIDDENNAME                    => $config->user(),
                    CAN_MULTIPART                 => 1,
                    pause99_add_uri_upload        => $basename,
                    SUBMIT_pause99_add_uri_httpupload => " Upload this file from my disk ",
                    pause99_add_uri_uri           => "",
                    pause99_add_uri_httpupload    => [ $file ],
                   };
        if ($config->directory)
        {
            $argref->{'pause99_add_uri_subdirtext'} = $config->directory;
        }

        $request = POST($PAUSE_ADD_URI,
                        Content_Type => 'form-data',
                        Content      => $argref);
        $request->authorization_basic($config->user, $config->password);

        _debug("----- REQUEST BEGIN -----\n",
               $request->as_string(),
               "----- REQUEST END -------\n");

        #---------------------------------------------------------------
        # Make the request to the PAUSE web server
        #---------------------------------------------------------------
        _verbose("  POSTing upload for $file\n");
        $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
        {
            _debug("Looks OK!\n",
                   "----- RESPONSE BEGIN -----\n",
                   $response->as_string(),
                   "----- RESPONSE END -------\n");
            _verbose("    PAUSE add message sent ok [",
                     $response->code, "]\n");
        }
    }
}


#=======================================================================
#
# _verbose()
#
# displays the message strings passed if in verbose mode.
#
#=======================================================================
sub _verbose
{
    return unless $config->verbose;
    print join('', @_);
}


#=======================================================================
#
# _debug()
#
# displays the message strings passed if in debug mode.
#
#=======================================================================
sub _debug
{
    return unless $config->debug;
    print join('', @_);
}


__END__

#-----------------------------------------------------------------------

=head1 NAME

cpan-upload-http - upload one or more files to CPAN, using PAUSE

=head1 SYNOPSIS

B<cpan-upload-http> [OPTIONS] I<file1> .. I<fileN>

=head1 DESCRIPTION

B<cpan-upload-http> is a script which automates the process of uploading
a file to CPAN using PAUSE, the Perl Authors Upload Server.
For example, to upload a recent version of the Net::Dict module
I ran:

    % cpan-upload-http -verbose Net-Dict-1.07.tar.gz

If everything went OK, you'll get two mail messages from the PAUSE monitor:
one to acknowledge the upload,
and one to let you know if your upload made it through to CPAN.

Given one or more files to upload, cpan-upload-http carries
out the following two steps:

=over 4

=item *

HTTP file upload and register the module by POSTing to the PAUSE web server.

=back

This is just one of the ways you can upload something to PAUSE.
See the PAUSE FAQ for details (referenced in SEE ALSO section below).

Before using cpan-upload-http 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,
as described in L<"CONFIGURATION FILE"> below.
If not, you can just use the command-line options,
as described in L<"OPTIONS"> below.
If you don't provide your password (via configuration file or
command-line), then you will be prompted for it.
Echo'ing will be turned off while you type your password.
This behaviour can be suppressed with the B<-non_interactive>
option, described below.

=head1 OPTIONS

=over 4

=item -user <string>

Your PAUSE username (which you previously registered with PAUSE).

=item -password <string>

The password for your PAUSE username.

=item -directory <string> | -dir <string>

A subdirectory in your CPAN area where the file should be uploaded to.

=item -mailto <email>

Your email address to include the HTTP request header.

=item -http_proxy <URL>

Specifies the URL for a proxy to use when making HTTP requests.

=item -non_interactive | -ni

cpan-upload-http should not prompt for any missing information (eg password),
it should just warn or die, as appropriate.

=item -help

Displays a short help message with the OPTIONS section
from the cpan-upload-http documentation.

=item -doc

Display the full documentation for B<cpan-upload-http>.

=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-http> script.

=back

=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 B<user> I<username>

This is used to specify your PAUSE username.
This just saves you from typing it every time you run the script.

=item B<password> I<password>

This is used to specify your PAUSE password.

=item B<directory> I<path>

Specify a subdirectory in your CPAN area.

=item B<http_proxy> I<URL>

The URL for the proxy to use when making HTTP requests to the PAUSE
web server. For example:

    http_proxy = http://proxy/

=item B<mailto> I<EMAIL>

Specifies the email address which is passed in the header of
the HTTP request.
You must provide this.

=item B<non_interactive>

Specifies that cpan-upload-http should never prompt the user (eg for password),
but should take a default action.

=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      = neil@bowers.com
    http_proxy  = http://proxy.cre.canon.co.uk/

    non_interactive

Note that your .pause must not be readable by others,
since it can contain your PAUSE password. The B<cpan-upload-http> script
refuses to run if your config file can be read by others.

=cut


=head1 POSSIBLE TODO ITEMS

Also, let me know if you ever have occasion to wish that the features below
had been implemented. I probably won't do them unless someone
would like to see them in.

I'd be happy to hear any more suggestions.

=over 4

=item *

As with the password, prompt for PAUSE username and email address
if not provided (by .pause file or on the command-line).

=item *

Add configuration options for specifying the URI we POST to.
This would let you deal with any changes without requiring a new release.
These aren't likely to change on any regular basis, so seem gratuitous.

=back

=head1 SEE ALSO

=over 4

=item www.cpan.org

The home page for the Comprehensive Perl Archive Network.

=item PAUSE

The Perl Authors Upload SErver. The PAUSE FAQ can be seen on CPAN:

    http://www.cpan.org/modules/04pause.html

=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.cpan.org/modules/by-module/LWP/

=item AppConfig::Std

The module used to handle command-line options and the configuration file.

    http://www.cpan.org/authors/id/NEILB/

This is actually a subclass of C<AppConfig>, which you'll also need.

    http://www.cpan.org/authors/id/ABW/

=item Term::ReadKey

The module used to turn off echo'ing if we prompt the user
for a PAUSE password.

=back

=head1 VERSION

$Revision: 2.2 $

=head1 SCRIPT CATEGORIES

CPAN

=head1 PREREQUISITES

AppConfig::Std
HTTP::Request::Common
LWP::UserAgent
HTTP::Status
File::Basename
Term::ReadKey

=head1 AUTHOR

Neil Bowers E<lt>neil@bowers.comE<gt>

Brad Fitzpatrick E<lt>brad@danga.comE<gt> -- HTTP upload support, FTP removal.

=head1 COPYRIGHT

Copyright (c) 2001-2002 Neil Bowers.

Copyright (c) 1998-2001 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