[p5sagit/p5-mst-13.2.git] / lib / CPANPLUS / Internals / Fetch.pm

package CPANPLUS::Internals::Fetch;

use strict;

use CPANPLUS::Error;
use CPANPLUS::Internals::Constants;

use File::Fetch;
use File::Spec;
use Cwd                         qw[cwd];
use IPC::Cmd                    qw[run];
use Params::Check               qw[check];
use Module::Load::Conditional   qw[can_load];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

$Params::Check::VERBOSE = 1;

=pod

=head1 NAME

CPANPLUS::Internals::Fetch

=head1 SYNOPSIS

    my $output = $cb->_fetch(
                        module      => $modobj,
                        fetchdir    => '/path/to/save/to',
                        verbose     => BOOL,
                        force       => BOOL,
                    );

    $cb->_add_fail_host( host => 'foo.com' );
    $cb->_host_ok(       host => 'foo.com' );


=head1 DESCRIPTION

CPANPLUS::Internals::Fetch fetches files from either ftp, http, file
or rsync mirrors.

This is the rough flow:

    $cb->_fetch
        Delegate to File::Fetch;


=head1 METHODS

=cut

=head1 $path = _fetch( module => $modobj, [fetchdir => '/path/to/save/to', fetch_from => 'scheme://path/to/fetch/from', verbose => BOOL, force => BOOL, prefer_bin => BOOL] )

C<_fetch> will fetch files based on the information in a module
object. You always need a module object. If you want a fake module
object for a one-off fetch, look at C<CPANPLUS::Module::Fake>.

C<fetchdir> is the place to save the file to. Usually this
information comes from your configuration, but you can override it
expressly if needed.

C<fetch_from> lets you specify an URI to get this file from. If you
do not specify one, your list of configured hosts will be probed to
download the file from.

C<force> forces a new download, even if the file already exists.

C<verbose> simply indicates whether or not to print extra messages.

C<prefer_bin> indicates whether you prefer the use of commandline
programs over perl modules. Defaults to your corresponding config
setting.

C<_fetch> figures out, based on the host list, what scheme to use and
from there, delegates to C<File::Fetch> do the actual fetching.

Returns the path of the output file on success, false on failure.

Note that you can set a C<blacklist> on certain methods in the config.
Simply add the identifying name of the method (ie, C<lwp>) to:
    $conf->_set_fetch( blacklist => ['lwp'] );

And the C<LWP> function will be skipped by C<File::Fetch>.

=cut

sub _fetch {
    my $self = shift;
    my $conf = $self->configure_object;
    my %hash = @_;

    local $Params::Check::NO_DUPLICATES = 0;

    my ($modobj, $verbose, $force, $fetch_from);
    my $tmpl = {
        module      => { required => 1, allow => IS_MODOBJ, store => \$modobj },
        fetchdir    => { default => $conf->get_conf('fetchdir') },
        fetch_from  => { default => '', store => \$fetch_from },
        force       => { default => $conf->get_conf('force'),
                            store => \$force },
        verbose     => { default => $conf->get_conf('verbose'),
                            store => \$verbose },
        prefer_bin  => { default => $conf->get_conf('prefer_bin') },
    };


    my $args = check( $tmpl, \%hash ) or return;

    ### check if we already downloaded the thing ###
    if( (my $where = $modobj->status->fetch()) && !$force ) {
        msg(loc("Already fetched '%1' to '%2', " .
                "won't fetch again without force",
                $modobj->module, $where ), $verbose );
        return $where;
    }

    my ($remote_file, $local_file, $local_path);

    ### build the local path to downlaod to ###
    {
        $local_path =   $args->{fetchdir} ||
                        File::Spec->catdir(
                            $conf->get_conf('base'),
                            $modobj->path,
                        );

        ### create the path if it doesn't exist ###
        unless( -d $local_path ) {
            unless( $self->_mkdir( dir => $local_path ) ) {
                msg( loc("Could not create path '%1'", $local_path), $verbose);
                return;
            }
        }

        $local_file = File::Spec->rel2abs(
                        File::Spec->catfile(
                                    $local_path,
                                    $modobj->package,
                        )
                    );
    }

    ### do we already have the file? ###
    if( -e $local_file ) {

        if( $args->{force} ) {

            ### some fetches will fail if the files exist already, so let's
            ### delete them first
            unlink $local_file
                or msg( loc("Could not delete %1, some methods may " .
                            "fail to force a download", $local_file), $verbose);
         } else {

            ### store where we fetched it ###
            $modobj->status->fetch( $local_file );

            return $local_file;
        }
    }


    ### we got a custom URI 
    if ( $fetch_from ) {
        my $abs = $self->__file_fetch(  from    => $fetch_from,
                                        to      => $local_path,
                                        verbose => $verbose );
                                        
        unless( $abs ) {
            error(loc("Unable to download '%1'", $fetch_from));
            return;
        }            

        ### store where we fetched it ###
        $modobj->status->fetch( $abs );

        return $abs;

    ### we will get it from one of our mirrors
    } else {
        ### build the remote path to download from ###
        {   $remote_file = File::Spec::Unix->catfile(
                                        $modobj->path,
                                        $modobj->package,
                                    );
            unless( $remote_file ) {
                error( loc('No remote file given for download') );
                return;
            }
        }
    
        ### see if we even have a host or a method to use to download with ###
        my $found_host;
        my @maybe_bad_host;
    
        HOST: {
            ### F*CKING PIECE OF F*CKING p4 SHIT makes 
            ### '$File :: Fetch::SOME_VAR'
            ### into a meta variable and starts substituting the file name...
            ### GRAAAAAAAAAAAAAAAAAAAAAAH!
            ### use ' to combat it!
    
            ### set up some flags for File::Fetch ###
            local $File'Fetch::BLACKLIST    = $conf->_get_fetch('blacklist');
            local $File'Fetch::TIMEOUT      = $conf->get_conf('timeout');
            local $File'Fetch::DEBUG        = $conf->get_conf('debug');
            local $File'Fetch::FTP_PASSIVE  = $conf->get_conf('passive');
            local $File'Fetch::FROM_EMAIL   = $conf->get_conf('email');
            local $File'Fetch::PREFER_BIN   = $conf->get_conf('prefer_bin');
            local $File'Fetch::WARN         = $verbose;
    
    
            ### loop over all hosts we have ###
            for my $host ( @{$conf->get_conf('hosts')} ) {
                $found_host++;
    
                my $mirror_path = File::Spec::Unix->catfile(
                                        $host->{'path'}, $remote_file
                                    );
    
                ### build pretty print uri ###
                my $where;
                if( $host->{'scheme'} eq 'file' ) {
                    $where = CREATE_FILE_URI->(
                                File::Spec::Unix->rel2abs(
                                    File::Spec::Unix->catdir(
                                        grep { defined $_ && length $_ }
                                        $host->{'host'},
                                        $mirror_path
                                     )
                                )
                            );
                } else {
                    my %args = ( scheme => $host->{scheme},
                                 host   => $host->{host},
                                 path   => $mirror_path,
                                );
                    
                    $where = $self->_host_to_uri( %args );
                }
    
                my $abs = $self->__file_fetch(  from    => $where, 
                                                to      => $local_path,
                                                verbose => $verbose );    
                
                ### we got a path back?
                if( $abs ) {
                    ### store where we fetched it ###
                    $modobj->status->fetch( $abs );
        
                    ### this host is good, the previous ones are apparently
                    ### not, so mark them as such.
                    $self->_add_fail_host( host => $_ ) for @maybe_bad_host;
                        
                    return $abs;
                }
                
                ### so we tried to get the file but didn't actually fetch it --
                ### there's a chance this host is bad. mark it as such and 
                ### actually flag it back if we manage to get the file 
                ### somewhere else
                push @maybe_bad_host, $host;
            }
        }
    
        $found_host
            ? error(loc("Fetch failed: host list exhausted " .
                        "-- are you connected today?"))
            : error(loc("No hosts found to download from " .
                        "-- check your config"));
    }
    
    return;
}

sub __file_fetch {
    my $self = shift;
    my $conf = $self->configure_object;
    my %hash = @_;

    my ($where, $local_path, $verbose);
    my $tmpl = {
        from    => { required   => 1, store => \$where },
        to      => { required   => 1, store => \$local_path },
        verbose => { default    => $conf->get_conf('verbose'),
                     store      => \$verbose },
    };
    
    check( $tmpl, \%hash ) or return;

    msg(loc("Trying to get '%1'", $where ), $verbose );

    ### build the object ###
    my $ff = File::Fetch->new( uri => $where );

    ### sanity check ###
    error(loc("Bad uri '%1'",$where)), return unless $ff;

    if( my $file = $ff->fetch( to => $local_path ) ) {
        unless( -e $file && -s _ ) {
            msg(loc("'%1' said it fetched '%2', but it was not created",
                    'File::Fetch', $file), $verbose);

        } else {
            my $abs = File::Spec->rel2abs( $file );
            return $abs;
        }

    } else {
        error(loc("Fetching of '%1' failed: %2", $where, $ff->error));
    }

    return;
}

=pod

=head2 _add_fail_host( host => $host_hashref )

Mark a particular host as bad. This makes C<CPANPLUS::Internals::Fetch>
skip it in fetches until this cache is flushed.

=head2 _host_ok( host => $host_hashref )

Query the cache to see if this host is ok, or if it has been flagged
as bad.

Returns true if the host is ok, false otherwise.

=cut

{   ### caching functions ###

    sub _add_fail_host {
        my $self = shift;
        my %hash = @_;

        my $host;
        my $tmpl = {
            host => { required      => 1, default   => {},
                      strict_type   => 1, store     => \$host },
        };

        check( $tmpl, \%hash ) or return;

        return $self->_hosts->{$host} = 1;
    }

    sub _host_ok {
        my $self = shift;
        my %hash = @_;

        my $host;
        my $tmpl = {
            host => { required => 1, store => \$host },
        };

        check( $tmpl, \%hash ) or return;

        return $self->_hosts->{$host} ? 0 : 1;
    }
}


1;

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
Commit	Line	Data
6aaee015	1	package CPANPLUS::Internals::Fetch;
	2
	3	use strict;
	4
	5	use CPANPLUS::Error;
	6	use CPANPLUS::Internals::Constants;
	7
	8	use File::Fetch;
	9	use File::Spec;
	10	use Cwd qw[cwd];
	11	use IPC::Cmd qw[run];
	12	use Params::Check qw[check];
	13	use Module::Load::Conditional qw[can_load];
	14	use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
	15
	16	$Params::Check::VERBOSE = 1;
	17
	18	=pod
	19
	20	=head1 NAME
	21
	22	CPANPLUS::Internals::Fetch
	23
	24	=head1 SYNOPSIS
	25
	26	my $output = $cb->_fetch(
	27	module => $modobj,
	28	fetchdir => '/path/to/save/to',
	29	verbose => BOOL,
	30	force => BOOL,
	31	);
	32
	33	$cb->_add_fail_host( host => 'foo.com' );
	34	$cb->_host_ok( host => 'foo.com' );
	35
	36
	37	=head1 DESCRIPTION
	38
	39	CPANPLUS::Internals::Fetch fetches files from either ftp, http, file
	40	or rsync mirrors.
	41
	42	This is the rough flow:
	43
	44	$cb->_fetch
	45	Delegate to File::Fetch;
	46
	47
	48	=head1 METHODS
	49
	50	=cut
	51
	52	=head1 $path = _fetch( module => $modobj, [fetchdir => '/path/to/save/to', fetch_from => 'scheme://path/to/fetch/from', verbose => BOOL, force => BOOL, prefer_bin => BOOL] )
	53
	54	C<_fetch> will fetch files based on the information in a module
	55	object. You always need a module object. If you want a fake module
	56	object for a one-off fetch, look at C<CPANPLUS::Module::Fake>.
	57
	58	C<fetchdir> is the place to save the file to. Usually this
	59	information comes from your configuration, but you can override it
	60	expressly if needed.
	61
	62	C<fetch_from> lets you specify an URI to get this file from. If you
	63	do not specify one, your list of configured hosts will be probed to
	64	download the file from.
65
66	C<force> forces a new download, even if the file already exists.
67
68	C<verbose> simply indicates whether or not to print extra messages.
69
70	C<prefer_bin> indicates whether you prefer the use of commandline
71	programs over perl modules. Defaults to your corresponding config
72	setting.
73
74	C<_fetch> figures out, based on the host list, what scheme to use and
75	from there, delegates to C<File::Fetch> do the actual fetching.
76
77	Returns the path of the output file on success, false on failure.
78
79	Note that you can set a C<blacklist> on certain methods in the config.
80	Simply add the identifying name of the method (ie, C<lwp>) to:
81	$conf->_set_fetch( blacklist => ['lwp'] );
82
83	And the C<LWP> function will be skipped by C<File::Fetch>.
84
85	=cut
86
87	sub _fetch {
88	my $self = shift;
89	my $conf = $self->configure_object;
90	my %hash = @_;
91
92	local $Params::Check::NO_DUPLICATES = 0;
93
94	my ($modobj, $verbose, $force, $fetch_from);
95	my $tmpl = {
96	module => { required => 1, allow => IS_MODOBJ, store => \$modobj },
97	fetchdir => { default => $conf->get_conf('fetchdir') },
98	fetch_from => { default => '', store => \$fetch_from },
99	force => { default => $conf->get_conf('force'),
100	store => \$force },
101	verbose => { default => $conf->get_conf('verbose'),
102	store => \$verbose },
103	prefer_bin => { default => $conf->get_conf('prefer_bin') },
104	};
105
106
107	my $args = check( $tmpl, \%hash ) or return;
108
109	### check if we already downloaded the thing ###
110	if( (my $where = $modobj->status->fetch()) && !$force ) {
111	msg(loc("Already fetched '%1' to '%2', " .
112	"won't fetch again without force",
113	$modobj->module, $where ), $verbose );
114	return $where;
115	}
116
117	my ($remote_file, $local_file, $local_path);
118
119	### build the local path to downlaod to ###
120	{
121	$local_path = $args->{fetchdir} \|\|
122	File::Spec->catdir(
123	$conf->get_conf('base'),
124	$modobj->path,
125	);
126
127	### create the path if it doesn't exist ###
128	unless( -d $local_path ) {
129	unless( $self->_mkdir( dir => $local_path ) ) {
130	msg( loc("Could not create path '%1'", $local_path), $verbose);
131	return;
132	}
133	}
134
135	$local_file = File::Spec->rel2abs(
136	File::Spec->catfile(
137	$local_path,
138	$modobj->package,
139	)
140	);
141	}
142
143	### do we already have the file? ###
144	if( -e $local_file ) {
145
146	if( $args->{force} ) {
147
148	### some fetches will fail if the files exist already, so let's
149	### delete them first
150	unlink $local_file
151	or msg( loc("Could not delete %1, some methods may " .
152	"fail to force a download", $local_file), $verbose);
153	} else {
154
155	### store where we fetched it ###
156	$modobj->status->fetch( $local_file );
157
158	return $local_file;
159	}
160	}
161
162
163	### we got a custom URI
164	if ( $fetch_from ) {
165	my $abs = $self->__file_fetch( from => $fetch_from,
166	to => $local_path,
167	verbose => $verbose );
168
169	unless( $abs ) {
170	error(loc("Unable to download '%1'", $fetch_from));
171	return;
172	}
173
174	### store where we fetched it ###
175	$modobj->status->fetch( $abs );
176
177	return $abs;
178
179	### we will get it from one of our mirrors
180	} else {
181	### build the remote path to download from ###
182	{ $remote_file = File::Spec::Unix->catfile(
183	$modobj->path,
184	$modobj->package,
185	);
186	unless( $remote_file ) {
187	error( loc('No remote file given for download') );
188	return;
189	}
190	}
191
192	### see if we even have a host or a method to use to download with ###
193	my $found_host;
194	my @maybe_bad_host;
195
196	HOST: {
197	### FCKING PIECE OF FCKING p4 SHIT makes
198	### '$File :: Fetch::SOME_VAR'
199	### into a meta variable and starts substituting the file name...
200	### GRAAAAAAAAAAAAAAAAAAAAAAH!
201	### use ' to combat it!
202
203	### set up some flags for File::Fetch ###
204	local $File'Fetch::BLACKLIST = $conf->_get_fetch('blacklist');
205	local $File'Fetch::TIMEOUT = $conf->get_conf('timeout');
206	local $File'Fetch::DEBUG = $conf->get_conf('debug');
207	local $File'Fetch::FTP_PASSIVE = $conf->get_conf('passive');
208	local $File'Fetch::FROM_EMAIL = $conf->get_conf('email');
209	local $File'Fetch::PREFER_BIN = $conf->get_conf('prefer_bin');
210	local $File'Fetch::WARN = $verbose;
211
212
213	### loop over all hosts we have ###
214	for my $host ( @{$conf->get_conf('hosts')} ) {
215	$found_host++;
216
217	my $mirror_path = File::Spec::Unix->catfile(
218	$host->{'path'}, $remote_file
219	);
220
221	### build pretty print uri ###
222	my $where;
223	if( $host->{'scheme'} eq 'file' ) {
224	$where = CREATE_FILE_URI->(
225	File::Spec::Unix->rel2abs(
226	File::Spec::Unix->catdir(
227	grep { defined $_ && length $_ }
228	$host->{'host'},
229	$mirror_path
230	)
231	)
232	);
233	} else {
234	my %args = ( scheme => $host->{scheme},
235	host => $host->{host},
236	path => $mirror_path,
237	);
238
239	$where = $self->_host_to_uri( %args );
240	}
241
242	my $abs = $self->__file_fetch( from => $where,
243	to => $local_path,
244	verbose => $verbose );
245
246	### we got a path back?
247	if( $abs ) {
248	### store where we fetched it ###
249	$modobj->status->fetch( $abs );
250
251	### this host is good, the previous ones are apparently
252	### not, so mark them as such.
253	$self->_add_fail_host( host => $_ ) for @maybe_bad_host;
254
255	return $abs;
256	}
257
258	### so we tried to get the file but didn't actually fetch it --
259	### there's a chance this host is bad. mark it as such and
260	### actually flag it back if we manage to get the file
261	### somewhere else
262	push @maybe_bad_host, $host;
263	}
264	}
265
266	$found_host
267	? error(loc("Fetch failed: host list exhausted " .
268	"-- are you connected today?"))
269	: error(loc("No hosts found to download from " .
270	"-- check your config"));
271	}
272
273	return;
274	}
275
276	sub __file_fetch {
277	my $self = shift;
278	my $conf = $self->configure_object;
279	my %hash = @_;
280
281	my ($where, $local_path, $verbose);
282	my $tmpl = {
283	from => { required => 1, store => \$where },
284	to => { required => 1, store => \$local_path },
285	verbose => { default => $conf->get_conf('verbose'),
286	store => \$verbose },
287	};
288
289	check( $tmpl, \%hash ) or return;
290
291	msg(loc("Trying to get '%1'", $where ), $verbose );
292
293	### build the object ###
294	my $ff = File::Fetch->new( uri => $where );
295
296	### sanity check ###
297	error(loc("Bad uri '%1'",$where)), return unless $ff;
298
299	if( my $file = $ff->fetch( to => $local_path ) ) {
300	unless( -e $file && -s _ ) {
301	msg(loc("'%1' said it fetched '%2', but it was not created",
302	'File::Fetch', $file), $verbose);
303
304	} else {
305	my $abs = File::Spec->rel2abs( $file );
306	return $abs;
307	}
308
309	} else {
310	error(loc("Fetching of '%1' failed: %2", $where, $ff->error));
311	}
312
313	return;
314	}
315
316	=pod
317
318	=head2 _add_fail_host( host => $host_hashref )
319
320	Mark a particular host as bad. This makes C<CPANPLUS::Internals::Fetch>
321	skip it in fetches until this cache is flushed.
322
323	=head2 _host_ok( host => $host_hashref )
324
325	Query the cache to see if this host is ok, or if it has been flagged
326	as bad.
327
328	Returns true if the host is ok, false otherwise.
329
330	=cut
331
332	{ ### caching functions ###
333
334	sub _add_fail_host {
335	my $self = shift;
336	my %hash = @_;
337
338	my $host;
339	my $tmpl = {
340	host => { required => 1, default => {},
341	strict_type => 1, store => \$host },
342	};
343
344	check( $tmpl, \%hash ) or return;
345
346	return $self->_hosts->{$host} = 1;
347	}
348
349	sub _host_ok {
350	my $self = shift;
351	my %hash = @_;
352
353	my $host;
354	my $tmpl = {
355	host => { required => 1, store => \$host },
356	};
357
358	check( $tmpl, \%hash ) or return;
359
360	return $self->_hosts->{$host} ? 0 : 1;
361	}
362	}
363
364
365	1;
366
367	# Local variables:
368	# c-indentation-style: bsd
369	# c-basic-offset: 4
370	# indent-tabs-mode: nil
371	# End:
372	# vim: expandtab shiftwidth=4: