File Coverage

blib/lib/CPAN/HandleConfig.pm
Criterion Covered Total %
statement 65 286 22.7
branch 16 166 9.6
condition 7 107 6.5
subroutine 13 29 44.8
pod 1 16 6.2
total 102 604 16.8


line stmt bran cond sub pod time code
1             package CPAN::HandleConfig;
2 14     14   558 use strict;
  14         30  
  14         474  
3 14     14   75 use vars qw(%can %keys $loading $VERSION);
  14         24  
  14         841  
4 14     14   82 use File::Path ();
  14         62  
  14         259  
5 14     14   70 use File::Spec ();
  14         49  
  14         241  
6 14     14   74 use File::Basename ();
  14         35  
  14         264  
7 14     14   126 use Carp ();
  14         30  
  14         56420  
8              
9             =head1 NAME
10              
11             CPAN::HandleConfig - internal configuration handling for CPAN.pm
12              
13             =cut
14              
15             $VERSION = "5.5012"; # see also CPAN::Config::VERSION at end of file
16              
17             %can = (
18             commit => "Commit changes to disk",
19             defaults => "Reload defaults from disk",
20             help => "Short help about 'o conf' usage",
21             init => "Interactive setting of all options",
22             );
23              
24             # Q: where is the "How do I add a new config option" HOWTO?
25             # A1: svn diff -r 757:758 # where dagolden added test_report [git e997b71de88f1019a1472fc13cb97b1b7f96610f]
26             # A2: svn diff -r 985:986 # where andk added yaml_module [git 312b6d9b12b1bdec0b6e282d853482145475021f]
27             # A3: 1. add new config option to %keys below
28             # 2. add a Pod description in CPAN::FirstTime in the DESCRIPTION
29             # section; it should include a prompt line; see others for
30             # examples
31             # 3. add a "matcher" section in CPAN::FirstTime::init that includes
32             # a prompt function; see others for examples
33             # 4. add config option to documentation section in CPAN.pm
34              
35             %keys = map { $_ => undef }
36             (
37             "allow_installing_module_downgrades",
38             "allow_installing_outdated_dists",
39             "applypatch",
40             "auto_commit",
41             "build_cache",
42             "build_dir",
43             "build_dir_reuse",
44             "build_requires_install_policy",
45             "bzip2",
46             "cache_metadata",
47             "check_sigs",
48             "cleanup_after_install",
49             "colorize_debug",
50             "colorize_output",
51             "colorize_print",
52             "colorize_warn",
53             "commandnumber_in_prompt",
54             "commands_quote",
55             "connect_to_internet_ok",
56             "cpan_home",
57             "curl",
58             "dontload_hash", # deprecated after 1.83_68 (rev. 581)
59             "dontload_list",
60             "ftp",
61             "ftp_passive",
62             "ftp_proxy",
63             "ftpstats_size",
64             "ftpstats_period",
65             "getcwd",
66             "gpg",
67             "gzip",
68             "halt_on_failure",
69             "histfile",
70             "histsize",
71             "http_proxy",
72             "inactivity_timeout",
73             "index_expire",
74             "inhibit_startup_message",
75             "keep_source_where",
76             "load_module_verbosity",
77             "lynx",
78             "make",
79             "make_arg",
80             "make_install_arg",
81             "make_install_make_command",
82             "makepl_arg",
83             "mbuild_arg",
84             "mbuild_install_arg",
85             "mbuild_install_build_command",
86             "mbuildpl_arg",
87             "ncftp",
88             "ncftpget",
89             "no_proxy",
90             "pager",
91             "password",
92             "patch",
93             "patches_dir",
94             "perl5lib_verbosity",
95             "plugin_list",
96             "prefer_external_tar",
97             "prefer_installer",
98             "prefs_dir",
99             "prerequisites_policy",
100             "proxy_pass",
101             "proxy_user",
102             "pushy_https",
103             "randomize_urllist",
104             "recommends_policy",
105             "scan_cache",
106             "shell",
107             "show_unparsable_versions",
108             "show_upload_date",
109             "show_zero_versions",
110             "suggests_policy",
111             "tar",
112             "tar_verbosity",
113             "term_is_latin",
114             "term_ornaments",
115             "test_report",
116             "trust_test_report_history",
117             "unzip",
118             "urllist",
119             "urllist_ping_verbose",
120             "urllist_ping_external",
121             "use_prompt_default",
122             "use_sqlite",
123             "username",
124             "version_timeout",
125             "wait_list",
126             "wget",
127             "yaml_load_code",
128             "yaml_module",
129             );
130              
131             my %prefssupport = map { $_ => 1 }
132             (
133             "allow_installing_module_downgrades",
134             "allow_installing_outdated_dists",
135             "build_requires_install_policy",
136             "check_sigs",
137             "make",
138             "make_install_make_command",
139             "prefer_installer",
140             "test_report",
141             );
142              
143             # returns true on successful action
144             sub edit {
145 0     0 0 0 my($self,@args) = @_;
146 0 0       0 return unless @args;
147 0         0 CPAN->debug("self[$self]args[".join(" | ",@args)."]");
148 0         0 my($o,$str,$func,$args,$key_exists);
149 0         0 $o = shift @args;
150 0 0       0 if($can{$o}) {
151 0         0 my $success = $self->$o(args => \@args); # o conf init => sub init => sub load
152 0 0       0 unless ($success) {
153 0         0 die "Panic: could not configure CPAN.pm for args [@args]. Giving up.";
154             }
155             } else {
156 0 0       0 CPAN->debug("o[$o]") if $CPAN::DEBUG;
157 0 0       0 unless (exists $keys{$o}) {
158 0         0 $CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n");
159             }
160 0         0 my $changed;
161              
162              
163             # one day I used randomize_urllist for a boolean, so we must
164             # list them explicitly --ak
165 0 0       0 if (0) {
    0          
166 0         0 } elsif ($o =~ /^(wait_list|urllist|dontload_list|plugin_list)$/) {
167              
168             #
169             # ARRAYS
170             #
171              
172 0         0 $func = shift @args;
173 0   0     0 $func ||= "";
174 0 0       0 CPAN->debug("func[$func]args[@args]") if $CPAN::DEBUG;
175             # Let's avoid eval, it's easier to comprehend without.
176 0 0       0 if ($func eq "push") {
    0          
    0          
    0          
    0          
    0          
177 0         0 push @{$CPAN::Config->{$o}}, @args;
  0         0  
178 0         0 $changed = 1;
179             } elsif ($func eq "pop") {
180 0         0 pop @{$CPAN::Config->{$o}};
  0         0  
181 0         0 $changed = 1;
182             } elsif ($func eq "shift") {
183 0         0 shift @{$CPAN::Config->{$o}};
  0         0  
184 0         0 $changed = 1;
185             } elsif ($func eq "unshift") {
186 0         0 unshift @{$CPAN::Config->{$o}}, @args;
  0         0  
187 0         0 $changed = 1;
188             } elsif ($func eq "splice") {
189 0   0     0 my $offset = shift @args || 0;
190 0   0     0 my $length = shift @args || 0;
191 0         0 splice @{$CPAN::Config->{$o}}, $offset, $length, @args; # may warn
  0         0  
192 0         0 $changed = 1;
193             } elsif ($func) {
194 0         0 $CPAN::Config->{$o} = [$func, @args];
195 0         0 $changed = 1;
196             } else {
197 0         0 $self->prettyprint($o);
198             }
199 0 0       0 if ($changed) {
200 0 0       0 if ($o eq "urllist") {
    0          
201             # reset the cached values
202 0         0 undef $CPAN::FTP::Thesite;
203 0         0 undef $CPAN::FTP::Themethod;
204 0         0 $CPAN::Index::LAST_TIME = 0;
205             } elsif ($o eq "dontload_list") {
206             # empty it, it will be built up again
207 0         0 $CPAN::META->{dontload_hash} = {};
208             }
209             }
210             } elsif ($o =~ /_hash$/) {
211              
212             #
213             # HASHES
214             #
215              
216 0 0 0     0 if (@args==1 && $args[0] eq "") {
    0          
217 0         0 @args = ();
218             } elsif (@args % 2) {
219 0         0 push @args, "";
220             }
221 0         0 $CPAN::Config->{$o} = { @args };
222 0         0 $changed = 1;
223             } else {
224              
225             #
226             # SCALARS
227             #
228              
229 0 0       0 if (defined $args[0]) {
230 0         0 $CPAN::CONFIG_DIRTY = 1;
231 0         0 $CPAN::Config->{$o} = $args[0];
232 0         0 $changed = 1;
233             }
234             $self->prettyprint($o)
235 0 0 0     0 if exists $keys{$o} or defined $CPAN::Config->{$o};
236             }
237 0 0       0 if ($changed) {
238 0 0       0 if ($CPAN::Config->{auto_commit}) {
239 0         0 $self->commit;
240             } else {
241 0         0 $CPAN::CONFIG_DIRTY = 1;
242 0         0 $CPAN::Frontend->myprint("Please use 'o conf commit' to ".
243             "make the config permanent!\n\n");
244             }
245             }
246             }
247             }
248              
249             sub prettyprint {
250 0     0 0 0 my($self,$k) = @_;
251 0         0 my $v = $CPAN::Config->{$k};
252 0 0       0 if (ref $v) {
    0          
253 0         0 my(@report);
254 0 0       0 if (ref $v eq "ARRAY") {
255 0         0 @report = map {"\t$_ \[$v->[$_]]\n"} 0..$#$v;
  0         0  
256             } else {
257             @report = map
258             {
259 0         0 sprintf "\t%-18s => %s\n",
260             "[$_]",
261 0 0       0 defined $v->{$_} ? "[$v->{$_}]" : "undef"
262             } sort keys %$v;
263             }
264 0         0 $CPAN::Frontend->myprint(
265             join(
266             "",
267             sprintf(
268             " %-18s\n",
269             $k
270             ),
271             @report
272             )
273             );
274             } elsif (defined $v) {
275 0         0 $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
276             } else {
277 0         0 $CPAN::Frontend->myprint(sprintf " %-18s undef\n", $k);
278             }
279             }
280              
281             # generally, this should be called without arguments so that the currently
282             # loaded config file is where changes are committed.
283             sub commit {
284 0     0 0 0 my($self,@args) = @_;
285 0 0       0 CPAN->debug("args[@args]") if $CPAN::DEBUG;
286 0 0       0 if ($CPAN::RUN_DEGRADED) {
287 0         0 $CPAN::Frontend->mydie(
288             "'o conf commit' disabled in ".
289             "degraded mode. Maybe try\n".
290             " !undef \$CPAN::RUN_DEGRADED\n"
291             );
292             }
293 0         0 my ($configpm, $must_reload);
294              
295             # XXX does anything do this? can it be simplified? -- dagolden, 2011-01-19
296 0 0       0 if (@args) {
297 0 0       0 if ($args[0] eq "args") {
298             # we have not signed that contract
299             } else {
300 0         0 $configpm = $args[0];
301             }
302             }
303              
304             # use provided name or the current config or create a new MyConfig
305 0   0     0 $configpm ||= require_myconfig_or_config() || make_new_config();
      0        
306              
307             # commit to MyConfig if we can't write to Config
308 0 0 0     0 if ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm} ) {
309 0         0 my $myconfig = _new_config_name();
310 0         0 $CPAN::Frontend->mywarn(
311             "Your $configpm file\n".
312             "is not writable. I will attempt to write your configuration to\n" .
313             "$myconfig instead.\n\n"
314             );
315 0         0 $configpm = make_new_config();
316 0         0 $must_reload++; # so it gets loaded as $INC{'CPAN/MyConfig.pm'}
317             }
318              
319             # XXX why not just "-w $configpm"? -- dagolden, 2011-01-19
320 0         0 my($mode);
321 0 0       0 if (-f $configpm) {
322 0         0 $mode = (stat $configpm)[2];
323 0 0 0     0 if ($mode && ! -w _) {
324 0         0 _die_cant_write_config($configpm);
325             }
326             }
327              
328 0         0 $self->_write_config_file($configpm);
329 0 0       0 require_myconfig_or_config() if $must_reload;
330              
331             #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
332             #chmod $mode, $configpm;
333             ###why was that so? $self->defaults;
334 0         0 $CPAN::Frontend->myprint("commit: wrote '$configpm'\n");
335 0         0 $CPAN::CONFIG_DIRTY = 0;
336 0         0 1;
337             }
338              
339             sub _write_config_file {
340 0     0   0 my ($self, $configpm) = @_;
341 0         0 my $msg;
342 0 0       0 $msg = <
343              
344             # This is CPAN.pm's systemwide configuration file. This file provides
345             # defaults for users, and the values can be changed in a per-user
346             # configuration file.
347              
348             EOF
349 0   0     0 $msg ||= "\n";
350 0         0 my($fh) = FileHandle->new;
351 0 0       0 rename $configpm, "$configpm~" if -f $configpm;
352 0 0       0 open $fh, ">$configpm" or
353             $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
354 0         0 $fh->print(qq[$msg\$CPAN::Config = \{\n]);
355 0         0 foreach (sort keys %$CPAN::Config) {
356 0 0       0 unless (exists $keys{$_}) {
357             # do not drop them: forward compatibility!
358 0         0 $CPAN::Frontend->mywarn("Unknown config variable '$_'\n");
359 0         0 next;
360             }
361             $fh->print(
362             " '$_' => ",
363 0         0 $self->neatvalue($CPAN::Config->{$_}),
364             ",\n"
365             );
366             }
367 0         0 $fh->print("};\n1;\n__END__\n");
368 0         0 close $fh;
369              
370 0         0 return;
371             }
372              
373              
374             # stolen from MakeMaker; not taking the original because it is buggy;
375             # bugreport will have to say: keys of hashes remain unquoted and can
376             # produce syntax errors
377             sub neatvalue {
378 7     7 0 3653 my($self, $v) = @_;
379 7 50       21 return "undef" unless defined $v;
380 7         15 my($t) = ref $v;
381 7 100       17 unless ($t) {
382 4         17 $v =~ s/\\/\\\\/g;
383 4         19 return "q[$v]";
384             }
385 3 100       9 if ($t eq 'ARRAY') {
386 1         4 my(@m, @neat);
387 1         11 push @m, "[";
388 1         9 foreach my $elem (@$v) {
389 1         6 push @neat, "q[$elem]";
390             }
391 1         5 push @m, join ", ", @neat;
392 1         2 push @m, "]";
393 1         6 return join "", @m;
394             }
395 2 50       8 return "$v" unless $t eq 'HASH';
396 2         5 my @m;
397 2         10 foreach my $key (sort keys %$v) {
398 2         5 my $val = $v->{$key};
399 2         12 push(@m,"q[$key]=>".$self->neatvalue($val)) ;
400             }
401 2         9 return "{ ".join(', ',@m)." }";
402             }
403              
404             sub defaults {
405 0     0 0 0 my($self) = @_;
406 0 0       0 if ($CPAN::RUN_DEGRADED) {
407 0         0 $CPAN::Frontend->mydie(
408             "'o conf defaults' disabled in ".
409             "degraded mode. Maybe try\n".
410             " !undef \$CPAN::RUN_DEGRADED\n"
411             );
412             }
413 0         0 my $done;
414 0         0 for my $config (qw(CPAN/MyConfig.pm CPAN/Config.pm)) {
415 0 0       0 if ($INC{$config}) {
416 0 0       0 CPAN->debug("INC{'$config'}[$INC{$config}]") if $CPAN::DEBUG;
417 0         0 CPAN::Shell->_reload_this($config,{reloforce => 1});
418 0         0 $CPAN::Frontend->myprint("'$INC{$config}' reread\n");
419 0         0 last;
420             }
421             }
422 0         0 $CPAN::CONFIG_DIRTY = 0;
423 0         0 1;
424             }
425              
426             =head2 C<< CLASS->safe_quote ITEM >>
427              
428             Quotes an item to become safe against spaces
429             in shell interpolation. An item is enclosed
430             in double quotes if:
431              
432             - the item contains spaces in the middle
433             - the item does not start with a quote
434              
435             This happens to avoid shell interpolation
436             problems when whitespace is present in
437             directory names.
438              
439             This method uses C to determine
440             the correct quote. If C is
441             a space, no quoting will take place.
442              
443              
444             if it starts and ends with the same quote character: leave it as it is
445              
446             if it contains no whitespace: leave it as it is
447              
448             if it contains whitespace, then
449              
450             if it contains quotes: better leave it as it is
451              
452             else: quote it with the correct quote type for the box we're on
453              
454             =cut
455              
456             {
457             # Instead of patching the guess, set commands_quote
458             # to the right value
459             my ($quotes,$use_quote)
460             = $^O eq 'MSWin32'
461             ? ('"', '"')
462             : (q{"'}, "'")
463             ;
464              
465             sub safe_quote {
466 2     2 1 8 my ($self, $command) = @_;
467             # Set up quote/default quote
468 2   33     28 my $quote = $CPAN::Config->{commands_quote} || $quotes;
469              
470 2 50 33     16 if ($quote ne ' '
      33        
      33        
471             and defined($command )
472             and $command =~ /\s/
473             and $command !~ /[$quote]/) {
474 0         0 return qq<$use_quote$command$use_quote>
475             }
476 2         13 return $command;
477             }
478             }
479              
480             sub init {
481 0     0 0 0 my($self,@args) = @_;
482 0         0 CPAN->debug("self[$self]args[".join(",",@args)."]");
483 0         0 $self->load(do_init => 1, @args);
484 0         0 1;
485             }
486              
487             # Loads CPAN::MyConfig or fall-back to CPAN::Config. Will not reload a file
488             # if already loaded. Returns the path to the file %INC or else the empty string
489             #
490             # Note -- if CPAN::Config were loaded and CPAN::MyConfig subsequently
491             # created, calling this again will leave *both* in %INC
492              
493             sub require_myconfig_or_config () {
494 9 50 33 9 0 68 if ( $INC{"CPAN/MyConfig.pm"} || _try_loading("CPAN::MyConfig", cpan_home())) {
    0 0        
495 9         42 return $INC{"CPAN/MyConfig.pm"};
496             }
497             elsif ( $INC{"CPAN/Config.pm"} || _try_loading("CPAN::Config") ) {
498 0         0 return $INC{"CPAN/Config.pm"};
499             }
500             else {
501 0         0 return q{};
502             }
503             }
504              
505             # Load a module, but ignore "can't locate..." errors
506             # Optionally take a list of directories to add to @INC for the load
507             sub _try_loading {
508 0     0   0 my ($module, @dirs) = @_;
509 0         0 (my $file = $module) =~ s{::}{/}g;
510 0         0 $file .= ".pm";
511              
512 0         0 local @INC = @INC;
513 0         0 for my $dir ( @dirs ) {
514 0 0       0 if ( -f File::Spec->catfile($dir, $file) ) {
515 0         0 unshift @INC, $dir;
516 0         0 last;
517             }
518             }
519              
520 0         0 eval { require $file };
  0         0  
521 0         0 my $err_myconfig = $@;
522 0 0 0     0 if ($err_myconfig and $err_myconfig !~ m#locate \Q$file\E#) {
523 0         0 die "Error while requiring ${module}:\n$err_myconfig";
524             }
525 0         0 return $INC{$file};
526             }
527              
528             # prioritized list of possible places for finding "CPAN/MyConfig.pm"
529             sub cpan_home_dir_candidates {
530 0     0 0 0 my @dirs;
531 0         0 my $old_v = $CPAN::Config->{load_module_verbosity};
532 0         0 $CPAN::Config->{load_module_verbosity} = q[none];
533 0 0       0 if ($CPAN::META->has_usable('File::HomeDir')) {
534 0 0       0 if ($^O ne 'darwin') {
535 0         0 push @dirs, File::HomeDir->my_data;
536             # my_data is ~/Library/Application Support on darwin,
537             # which causes issues in the toolchain.
538             }
539 0         0 push @dirs, File::HomeDir->my_home;
540             }
541             # Windows might not have HOME, so check it first
542 0 0       0 push @dirs, $ENV{HOME} if $ENV{HOME};
543             # Windows might have these instead
544             push( @dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') )
545 0 0 0     0 if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
546 0 0       0 push @dirs, $ENV{USERPROFILE} if $ENV{USERPROFILE};
547              
548 0         0 $CPAN::Config->{load_module_verbosity} = $old_v;
549 0 0       0 my $dotcpan = $^O eq 'VMS' ? '_cpan' : '.cpan';
550 0         0 @dirs = map { File::Spec->catdir($_, $dotcpan) } grep { defined } @dirs;
  0         0  
  0         0  
551 0 0       0 return wantarray ? @dirs : $dirs[0];
552             }
553              
554             sub load {
555 9     9 0 126 my($self, %args) = @_;
556 9         30 $CPAN::Be_Silent+=0; # protect against 'used only once'
557 9 50       66 $CPAN::Be_Silent++ if $args{be_silent}; # do not use; planned to be removed in 2011
558 9   50     152 my $do_init = delete $args{do_init} || 0;
559 9         30 my $make_myconfig = delete $args{make_myconfig};
560 9 100       44 $loading = 0 unless defined $loading;
561              
562 9         45 my $configpm = require_myconfig_or_config;
563 9         66 my @miss = $self->missing_config_data;
564 9 50       35 CPAN->debug("do_init[$do_init]loading[$loading]miss[@miss]") if $CPAN::DEBUG;
565 9 50 33     88 return unless $do_init || @miss;
566 0 0 0     0 if (@miss==1 and $miss[0] eq "pushy_https" && !$do_init) {
      0        
567 0         0 $CPAN::Frontend->myprint(<<'END');
568              
569             Starting with version 2.29 of the cpan shell, a new download mechanism
570             is the default which exclusively uses cpan.org as the host to download
571             from. The configuration variable pushy_https can be used to (de)select
572             the new mechanism. Please read more about it and make your choice
573             between the old and the new mechanism by running
574              
575             o conf init pushy_https
576              
577             Once you have done that and stored the config variable this dialog
578             will disappear.
579             END
580              
581 0         0 return;
582             }
583              
584             # I'm not how we'd ever wind up in a recursive loop, but I'm leaving
585             # this here for safety's sake -- dagolden, 2011-01-19
586 0 0       0 return if $loading;
587 0   0     0 local $loading = ($loading||0) + 1;
588              
589             # Warn if we have a config file, but things were found missing
590 0 0 0     0 if ($configpm && @miss && !$do_init) {
      0        
591 0 0 0     0 if ($make_myconfig || ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm})) {
      0        
592 0         0 $configpm = make_new_config();
593 0         0 $CPAN::Frontend->myprint(<
594             The system CPAN configuration file has provided some default values,
595             but you need to complete the configuration dialog for CPAN.pm.
596             Configuration will be written to
597             <<$configpm>>
598             END
599             }
600             else {
601 0         0 $CPAN::Frontend->myprint(<
602             Sorry, we have to rerun the configuration dialog for CPAN.pm due to
603             some missing parameters. Configuration will be written to
604             <<$configpm>>
605              
606             END
607             }
608             }
609              
610 0         0 require CPAN::FirstTime;
611 0   0     0 return CPAN::FirstTime::init($configpm || make_new_config(), %args);
612             }
613              
614             # Creates a new, empty config file at the preferred location
615             # Any existing will be renamed with a ".bak" suffix if possible
616             # If the file cannot be created, an exception is thrown
617             sub make_new_config {
618 0     0 0 0 my $configpm = _new_config_name();
619 0         0 my $configpmdir = File::Basename::dirname( $configpm );
620 0 0       0 File::Path::mkpath($configpmdir) unless -d $configpmdir;
621              
622 0 0       0 if ( -w $configpmdir ) {
623             #_#_# following code dumped core on me with 5.003_11, a.k.
624 0 0       0 if( -f $configpm ) {
625 0         0 my $configpm_bak = "$configpm.bak";
626 0 0       0 unlink $configpm_bak if -f $configpm_bak;
627 0 0       0 if( rename $configpm, $configpm_bak ) {
628 0         0 $CPAN::Frontend->mywarn(<
629             Old configuration file $configpm
630             moved to $configpm_bak
631             END
632             }
633             }
634 0         0 my $fh = FileHandle->new;
635 0 0       0 if ($fh->open(">$configpm")) {
636 0         0 $fh->print("1;\n");
637 0         0 return $configpm;
638             }
639             }
640 0         0 _die_cant_write_config($configpm);
641             }
642              
643             sub _die_cant_write_config {
644 0     0   0 my ($configpm) = @_;
645 0         0 $CPAN::Frontend->mydie(<<"END");
646             WARNING: CPAN.pm is unable to write a configuration file. You
647             must be able to create and write to '$configpm'.
648              
649             Aborting configuration.
650             END
651              
652             }
653              
654             # From candidate directories, we would like (in descending preference order):
655             # * the one that contains a MyConfig file
656             # * one that exists (even without MyConfig)
657             # * the first one on the list
658             sub cpan_home {
659 0     0 0 0 my @dirs = cpan_home_dir_candidates();
660 0         0 for my $d (@dirs) {
661 0 0       0 return $d if -f "$d/CPAN/MyConfig.pm";
662             }
663 0         0 for my $d (@dirs) {
664 0 0       0 return $d if -d $d;
665             }
666 0         0 return $dirs[0];
667             }
668              
669             sub _new_config_name {
670 0     0   0 return File::Spec->catfile(cpan_home(), 'CPAN', 'MyConfig.pm');
671             }
672              
673             # returns mandatory but missing entries in the Config
674             sub missing_config_data {
675 9     9 0 23 my(@miss);
676 9 50       79 for (
677             "auto_commit",
678             "build_cache",
679             "build_dir",
680             "cache_metadata",
681             "cpan_home",
682             "ftp_proxy",
683             #"gzip",
684             "http_proxy",
685             "index_expire",
686             #"inhibit_startup_message",
687             "keep_source_where",
688             #"make",
689             "make_arg",
690             "make_install_arg",
691             "makepl_arg",
692             "mbuild_arg",
693             "mbuild_install_arg",
694             ($^O eq "MSWin32" ? "" : "mbuild_install_build_command"),
695             "mbuildpl_arg",
696             "no_proxy",
697             #"pager",
698             "prerequisites_policy",
699             "pushy_https",
700             "scan_cache",
701             #"tar",
702             #"unzip",
703             "urllist",
704             ) {
705 189 50       354 next unless exists $keys{$_};
706 189 50       377 push @miss, $_ unless defined $CPAN::Config->{$_};
707             }
708 9         27 return @miss;
709             }
710              
711             sub help {
712 0     0 0   $CPAN::Frontend->myprint(q[
713             Known options:
714             commit commit session changes to disk
715             defaults reload default config values from disk
716             help this help
717             init enter a dialog to set all or a set of parameters
718              
719             Edit key values as in the following (the "o" is a literal letter o):
720             o conf build_cache 15
721             o conf build_dir "/foo/bar"
722             o conf urllist shift
723             o conf urllist unshift ftp://ftp.foo.bar/
724             o conf inhibit_startup_message 1
725              
726             ]);
727 0           1; #don't reprint CPAN::Config
728             }
729              
730             sub cpl {
731 0     0 0   my($word,$line,$pos) = @_;
732 0   0       $word ||= "";
733 0 0         CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
734 0           my(@words) = split " ", substr($line,0,$pos+1);
735 0 0 0       if (
    0 0        
    0 0        
      0        
      0        
      0        
736             defined($words[2])
737             and
738             $words[2] =~ /list$/
739             and
740             (
741             @words == 3
742             ||
743             @words == 4 && length($word)
744             )
745             ) {
746 0           return grep /^\Q$word\E/, qw(splice shift unshift pop push);
747             } elsif (defined($words[2])
748             and
749             $words[2] eq "init"
750             and
751             (
752             @words == 3
753             ||
754             @words >= 4 && length($word)
755             )) {
756 0           return sort grep /^\Q$word\E/, keys %keys;
757             } elsif (@words >= 4) {
758 0           return ();
759             }
760 0           my %seen;
761 0           my(@o_conf) = sort grep { !$seen{$_}++ }
  0            
762             keys %can,
763             keys %$CPAN::Config,
764             keys %keys;
765 0           return grep /^\Q$word\E/, @o_conf;
766             }
767              
768             sub prefs_lookup {
769 0     0 0   my($self,$distro,$what) = @_;
770              
771 0 0         if ($prefssupport{$what}) {
772             return $CPAN::Config->{$what} unless
773             $distro
774             and $distro->prefs
775             and $distro->prefs->{cpanconfig}
776 0 0 0       and defined $distro->prefs->{cpanconfig}{$what};
      0        
      0        
777 0           return $distro->prefs->{cpanconfig}{$what};
778             } else {
779 0           $CPAN::Frontend->mywarn("Warning: $what not yet officially ".
780             "supported for distroprefs, doing a normal lookup\n");
781 0           return $CPAN::Config->{$what};
782             }
783             }
784              
785              
786             {
787             package
788             CPAN::Config; ####::###### #hide from indexer
789             # note: J. Nick Koston wrote me that they are using
790             # CPAN::Config->commit although undocumented. I suggested
791             # CPAN::Shell->o("conf","commit") even when ugly it is at least
792             # documented
793              
794             # that's why I added the CPAN::Config class with autoload and
795             # deprecated warning
796              
797 14     14   167 use strict;
  14         32  
  14         472  
798 14     14   113 use vars qw($AUTOLOAD $VERSION);
  14         27  
  14         2426  
799             $VERSION = "5.5012";
800              
801             # formerly CPAN::HandleConfig was known as CPAN::Config
802             sub AUTOLOAD { ## no critic
803 0     0     my $class = shift; # e.g. in dh-make-perl: CPAN::Config
804 0           my($l) = $AUTOLOAD;
805 0           $CPAN::Frontend->mywarn("Dispatching deprecated method '$l' to CPAN::HandleConfig\n");
806 0           $l =~ s/.*:://;
807 0           CPAN::HandleConfig->$l(@_);
808             }
809             }
810              
811             1;
812              
813             __END__