File Coverage

lib/CPAN/HandleConfig.pm
Criterion Covered Total %
statement 123 236 52.1
branch 51 132 38.6
condition 13 74 17.6
subroutine 16 20 80.0
pod 1 13 7.7
total 204 475 42.9


line stmt bran cond sub pod time code
1             package CPAN::HandleConfig;
2 8     8   171 use strict;
  8         127  
  8         282  
3 8     8   124 use vars qw(%can %keys $VERSION);
  8         76  
  8         417  
4              
5             $VERSION = sprintf "%.6f", substr(q$Rev: 847 $,4)/1000000 + 5.4;
6              
7             %can = (
8                     commit => "Commit changes to disk",
9                     defaults => "Reload defaults from disk",
10                     help => "Short help about 'o conf' usage",
11                     init => "Interactive setting of all options",
12             );
13              
14             %keys = map { $_ => undef } (
15             # allow_unauthenticated ?? some day...
16                                          "build_cache",
17                                          "build_dir",
18                                          "bzip2",
19                                          "cache_metadata",
20                                          "check_sigs",
21                                          "colorize_output",
22                                          "colorize_print",
23                                          "colorize_warn",
24                                          "commandnumber_in_prompt",
25                                          "commands_quote",
26                                          "cpan_home",
27                                          "curl",
28                                          "dontload_hash", # deprecated after 1.83_68 (rev. 581)
29                                          "dontload_list",
30                                          "ftp",
31                                          "ftp_passive",
32                                          "ftp_proxy",
33                                          "getcwd",
34                                          "gpg",
35                                          "gzip",
36                                          "histfile",
37                                          "histsize",
38                                          "http_proxy",
39                                          "inactivity_timeout",
40                                          "index_expire",
41                                          "inhibit_startup_message",
42                                          "keep_source_where",
43                                          "lynx",
44                                          "make",
45                                          "make_arg",
46                                          "make_install_arg",
47                                          "make_install_make_command",
48                                          "makepl_arg",
49                                          "mbuild_arg",
50                                          "mbuild_install_arg",
51                                          "mbuild_install_build_command",
52                                          "mbuildpl_arg",
53                                          "ncftp",
54                                          "ncftpget",
55                                          "no_proxy",
56                                          "pager",
57                                          "password",
58                                          "prefer_installer",
59                                          "prerequisites_policy",
60                                          "proxy_pass",
61                                          "proxy_user",
62                                          "scan_cache",
63                                          "shell",
64                                          "show_upload_date",
65                                          "tar",
66                                          "term_is_latin",
67                                          "term_ornaments",
68                                          "test_report",
69                                          "unzip",
70                                          "urllist",
71                                          "username",
72                                          "wait_list",
73                                          "wget",
74                                         );
75             if ($^O eq "MSWin32") {
76                 for my $k (qw(
77             mbuild_install_build_command
78             make_install_make_command
79             )) {
80                     delete $keys{$k};
81                     if (exists $CPAN::Config->{$k}) {
82                         for ("deleting previously set config variable '$k' => '$CPAN::Config->{$k}'") {
83                             $CPAN::Frontend ? $CPAN::Frontend->mywarn($_) : warn $_;
84                         }
85                         delete $CPAN::Config->{$k};
86                     }
87                 }
88             }
89              
90             # returns true on successful action
91             sub edit {
92 66     66 0 845     my($self,@args) = @_;
93 66 50       1013     return unless @args;
94 66         3051     CPAN->debug("self[$self]args[".join(" | ",@args)."]");
95 66         595     my($o,$str,$func,$args,$key_exists);
96 66         626     $o = shift @args;
97 66         743     $DB::single = 1;
98 66 100       1160     if($can{$o}) {
99 54         6223 $self->$o(args => \@args); # o conf init => sub init => sub load
100 54         1464 return 1;
101                 } else {
102 12 50       204         CPAN->debug("o[$o]") if $CPAN::DEBUG;
103 12 50       173         unless (exists $keys{$o}) {
104 0         0             $CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n");
105                     }
106 12 100       264 if ($o =~ /list$/) {
    50          
107 2         18 $func = shift @args;
108 2   50     24 $func ||= "";
109 2 50       23             CPAN->debug("func[$func]") if $CPAN::DEBUG;
110 2         18             my $changed;
111             # Let's avoid eval, it's easier to comprehend without.
112 2 50       162 if ($func eq "push") {
    50          
    50          
    50          
    50          
    50          
113 0         0 push @{$CPAN::Config->{$o}}, @args;
  0         0  
114 0         0                 $changed = 1;
115             } elsif ($func eq "pop") {
116 0         0 pop @{$CPAN::Config->{$o}};
  0         0  
117 0         0                 $changed = 1;
118             } elsif ($func eq "shift") {
119 0         0 shift @{$CPAN::Config->{$o}};
  0         0  
120 0         0                 $changed = 1;
121             } elsif ($func eq "unshift") {
122 0         0 unshift @{$CPAN::Config->{$o}}, @args;
  0         0  
123 0         0                 $changed = 1;
124             } elsif ($func eq "splice") {
125 0         0 splice @{$CPAN::Config->{$o}}, @args;
  0         0  
126 0         0                 $changed = 1;
127             } elsif (@args) {
128 0         0 $CPAN::Config->{$o} = [@args];
129 0         0                 $changed = 1;
130             } else {
131 2         95                 $self->prettyprint($o);
132             }
133 2 50       27             if ($changed) {
134 0 0       0                 if ($o eq "urllist") {
    0          
135             # reset the cached values
136 0         0                     undef $CPAN::FTP::Thesite;
137 0         0                     undef $CPAN::FTP::Themethod;
138                             } elsif ($o eq "dontload_list") {
139             # empty it, it will be built up again
140 0         0                     $CPAN::META->{dontload_hash} = {};
141                             }
142                         }
143 2         34             return $changed;
144                     } elsif ($o =~ /_hash$/) {
145 0 0 0     0             @args = () if @args==1 && $args[0] eq "";
146 0 0       0             push @args, "" if @args % 2;
147 0         0             $CPAN::Config->{$o} = { @args };
148                     } else {
149 10 100       359 $CPAN::Config->{$o} = $args[0] if defined $args[0];
150 10         232 $self->prettyprint($o);
151 10         266             return 1;
152             }
153                 }
154             }
155              
156             sub prettyprint {
157 61     61 0 704   my($self,$k) = @_;
158 61         731   my $v = $CPAN::Config->{$k};
159 61 100       668   if (ref $v) {
    50          
160 4         34     my(@report);
161 4 50       110     if (ref $v eq "ARRAY") {
162 0         0       @report = map {"\t[$_]\n"} @$v;
  0         0  
163                 } else {
164 0         0       @report = map { sprintf("\t%-18s => %s\n",
  0         0  
165 0 0       0                               map { "[$_]" } $_,
166                                           defined $v->{$_} ? $v->{$_} : "UNDEFINED"
167                                          )} keys %$v;
168                 }
169 4         101     $CPAN::Frontend->myprint(
170                                          join(
171                                               "",
172                                               sprintf(
173                                                       " %-18s\n",
174                                                       $k
175                                                      ),
176                                               @report
177                                              )
178                                         );
179               } elsif (defined $v) {
180 57         1095     $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, $v);
181               } else {
182 0         0     $CPAN::Frontend->myprint(sprintf " %-18s [%s]\n", $k, "UNDEFINED");
183               }
184             }
185              
186             sub commit {
187 3     3 0 52     my($self,@args) = @_;
188 3         27     my $configpm;
189 3 50       48     if (@args) {
190 0 100       0       if ($args[0] eq "args") {
191             # we have not signed that contract
192                   } else {
193 1         12         $configpm = $args[0];
194                   }
195                 }
196 3 100       33     unless (defined $configpm){
197 2   33     63 $configpm ||= $INC{"CPAN/MyConfig.pm"};
198 2   33     22 $configpm ||= $INC{"CPAN/Config.pm"};
199 2 50       23 $configpm || Carp::confess(q{
200             CPAN::Config::commit called without an argument.
201             Please specify a filename where to save the configuration or try
202             "o conf init" to have an interactive course through configing.
203             });
204                 }
205 3         25     my($mode);
206 3 50       140     if (-f $configpm) {
207 3         199 $mode = (stat $configpm)[2];
208 3 50 33     110 if ($mode && ! -w _) {
209 0         0 Carp::confess("$configpm is not writable");
210             }
211                 }
212              
213 3         26     my $msg;
214 3 50       68     $msg = <<EOF unless $configpm =~ /MyConfig/;
215            
216             # This is CPAN.pm's systemwide configuration file. This file provides
217             # defaults for users, and the values can be changed in a per-user
218             # configuration file. The user-config file is being looked for as
219             # ~/.cpan/CPAN/MyConfig.pm.
220            
221             EOF
222 3   50     35     $msg ||= "\n";
223 3         180     my($fh) = FileHandle->new;
224 3 50       843     rename $configpm, "$configpm~" if -f $configpm;
225 3 50       282     open $fh, ">$configpm" or
226                     $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
227 3         118     $fh->print(qq[$msg\$CPAN::Config = \{\n]);
228 3         426     foreach (sort keys %$CPAN::Config) {
229 147 50       3137         unless (exists $keys{$_}) {
230 0         0             $CPAN::Frontend->mywarn("Dropping unknown config variable '$_'\n");
231 0         0             delete $CPAN::Config->{$_};
232 0         0             next;
233                     }
234             $fh->print(
235 147         5003 " '$_' => ",
236             $self->neatvalue($CPAN::Config->{$_}),
237             ",\n"
238             );
239                 }
240              
241 3         145     $fh->print("};\n1;\n__END__\n");
242 3         327     close $fh;
243              
244             #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
245             #chmod $mode, $configpm;
246             ###why was that so? $self->defaults;
247 3         87     $CPAN::Frontend->myprint("commit: wrote '$configpm'\n");
248 3         45     1;
249             }
250              
251             # stolen from MakeMaker; not taking the original because it is buggy;
252             # bugreport will have to say: keys of hashes remain unquoted and can
253             # produce syntax errors
254             sub neatvalue {
255 147     147 0 1425     my($self, $v) = @_;
256 147 50       1327     return "undef" unless defined $v;
257 147         1320     my($t) = ref $v;
258 147 100       3635     return "q[$v]" unless $t;
259 6 50       65     if ($t eq 'ARRAY') {
260 6         49         my(@m, @neat);
261 6         55         push @m, "[";
262 6         134         foreach my $elem (@$v) {
263 6         154             push @neat, "q[$elem]";
264                     }
265 6         67         push @m, join ", ", @neat;
266 6         52         push @m, "]";
267 6         88         return join "", @m;
268                 }
269 0 0       0     return "$v" unless $t eq 'HASH';
270 0         0     my(@m, $key, $val);
271 0         0     while (($key,$val) = each %$v){
272 0 0       0         last unless defined $key; # cautious programming in case (undef,undef) is true
273 0         0         push(@m,"q[$key]=>".$self->neatvalue($val)) ;
274                 }
275 0         0     return "{ ".join(', ',@m)." }";
276             }
277              
278             sub defaults {
279 3     3 0 31     my($self) = @_;
280 3         553     my $done;
281 3         43     for my $config (qw(CPAN/MyConfig.pm CPAN/Config.pm)) {
282 3 50       39         if ($INC{$config}) {
283 3         79             CPAN::Shell->reload_this($config);
284 3         533             $CPAN::Frontend->myprint("'$INC{$config}' reread\n");
285 3         83