lib/CPAN/HandleConfig.pm

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