File Coverage

lib/CPAN/HandleConfig.pm
Criterion Covered Total %
statement 123 236 52.1
branch 51 132 38.6
condition 13 74 17.6
subroutine 16 20 80.0
pod 1 13 7.7
total 204 475 42.9


line stmt bran cond sub pod time code
1             package CPAN::HandleConfig;
2 8     8   171 use strict;
  8         127  
  8         282  
3 8     8   124 use vars qw(%can %keys $VERSION);
  8         76  
  8         417  
4              
5             $VERSION = sprintf "%.6f", substr(q$Rev: 847 $,4)/1000000 + 5.4;
6              
7             %can = (
8                     commit => "Commit changes to disk",
9                     defaults => "Reload defaults from disk",
10                     help => "Short help about 'o conf' usage",
11                     init => "Interactive setting of all options",
12             );
13              
14             %keys = map { $_ => undef } (
15             # allow_unauthenticated ?? some day...
16                                          "build_cache",
17                                          "build_dir",
18                                          "bzip2",
19                                          "cache_metadata",
20                                          "check_sigs",
21                                          "colorize_output",
22                                          "colorize_print",
23                                          "colorize_warn",
24                                          "commandnumber_in_prompt",
25                                          "commands_quote",
26                                          "cpan_home",
27                                          "curl",
28                                          "dontload_hash", # deprecated after 1.83_68 (rev. 581)
29                                          "dontload_list",
30                                          "ftp",
31                                          "ftp_passive",
32                                          "ftp_proxy",
33                                          "getcwd",
34                                          "gpg",
35                                          "gzip",
36                                          "histfile",
37                                          "histsize",
38                                          "http_proxy",
39                                          "inactivity_timeout",
40                                          "index_expire",
41                                          "inhibit_startup_message",
42                                          "keep_source_where",
43                                          "lynx",
44                                          "make",
45                                          "make_arg",
46                                          "make_install_arg",
47                                          "make_install_make_command",
48                                          "makepl_arg",
49                                          "mbuild_arg",
50                                          "mbuild_install_arg",
51                                          "mbuild_install_build_command",
52                                          "mbuildpl_arg",
53                                          "ncftp",
54                                          "ncftpget",
55                                          "no_proxy",
56                                          "pager",
57                                          "password",
58                                          "prefer_installer",
59                                          "prerequisites_policy",
60                                          "proxy_pass",
61                                          "proxy_user",
62                                          "scan_cache",
63                                          "shell",
64                                          "show_upload_date",
65                                          "tar",
66                                          "term_is_latin",
67                                          "term_ornaments",
68                                          "test_report",
69                                          "unzip",
70                                          "urllist",
71                                          "username",
72                                          "wait_list",
73                                          "wget",
74                                         );
75             if ($^O eq "MSWin32") {
76                 for my $k (qw(
77             mbuild_install_build_command
78             make_install_make_command
79             )) {
80                     delete $keys{$k};
81                     if (exists $CPAN::Config->{$k}) {
82                         for ("deleting previously set config variable '$k' => '$CPAN::Config->{$k}'") {
83                             $CPAN::Frontend ? $CPAN::Frontend->mywarn($_) : warn $_;
84                         }
85                         delete $CPAN::Config->{$k};
86                     }
87                 }
88             }
89              
90             # returns true on successful action
91             sub edit {
92 66     66 0 845     my($self,@args) = @_;
93 66 50       1013     return unless @args;
94 66         3051     CPAN->debug("self[$self]args[".join(" | ",@args)."]");
95 66         595     my($o,$str,$func,$args,$key_exists);
96 66         626     $o = shift @args;
97 66         743     $DB::single = 1;
98 66 100       1160     if($can{$o}) {
99 54         6223 $self->$o(args => \@args); # o conf init => sub init => sub load
100 54         1464 return 1;
101                 } else {
102 12 50       204         CPAN->debug("o[$o]") if $CPAN::DEBUG;
103 12 50       173         unless (exists $keys{$o}) {
104 0         0             $CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n");
105                     }
106 12 100       264 if ($o =~ /list$/) {
    50          
107 2         18 $func = shift @args;
108 2   50     24 $func ||= "";
109 2 50       23             CPAN->debug("func[$func]") if $CPAN::DEBUG;
110 2         18             my $changed;
111             # Let's avoid eval, it's easier to comprehend without.
112 2 50       162 if ($func eq "push") {
    50          
    50          
    50          
    50          
    50          
113 0         0 push @{$CPAN::Config->{$o}}, @args;
  0         0  
114 0         0                 $changed = 1;
115             } elsif ($func eq "pop") {
116 0         0 pop @{$CPAN::Config->{$o}};
  0         0  
117 0         0                 $changed = 1;
118             } elsif ($func eq "shift") {
119 0         0 shift @{$CPAN::Config->{$o}};
  0         0  
120 0         0                 $changed = 1;
121             } elsif ($func eq "unshift") {
122 0         0 unshift @{$CPAN::Config->{$o}}, @args;
  0         0  
123 0         0                 $changed = 1;
124             } elsif ($func eq "splice") {
125 0         0 splice @{$CPAN::Config->{$o}}, @args;
  0         0  
126 0         0                 $changed = 1;
127             } elsif (@args) {
128 0         0 $CPAN::Config->{$o} = [@args];
129 0         0                 $changed = 1;
130             } else {
131 2         95                 $self->prettyprint($o);
132             }
133 2 50       27             if ($changed) {
134 0 0       0                 if ($o eq "urllist") {
    0          
135             # reset the cached values
136 0         0                     undef $CPAN::FTP::Thesite;
137 0         0                     undef $CPAN::FTP::Themethod;
138                             } elsif ($o eq "dontload_list") {
139             # empty it, it will be built up again
140 0         0                     $CPAN::META->{dontload_hash} = {};
141                             }
142                         }
143 2         34             return $changed;
144                     } elsif ($o =~ /_hash$/) {
145 0 0 0     0             @args = () if @args==1 && $args[0] eq "";
146 0 0       0             push @args, "" if @args % 2;
147 0         0             $CPAN::Config->{$o} = { @args };
148                     } else {
149 10 100       359 $CPAN::Config->{$o} = $args[0] if defined $args[0];
150 10         232 $self->prettyprint($o);
151 10         266             return 1;
152             }
153                 }
154             }
155              
156             sub prettyprint {
157 61     61 0 704   my($self,$k) = @_;
158 61         731   my $v = $CPAN::Config->{$k};
159 61 100       668   if (ref $v) {
    50          
160 4         34     my(@report);
161 4 50       110     if (ref $v eq "ARRAY") {
162 0         0       @report = map {"\t[$_]\n"} @$v;
  0         0  
163                 } else {
164 0         0       @report = map { sprintf("\t%-18s => %s\n",
  0         0  
165 0 0       0                               map { "[$_]" } $_,
166                                           defined $v->{$_} ? $v->{$_} : "UNDEFINED"
167                                          )} keys %$v;
168                 }
169 4         101     $CPAN::Frontend->myprint(
170                                          join(
171                                               "",
172                                               sprintf(
173                                                       " %-18s\n",
174                                                       $k
175                                                      ),
176                                               @report
177                                              )
178                                         );
179               } elsif (defined $v) {
180 57         1095     $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
181               } else {
182 0         0     $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, "UNDEFINED");
183               }
184             }
185              
186             sub commit {
187 3     3 0 52     my($self,@args) = @_;
188 3         27     my $configpm;
189 3 50       48     if (@args) {
190 0 100       0       if ($args[0] eq "args") {
191             # we have not signed that contract
192                   } else {
193 1         12         $configpm = $args[0];
194                   }
195                 }
196 3 100       33     unless (defined $configpm){
197 2   33     63 $configpm ||= $INC{"CPAN/MyConfig.pm"};
198 2   33     22 $configpm ||= $INC{"CPAN/Config.pm"};
199 2 50       23 $configpm || Carp::confess(q{
200             CPAN::Config::commit called without an argument.
201             Please specify a filename where to save the configuration or try
202             "o conf init" to have an interactive course through configing.
203             });
204                 }
205 3         25     my($mode);
206 3 50       140     if (-f $configpm) {
207 3         199 $mode = (stat $configpm)[2];
208 3 50 33     110 if ($mode && ! -w _) {
209 0         0 Carp::confess("$configpm is not writable");
210             }
211                 }
212              
213 3         26     my $msg;
214 3 50       68     $msg = <<EOF unless $configpm =~ /MyConfig/;
215            
216             # This is CPAN.pm's systemwide configuration file. This file provides
217             # defaults for users, and the values can be changed in a per-user
218             # configuration file. The user-config file is being looked for as
219             # ~/.cpan/CPAN/MyConfig.pm.
220            
221             EOF
222 3   50     35     $msg ||= "\n";
223 3         180     my($fh) = FileHandle->new;
224 3 50       843     rename $configpm, "$configpm~" if -f $configpm;
225 3 50       282     open $fh, ">$configpm" or
226                     $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
227 3         118     $fh->print(qq[$msg\$CPAN::Config = \{\n]);
228 3         426     foreach (sort keys %$CPAN::Config) {
229 147 50       3137         unless (exists $keys{$_}) {
230 0         0             $CPAN::Frontend->mywarn("Dropping unknown config variable '$_'\n");
231 0         0             delete $CPAN::Config->{$_};
232 0         0             next;
233                     }
234             $fh->print(
235 147         5003 " '$_' => ",
236             $self->neatvalue($CPAN::Config->{$_}),
237             ",\n"
238             );
239                 }
240              
241 3         145     $fh->print("};\n1;\n__END__\n");
242 3         327     close $fh;
243              
244             #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
245             #chmod $mode, $configpm;
246             ###why was that so? $self->defaults;
247 3         87     $CPAN::Frontend->myprint("commit: wrote '$configpm'\n");
248 3         45     1;
249             }
250              
251             # stolen from MakeMaker; not taking the original because it is buggy;
252             # bugreport will have to say: keys of hashes remain unquoted and can
253             # produce syntax errors
254             sub neatvalue {
255 147     147 0 1425     my($self, $v) = @_;
256 147 50       1327     return "undef" unless defined $v;
257 147         1320     my($t) = ref $v;
258 147 100       3635     return "q[$v]" unless $t;
259 6 50       65     if ($t eq 'ARRAY') {
260 6         49         my(@m, @neat);
261 6         55         push @m, "[";
262 6         134         foreach my $elem (@$v) {
263 6         154             push @neat, "q[$elem]";
264                     }
265 6         67         push @m, join ", ", @neat;
266 6         52         push @m, "]";
267 6         88         return join "", @m;
268                 }
269 0 0       0     return "$v" unless $t eq 'HASH';
270 0         0     my(@m, $key, $val);
271 0         0     while (($key,$val) = each %$v){
272 0 0       0         last unless defined $key; # cautious programming in case (undef,undef) is true
273 0         0         push(@m,"q[$key]=>".$self->neatvalue($val)) ;
274                 }
275 0         0     return "{ ".join(', ',@m)." }";
276             }
277              
278             sub defaults {
279 3     3 0 31     my($self) = @_;
280 3         553     my $done;
281 3         43     for my $config (qw(CPAN/MyConfig.pm CPAN/Config.pm)) {
282 3 50       39         if ($INC{$config}) {
283 3         79             CPAN::Shell->reload_this($config);
284 3         533             $CPAN::Frontend->myprint("'$INC{$config}' reread\n");
285 3         83             last;
286                     }
287                 }
288 3         88     1;
289             }
290              
291             =head2 C<< CLASS->safe_quote ITEM >>
292            
293             Quotes an item to become safe against spaces
294             in shell interpolation. An item is enclosed
295             in double quotes if:
296            
297             - the item contains spaces in the middle
298             - the item does not start with a quote
299            
300             This happens to avoid shell interpolation
301             problems when whitespace is present in
302             directory names.
303            
304             This method uses C<commands_quote> to determine
305             the correct quote. If C<commands_quote> is
306             a space, no quoting will take place.
307            
308            
309             if it starts and ends with the same quote character: leave it as it is
310            
311             if it contains no whitespace: leave it as it is
312            
313             if it contains whitespace, then
314            
315             if it contains quotes: better leave it as it is
316            
317             else: quote it with the correct quote type for the box we're on
318            
319             =cut
320              
321             {
322             # Instead of patching the guess, set commands_quote
323             # to the right value
324                 my ($quotes,$use_quote)
325                     = $^O eq 'MSWin32'
326                         ? ('"', '"')
327                             : (q<"'>, "'")
328                                 ;
329              
330                 sub safe_quote {
331 30     30 1 1191         my ($self, $command) = @_;
332             # Set up quote/default quote
333 30   33     1701         my $quote = $CPAN::Config->{commands_quote} || $quotes;
334              
335 30 50 33     1183         if ($quote ne ' '
      33        
336                         and $command =~ /\s/
337                         and $command !~ /[$quote]/) {
338 0         0             return qq<$use_quote$command$use_quote>
339                     }
340 30         834         return $command;
341                 }
342             }
343              
344             sub init {
345 48     48 0 652     my($self,@args) = @_;
346 48         580     undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
347             # have the least
348             # important
349             # variable
350             # undefined
351 48         590     $self->load(@args);
352 48         650     1;
353             }
354              
355             # This is a piece of repeated code that is abstracted here for
356             # maintainability. RMB
357             #
358             sub _configpmtest {
359 0     0   0     my($configpmdir, $configpmtest) = @_;
360 0 0       0     if (-w $configpmtest) {
    0          
361 0         0         return $configpmtest;
362                 } elsif (-w $configpmdir) {
363             #_#_# following code dumped core on me with 5.003_11, a.k.
364 0         0         my $configpm_bak = "$configpmtest.bak";
365 0 0       0         unlink $configpm_bak if -f $configpm_bak;
366 0 0       0         if( -f $configpmtest ) {
367 0 0       0             if( rename $configpmtest, $configpm_bak ) {
368 0         0 $CPAN::Frontend->mywarn(<<END);
369             Old configuration file $configpmtest
370             moved to $configpm_bak
371             END
372             }
373             }
374 0         0 my $fh = FileHandle->new;
375 0 0       0 if ($fh->open(">$configpmtest")) {
376 0         0 $fh->print("1;\n");
377 0         0 return $configpmtest;
378             } else {
379             # Should never happen
380 0         0 Carp::confess("Cannot open >$configpmtest");
381             }
382 0         0     } else { return }
383             }
384              
385             sub require_myconfig_or_config () {
386 107 50   107 0 1402     return if $INC{"CPAN/MyConfig.pm"};
387 0         0     local @INC = @INC;
388 0         0     my $home = home();
389 0         0     unshift @INC, File::Spec->catdir($home,'.cpan');
390 0         0     eval { require CPAN::MyConfig };
  0         0  
391 0         0     my $err_myconfig = $@;
392 0 0 0     0     if ($err_myconfig and $err_myconfig !~ m#locate CPAN/MyConfig\.pm#) {
393 0         0         die "Error while requiring CPAN::MyConfig:\n$err_myconfig";
394                 }
395 0 0       0     unless ($INC{"CPAN/MyConfig.pm"}) { # this guy has settled his needs already
396 0         0       eval {require CPAN::Config;}; # not everybody has one
  0         0  
397 0         0       my $err_config = $@;
398 0 0 0     0       if ($err_config and $err_config !~ m#locate CPAN/Config\.pm#) {
399 0         0           die "Error while requiring CPAN::Config:\n$err_config";
400                   }
401                 }
402             }
403              
404             sub home () {
405 0     0 0 0     my $home;
406 0 0       0     if ($CPAN::META->has_usable("File::HomeDir")) {
407 0         0         $home = File::HomeDir->my_data;
408                 } else {
409 0         0         $home = $ENV{HOME};
410                 }
411 0         0     $home;
412             }
413              
414             sub load {
415 59     59 0 833     my($self, %args) = @_;
416 59 50       6153 $CPAN::Be_Silent++ if $args{be_silent};
417              
418 59         1362     my(@miss);
419 8     8   229     use Carp;
  8         127  
  8         945  
420 59         675     require_myconfig_or_config;
421 59 100       1053     return unless @miss = $self->missing_config_data;
422              
423 48         973     require CPAN::FirstTime;
424 48         496     my($configpm,$fh,$redo,$theycalled);
425 48   50     762     $redo ||= "";
426 48 50 33     1127     $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
427 48 50 33     3392     if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
    50 33        
428 0         0 $configpm = $INC{"CPAN/Config.pm"};
429 0         0 $redo++;
430                 } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
431 48         691 $configpm = $INC{"CPAN/MyConfig.pm"};
432 48         421 $redo++;
433                 } else {
434 0         0 my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
435 0         0 my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
436 0         0 my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
437 0         0         my $inc_key;
438 0 0 0     0 if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
439 0         0 $configpm = _configpmtest($configpmdir,$configpmtest);
440 0         0             $inc_key = "CPAN/Config.pm";
441             }
442 0 0       0 unless ($configpm) {
443 0         0 $configpmdir = File::Spec->catdir(home,".cpan","CPAN");
444 0         0 File::Path::mkpath($configpmdir);
445 0         0 $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
446 0         0 $configpm = _configpmtest($configpmdir,$configpmtest);
447 0         0             $inc_key = "CPAN/MyConfig.pm";
448             }
449 0 0       0         if ($configpm) {
450 0         0           $INC{$inc_key} = $configpm;
451                     } else {
452 0         0           my $text = qq{WARNING: CPAN.pm is unable to } .
453                           qq{create a configuration file.};
454 0         0           output($text, 'confess');
455                     }
456              
457                 }
458 48         470     local($") = ", ";
459 48 50 33     643     if ($redo && ! $theycalled){
460 0         0         $CPAN::Frontend->myprint(<<END);
461             Sorry, we have to rerun the configuration dialog for CPAN.pm due to
462             the following indispensable but missing parameters:
463            
464             @miss
465             END
466 0         0         $args{args} = \@miss;
467                 }
468 48         389     if (0) {
469             # where do we need this?
470                     $CPAN::Frontend->myprint(qq{
471             $configpm initialized.
472             });
473                 }
474 48         795     CPAN::FirstTime::init($configpm, %args);
475             }
476              
477             sub missing_config_data {
478 59     59 0 513     my(@miss);
479 59         979     for (
480                      "build_cache",
481                      "build_dir",
482                      "cache_metadata",
483                      "cpan_home",
484                      "ftp_proxy",
485             #"gzip",
486                      "http_proxy",
487                      "index_expire",
488                      "inhibit_startup_message",
489                      "keep_source_where",
490             #"make",
491                      "make_arg",
492                      "make_install_arg",
493                      "makepl_arg",
494                      "mbuild_arg",
495                      "mbuild_install_arg",
496                      "mbuild_install_build_command",
497                      "mbuildpl_arg",
498                      "no_proxy",
499             #"pager",
500                      "prerequisites_policy",
501                      "scan_cache",
502             #"tar",
503             #"unzip",
504                      "urllist",
505                     ) {
506 1180 50       13145         next unless exists $keys{$_};
507 1180 100       21502 push @miss, $_ unless defined $CPAN::Config->{$_};
508                 }
509 59         960     return @miss;
510             }
511              
512             sub help {
513 1     1 0 19     $CPAN::Frontend->myprint(q[
514             Known options:
515             commit commit session changes to disk
516             defaults reload default config values from disk
517             help this help
518             init enter a dialog to set all or a set of parameters
519            
520             Edit key values as in the following (the "o" is a literal letter o):
521             o conf build_cache 15
522             o conf build_dir "/foo/bar"
523             o conf urllist shift
524             o conf urllist unshift ftp://ftp.foo.bar/
525             o conf inhibit_startup_message 1
526            
527             ]);
528 1         13     undef; #don't reprint CPAN::Config
529             }
530              
531             sub cpl {
532 0     0 0       my($word,$line,$pos) = @_;
533 0   0           $word ||= "";
534 0 0             CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
535 0               my(@words) = split " ", substr($line,0,$pos+1);
536 0 0 0           if (
    0 0        
    0 0        
      0        
      0        
      0        
      0        
      0        
537             defined($words[2])
538             and
539                     $words[2] =~ /list$/
540                     and
541             (
542             @words == 3
543             ||
544             @words == 4 && length($word)
545             )
546                    ) {
547 0           return grep /^\Q$word\E/, qw(splice shift unshift pop push);
548                 } elsif (defined($words[2])
549                          and
550                          $words[2] eq "init"
551                          and
552                         (
553                          @words == 3
554                          ||
555                          @words >= 4 && length($word)
556                         )) {
557 0           return sort grep /^\Q$word\E/, keys %keys;
558                 } elsif (@words >= 4) {
559 0           return ();
560                 }
561 0               my %seen;
562 0               my(@o_conf) = sort grep { !$seen{$_}++ }
  0            
563                     keys %can,
564                         keys %$CPAN::Config,
565                             keys %keys;
566 0               return grep /^\Q$word\E/, @o_conf;
567             }
568              
569              
570             package
571                 CPAN::Config; ####::###### #hide from indexer
572             # note: J. Nick Koston wrote me that they are using
573             # CPAN::Config->commit although undocumented. I suggested
574             # CPAN::Shell->o("conf","commit") even when ugly it is at least
575             # documented
576              
577             # that's why I added the CPAN::Config class with autoload and
578             # deprecated warning
579              
580 8     8   242 use strict;
  8         198  
  8         407  
581 8     8   177 use vars qw($AUTOLOAD $VERSION);
  8         76  
  8         131  
582             $VERSION = sprintf "%.2f", substr(q$Rev: 847 $,4)/100;
583              
584             # formerly CPAN::HandleConfig was known as CPAN::Config
585             sub AUTOLOAD {
586 0     0       my($l) = $AUTOLOAD;
587 0             $CPAN::Frontend->mywarn("Dispatching deprecated method '$l' to CPAN::HandleConfig");
588 0             $l =~ s/.*:://;
589 0             CPAN::HandleConfig->$l(@_);
590             }
591              
592             1;
593              
594             __END__
595            
596             =head1 LICENSE
597            
598             This program is free software; you can redistribute it and/or
599             modify it under the same terms as Perl itself.
600            
601             =cut
602            
603             # Local Variables:
604             # mode: cperl
605             # cperl-indent-level: 4
606             # End:
607