This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
93e2a9c3f39b3bf8a317ac495044820f3c555223
[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: 657 $,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                              "build_cache",
16                              "build_dir",
17                              "bzip2",
18                              "cache_metadata",
19                              "commandnumber_in_prompt",
20                              "cpan_home",
21                              "curl",
22                              "dontload_hash", # deprecated after 1.83_68 (rev. 581)
23                              "dontload_list",
24                              "ftp",
25                              "ftp_passive",
26                              "ftp_proxy",
27                              "getcwd",
28                              "gpg",
29                              "gzip",
30                              "histfile",
31                              "histsize",
32                              "http_proxy",
33                              "inactivity_timeout",
34                              "index_expire",
35                              "inhibit_startup_message",
36                              "keep_source_where",
37                              "lynx",
38                              "make",
39                              "make_arg",
40                              "make_install_arg",
41                              "make_install_make_command",
42                              "makepl_arg",
43                              "mbuild_arg",
44                              "mbuild_install_arg",
45                              "mbuild_install_build_command",
46                              "mbuildpl_arg",
47                              "ncftp",
48                              "ncftpget",
49                              "no_proxy",
50                              "pager",
51                              "prefer_installer",
52                              "prerequisites_policy",
53                              "scan_cache",
54                              "shell",
55                              "show_upload_date",
56                              "tar",
57                              "term_is_latin",
58                              "unzip",
59                              "urllist",
60                              "wait_list",
61                              "wget",
62                             );
63 if ($^O eq "MSWin32") {
64     for my $k (qw(
65                   mbuild_install_build_command
66                   make_install_make_command
67                  )) {
68         delete $keys{$k};
69         if (exists $CPAN::Config->{$k}) {
70             for ("deleting previously set config variable '$k' => '$CPAN::Config->{$k}'") {
71                 $CPAN::Frontend ? $CPAN::Frontend->mywarn($_) : warn $_;
72             }
73             delete $CPAN::Config->{$k};
74         }
75     }
76 }
77
78 # returns true on successful action
79 sub edit {
80     my($self,@args) = @_;
81     return unless @args;
82     CPAN->debug("self[$self]args[".join(" | ",@args)."]");
83     my($o,$str,$func,$args,$key_exists);
84     $o = shift @args;
85     $DB::single = 1;
86     if($can{$o}) {
87         $self->$o(args => \@args);
88         return 1;
89     } else {
90         CPAN->debug("o[$o]") if $CPAN::DEBUG;
91         unless (exists $keys{$o}) {
92             $CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n");
93         }
94         if ($o =~ /list$/) {
95             $func = shift @args;
96             $func ||= "";
97             CPAN->debug("func[$func]") if $CPAN::DEBUG;
98             my $changed;
99             # Let's avoid eval, it's easier to comprehend without.
100             if ($func eq "push") {
101                 push @{$CPAN::Config->{$o}}, @args;
102                 $changed = 1;
103             } elsif ($func eq "pop") {
104                 pop @{$CPAN::Config->{$o}};
105                 $changed = 1;
106             } elsif ($func eq "shift") {
107                 shift @{$CPAN::Config->{$o}};
108                 $changed = 1;
109             } elsif ($func eq "unshift") {
110                 unshift @{$CPAN::Config->{$o}}, @args;
111                 $changed = 1;
112             } elsif ($func eq "splice") {
113                 splice @{$CPAN::Config->{$o}}, @args;
114                 $changed = 1;
115             } elsif (@args) {
116                 $CPAN::Config->{$o} = [@args];
117                 $changed = 1;
118             } else {
119                 $self->prettyprint($o);
120             }
121             if ($changed) {
122                 if ($o eq "urllist") {
123                     # reset the cached values
124                     undef $CPAN::FTP::Thesite;
125                     undef $CPAN::FTP::Themethod;
126                 } elsif ($o eq "dontload_list") {
127                     # empty it, it will be built up again
128                     $CPAN::META->{dontload_hash} = {};
129                 }
130             }
131             return $changed;
132         } elsif ($o =~ /_hash$/) {
133             @args = () if @args==1 && $args[0] eq "";
134             push @args, "" if @args % 2;
135             $CPAN::Config->{$o} = { @args };
136         } else {
137             $CPAN::Config->{$o} = $args[0] if defined $args[0];
138             $self->prettyprint($o);
139         }
140     }
141 }
142
143 sub prettyprint {
144   my($self,$k) = @_;
145   my $v = $CPAN::Config->{$k};
146   if (ref $v) {
147     my(@report);
148     if (ref $v eq "ARRAY") {
149       @report = map {"\t[$_]\n"} @$v;
150     } else {
151       @report = map { sprintf("\t%-18s => %s\n",
152                               map { "[$_]" } $_,
153                               defined $v->{$_} ? $v->{$_} : "UNDEFINED"
154                              )} keys %$v;
155     }
156     $CPAN::Frontend->myprint(
157                              join(
158                                   "",
159                                   sprintf(
160                                           "    %-18s\n",
161                                           $k
162                                          ),
163                                   @report
164                                  )
165                             );
166   } elsif (defined $v) {
167     $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
168   } else {
169     $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, "UNDEFINED");
170   }
171 }
172
173 sub commit {
174     my($self,@args) = @_;
175     my $configpm;
176     if (@args) {
177       if ($args[0] eq "args") {
178         # we have not signed that contract
179       } else {
180         $configpm = $args[0];
181       }
182     }
183     unless (defined $configpm){
184         $configpm ||= $INC{"CPAN/MyConfig.pm"};
185         $configpm ||= $INC{"CPAN/Config.pm"};
186         $configpm || Carp::confess(q{
187 CPAN::Config::commit called without an argument.
188 Please specify a filename where to save the configuration or try
189 "o conf init" to have an interactive course through configing.
190 });
191     }
192     my($mode);
193     if (-f $configpm) {
194         $mode = (stat $configpm)[2];
195         if ($mode && ! -w _) {
196             Carp::confess("$configpm is not writable");
197         }
198     }
199
200     my $msg;
201     $msg = <<EOF unless $configpm =~ /MyConfig/;
202
203 # This is CPAN.pm's systemwide configuration file. This file provides
204 # defaults for users, and the values can be changed in a per-user
205 # configuration file. The user-config file is being looked for as
206 # ~/.cpan/CPAN/MyConfig.pm.
207
208 EOF
209     $msg ||= "\n";
210     my($fh) = FileHandle->new;
211     rename $configpm, "$configpm~" if -f $configpm;
212     open $fh, ">$configpm" or
213         $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
214     $fh->print(qq[$msg\$CPAN::Config = \{\n]);
215     foreach (sort keys %$CPAN::Config) {
216         unless (exists $keys{$_}) {
217             $CPAN::Frontend->mywarn("Dropping unknown config variable '$_'\n");
218             delete $CPAN::Config->{$_};
219             next;
220         }
221         $fh->print(
222                    "  '$_' => ",
223                    $self->neatvalue($CPAN::Config->{$_}),
224                    ",\n"
225                   );
226     }
227
228     $fh->print("};\n1;\n__END__\n");
229     close $fh;
230
231     #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
232     #chmod $mode, $configpm;
233 ###why was that so?    $self->defaults;
234     $CPAN::Frontend->myprint("commit: wrote '$configpm'\n");
235     1;
236 }
237
238 # stolen from MakeMaker; not taking the original because it is buggy;
239 # bugreport will have to say: keys of hashes remain unquoted and can
240 # produce syntax errors
241 sub neatvalue {
242     my($self, $v) = @_;
243     return "undef" unless defined $v;
244     my($t) = ref $v;
245     return "q[$v]" unless $t;
246     if ($t eq 'ARRAY') {
247         my(@m, @neat);
248         push @m, "[";
249         foreach my $elem (@$v) {
250             push @neat, "q[$elem]";
251         }
252         push @m, join ", ", @neat;
253         push @m, "]";
254         return join "", @m;
255     }
256     return "$v" unless $t eq 'HASH';
257     my(@m, $key, $val);
258     while (($key,$val) = each %$v){
259         last unless defined $key; # cautious programming in case (undef,undef) is true
260         push(@m,"q[$key]=>".$self->neatvalue($val)) ;
261     }
262     return "{ ".join(', ',@m)." }";
263 }
264
265 sub defaults {
266     my($self) = @_;
267     my $done;
268     for my $config (qw(CPAN/MyConfig.pm CPAN/Config.pm)) {
269       CPAN::Shell->reload_this($config) and $done++;
270       last if $done;
271     }
272     1;
273 }
274
275 sub init {
276     my($self,@args) = @_;
277     undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
278                                                       # have the least
279                                                       # important
280                                                       # variable
281                                                       # undefined
282     $self->load(@args);
283     1;
284 }
285
286 # This is a piece of repeated code that is abstracted here for
287 # maintainability.  RMB
288 #
289 sub _configpmtest {
290     my($configpmdir, $configpmtest) = @_; 
291     if (-w $configpmtest) {
292         return $configpmtest;
293     } elsif (-w $configpmdir) {
294         #_#_# following code dumped core on me with 5.003_11, a.k.
295         my $configpm_bak = "$configpmtest.bak";
296         unlink $configpm_bak if -f $configpm_bak;
297         if( -f $configpmtest ) {
298             if( rename $configpmtest, $configpm_bak ) {
299                                 $CPAN::Frontend->mywarn(<<END);
300 Old configuration file $configpmtest
301     moved to $configpm_bak
302 END
303             }
304         }
305         my $fh = FileHandle->new;
306         if ($fh->open(">$configpmtest")) {
307             $fh->print("1;\n");
308             return $configpmtest;
309         } else {
310             # Should never happen
311             Carp::confess("Cannot open >$configpmtest");
312         }
313     } else { return }
314 }
315
316 sub require_myconfig_or_config () {
317     return if $INC{"CPAN/MyConfig.pm"};
318     local @INC = @INC;
319     my $home = home();
320     unshift @INC, File::Spec->catdir($home,'.cpan');
321     eval { require CPAN::MyConfig };
322     unless ($INC{"CPAN/MyConfig.pm"}) { # this guy has settled his needs already
323       eval {require CPAN::Config;}; # not everybody has one
324     }
325 }
326
327 sub home () {
328     my $home;
329     if ($CPAN::META->has_usable("File::HomeDir")) {
330         $home = File::HomeDir->my_data;
331     } else {
332         $home = $ENV{HOME};
333     }
334     $home;
335 }
336
337 sub load {
338     my($self, %args) = @_;
339         $CPAN::Be_Silent++ if $args{be_silent};
340
341     my(@miss);
342     use Carp;
343     require_myconfig_or_config;
344     return unless @miss = $self->missing_config_data;
345
346     require CPAN::FirstTime;
347     my($configpm,$fh,$redo,$theycalled);
348     $redo ||= "";
349     $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
350     if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
351         $configpm = $INC{"CPAN/Config.pm"};
352         $redo++;
353     } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
354         $configpm = $INC{"CPAN/MyConfig.pm"};
355         $redo++;
356     } else {
357         my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
358         my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
359         my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
360         my $inc_key;
361         if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
362             $configpm = _configpmtest($configpmdir,$configpmtest);
363             $inc_key = "CPAN/Config.pm";
364         }
365         unless ($configpm) {
366             $configpmdir = File::Spec->catdir(home,".cpan","CPAN");
367             File::Path::mkpath($configpmdir);
368             $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
369             $configpm = _configpmtest($configpmdir,$configpmtest);
370             $inc_key = "CPAN/MyConfig.pm";
371         }
372         if ($configpm) {
373           $INC{$inc_key} = $configpm;
374         } else {
375           my $text = qq{WARNING: CPAN.pm is unable to } .
376               qq{create a configuration file.};
377           output($text, 'confess');
378         }
379
380     }
381     local($") = ", ";
382     $CPAN::Frontend->myprint(<<END) if $redo && ! $theycalled;
383 Sorry, we have to rerun the configuration dialog for CPAN.pm due to
384 the following indispensable but missing parameters:
385
386 @miss
387 END
388     $CPAN::Frontend->myprint(qq{
389 $configpm initialized.
390 });
391
392     sleep 2;
393     CPAN::FirstTime::init($configpm, %args);
394 }
395
396 sub missing_config_data {
397     my(@miss);
398     for (
399          "build_cache",
400          "build_dir",
401          "cache_metadata",
402          "cpan_home",
403          "ftp_proxy",
404          "gzip",
405          "http_proxy",
406          "index_expire",
407          "inhibit_startup_message",
408          "keep_source_where",
409          "make",
410          "make_arg",
411          "make_install_arg",
412          "makepl_arg",
413          "mbuild_arg",
414          "mbuild_install_arg",
415          "mbuild_install_build_command",
416          "mbuildpl_arg",
417          "no_proxy",
418          "pager",
419          "prerequisites_policy",
420          "scan_cache",
421          "tar",
422          "unzip",
423          "urllist",
424         ) {
425         next unless exists $keys{$_};
426         push @miss, $_ unless defined $CPAN::Config->{$_};
427     }
428     return @miss;
429 }
430
431 sub help {
432     $CPAN::Frontend->myprint(q[
433 Known options:
434   commit    commit session changes to disk
435   defaults  reload default config values from disk
436   help      this help
437   init      go through a dialog to set all parameters
438
439 Edit key values as in the following (the "o" is a literal letter o):
440   o conf build_cache 15
441   o conf build_dir "/foo/bar"
442   o conf urllist shift
443   o conf urllist unshift ftp://ftp.foo.bar/
444   o conf inhibit_startup_message 1
445
446 ]);
447     undef; #don't reprint CPAN::Config
448 }
449
450 sub cpl {
451     my($word,$line,$pos) = @_;
452     $word ||= "";
453     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
454     my(@words) = split " ", substr($line,0,$pos+1);
455     if (
456         defined($words[2])
457         and
458         (
459          $words[2] =~ /list$/ && @words == 3
460          ||
461          $words[2] =~ /list$/ && @words == 4 && length($word)
462         )
463        ) {
464         return grep /^\Q$word\E/, qw(splice shift unshift pop push);
465     } elsif (@words >= 4) {
466         return ();
467     }
468     my %seen;
469     my(@o_conf) =  sort grep { !$seen{$_}++ }
470         keys %can,
471             keys %$CPAN::Config,
472                 keys %keys;
473     return grep /^\Q$word\E/, @o_conf;
474 }
475
476
477 package
478     CPAN::Config; ####::###### #hide from indexer
479 # note: J. Nick Koston wrote me that they are using
480 # CPAN::Config->commit although undocumented. I suggested
481 # CPAN::Shell->o("conf","commit") even when ugly it is at least
482 # documented
483
484 # that's why I added the CPAN::Config class with autoload and
485 # deprecated warning
486
487 use strict;
488 use vars qw($AUTOLOAD $VERSION);
489 $VERSION = sprintf "%.2f", substr(q$Rev: 657 $,4)/100;
490
491 # formerly CPAN::HandleConfig was known as CPAN::Config
492 sub AUTOLOAD {
493   my($l) = $AUTOLOAD;
494   $CPAN::Frontend->mywarn("Dispatching deprecated method '$l' to CPAN::HandleConfig");
495   $l =~ s/.*:://;
496   CPAN::HandleConfig->$l(@_);
497 }
498
499 1;
500
501 __END__
502 # Local Variables:
503 # mode: cperl
504 # cperl-indent-level: 4
505 # End: