1187767Sluigipackage CPAN::HandleConfig; 2187767Sluigiuse strict; 3187767Sluigiuse vars qw(%can %keys $loading $VERSION); 4187767Sluigiuse File::Path (); 5187767Sluigiuse File::Spec (); 6187767Sluigiuse File::Basename (); 7187767Sluigiuse Carp (); 8187767Sluigi 9187767Sluigi=head1 NAME 10187767Sluigi 11187767SluigiCPAN::HandleConfig - internal configuration handling for CPAN.pm 12187767Sluigi 13187767Sluigi=cut 14187767Sluigi 15187767Sluigi$VERSION = "5.5012"; # see also CPAN::Config::VERSION at end of file 16187767Sluigi 17187767Sluigi%can = ( 18187767Sluigi commit => "Commit changes to disk", 19187767Sluigi defaults => "Reload defaults from disk", 20187767Sluigi help => "Short help about 'o conf' usage", 21187767Sluigi init => "Interactive setting of all options", 22187767Sluigi); 23187767Sluigi 24187767Sluigi# Q: where is the "How do I add a new config option" HOWTO? 25187767Sluigi# A1: svn diff -r 757:758 # where dagolden added test_report [git e997b71de88f1019a1472fc13cb97b1b7f96610f] 26187767Sluigi# A2: svn diff -r 985:986 # where andk added yaml_module [git 312b6d9b12b1bdec0b6e282d853482145475021f] 27187767Sluigi# A3: 1. add new config option to %keys below 28187767Sluigi# 2. add a Pod description in CPAN::FirstTime in the DESCRIPTION 29187767Sluigi# section; it should include a prompt line; see others for 30187767Sluigi# examples 31187767Sluigi# 3. add a "matcher" section in CPAN::FirstTime::init that includes 32187767Sluigi# a prompt function; see others for examples 33187767Sluigi# 4. add config option to documentation section in CPAN.pm 34187767Sluigi 35187767Sluigi%keys = map { $_ => undef } 36187767Sluigi ( 37187767Sluigi "allow_installing_module_downgrades", 38204591Sluigi "allow_installing_outdated_dists", 39187767Sluigi "applypatch", 40187767Sluigi "auto_commit", 41187767Sluigi "build_cache", 42187767Sluigi "build_dir", 43187767Sluigi "build_dir_reuse", 44187767Sluigi "build_requires_install_policy", 45187767Sluigi "bzip2", 46187767Sluigi "cache_metadata", 47187767Sluigi "check_sigs", 48187767Sluigi "cleanup_after_install", 49187767Sluigi "colorize_debug", 50187767Sluigi "colorize_output", 51187767Sluigi "colorize_print", 52187767Sluigi "colorize_warn", 53187767Sluigi "commandnumber_in_prompt", 54187767Sluigi "commands_quote", 55187767Sluigi "connect_to_internet_ok", 56187767Sluigi "cpan_home", 57187767Sluigi "curl", 58187767Sluigi "dontload_hash", # deprecated after 1.83_68 (rev. 581) 59187767Sluigi "dontload_list", 60187767Sluigi "ftp", 61187767Sluigi "ftp_passive", 62187767Sluigi "ftp_proxy", 63187767Sluigi "ftpstats_size", 64187767Sluigi "ftpstats_period", 65187767Sluigi "getcwd", 66187767Sluigi "gpg", 67187767Sluigi "gzip", 68187767Sluigi "halt_on_failure", 69187767Sluigi "histfile", 70187767Sluigi "histsize", 71187767Sluigi "http_proxy", 72187767Sluigi "inactivity_timeout", 73187767Sluigi "index_expire", 74187769Sluigi "inhibit_startup_message", 75187769Sluigi "keep_source_where", 76187769Sluigi "load_module_verbosity", 77187769Sluigi "lynx", 78187769Sluigi "make", 79187769Sluigi "make_arg", 80187769Sluigi "make_install_arg", 81187769Sluigi "make_install_make_command", 82187769Sluigi "makepl_arg", 83187769Sluigi "mbuild_arg", 84187769Sluigi "mbuild_install_arg", 85204591Sluigi "mbuild_install_build_command", 86187769Sluigi "mbuildpl_arg", 87204591Sluigi "ncftp", 88204591Sluigi "ncftpget", 89187769Sluigi "no_proxy", 90187769Sluigi "pager", 91187769Sluigi "password", 92187769Sluigi "patch", 93187769Sluigi "patches_dir", 94187769Sluigi "perl5lib_verbosity", 95187769Sluigi "plugin_list", 96187769Sluigi "prefer_external_tar", 97187769Sluigi "prefer_installer", 98187769Sluigi "prefs_dir", 99187769Sluigi "prerequisites_policy", 100187769Sluigi "proxy_pass", 101190633Spiso "proxy_user", 102223666Sae "pushy_https", 103223666Sae "randomize_urllist", 104187769Sluigi "recommends_policy", 105187769Sluigi "scan_cache", 106187769Sluigi "shell", 107187769Sluigi "show_unparsable_versions", 108187769Sluigi "show_upload_date", 109187769Sluigi "show_zero_versions", 110187769Sluigi "suggests_policy", 111187769Sluigi "tar", 112187769Sluigi "tar_verbosity", 113187769Sluigi "term_is_latin", 114187769Sluigi "term_ornaments", 115187769Sluigi "test_report", 116187769Sluigi "trust_test_report_history", 117187769Sluigi "unzip", 118187769Sluigi "urllist", 119187769Sluigi "urllist_ping_verbose", 120187769Sluigi "urllist_ping_external", 121187769Sluigi "use_prompt_default", 122187769Sluigi "use_sqlite", 123187769Sluigi "username", 124187769Sluigi "version_timeout", 125187769Sluigi "wait_list", 126187769Sluigi "wget", 127187769Sluigi "yaml_load_code", 128187769Sluigi "yaml_module", 129187769Sluigi ); 130205169Sluigi 131187769Sluigimy %prefssupport = map { $_ => 1 } 132187769Sluigi ( 133187769Sluigi "allow_installing_module_downgrades", 134187769Sluigi "allow_installing_outdated_dists", 135187769Sluigi "build_requires_install_policy", 136187769Sluigi "check_sigs", 137187769Sluigi "make", 138187769Sluigi "make_install_make_command", 139187769Sluigi "prefer_installer", 140187769Sluigi "test_report", 141187769Sluigi ); 142187769Sluigi 143187769Sluigi# returns true on successful action 144187769Sluigisub edit { 145187769Sluigi my($self,@args) = @_; 146187769Sluigi return unless @args; 147187769Sluigi CPAN->debug("self[$self]args[".join(" | ",@args)."]"); 148187769Sluigi my($o,$str,$func,$args,$key_exists); 149187769Sluigi $o = shift @args; 150187769Sluigi if($can{$o}) { 151187769Sluigi my $success = $self->$o(args => \@args); # o conf init => sub init => sub load 152187769Sluigi unless ($success) { 153187769Sluigi die "Panic: could not configure CPAN.pm for args [@args]. Giving up."; 154187769Sluigi } 155187769Sluigi } else { 156187769Sluigi CPAN->debug("o[$o]") if $CPAN::DEBUG; 157187769Sluigi unless (exists $keys{$o}) { 158187769Sluigi $CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n"); 159187769Sluigi } 160204591Sluigi my $changed; 161204591Sluigi 162187769Sluigi 163187769Sluigi # one day I used randomize_urllist for a boolean, so we must 164204591Sluigi # list them explicitly --ak 165194930Soleg if (0) { 166187769Sluigi } elsif ($o =~ /^(wait_list|urllist|dontload_list|plugin_list)$/) { 167187769Sluigi 168187769Sluigi # 169187769Sluigi # ARRAYS 170204591Sluigi # 171187769Sluigi 172204591Sluigi $func = shift @args; 173204591Sluigi $func ||= ""; 174204591Sluigi CPAN->debug("func[$func]args[@args]") if $CPAN::DEBUG; 175204591Sluigi # Let's avoid eval, it's easier to comprehend without. 176204591Sluigi if ($func eq "push") { 177187769Sluigi push @{$CPAN::Config->{$o}}, @args; 178187769Sluigi $changed = 1; 179187769Sluigi } elsif ($func eq "pop") { 180187769Sluigi pop @{$CPAN::Config->{$o}}; 181187769Sluigi $changed = 1; 182187769Sluigi } elsif ($func eq "shift") { 183223080Sae shift @{$CPAN::Config->{$o}}; 184187769Sluigi $changed = 1; 185187769Sluigi } elsif ($func eq "unshift") { 186187769Sluigi unshift @{$CPAN::Config->{$o}}, @args; 187187769Sluigi $changed = 1; 188187769Sluigi } elsif ($func eq "splice") { 189220804Sglebius my $offset = shift @args || 0; 190187769Sluigi my $length = shift @args || 0; 191187769Sluigi splice @{$CPAN::Config->{$o}}, $offset, $length, @args; # may warn 192187769Sluigi $changed = 1; 193187769Sluigi } elsif ($func) { 194187769Sluigi $CPAN::Config->{$o} = [$func, @args]; 195187769Sluigi $changed = 1; 196187769Sluigi } else { 197187769Sluigi $self->prettyprint($o); 198187769Sluigi } 199187769Sluigi if ($changed) { 200187769Sluigi if ($o eq "urllist") { 201187769Sluigi # reset the cached values 202187769Sluigi undef $CPAN::FTP::Thesite; 203187769Sluigi undef $CPAN::FTP::Themethod; 204200567Sluigi $CPAN::Index::LAST_TIME = 0; 205215179Sluigi } elsif ($o eq "dontload_list") { 206248552Smelifaro # empty it, it will be built up again 207187769Sluigi $CPAN::META->{dontload_hash} = {}; 208187767Sluigi } 209187767Sluigi } 210187767Sluigi } elsif ($o =~ /_hash$/) { 211187767Sluigi 212204591Sluigi # 213204591Sluigi # HASHES 214187767Sluigi # 215206843Sluigi 216187787Sluigi if (@args==1 && $args[0] eq "") { 217187767Sluigi @args = (); 218187767Sluigi } elsif (@args % 2) { 219187767Sluigi push @args, ""; 220187767Sluigi } 221187770Sluigi $CPAN::Config->{$o} = { @args }; 222187767Sluigi $changed = 1; 223187769Sluigi } else { 224187767Sluigi 225187770Sluigi # 226187769Sluigi # SCALARS 227187770Sluigi # 228187770Sluigi 229187769Sluigi if (defined $args[0]) { 230187769Sluigi $CPAN::CONFIG_DIRTY = 1; 231187769Sluigi $CPAN::Config->{$o} = $args[0]; 232187769Sluigi $changed = 1; 233187770Sluigi } 234187769Sluigi $self->prettyprint($o) 235187819Sluigi if exists $keys{$o} or defined $CPAN::Config->{$o}; 236187819Sluigi } 237187819Sluigi if ($changed) { 238187819Sluigi if ($CPAN::Config->{auto_commit}) { 239187819Sluigi $self->commit; 240187819Sluigi } else { 241187819Sluigi $CPAN::CONFIG_DIRTY = 1; 242187819Sluigi $CPAN::Frontend->myprint("Please use 'o conf commit' to ". 243187819Sluigi "make the config permanent!\n\n"); 244187983Sluigi } 245187819Sluigi } 246187819Sluigi } 247187819Sluigi} 248187769Sluigi 249187767Sluigisub prettyprint { 250187767Sluigi my($self,$k) = @_; 251187767Sluigi my $v = $CPAN::Config->{$k}; 252187767Sluigi if (ref $v) { 253187767Sluigi my(@report); 254187767Sluigi if (ref $v eq "ARRAY") { 255187767Sluigi @report = map {"\t$_ \[$v->[$_]]\n"} 0..$#$v; 256187770Sluigi } else { 257204591Sluigi @report = map 258187767Sluigi { 259187767Sluigi sprintf "\t%-18s => %s\n", 260187767Sluigi "[$_]", 261204591Sluigi defined $v->{$_} ? "[$v->{$_}]" : "undef" 262187767Sluigi } sort keys %$v; 263204591Sluigi } 264204591Sluigi $CPAN::Frontend->myprint( 265187767Sluigi join( 266187767Sluigi "", 267187767Sluigi sprintf( 268187767Sluigi " %-18s\n", 269187983Sluigi $k 270187983Sluigi ), 271187983Sluigi @report 272187983Sluigi ) 273187983Sluigi ); 274187983Sluigi } elsif (defined $v) { 275187770Sluigi $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v); 276204591Sluigi } else { 277204591Sluigi $CPAN::Frontend->myprint(sprintf " %-18s undef\n", $k); 278187769Sluigi } 279187769Sluigi} 280187770Sluigi 281187770Sluigi# generally, this should be called without arguments so that the currently 282187819Sluigi# loaded config file is where changes are committed. 283187819Sluigisub commit { 284187819Sluigi my($self,@args) = @_; 285187819Sluigi CPAN->debug("args[@args]") if $CPAN::DEBUG; 286187770Sluigi if ($CPAN::RUN_DEGRADED) { 287247712Smelifaro $CPAN::Frontend->mydie( 288247712Smelifaro "'o conf commit' disabled in ". 289187770Sluigi "degraded mode. Maybe try\n". 290247712Smelifaro " !undef \$CPAN::RUN_DEGRADED\n" 291187770Sluigi ); 292247712Smelifaro } 293187819Sluigi my ($configpm, $must_reload); 294 295 # XXX does anything do this? can it be simplified? -- dagolden, 2011-01-19 296 if (@args) { 297 if ($args[0] eq "args") { 298 # we have not signed that contract 299 } else { 300 $configpm = $args[0]; 301 } 302 } 303 304 # use provided name or the current config or create a new MyConfig 305 $configpm ||= require_myconfig_or_config() || make_new_config(); 306 307 # commit to MyConfig if we can't write to Config 308 if ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm} ) { 309 my $myconfig = _new_config_name(); 310 $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 $configpm = make_new_config(); 316 $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 my($mode); 321 if (-f $configpm) { 322 $mode = (stat $configpm)[2]; 323 if ($mode && ! -w _) { 324 _die_cant_write_config($configpm); 325 } 326 } 327 328 $self->_write_config_file($configpm); 329 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 $CPAN::Frontend->myprint("commit: wrote '$configpm'\n"); 335 $CPAN::CONFIG_DIRTY = 0; 336 1; 337} 338 339sub _write_config_file { 340 my ($self, $configpm) = @_; 341 my $msg; 342 $msg = <<EOF if $configpm =~ m{CPAN/Config\.pm}; 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 348EOF 349 $msg ||= "\n"; 350 my($fh) = FileHandle->new; 351 rename $configpm, "$configpm~" if -f $configpm; 352 open $fh, ">$configpm" or 353 $CPAN::Frontend->mydie("Couldn't open >$configpm: $!"); 354 $fh->print(qq[$msg\$CPAN::Config = \{\n]); 355 foreach (sort keys %$CPAN::Config) { 356 unless (exists $keys{$_}) { 357 # do not drop them: forward compatibility! 358 $CPAN::Frontend->mywarn("Unknown config variable '$_'\n"); 359 next; 360 } 361 $fh->print( 362 " '$_' => ", 363 $self->neatvalue($CPAN::Config->{$_}), 364 ",\n" 365 ); 366 } 367 $fh->print("};\n1;\n__END__\n"); 368 close $fh; 369 370 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 377sub neatvalue { 378 my($self, $v) = @_; 379 return "undef" unless defined $v; 380 my($t) = ref $v; 381 unless ($t) { 382 $v =~ s/\\/\\\\/g; 383 return "q[$v]"; 384 } 385 if ($t eq 'ARRAY') { 386 my(@m, @neat); 387 push @m, "["; 388 foreach my $elem (@$v) { 389 push @neat, "q[$elem]"; 390 } 391 push @m, join ", ", @neat; 392 push @m, "]"; 393 return join "", @m; 394 } 395 return "$v" unless $t eq 'HASH'; 396 my @m; 397 foreach my $key (sort keys %$v) { 398 my $val = $v->{$key}; 399 push(@m,"q[$key]=>".$self->neatvalue($val)) ; 400 } 401 return "{ ".join(', ',@m)." }"; 402} 403 404sub defaults { 405 my($self) = @_; 406 if ($CPAN::RUN_DEGRADED) { 407 $CPAN::Frontend->mydie( 408 "'o conf defaults' disabled in ". 409 "degraded mode. Maybe try\n". 410 " !undef \$CPAN::RUN_DEGRADED\n" 411 ); 412 } 413 my $done; 414 for my $config (qw(CPAN/MyConfig.pm CPAN/Config.pm)) { 415 if ($INC{$config}) { 416 CPAN->debug("INC{'$config'}[$INC{$config}]") if $CPAN::DEBUG; 417 CPAN::Shell->_reload_this($config,{reloforce => 1}); 418 $CPAN::Frontend->myprint("'$INC{$config}' reread\n"); 419 last; 420 } 421 } 422 $CPAN::CONFIG_DIRTY = 0; 423 1; 424} 425 426=head2 C<< CLASS->safe_quote ITEM >> 427 428Quotes an item to become safe against spaces 429in shell interpolation. An item is enclosed 430in double quotes if: 431 432 - the item contains spaces in the middle 433 - the item does not start with a quote 434 435This happens to avoid shell interpolation 436problems when whitespace is present in 437directory names. 438 439This method uses C<commands_quote> to determine 440the correct quote. If C<commands_quote> is 441a space, no quoting will take place. 442 443 444if it starts and ends with the same quote character: leave it as it is 445 446if it contains no whitespace: leave it as it is 447 448if it contains whitespace, then 449 450if it contains quotes: better leave it as it is 451 452else: 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 my ($self, $command) = @_; 467 # Set up quote/default quote 468 my $quote = $CPAN::Config->{commands_quote} || $quotes; 469 470 if ($quote ne ' ' 471 and defined($command ) 472 and $command =~ /\s/ 473 and $command !~ /[$quote]/) { 474 return qq<$use_quote$command$use_quote> 475 } 476 return $command; 477 } 478} 479 480sub init { 481 my($self,@args) = @_; 482 CPAN->debug("self[$self]args[".join(",",@args)."]"); 483 $self->load(do_init => 1, @args); 484 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 493sub require_myconfig_or_config () { 494 if ( $INC{"CPAN/MyConfig.pm"} || _try_loading("CPAN::MyConfig", cpan_home())) { 495 return $INC{"CPAN/MyConfig.pm"}; 496 } 497 elsif ( $INC{"CPAN/Config.pm"} || _try_loading("CPAN::Config") ) { 498 return $INC{"CPAN/Config.pm"}; 499 } 500 else { 501 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 507sub _try_loading { 508 my ($module, @dirs) = @_; 509 (my $file = $module) =~ s{::}{/}g; 510 $file .= ".pm"; 511 512 local @INC = @INC; 513 for my $dir ( @dirs ) { 514 if ( -f File::Spec->catfile($dir, $file) ) { 515 unshift @INC, $dir; 516 last; 517 } 518 } 519 520 eval { require $file }; 521 my $err_myconfig = $@; 522 if ($err_myconfig and $err_myconfig !~ m#locate \Q$file\E#) { 523 die "Error while requiring ${module}:\n$err_myconfig"; 524 } 525 return $INC{$file}; 526} 527 528# prioritized list of possible places for finding "CPAN/MyConfig.pm" 529sub cpan_home_dir_candidates { 530 my @dirs; 531 my $old_v = $CPAN::Config->{load_module_verbosity}; 532 $CPAN::Config->{load_module_verbosity} = q[none]; 533 if ($CPAN::META->has_usable('File::HomeDir')) { 534 if ($^O ne 'darwin') { 535 push @dirs, File::HomeDir->my_data; 536 # my_data is ~/Library/Application Support on darwin, 537 # which causes issues in the toolchain. 538 } 539 push @dirs, File::HomeDir->my_home; 540 } 541 # Windows might not have HOME, so check it first 542 push @dirs, $ENV{HOME} if $ENV{HOME}; 543 # Windows might have these instead 544 push( @dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') ) 545 if $ENV{HOMEDRIVE} && $ENV{HOMEPATH}; 546 push @dirs, $ENV{USERPROFILE} if $ENV{USERPROFILE}; 547 548 $CPAN::Config->{load_module_verbosity} = $old_v; 549 my $dotcpan = $^O eq 'VMS' ? '_cpan' : '.cpan'; 550 @dirs = map { File::Spec->catdir($_, $dotcpan) } grep { defined } @dirs; 551 return wantarray ? @dirs : $dirs[0]; 552} 553 554sub load { 555 my($self, %args) = @_; 556 $CPAN::Be_Silent+=0; # protect against 'used only once' 557 $CPAN::Be_Silent++ if $args{be_silent}; # do not use; planned to be removed in 2011 558 my $do_init = delete $args{do_init} || 0; 559 my $make_myconfig = delete $args{make_myconfig}; 560 $loading = 0 unless defined $loading; 561 562 my $configpm = require_myconfig_or_config; 563 my @miss = $self->missing_config_data; 564 CPAN->debug("do_init[$do_init]loading[$loading]miss[@miss]") if $CPAN::DEBUG; 565 return unless $do_init || @miss; 566 if (@miss==1 and $miss[0] eq "pushy_https" && !$do_init) { 567 $CPAN::Frontend->myprint(<<'END'); 568 569Starting with version 2.29 of the cpan shell, a new download mechanism 570is the default which exclusively uses cpan.org as the host to download 571from. The configuration variable pushy_https can be used to (de)select 572the new mechanism. Please read more about it and make your choice 573between the old and the new mechanism by running 574 575 o conf init pushy_https 576 577Once you have done that and stored the config variable this dialog 578will disappear. 579END 580 581 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 return if $loading; 587 local $loading = ($loading||0) + 1; 588 589 # Warn if we have a config file, but things were found missing 590 if ($configpm && @miss && !$do_init) { 591 if ($make_myconfig || ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm})) { 592 $configpm = make_new_config(); 593 $CPAN::Frontend->myprint(<<END); 594The system CPAN configuration file has provided some default values, 595but you need to complete the configuration dialog for CPAN.pm. 596Configuration will be written to 597 <<$configpm>> 598END 599 } 600 else { 601 $CPAN::Frontend->myprint(<<END); 602Sorry, we have to rerun the configuration dialog for CPAN.pm due to 603some missing parameters. Configuration will be written to 604 <<$configpm>> 605 606END 607 } 608 } 609 610 require CPAN::FirstTime; 611 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 617sub make_new_config { 618 my $configpm = _new_config_name(); 619 my $configpmdir = File::Basename::dirname( $configpm ); 620 File::Path::mkpath($configpmdir) unless -d $configpmdir; 621 622 if ( -w $configpmdir ) { 623 #_#_# following code dumped core on me with 5.003_11, a.k. 624 if( -f $configpm ) { 625 my $configpm_bak = "$configpm.bak"; 626 unlink $configpm_bak if -f $configpm_bak; 627 if( rename $configpm, $configpm_bak ) { 628 $CPAN::Frontend->mywarn(<<END); 629Old configuration file $configpm 630 moved to $configpm_bak 631END 632 } 633 } 634 my $fh = FileHandle->new; 635 if ($fh->open(">$configpm")) { 636 $fh->print("1;\n"); 637 return $configpm; 638 } 639 } 640 _die_cant_write_config($configpm); 641} 642 643sub _die_cant_write_config { 644 my ($configpm) = @_; 645 $CPAN::Frontend->mydie(<<"END"); 646WARNING: CPAN.pm is unable to write a configuration file. You 647must be able to create and write to '$configpm'. 648 649Aborting configuration. 650END 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 658sub cpan_home { 659 my @dirs = cpan_home_dir_candidates(); 660 for my $d (@dirs) { 661 return $d if -f "$d/CPAN/MyConfig.pm"; 662 } 663 for my $d (@dirs) { 664 return $d if -d $d; 665 } 666 return $dirs[0]; 667} 668 669sub _new_config_name { 670 return File::Spec->catfile(cpan_home(), 'CPAN', 'MyConfig.pm'); 671} 672 673# returns mandatory but missing entries in the Config 674sub missing_config_data { 675 my(@miss); 676 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 next unless exists $keys{$_}; 706 push @miss, $_ unless defined $CPAN::Config->{$_}; 707 } 708 return @miss; 709} 710 711sub help { 712 $CPAN::Frontend->myprint(q[ 713Known 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 719Edit 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 1; #don't reprint CPAN::Config 728} 729 730sub cpl { 731 my($word,$line,$pos) = @_; 732 $word ||= ""; 733 CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; 734 my(@words) = split " ", substr($line,0,$pos+1); 735 if ( 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 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 return sort grep /^\Q$word\E/, keys %keys; 757 } elsif (@words >= 4) { 758 return (); 759 } 760 my %seen; 761 my(@o_conf) = sort grep { !$seen{$_}++ } 762 keys %can, 763 keys %$CPAN::Config, 764 keys %keys; 765 return grep /^\Q$word\E/, @o_conf; 766} 767 768sub prefs_lookup { 769 my($self,$distro,$what) = @_; 770 771 if ($prefssupport{$what}) { 772 return $CPAN::Config->{$what} unless 773 $distro 774 and $distro->prefs 775 and $distro->prefs->{cpanconfig} 776 and defined $distro->prefs->{cpanconfig}{$what}; 777 return $distro->prefs->{cpanconfig}{$what}; 778 } else { 779 $CPAN::Frontend->mywarn("Warning: $what not yet officially ". 780 "supported for distroprefs, doing a normal lookup\n"); 781 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 use strict; 798 use vars qw($AUTOLOAD $VERSION); 799 $VERSION = "5.5012"; 800 801 # formerly CPAN::HandleConfig was known as CPAN::Config 802 sub AUTOLOAD { ## no critic 803 my $class = shift; # e.g. in dh-make-perl: CPAN::Config 804 my($l) = $AUTOLOAD; 805 $CPAN::Frontend->mywarn("Dispatching deprecated method '$l' to CPAN::HandleConfig\n"); 806 $l =~ s/.*:://; 807 CPAN::HandleConfig->$l(@_); 808 } 809} 810 8111; 812 813__END__ 814 815=head1 LICENSE 816 817This program is free software; you can redistribute it and/or 818modify it under the same terms as Perl itself. 819 820=cut 821 822# Local Variables: 823# mode: cperl 824# cperl-indent-level: 4 825# End: 826# vim: ts=4 sts=4 sw=4: 827