File Coverage

blib/lib/Module/Release/WebUpload/Mojo.pm
Criterion Covered Total %
statement 20 43 46.5
branch 0 8 0.0
condition n/a
subroutine 7 11 63.6
pod 3 4 75.0
total 30 66 45.4


line stmt bran cond sub pod time code
1 1     1   1086 use v5.16;
  1         4  
2              
3             package Module::Release::WebUpload::Mojo;
4              
5 1     1   6 use strict;
  1         2  
  1         20  
6 1     1   5 use warnings;
  1         1  
  1         38  
7 1     1   7 use Exporter qw(import);
  1         1  
  1         41  
8              
9 1     1   7 use Carp qw(croak);
  1         1  
  1         53  
10 1     1   695 use Mojo::UserAgent;
  1         450662  
  1         10  
11 1     1   47 use File::Basename qw(basename);
  1         3  
  1         441  
12              
13             our @EXPORT = qw(
14             web_upload
15             make_agent
16             default_web_hostname
17             pause_add_uri
18             );
19              
20             our $VERSION = '2.128';
21              
22             =encoding utf8
23              
24             =head1 NAME
25              
26             Module::Release::WebUpload::Mojo - Upload through the PAUSE web interface
27              
28             =head1 SYNOPSIS
29              
30             The release script automatically loads this module when it's time
31             to upload a file. It's implemented with C.
32              
33             =head1 DESCRIPTION
34              
35             =over 4
36              
37             =item web_upload( PARAMS )
38              
39             Upload the file to PAUSE
40              
41             =cut
42              
43             sub web_upload {
44 0     0 1   my $self = shift;
45              
46 0           my $ua = $self->make_agent;
47              
48 0           $self->_debug( sprintf "Uploading file %s", $self->local_file );
49              
50 0           my $params = {
51             HIDDENNAME => $self->config->cpan_user,
52             CAN_MULTIPART => 1,
53             pause99_add_uri_subdirtext => '',
54             SUBMIT_pause99_add_uri_httpupload => ' Upload this file from my disk ',
55             pause99_add_uri_httpupload => { file => $self->local_file },
56             };
57              
58 0           $self->_print( "File uploading\n" );
59 0           my $tx = $ua->post(
60             $self->pause_add_uri(
61             $self->config->cpan_user,
62             $self->config->cpan_pass,
63             ),
64             form => $params,
65             );
66              
67 0 0         if( my $res = eval { $tx->result } ) {
  0            
68 0           $self->_print( "File uploaded\n" );
69 0           return 1;
70             }
71             else {
72 0           my $err = $tx->res->error;
73 0 0         $self->_print( "$err->{code} response: $err->{message}" ) if $err->{code};
74 0           $self->_print( "Connection error: $err->{message}" );
75 0           return 0;
76             }
77             }
78              
79             sub make_agent {
80 0     0 0   my( $self ) = @_;
81 0           my $agent = Mojo::UserAgent->new;
82 0           $agent->transactor->name( 'release' );
83 0 0         $agent->http_proxy( $self->config->http_proxy ) if $self->config->http_proxy;
84 0 0         $agent->https_proxy( $self->config->https_proxy ) if $self->config->https_proxy;
85              
86 0           return $agent;
87             }
88              
89             =back
90              
91             =head2 Default values
92              
93             Override these methods to change the default values. Remember that
94             the overridden methods have to show up in the C
95             namespace.
96              
97             =over 4
98              
99             =item default_web_hostname
100              
101             pause.perl.org
102              
103             =item pause_add_uri
104              
105             http://pause.perl.org/pause/authenquery
106              
107             =cut
108              
109 0     0 1   sub default_web_hostname { "pause.perl.org" }
110             sub pause_add_uri {
111 0     0 1   my( $self, $user, $pass ) = @_;
112 0           sprintf 'https://%s:%s@pause.perl.org/pause/authenquery', $user, $pass;
113             };
114              
115             =back
116              
117             =head1 SEE ALSO
118              
119             L
120              
121             =head1 SOURCE AVAILABILITY
122              
123             This source is in GitHub
124              
125             https://github.com/briandfoy/module-release
126              
127             =head1 AUTHOR
128              
129             brian d foy, C<< >>
130              
131             =head1 COPYRIGHT AND LICENSE
132              
133             Copyright © 2007-2021, brian d foy C<< >>. All rights reserved.
134              
135             This program is free software; you can redistribute it and/or modify
136             it under the Artistic License 2.0.
137              
138             =cut
139              
140             1;