X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCPAN%2FHandleConfig.pm;h=ec0aefdab989a79c4025b1e59c2e1594123d8de2;hb=15baf0c4b0f9a876f29eed6822a55401efbcabec;hp=a755254fa642a5b8c911210f61697d3072df020b;hpb=7d97ad34e1daa2105bc553c4c1183155427a25b3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/CPAN/HandleConfig.pm b/lib/CPAN/HandleConfig.pm index a755254..ec0aefd 100644 --- a/lib/CPAN/HandleConfig.pm +++ b/lib/CPAN/HandleConfig.pm @@ -1,8 +1,8 @@ package CPAN::HandleConfig; use strict; -use vars qw(%can %keys $VERSION); +use vars qw(%can %keys $loading $VERSION); -$VERSION = sprintf "%.6f", substr(q$Rev: 958 $,4)/1000000 + 5.4; +$VERSION = sprintf "%.6f", substr(q$Rev: 2212 $,4)/1000000 + 5.4; %can = ( commit => "Commit changes to disk", @@ -11,68 +11,96 @@ $VERSION = sprintf "%.6f", substr(q$Rev: 958 $,4)/1000000 + 5.4; init => "Interactive setting of all options", ); -%keys = map { $_ => undef } ( - # allow_unauthenticated ?? some day... - "build_cache", - "build_dir", - "build_requires_install_policy", - "bzip2", - "cache_metadata", - "check_sigs", - "colorize_output", - "colorize_print", - "colorize_warn", - "commandnumber_in_prompt", - "commands_quote", - "cpan_home", - "curl", - "dontload_hash", # deprecated after 1.83_68 (rev. 581) - "dontload_list", - "ftp", - "ftp_passive", - "ftp_proxy", - "getcwd", - "gpg", - "gzip", - "histfile", - "histsize", - "http_proxy", - "inactivity_timeout", - "index_expire", - "inhibit_startup_message", - "keep_source_where", - "lynx", - "make", - "make_arg", - "make_install_arg", - "make_install_make_command", - "makepl_arg", - "mbuild_arg", - "mbuild_install_arg", - "mbuild_install_build_command", - "mbuildpl_arg", - "ncftp", - "ncftpget", - "no_proxy", - "pager", - "password", - "prefer_installer", - "prerequisites_policy", - "proxy_pass", - "proxy_user", - "scan_cache", - "shell", - "show_upload_date", - "tar", - "term_is_latin", - "term_ornaments", - "test_report", - "unzip", - "urllist", - "username", - "wait_list", - "wget", - ); +# Q: where is the "How do I add a new config option" HOWTO? +# A1: svn diff -r 757:758 # where dagolden added test_report +# A2: svn diff -r 985:986 # where andk added yaml_module +%keys = map { $_ => undef } + ( + "applypatch", + "auto_commit", + "build_cache", + "build_dir", + "build_dir_reuse", + "build_requires_install_policy", + "bzip2", + "cache_metadata", + "check_sigs", + "colorize_debug", + "colorize_output", + "colorize_print", + "colorize_warn", + "commandnumber_in_prompt", + "commands_quote", + "cpan_home", + "curl", + "dontload_hash", # deprecated after 1.83_68 (rev. 581) + "dontload_list", + "ftp", + "ftp_passive", + "ftp_proxy", + "getcwd", + "gpg", + "gzip", + "histfile", + "histsize", + "http_proxy", + "inactivity_timeout", + "index_expire", + "inhibit_startup_message", + "keep_source_where", + "load_module_verbosity", + "lynx", + "make", + "make_arg", + "make_install_arg", + "make_install_make_command", + "makepl_arg", + "mbuild_arg", + "mbuild_install_arg", + "mbuild_install_build_command", + "mbuildpl_arg", + "ncftp", + "ncftpget", + "no_proxy", + "pager", + "password", + "patch", + "prefer_installer", + "prefs_dir", + "prerequisites_policy", + "proxy_pass", + "proxy_user", + "randomize_urllist", + "scan_cache", + "shell", + "show_unparsable_versions", + "show_upload_date", + "show_zero_versions", + "tar", + "tar_verbosity", + "term_is_latin", + "term_ornaments", + "test_report", + "unzip", + "urllist", + "use_sqlite", + "username", + "wait_list", + "wget", + "yaml_load_code", + "yaml_module", + ); + +my %prefssupport = map { $_ => 1 } + ( + "build_requires_install_policy", + "check_sigs", + "make", + "make_install_make_command", + "prefer_installer", + "test_report", + ); + if ($^O eq "MSWin32") { for my $k (qw( mbuild_install_build_command @@ -97,96 +125,144 @@ sub edit { $o = shift @args; $DB::single = 1; if($can{$o}) { - $self->$o(args => \@args); # o conf init => sub init => sub load - return 1; + $self->$o(args => \@args); # o conf init => sub init => sub load + return 1; } else { CPAN->debug("o[$o]") if $CPAN::DEBUG; unless (exists $keys{$o}) { $CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n"); } - if ($o =~ /list$/) { - $func = shift @args; - $func ||= ""; - CPAN->debug("func[$func]") if $CPAN::DEBUG; - my $changed; - # Let's avoid eval, it's easier to comprehend without. - if ($func eq "push") { - push @{$CPAN::Config->{$o}}, @args; + my $changed; + + + # one day I used randomize_urllist for a boolean, so we must + # list them explicitly --ak + if (0) { + } elsif ($o =~ /^(wait_list|urllist|dontload_list)$/) { + + # + # ARRAYS + # + + $func = shift @args; + $func ||= ""; + CPAN->debug("func[$func]args[@args]") if $CPAN::DEBUG; + # Let's avoid eval, it's easier to comprehend without. + if ($func eq "push") { + push @{$CPAN::Config->{$o}}, @args; $changed = 1; - } elsif ($func eq "pop") { - pop @{$CPAN::Config->{$o}}; + } elsif ($func eq "pop") { + pop @{$CPAN::Config->{$o}}; $changed = 1; - } elsif ($func eq "shift") { - shift @{$CPAN::Config->{$o}}; + } elsif ($func eq "shift") { + shift @{$CPAN::Config->{$o}}; $changed = 1; - } elsif ($func eq "unshift") { - unshift @{$CPAN::Config->{$o}}, @args; + } elsif ($func eq "unshift") { + unshift @{$CPAN::Config->{$o}}, @args; $changed = 1; - } elsif ($func eq "splice") { - splice @{$CPAN::Config->{$o}}, @args; + } elsif ($func eq "splice") { + my $offset = shift @args || 0; + my $length = shift @args || 0; + splice @{$CPAN::Config->{$o}}, $offset, $length, @args; # may warn $changed = 1; - } elsif (@args) { - $CPAN::Config->{$o} = [@args]; + } elsif ($func) { + $CPAN::Config->{$o} = [$func, @args]; $changed = 1; - } else { + } else { $self->prettyprint($o); - } + } if ($changed) { if ($o eq "urllist") { # reset the cached values undef $CPAN::FTP::Thesite; undef $CPAN::FTP::Themethod; + $CPAN::Index::LAST_TIME = 0; } elsif ($o eq "dontload_list") { # empty it, it will be built up again $CPAN::META->{dontload_hash} = {}; } } - return $changed; } elsif ($o =~ /_hash$/) { - @args = () if @args==1 && $args[0] eq ""; - push @args, "" if @args % 2; + + # + # HASHES + # + + if (@args==1 && $args[0] eq "") { + @args = (); + } elsif (@args % 2) { + push @args, ""; + } $CPAN::Config->{$o} = { @args }; + $changed = 1; } else { - $CPAN::Config->{$o} = $args[0] if defined $args[0]; - $self->prettyprint($o) + + # + # SCALARS + # + + if (defined $args[0]) { + $CPAN::CONFIG_DIRTY = 1; + $CPAN::Config->{$o} = $args[0]; + $changed = 1; + } + $self->prettyprint($o) if exists $keys{$o} or defined $CPAN::Config->{$o}; - return 1; - } + } + if ($changed) { + if ($CPAN::Config->{auto_commit}) { + $self->commit; + } else { + $CPAN::CONFIG_DIRTY = 1; + $CPAN::Frontend->myprint("Please use 'o conf commit' to ". + "make the config permanent!\n\n"); + } + } } } sub prettyprint { - my($self,$k) = @_; - my $v = $CPAN::Config->{$k}; - if (ref $v) { - my(@report); - if (ref $v eq "ARRAY") { - @report = map {"\t[$_]\n"} @$v; + my($self,$k) = @_; + my $v = $CPAN::Config->{$k}; + if (ref $v) { + my(@report); + if (ref $v eq "ARRAY") { + @report = map {"\t$_ \[$v->[$_]]\n"} 0..$#$v; + } else { + @report = map + { + sprintf "\t%-18s => %s\n", + "[$_]", + defined $v->{$_} ? "[$v->{$_}]" : "undef" + } keys %$v; + } + $CPAN::Frontend->myprint( + join( + "", + sprintf( + " %-18s\n", + $k + ), + @report + ) + ); + } elsif (defined $v) { + $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v); } else { - @report = map { sprintf("\t%-18s => %s\n", - map { "[$_]" } $_, - defined $v->{$_} ? $v->{$_} : "UNDEFINED" - )} keys %$v; + $CPAN::Frontend->myprint(sprintf " %-18s undef\n", $k); } - $CPAN::Frontend->myprint( - join( - "", - sprintf( - " %-18s\n", - $k - ), - @report - ) - ); - } elsif (defined $v) { - $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v); - } else { - $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, "UNDEFINED"); - } } sub commit { my($self,@args) = @_; + CPAN->debug("args[@args]") if $CPAN::DEBUG; + if ($CPAN::RUN_DEGRADED) { + $CPAN::Frontend->mydie( + "'o conf commit' disabled in ". + "degraded mode. Maybe try\n". + " !undef \$CPAN::RUN_DEGRADED\n" + ); + } my $configpm; if (@args) { if ($args[0] eq "args") { @@ -195,10 +271,10 @@ sub commit { $configpm = $args[0]; } } - unless (defined $configpm){ - $configpm ||= $INC{"CPAN/MyConfig.pm"}; - $configpm ||= $INC{"CPAN/Config.pm"}; - $configpm || Carp::confess(q{ + unless (defined $configpm) { + $configpm ||= $INC{"CPAN/MyConfig.pm"}; + $configpm ||= $INC{"CPAN/Config.pm"}; + $configpm || Carp::confess(q{ CPAN::Config::commit called without an argument. Please specify a filename where to save the configuration or try "o conf init" to have an interactive course through configing. @@ -206,10 +282,10 @@ Please specify a filename where to save the configuration or try } my($mode); if (-f $configpm) { - $mode = (stat $configpm)[2]; - if ($mode && ! -w _) { - Carp::confess("$configpm is not writable"); - } + $mode = (stat $configpm)[2]; + if ($mode && ! -w _) { + Carp::confess("$configpm is not writable"); + } } my $msg; @@ -229,15 +305,15 @@ EOF $fh->print(qq[$msg\$CPAN::Config = \{\n]); foreach (sort keys %$CPAN::Config) { unless (exists $keys{$_}) { - $CPAN::Frontend->mywarn("Dropping unknown config variable '$_'\n"); - delete $CPAN::Config->{$_}; + # do not drop them: forward compatibility! + $CPAN::Frontend->mywarn("Unknown config variable '$_'\n"); next; } - $fh->print( - " '$_' => ", - $self->neatvalue($CPAN::Config->{$_}), - ",\n" - ); + $fh->print( + " '$_' => ", + $self->neatvalue($CPAN::Config->{$_}), + ",\n" + ); } $fh->print("};\n1;\n__END__\n"); @@ -247,6 +323,7 @@ EOF #chmod $mode, $configpm; ###why was that so? $self->defaults; $CPAN::Frontend->myprint("commit: wrote '$configpm'\n"); + $CPAN::CONFIG_DIRTY = 0; 1; } @@ -257,7 +334,10 @@ sub neatvalue { my($self, $v) = @_; return "undef" unless defined $v; my($t) = ref $v; - return "q[$v]" unless $t; + unless ($t) { + $v =~ s/\\/\\\\/g; + return "q[$v]"; + } if ($t eq 'ARRAY') { my(@m, @neat); push @m, "["; @@ -270,7 +350,7 @@ sub neatvalue { } return "$v" unless $t eq 'HASH'; my(@m, $key, $val); - while (($key,$val) = each %$v){ + while (($key,$val) = each %$v) { last unless defined $key; # cautious programming in case (undef,undef) is true push(@m,"q[$key]=>".$self->neatvalue($val)) ; } @@ -279,14 +359,23 @@ sub neatvalue { sub defaults { my($self) = @_; + if ($CPAN::RUN_DEGRADED) { + $CPAN::Frontend->mydie( + "'o conf defaults' disabled in ". + "degraded mode. Maybe try\n". + " !undef \$CPAN::RUN_DEGRADED\n" + ); + } my $done; for my $config (qw(CPAN/MyConfig.pm CPAN/Config.pm)) { if ($INC{$config}) { - CPAN::Shell->reload_this($config); + CPAN->debug("INC{'$config'}[$INC{$config}]") if $CPAN::DEBUG; + CPAN::Shell->_reload_this($config,{reloforce => 1}); $CPAN::Frontend->myprint("'$INC{$config}' reread\n"); last; } } + $CPAN::CONFIG_DIRTY = 0; 1; } @@ -326,7 +415,7 @@ else: quote it with the correct quote type for the box we're on my ($quotes,$use_quote) = $^O eq 'MSWin32' ? ('"', '"') - : (q<"'>, "'") + : (q{"'}, "'") ; sub safe_quote { @@ -335,6 +424,7 @@ else: quote it with the correct quote type for the box we're on my $quote = $CPAN::Config->{commands_quote} || $quotes; if ($quote ne ' ' + and defined($command ) and $command =~ /\s/ and $command !~ /[$quote]/) { return qq<$use_quote$command$use_quote> @@ -345,12 +435,8 @@ else: quote it with the correct quote type for the box we're on sub init { my($self,@args) = @_; - undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to - # have the least - # important - # variable - # undefined - $self->load(@args); + CPAN->debug("self[$self]args[".join(",",@args)."]"); + $self->load(doit => 1, @args); 1; } @@ -358,7 +444,7 @@ sub init { # maintainability. RMB # sub _configpmtest { - my($configpmdir, $configpmtest) = @_; + my($configpmdir, $configpmtest) = @_; if (-w $configpmtest) { return $configpmtest; } elsif (-w $configpmdir) { @@ -367,20 +453,20 @@ sub _configpmtest { unlink $configpm_bak if -f $configpm_bak; if( -f $configpmtest ) { if( rename $configpmtest, $configpm_bak ) { - $CPAN::Frontend->mywarn(<mywarn(<new; - if ($fh->open(">$configpmtest")) { - $fh->print("1;\n"); - return $configpmtest; - } else { - # Should never happen - Carp::confess("Cannot open >$configpmtest"); - } + } + } + my $fh = FileHandle->new; + if ($fh->open(">$configpmtest")) { + $fh->print("1;\n"); + return $configpmtest; + } else { + # Should never happen + Carp::confess("Cannot open >$configpmtest"); + } } else { return } } @@ -407,7 +493,11 @@ sub home () { my $home; if ($CPAN::META->has_usable("File::HomeDir")) { $home = File::HomeDir->my_data; - } else { + unless (defined $home) { + $home = File::HomeDir->my_home + } + } + unless (defined $home) { $home = $ENV{HOME}; } $home; @@ -415,39 +505,42 @@ sub home () { sub load { my($self, %args) = @_; - $CPAN::Be_Silent++ if $args{be_silent}; + $CPAN::Be_Silent++ if $args{be_silent}; + my $doit; + $doit = delete $args{doit}; - my(@miss); use Carp; require_myconfig_or_config; - return unless @miss = $self->missing_config_data; + my @miss = $self->missing_config_data; + return unless $doit || @miss; + return if $loading; + $loading++; require CPAN::FirstTime; - my($configpm,$fh,$redo,$theycalled); + my($configpm,$fh,$redo); $redo ||= ""; - $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message'; if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) { - $configpm = $INC{"CPAN/Config.pm"}; - $redo++; + $configpm = $INC{"CPAN/Config.pm"}; + $redo++; } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) { - $configpm = $INC{"CPAN/MyConfig.pm"}; - $redo++; + $configpm = $INC{"CPAN/MyConfig.pm"}; + $redo++; } else { - my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"}); - my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN"); - my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm"); + my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"}); + my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN"); + my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm"); my $inc_key; - if (-d $configpmdir or File::Path::mkpath($configpmdir)) { - $configpm = _configpmtest($configpmdir,$configpmtest); + if (-d $configpmdir or File::Path::mkpath($configpmdir)) { + $configpm = _configpmtest($configpmdir,$configpmtest); $inc_key = "CPAN/Config.pm"; - } - unless ($configpm) { - $configpmdir = File::Spec->catdir(home,".cpan","CPAN"); - File::Path::mkpath($configpmdir); - $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm"); - $configpm = _configpmtest($configpmdir,$configpmtest); + } + unless ($configpm) { + $configpmdir = File::Spec->catdir(home,".cpan","CPAN"); + File::Path::mkpath($configpmdir); + $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm"); + $configpm = _configpmtest($configpmdir,$configpmtest); $inc_key = "CPAN/MyConfig.pm"; - } + } if ($configpm) { $INC{$inc_key} = $configpm; } else { @@ -458,27 +551,25 @@ sub load { } local($") = ", "; - if ($redo && ! $theycalled){ + if ($redo && !$doit) { $CPAN::Frontend->myprint(<myprint(qq{ -$configpm initialized. -}); - } CPAN::FirstTime::init($configpm, %args); + $loading--; + return; } + +# returns mandatory but missing entries in the Config sub missing_config_data { my(@miss); for ( + "auto_commit", "build_cache", "build_dir", "cache_metadata", @@ -487,7 +578,7 @@ sub missing_config_data { #"gzip", "http_proxy", "index_expire", - "inhibit_startup_message", + #"inhibit_startup_message", "keep_source_where", #"make", "make_arg", @@ -506,7 +597,7 @@ sub missing_config_data { "urllist", ) { next unless exists $keys{$_}; - push @miss, $_ unless defined $CPAN::Config->{$_}; + push @miss, $_ unless defined $CPAN::Config->{$_}; } return @miss; } @@ -536,17 +627,17 @@ sub cpl { CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG; my(@words) = split " ", substr($line,0,$pos+1); if ( - defined($words[2]) - and + defined($words[2]) + and $words[2] =~ /list$/ and - ( - @words == 3 - || - @words == 4 && length($word) - ) + ( + @words == 3 + || + @words == 4 && length($word) + ) ) { - return grep /^\Q$word\E/, qw(splice shift unshift pop push); + return grep /^\Q$word\E/, qw(splice shift unshift pop push); } elsif (defined($words[2]) and $words[2] eq "init" @@ -556,9 +647,9 @@ sub cpl { || @words >= 4 && length($word) )) { - return sort grep /^\Q$word\E/, keys %keys; + return sort grep /^\Q$word\E/, keys %keys; } elsif (@words >= 4) { - return (); + return (); } my %seen; my(@o_conf) = sort grep { !$seen{$_}++ } @@ -568,27 +659,47 @@ sub cpl { return grep /^\Q$word\E/, @o_conf; } +sub prefs_lookup { + my($self,$distro,$what) = @_; -package - CPAN::Config; ####::###### #hide from indexer -# note: J. Nick Koston wrote me that they are using -# CPAN::Config->commit although undocumented. I suggested -# CPAN::Shell->o("conf","commit") even when ugly it is at least -# documented + if ($prefssupport{$what}) { + return $CPAN::Config->{$what} unless + $distro + and $distro->prefs + and $distro->prefs->{cpanconfig} + and defined $distro->prefs->{cpanconfig}{$what}; + return $distro->prefs->{cpanconfig}{$what}; + } else { + $CPAN::Frontend->mywarn("Warning: $what not yet officially ". + "supported for distroprefs, doing a normal lookup"); + return $CPAN::Config->{$what}; + } +} -# that's why I added the CPAN::Config class with autoload and -# deprecated warning -use strict; -use vars qw($AUTOLOAD $VERSION); -$VERSION = sprintf "%.2f", substr(q$Rev: 958 $,4)/100; - -# formerly CPAN::HandleConfig was known as CPAN::Config -sub AUTOLOAD { - my($l) = $AUTOLOAD; - $CPAN::Frontend->mywarn("Dispatching deprecated method '$l' to CPAN::HandleConfig"); - $l =~ s/.*:://; - CPAN::HandleConfig->$l(@_); +{ + package + CPAN::Config; ####::###### #hide from indexer + # note: J. Nick Koston wrote me that they are using + # CPAN::Config->commit although undocumented. I suggested + # CPAN::Shell->o("conf","commit") even when ugly it is at least + # documented + + # that's why I added the CPAN::Config class with autoload and + # deprecated warning + + use strict; + use vars qw($AUTOLOAD $VERSION); + $VERSION = sprintf "%.2f", substr(q$Rev: 2212 $,4)/100; + + # formerly CPAN::HandleConfig was known as CPAN::Config + sub AUTOLOAD { + my $class = shift; # e.g. in dh-make-perl: CPAN::Config + my($l) = $AUTOLOAD; + $CPAN::Frontend->mywarn("Dispatching deprecated method '$l' to CPAN::HandleConfig\n"); + $l =~ s/.*:://; + CPAN::HandleConfig->$l(@_); + } } 1;