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