view release on metacpan or  search on metacpan

script/cpan2aur  view on Meta::CPAN

    return;
}

## AUR PACKAGE UPLOAD
##############################################################################

# Loads the last login username & session ID used.
sub _load_last_login
{
    return () unless ( -f $CFGPATH );

    die q{Please 'chmod 600 ~/.cpan2aur', it is not readable}
        unless ( -r $CFGPATH );

    my ($user, $sid);
    open my $cfgfile, q{<}, $CFGPATH or die "open $CFGPATH: $!";
    while (<$cfgfile>) {
        chomp;
        ($user, $sid) = split /:/;
        last; # only want first line
    }
    close $cfgfile;

    return () unless ( $user && $sid && $sid =~ /\A[a-fA-F0-9]+\z/ );

    # If the user specified a --name flag, make sure it matches the cached...
    return () if ( $NAME && ( lc $user ne lc $NAME ));

    chomp $sid;
    return ($user, $sid);
}

# Save the username & session ID for later.
sub _save_last_login
{
    my ($username, $sid) = @_;

    # Set umask to keep this file private...
    my $oldmask = umask 0077;
    $username   = lc $username;

    open my $cfgfile, '>', $CFGPATH or die "open $CFGPATH: $!";
    print $cfgfile "$username:$sid\n";
    close $cfgfile or die "close $CFGPATH: $!";

    umask $oldmask;
    return;
}

# Login to AUR to get a fresh session ID cookie.
# Params:  $ua - LWP::UserAgent object
#                (this gets a new cookie jar with a new session cookie)
#          $username - Username to login AUR.
#          $password - Password to login AUR.
# Returns: a new session ID
sub _new_login_sid
{
    my ($ua, $username, $passwd) = @_;

    # Get a fresh session ID cookie...
    $ua->cookie_jar( HTTP::Cookies->new() );
    my $resp = $ua->post( AUR_LOGIN_URI,
                          [ user        => $username,
                            passwd      => $passwd,
                            remember_me => 1, # probably not needed
                           ] );

    # Check for problems...
    error( 'Bad username or password' )
        if ( $resp->content =~ /$BAD_LOGIN_MSG/ );

    error( "AUR login expected status code 302.
Got status: ", $resp->status_line )
        if !( $resp->code == 302  && !$resp->is_success );

    return _scan_aursid($ua);
}

# Params: $sid - Session ID to login the AUR with.
# Returns: A new HTTP::Cookies object with an AUR session ID cookie.
sub _mk_session_cookie
{
    my ($sid) = @_;

    my %cookies = ( COOKIE_NAME() => $sid,
                    AURLANG       => 'en', );

    my $cookie_obj = HTTP::Cookies->new();
    for my $name ( keys %cookies ) {
        $cookie_obj->set_cookie( q{}, $name, $cookies{$name},
                                 q{/}, 'aur.archlinux.org' );
    }

    return $cookie_obj;
}

sub _scan_aursid
{
    my ($ua) = @_;
    my $sid;
    $ua->cookie_jar->scan(sub { $sid = $_[2] if ($_[1] eq 'AURSID') });
    unless($sid){
        Carp::confess 'AURSID cookie is missing';
    }
    return $sid;
}

# Params: $ua - LWP::UserAgent object, should have SID cookie in it.
#         $pkg_path - Path of source package file to upload.
sub _post_upload
{
    my ($ua, $pkg_path) = @_;

    my $sid = _scan_aursid($ua);
    my $resp = $ua->post( AUR_UPLOAD_URI,
                          'Content-Type' => 'form-data',
                          'Content'      => [ category  => CAT_LIB(),
                                              submit    => 'Upload',
                                              pkgsubmit => 1,
                                              token     => $sid,
                                              pfile     => [ $pkg_path ],
                                             ] );

    # We get a 302 Moved HTTP status code on success and when uploading a package
    # that we own, if the package file is older and ignored...
    return if ( $resp->code() == 302 );

    error( "When uploading file, got http status ", $resp->status_line )
        unless ( $resp->is_success );

    die $NEED_LOGIN_ERR      if ( $resp->content =~ /$NEED_LOGIN_MSG/ );
    error( $PKG_EXISTS_ERR ) if ( $resp->content =~ /$PKG_EXISTS_MSG/ );

    return;
}

# Make sure the libwww modules we need are loaded, if not offer to install
# as a package.
sub _load_web_modules
{
    _req_or_install( 'perl-libwww',
                     'LWP::UserAgent', 'HTTP::Cookies' );
    _req_or_install( 'perl-lwp-protocol-https',
                     'LWP::Protocol::https');
}

sub _req
{
    my $loaded = 1;
    for my $mod ( @_ ) {
        eval "require $mod; 1";
        if ( $@ ) { $loaded = 0; last; }
    };
    return $loaded;
}

sub _req_or_install
{
    my ($package, @modules) = @_;

    return if _req( @modules );

    my $answer = prompt_yn( <<"END_PROMPT" => 'yes' );
You need the $package package installed to upload to the AUR.
Do you want to install it now?
END_PROMPT

    exit NEEDLWP_ERRCODE unless ( $answer );

    status "Installing $package for uploads to the AUR...";
    my $modobj = find_module( $modules[0] );
    $modobj->install( target => 'install', prereq_target => 'install',
                      format => 'CPANPLUS::Dist::Arch' );

    # Try again after we install it!
    my $list = join ', ', @modules;
    error( "Unable to load $list" ) unless _req( @modules );
    return;
}

# Upload a package file to the AUR, handle all user interaction, loading old
# session ID's from our saved file, etc logic.
sub upload_pkgfile
{
    my ($pkg_path) = @_;

    _load_web_modules();

    status "Uploading $pkg_path to the AUR...";

    my ($username, $sid) = _load_last_login();
    $username ||= $NAME || prompt_ask( 'Username:' );

    if ( ! defined $username ) {
        print "\n";
        error( 'Unable to read username in uninteractive mode.' );
    }

    my $ua = LWP::UserAgent->new();
    # First try to reuse an old Session ID...
    if ( $sid ) {
        substatus "Sending package as $username...";