File Coverage

blib/lib/CPAN/FirstTime.pm
Criterion Covered Total %
statement 421 488 86.3
branch 189 270 70.0
condition 146 218 67.0
subroutine 31 31 100.0
pod n/a
total 787 1007 78.2


line stmt bran cond sub pod time code
1             # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2             package CPAN::Mirrored::By;
3 4     4   66 use strict;
  4         58  
  4         223  
4 4     4   72 use vars qw($VERSION);
  4         38  
  4         246  
5             $VERSION = sprintf "%.6f", substr(q$Rev: 879 $,4)/1000000 + 5.4;
6              
7             sub new {
8 565     565   6396     my($self,@arg) = @_;
9 565         12294     bless [@arg], $self;
10             }
11 1     1   15 sub continent { shift->[0] }
12 1     1   14 sub country { shift->[1] }
13 1     1   13 sub url { shift->[2] }
14              
15             package CPAN::FirstTime;
16              
17 4     4   91 use strict;
  4         37  
  4         61  
18 4     4   847 use ExtUtils::MakeMaker ();
  4         40  
  4         38  
19 4     4   83 use FileHandle ();
  4         39  
  4         38  
20 4     4   83 use File::Basename ();
  4         38  
  4         38  
21 4     4   60 use File::Path ();
  4         68  
  4         37  
22 4     4   86 use File::Spec;
  4         36  
  4         128  
23 4     4   58 use vars qw($VERSION $urllist);
  4         36  
  4         60  
24             $VERSION = sprintf "%.6f", substr(q$Rev: 879 $,4)/1000000 + 5.4;
25              
26             =head1 NAME
27            
28             CPAN::FirstTime - Utility for CPAN::Config file Initialization
29            
30             =head1 SYNOPSIS
31            
32             CPAN::FirstTime::init()
33            
34             =head1 DESCRIPTION
35            
36             The init routine asks a few questions and writes a CPAN/Config.pm or
37             CPAN/MyConfig.pm file (depending on what it is currently using).
38            
39             =head1 LICENSE
40            
41             This program is free software; you can redistribute it and/or
42             modify it under the same terms as Perl itself.
43            
44             =cut
45              
46 4     4   61 use vars qw( %prompts );
  4         38  
  4         52  
47              
48             sub init {
49 48     48   587     my($configpm, %args) = @_;
50 4     4   75     use Config;
  4         37  
  4         252  
51             # extra args after 'o conf init'
52 48 100 66     620     my $matcher = $args{args} && @{$args{args}} ? $args{args}[0] : '';
  48         757  
53 48 50       705     if ($matcher =~ /^\/(.*)\/$/) {
    100          
54             # case /regex/ => take the first, ignore the rest
55 0         0         $matcher = $1;
56 0         0         shift @{$args{args}};
  0         0  
57 0 0       0         if (@{$args{args}}) {
  0         0  
58 0         0             local $" = " ";
59 0         0             $CPAN::Frontend->mywarn("Ignoring excessive arguments '@{$args{args}}'");
  0         0  
60 0         0             $CPAN::Frontend->mysleep(2);
61                     }
62                 } elsif (0 == length $matcher) {
63                 } else {
64             # case WORD... => all arguments must be valid
65 47         393         for my $arg (@{$args{args}}) {
  47         614  
66 47 50       581             unless (exists $CPAN::HandleConfig::keys{$arg}) {
67 0         0                 $CPAN::Frontend->mywarn("'$arg' is not a valid configuration variable");
68 0         0                 return;
69                         }
70                     }
71 47         539         $matcher = "\\b(".join("|",@{$args{args}}).")\\b";
  47         617  
72                 }
73 48 50       547     CPAN->debug("matcher[$matcher]") if $CPAN::DEBUG;
74              
75 48 50       551     unless ($CPAN::VERSION) {
76 0         0 require CPAN::Nox;
77                 }
78 48         675     require CPAN::HandleConfig;
79 48         569     CPAN::HandleConfig::require_myconfig_or_config();
80 48   50     456     $CPAN::Config ||= {};
81 48         659     local($/) = "\n";
82 48         779     local($\) = "";
83 48         585     local($|) = 1;
84              
85 48         404     my($ans,$default);
86              
87             #
88             #= Files, directories
89             #
90              
91 48 100       449     unless ($matcher) {
92 1         20         $CPAN::Frontend->myprint($prompts{manual_config});
93                 }
94              
95 48         379     my $manual_conf;
96              
97 48         464     local *_real_prompt;
98 48 50       610     if ( $args{autoconfig} ) {
    100          
99 0         0         $manual_conf = "no";
100                 } elsif ($matcher) {
101 47         447         $manual_conf = "yes";
102                 } else {
103 1         13         my $_conf = prompt("Would you like me to configure as much as possible ".
104                                        "automatically?", "yes");
105 1 50 33     39         $manual_conf = ($_conf and $_conf =~ /^y/i) ? "no" : "yes";
106                 }
107 48 50       493     CPAN->debug("manual_conf[$manual_conf]") if $CPAN::DEBUG;
108 48         423     my $fastread;
109                 {
110 48 100       401       if ($manual_conf =~ /^y/i) {
  48         618  
111 47         422 $fastread = 0;
112                   } else {
113 1         10 $fastread = 1;
114 1   50     14 $CPAN::Config->{urllist} ||= [];
115              
116 1         12         local $^W = 0;
117             # prototype should match that of &MakeMaker::prompt
118 1         17         my $current_second = time;
119 1         10         my $current_second_count = 0;
120 1         10         my $i_am_mad = 0;
121             *_real_prompt = sub ($;$) {
122 46     46   527 my($q,$a) = @_;
123 46 50       568 my($ret) = defined $a ? $a : "";
124 46         885 $CPAN::Frontend->myprint(sprintf qq{%s [%s]\n\n}, $q, $ret);
125 46         488           eval { require Time::HiRes };
  46         1005  
126 46 50       494           unless ($@) {
127 46 100       898               if (time == $current_second) {
128 43         740                   $current_second_count++;
129 43 100       4031                   if ($current_second_count > 20) {
130             # I don't like more than 20 prompts per second
131 3         26                       $i_am_mad++;
132                               }
133                           } else {
134 3         46                   $current_second = time;
135 3         25                   $current_second_count = 0;
136 3 50       33                   $i_am_mad-- if $i_am_mad>0;
137                           }
138 46 100       505               if ($i_am_mad>0){
139             #require Carp;
140             #Carp::cluck("SLEEEEEEEEPIIIIIIIIIIINGGGGGGGGGGG");
141 22         2356905                   Time::HiRes::sleep(0.1);
142                           }
143                       }
144 46         1341 $ret;
145 1         501 };
146                   }
147                 }
148              
149 48 100 100     2002     if (!$matcher or 'cpan_home keep_source_where build_dir' =~ /$matcher/){
150 4         68         $CPAN::Frontend->myprint($prompts{config_intro});
151              
152 4 100 100     169         if (!$matcher or 'cpan_home' =~ /$matcher/) {
153 2   33     28             my $cpan_home = $CPAN::Config->{cpan_home}
154                             || File::Spec->catdir($ENV{HOME}, ".cpan");
155              
156 2 50       68             if (-d $cpan_home) {
157 2         33                 $CPAN::Frontend->myprint(qq{
158            
159             I see you already have a directory
160             $cpan_home
161             Shall we use it as the general CPAN build and cache directory?
162            
163             });
164                         } else {
165             # no cpan-home, must prompt and get one
166 0         0                 $CPAN::Frontend->myprint($prompts{cpan_home_where});
167                         }
168              
169 2         23             $default = $cpan_home;
170 2         43             while ($ans = prompt("CPAN build and cache directory?",$default)) {
171 2 50       95                 unless (File::Spec->file_name_is_absolute($ans)) {
172 0         0                     require Cwd;
173 0         0                     my $cwd = Cwd::cwd();
174 0         0                     my $absans = File::Spec->catdir($cwd,$ans);
175 0         0                     $CPAN::Frontend->mywarn("The path '$ans' is not an ".
176                                                         "absolute path. Please specify ".
177                                                         "an absolute path\n");
178 0         0                     $default = $absans;
179 0         0                     next;
180                             }
181 2         182                 eval { File::Path::mkpath($ans); }; # dies if it can't
  2         118  
182 2 50       11761                 if ($@) {
183 0         0                     $CPAN::Frontend->mywarn("Couldn't create directory $ans.\n".
184                                                         "Please retry.\n");
185 0         0                     next;
186                             }
187 2 50 33     79                 if (-d $ans && -w _) {
188 2         20                     last;
189                             } else {
190 0         0                     $CPAN::Frontend->mywarn("Couldn't find directory $ans\n".
191                                                         "or directory is not writable. Please retry.\n");
192                             }
193                         }
194 2         26             $CPAN::Config->{cpan_home} = $ans;
195                     }
196              
197 4 100 100     108         if (!$matcher or 'keep_source_where' =~ /$matcher/) {
198 2         72             my_dflt_prompt("keep_source_where",
199                                        File::Spec->catdir($CPAN::Config->{cpan_home},"sources"),
200                                        $matcher,
201                                       );
202                     }
203              
204 4 100 100     109         if (!$matcher or 'build_dir' =~ /$matcher/) {
205 2         39             my_dflt_prompt("build_dir",
206                                        File::Spec->catdir($CPAN::Config->{cpan_home},"build"),
207                                        $matcher
208                                       );
209                     }
210                 }
211              
212             #
213             #= Cache size, Index expire
214             #
215              
216 48 100 100     1422     if (!$matcher or 'build_cache' =~ /$matcher/){
217 2         32         $CPAN::Frontend->myprint($prompts{build_cache_intro});
218              
219             # large enough to build large dists like Tk
220 2         27         my_dflt_prompt(build_cache => 100, $matcher);
221                 }
222              
223 48 100 100     1435     if (!$matcher or 'index_expire' =~ /$matcher/) {
224 2         268         $CPAN::Frontend->myprint($prompts{index_expire_intro});
225              
226 2         27         my_dflt_prompt(index_expire => 1, $matcher);
227                 }
228              
229 48 100 100     1258     if (!$matcher or 'scan_cache' =~ /$matcher/){
230 2         82         $CPAN::Frontend->myprint($prompts{scan_cache_intro});
231              
232 2         49         my_prompt_loop(scan_cache => 'atstart', $matcher, 'atstart|never');
233                 }
234              
235             #
236             #= cache_metadata
237             #
238              
239 48         528     my_yn_prompt(cache_metadata => 1, $matcher);
240              
241             #
242             #= Do we follow PREREQ_PM?
243             #
244              
245 48 100 100     1219     if (!$matcher or 'prerequisites_policy' =~ /$matcher/){
246 2         31         $CPAN::Frontend->myprint($prompts{prerequisites_policy_intro});
247              
248 2         51         my_prompt_loop(prerequisites_policy => 'ask', $matcher,
249                                    'follow|ask|ignore');
250                 }
251              
252             #
253             #= Module::Signature
254             #
255 48 100 100     1112     if (!$matcher or 'check_sigs' =~ /$matcher/) {
256 2         23         my_yn_prompt(check_sigs => 0, $matcher);
257                 }
258              
259             #
260             #= CPAN::Reporter
261             #
262 48 100 100     1272     if (!$matcher or 'test_report' =~ /$matcher/) {
263 2         22         my_yn_prompt(test_report => 0, $matcher);
264 2 50 33     31         if (
      33        
265                         $CPAN::Config->{test_report} &&
266                         $CPAN::META->has_inst("CPAN::Reporter") &&
267                         CPAN::Reporter->can('configure')
268                        ) {
269 0         0             $CPAN::Frontend->myprint("\nProceeding to configure CPAN::Reporter.\n");
270 0         0             CPAN::Reporter::configure();
271 0         0             $CPAN::Frontend->myprint("\nReturning to CPAN configuration.\n");
272                     }
273                 }
274              
275             #
276             #= External programs
277             #
278              
279 48         751     my @external_progs = qw/bzip2 gzip tar unzip make
280             curl lynx wget ncftpget ncftp ftp
281             gpg/;
282 48         873     my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'};
283 48 100 100     3262     if (!$matcher or "@external_progs" =~ /$matcher/) {
284 13         209         $CPAN::Frontend->myprint($prompts{external_progs});
285              
286 13         187         my $old_warn = $^W;
287 13 50       167         local $^W if $^O eq 'MacOS';
288 13         138         local $^W = $old_warn;
289 13         106         my $progname;
290 13         118         for $progname (@external_progs) {
291 156 100 100     2443             next if $matcher && $progname !~ /$matcher/;
292 24 50       280             if ($^O eq 'MacOS') {
293 0         0                 $CPAN::Config->{$progname} = 'not_here';
294 0         0                 next;
295                         }
296              
297 24         211             my $progcall = $progname;
298 24 100