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   942 use v5.16;
  1         4  
2              
3             package Module::Release::WebUpload::Mojo;
4              
5 1     1   7 use strict;
  1         1  
  1         21  
6 1     1   4 use warnings;
  1         2  
  1         24  
7 1     1   15 use Exporter qw(import);
  1         2  
  1         31  
8              
9 1     1   6 use Carp qw(croak);
  1         2  
  1         51  
10 1     1   716 use Mojo::UserAgent;
  1         445941  
  1         10  
11 1     1   47 use File::Basename qw(basename);
  1         2  
  1         483  
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.131';
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\n", $self->local_file );
49              
50 0           my $params = {
51             ACTION => 'add_uri',
52             HIDDENNAME => $self->config->cpan_user,
53             CAN_MULTIPART => 1,
54             pause99_add_uri_subdirtext => '',
55             SUBMIT_pause99_add_uri_httpupload => ' Upload this file from my disk ',
56             pause99_add_uri_httpupload => { file => $self->local_file },
57             };
58              
59 0           $self->_print( "File uploading\n" );
60 0           my $tx = $ua->post(
61             $self->pause_add_uri(
62             $self->config->cpan_user,
63             $self->config->cpan_pass,
64             ),
65             form => $params,
66             );
67              
68 0 0         if( my $res = eval { $tx->result->is_success } ) {
  0            
69 0           $self->_debug( "Response headers:\n" . $tx->res->to_string . "\n" );
70 0           $self->_print( "File uploaded\n" );
71 0           return 1;
72             }
73             else {
74 0           my $err = $tx->res->error;
75             $self->_print( $err->{code} ?
76 0 0         "$err->{code} response: $err->{message}\n"
77             :
78             "Connection error: $err->{message}\n" );
79 0           return 0;
80             }
81             }
82              
83             sub make_agent {
84 0     0 0   my( $self ) = @_;
85 0           my $agent = Mojo::UserAgent->new;
86 0           $agent->transactor->name( 'release' );
87 0 0         $agent->http_proxy( $self->config->http_proxy ) if $self->config->http_proxy;
88 0 0         $agent->https_proxy( $self->config->https_proxy ) if $self->config->https_proxy;
89              
90 0           return $agent;
91             }
92              
93             =back
94              
95             =head2 Default values
96              
97             Override these methods to change the default values. Remember that
98             the overridden methods have to show up in the C
99             namespace.
100              
101             =over 4
102              
103             =item default_web_hostname
104              
105             pause.perl.org
106              
107             =item pause_add_uri
108              
109             http://pause.perl.org/pause/authenquery
110              
111             =cut
112              
113 0     0 1   sub default_web_hostname { "pause.perl.org" }
114             sub pause_add_uri {
115 0     0 1   my( $self, $user, $pass ) = @_;
116 0           sprintf 'https://%s:%s@pause.perl.org/pause/authenquery', $user, $pass;
117             };
118              
119             =back
120              
121             =head1 SEE ALSO
122              
123             L
124              
125             =head1 SOURCE AVAILABILITY
126              
127             This source is in GitHub
128              
129             https://github.com/briandfoy/module-release
130              
131             =head1 AUTHOR
132              
133             brian d foy, C<< >>
134              
135             =head1 COPYRIGHT AND LICENSE
136              
137             Copyright © 2007-2023, brian d foy C<< >>. All rights reserved.
138              
139             This program is free software; you can redistribute it and/or modify
140             it under the Artistic License 2.0.
141              
142             =cut
143              
144             1;