File Coverage

blib/lib/inc/Module/Install.pm
Criterion Covered Total %
statement 7 53 13.2
branch 0 36 0.0
condition 0 6 0.0
subroutine 3 7 42.8
pod n/a
total 10 102 9.8


line stmt bran cond sub pod time code
1             package inc::Module::Install;
2              
3             # This module ONLY loads if the user has manually installed their own
4             # installation of Module::Install, and are some form of MI author.
5             #
6             # It runs from the installed location, and is never bundled
7             # along with the other bundled modules.
8             #
9             # So because the version of this differs from the version that will
10             # be bundled almost every time, it doesn't have it's own version and
11             # isn't part of the synchronisation-checking.
12              
13 6     6   301928 use strict;
  6         17  
  6         218  
14 6     6   39 use vars qw{$VERSION};
  6         11  
  6         350  
15             BEGIN {
16             # While this version will be overwritten when Module::Install
17             # loads, it remains so Module::Install itself can detect which
18             # version an author currently has installed.
19             # This allows it to implement any back-compatibility features
20             # it may want or need to.
21 6     6   4740 $VERSION = '1.19';
22             }
23              
24             if ( -d './inc' ) {
25             my $author = $^O eq 'VMS' ? './inc/_author' : './inc/.author';
26             if ( -d $author ) {
27             my $modified_at = (stat($author))[9];
28             if ((time - $modified_at) > 24 * 60 * 60) {
29             # inc is a bit stale; there may be a newer Module::Install
30             _check_update($modified_at);
31             }
32             $Module::Install::AUTHOR = 1;
33             require File::Path;
34             File::Path::rmtree('inc');
35             }
36             } else {
37             $Module::Install::AUTHOR = 1;
38             }
39              
40             unshift @INC, 'inc' unless $INC[0] eq 'inc';
41             local $^W;
42             require Module::Install;
43              
44             sub _check_update {
45 0     0     my $modified_at = shift;
46              
47             # XXX: We have several online services to get update information
48             # including search.cpan.org. They are more reliable than the
49             # 02packages.details.txt.gz on the local machine. We might be
50             # better to depend on those services... but on which?
51              
52 0           my $cpan_version = 0;
53 0           if (0) { # XXX: should be configurable?
54             my $url = "http://search.cpan.org/dist/Module-Install/META.yml";
55             eval "require YAML::Tiny; 1" or return;
56              
57             if (eval "require LWP::UserAgent; 1") {
58             my $ua = LWP::UserAgent->new(
59             timeout => 10,
60             env_proxy => 1,
61             );
62             my $res = $ua->get($url);
63             return unless $res->is_success;
64             my $yaml = eval { YAML::Tiny::Load($res->content) } or return;
65             $cpan_version = $yaml->{version};
66             }
67             }
68             else {
69             # If you don't want to rely on the net...
70 0           require File::Spec;
71 0 0         $cpan_version = _check_update_local($modified_at) or return;
72             }
73              
74             # XXX: should die instead of warn?
75 0 0         warn <<"WARN" if $cpan_version > $VERSION;
76             Newer version of Module::Install is available on CPAN.
77             CPAN: $cpan_version
78             LOCAL: $VERSION
79             Please upgrade.
80             WARN
81             }
82              
83             sub _check_update_local {
84 0     0     my $modified_at = shift;
85              
86 0 0         return unless eval "require Compress::Zlib; 1";
87 0 0         _require_myconfig_or_config() or return;
88             my $file = File::Spec->catfile(
89             $CPAN::Config->{keep_source_where},
90 0           'modules',
91             '02packages.details.txt.gz'
92             );
93 0 0         return unless -f $file;
94             # return if (stat($file))[9] < $modified_at;
95              
96 0 0         my $gz = Compress::Zlib::gzopen($file, 'r') or return;
97 0           my $line;
98 0           while($gz->gzreadline($line)) {
99 0 0         my ($cpan_version) = $line =~ /^Module::Install\s+(\S+)/ or next;
100 0           return $cpan_version;
101             }
102 0           return;
103             }
104              
105             # adapted from CPAN::HandleConfig
106             sub _require_myconfig_or_config {
107 0 0   0     return 1 if $INC{"CPAN/MyConfig.pm"};
108 0           local @INC = @INC;
109 0 0         my $home = _home() or return;
110 0           my $cpan_dir = File::Spec->catdir($home,'.cpan');
111 0 0         return unless -d $cpan_dir;
112 0           unshift @INC, $cpan_dir;
113 0           eval { require CPAN::MyConfig };
  0            
114 0 0 0       if ($@ and $@ !~ m#locate CPAN/MyConfig\.pm#) {
115 0           warn "Error while requiring CPAN::MyConfig:\n$@\n";
116 0           return;
117             }
118 0 0         return 1 if $INC{"CPAN/MyConfig.pm"};
119              
120 0           eval { require CPAN::Config; };
  0            
121 0 0 0       if ($@ and $@ !~ m#locate CPAN/Config\.pm#) {
122 0           warn "Error while requiring CPAN::Config:\n$@\n";
123 0           return;
124             }
125 0 0         return 1 if $INC{"CPAN/Config.pm"};
126 0           return;
127             }
128              
129             # adapted from CPAN::HandleConfig
130             sub _home {
131 0     0     my $home;
132 0 0         if (eval {require File::HomeDir; 1}) {
  0            
  0            
133 0 0         $home = File::HomeDir->can('my_dot_config')
134             ? File::HomeDir->my_dot_config
135             : File::HomeDir->my_data;
136 0 0         unless (defined $home) {
137 0           $home = File::HomeDir->my_home
138             }
139             }
140 0 0         unless (defined $home) {
141 0           $home = $ENV{HOME};
142             }
143 0           $home;
144             }
145              
146             1;
147              
148             __END__