# cpan-upload - upload one or more file to CPAN (via PAUSE)
#
# $Id: cpan-upload,v 2.2 2002/07/02 21:44:10 neilb Exp $
#

use perl5:AppConfig::Std;
use perl5:Net::FTP;
use perl5:HTTP::Request::Common;
use perl5:LWP::UserAgent;
use perl5:HTTP::Status;
use perl5:File::Basename;

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

our &POST     := HTTP::Request::Common.can('POST');
our &basename := File::Basename.can('basename');

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


my $VERSION = "Pugs $?PUGS_VERSION";

initialise();

@uploaded_files = ftp_upload_files(@*ARGS);
pause_add_files(@uploaded_files) if @uploaded_files > 0;
_verbose(int(@*ARGS), int(@*ARGS) == 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;


    ($PROGRAM = $*PROGRAM_NAME) ~~ s:P5{^.*/}{};

    #-------------------------------------------------------------------
    # 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>;
    $config_file = "$HOME/.pause";
    $config = eval(q!
        my $config = AppConfig::Std->new();
        $config->define('user');
        $config->define('directory', {ARGCOUNT => 1, ALIAS => 'dir'});
        $config->define('password', { EXPAND   => 0 });
        $config->define('mailto');
        $config->define('ftp_gateway');
        $config->define('ftp_proxy');
        $config->define('http_proxy');
        $config->define('non_interactive', { ALIAS => 'ni', ARGCOUNT => 0 });
        $config;
    !, :lang<perl5>);

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

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

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

    die "No email address (mailto) specified\n" unless $config.mailto;
    die "No PAUSE user specified\n"             unless $config.user;

    $config.verbose(1) if $config.debug && !$config.verbose;

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

#=======================================================================
#
# ftp_upload_files()
#
# upload the one or more files to PAUSE ftp server.
# return a list of the files that were successfully uploaded.
#
#=======================================================================
sub ftp_upload_files (*@files) {
    my @uploaded = ();            # list of files actually uploaded
    my $ftp;                      # Net::FTP instance
    my @new_args;                 # arg list to pass to constructor
    my ($user, $password);        # user and password for login method
    my $file;

    _verbose("Using FTP to upload files to PAUSE\n");

    #-------------------------------------------------------------------
    # Make the connection to the PAUSE ftp server:
    # First we determine how we're going to make the connection ...
    #-------------------------------------------------------------------
    if $config.ftp_gateway {
        _debug("  establishing connection via an FTP gateway\n");
        @new_args = ($config.ftp_gateway);
        ($user, $password) = ("ftp\@$SITE", $config.mailto);
    }
    else {
        ($user, $password) = ('ftp', $config.mailto);
        @new_args = ($SITE);
        if $config.ftp_proxy {
            _debug("  establishing connection via proxy",
                     $config.ftp_proxy, "\n");
            push(@new_args, Firewall => $config.ftp_proxy);
        }
        else {
            _debug("  establishing connection\n");
        }
    }

    #-------------------------------------------------------------------
    # ... and then we actually make the connection and log in
    #-------------------------------------------------------------------
    $ftp = Net::FTP.new([,] @new_args);
    if (!$ftp) {
        die "failed to connect to remote server: $!\n";
    }

    if (!$ftp.login($user, $password)) {
        $ftp.quit();
        die "    failed to login as user 'ftp', password $password - ",
            $ftp.message(), "[", $ftp.code(), "]\n";
    }

    #-------------------------------------------------------------------
    # Change to the right directory, and set binary mode
    #-------------------------------------------------------------------
    _debug("  changing to \"$UPLOAD_DIR\" directory...\n");
    if (!$ftp.cwd($UPLOAD_DIR))
    {
        $ftp.quit();
        die "failed to change directory to $UPLOAD_DIR!\n";
    }

    _debug("  setting binary mode.\n");
    unless $ftp.binary() {
        $ftp.quit();
        die "  failed to change type to 'binary' - ", $ftp.message(),
            "[", $ftp.code(), "]\n";
    }

    #-------------------------------------------------------------------
    # Put the file(s)
    #-------------------------------------------------------------------
    for @files -> $file {

        _verbose("  uploading file \"$file\"\n");
        if $ftp.put($file) {
            push(@uploaded, $file);
        }
        else {
            warn "failed to upload $file - ", $ftp.message(), "\n";
            if (@files > 0 and !$config.non_interactive) {
                my $continue;

                repeat {
                    print "Do you want to continue? [y] ";
                    $continue = =$*IN;
                    $continue = 'y' if $continue ~~ m:P5/^$/;
                } while $continue !~~ m:P5/^[ynYN]/;
                exit(0) if $continue ~~ m:P5/^[nN]/;
            }
        }
    }

    #-------------------------------------------------------------------
    # Close the connection with the server.
    #-------------------------------------------------------------------
    _debug("  closing connection with FTP server\n");
    $ftp.quit;

    return @uploaded;
}

#=======================================================================
#
# pause_add_files()
#
# make an HTTP request to the add_uri form
#
#=======================================================================
sub pause_add_files (*@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() orelse 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
    #-------------------------------------------------------------------
    for @files -> $file {
        $basename = basename($file);

        #---------------------------------------------------------------
        # Create the request to add the file
        #---------------------------------------------------------------
        $argref = {
                    'HIDDENNAME'                    , "$config.user()",
                    'pause99_add_uri_upload'        , "$basename",
                    'SUBMIT_pause99_add_uri_upload' , " Upload the checked file "
                   };
        if ($config.directory)
        {
            $argref.{'pause99_add_uri_subdirtext'} = $config.directory;
        }

        $request = POST($PAUSE_ADD_URI, $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 == 404)
            {
                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__

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