lib/CPANPLUS/Configure.pm

   1 package CPANPLUS::Configure;
   2 use strict;
   3
   4
   5 use CPANPLUS::Internals::Constants;
   6 use CPANPLUS::Error;
   7 use CPANPLUS::Config;
   8
   9 use Log::Message;
  10 use Module::Load                qw[load];
  11 use Params::Check               qw[check];
  12 use File::Basename              qw[dirname];
  13 use Module::Loaded              ();
  14 use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
  15
  16 use vars                        qw[$AUTOLOAD $VERSION $MIN_CONFIG_VERSION];
  17 use base                        qw[CPANPLUS::Internals::Utils];
  18
  19 local $Params::Check::VERBOSE = 1;
  20
  21 ### require, avoid circular use ###
  22 require CPANPLUS::Internals;
  23 $VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION;
  24
  25 ### can't use O::A as we're using our own AUTOLOAD to get to
  26 ### the config options.
  27 for my $meth ( qw[conf]) {
  28     no strict 'refs';
  29
  30     *$meth = sub {
  31         my $self = shift;
  32         $self->{'_'.$meth} = $_[0] if @_;
  33         return $self->{'_'.$meth};
  34     }
  35 }
  36
  37
  38 =pod
  39
  40 =head1 NAME
  41
  42 CPANPLUS::Configure
  43
  44 =head1 SYNOPSIS
  45
  46     $conf   = CPANPLUS::Configure->new( );
  47
  48     $bool   = $conf->can_save;
  49     $bool   = $conf->save( $where );
  50
  51     @opts   = $conf->options( $type );
  52
  53     $make       = $conf->get_program('make');
  54     $verbose    = $conf->set_conf( verbose => 1 );
  55
  56 =head1 DESCRIPTION
  57
  58 This module deals with all the configuration issues for CPANPLUS.
  59 Users can use objects created by this module to alter the behaviour
  60 of CPANPLUS.
  61
  62 Please refer to the C<CPANPLUS::Backend> documentation on how to
  63 obtain a C<CPANPLUS::Configure> object.
  64
  65 =head1 METHODS
  66
  67 =head2 $Configure = CPANPLUS::Configure->new( load_configs => BOOL )
  68
  69 This method returns a new object. Normal users will never need to
  70 invoke the C<new> method, but instead retrieve the desired object via
  71 a method call on a C<CPANPLUS::Backend> object.
  72
  73 The C<load_configs> parameter controls wether or not additional
  74 user configurations are to be loaded or not. Defaults to C<true>.
  75
  76 =cut
  77
  78 ### store teh CPANPLUS::Config object in a closure, so we only
  79 ### initialize it once.. otherwise, on a 2nd ->new, settings
  80 ### from configs on top of this one will be reset
  81 {   my $Config;
  82
  83     sub new {
  84         my $class   = shift;
  85         my %hash    = @_;
  86
  87         ### XXX pass on options to ->init() like rescan?
  88         my ($load);
  89         my $tmpl    = {
  90             load_configs    => { default => 1, store => \$load },
  91         };
  92
  93         check( $tmpl, \%hash ) or (
  94             warn Params::Check->last_error, return
  95         );
  96
  97         $Config     ||= CPANPLUS::Config->new;
  98         my $self    = bless {}, $class;
  99         $self->conf( $Config );
 100
 101         ### you want us to load other configs?
 102         ### these can override things in the default config
 103         $self->init if $load;
 104
 105         return $self;
 106     }
 107 }
 108
 109 =head2 $bool = $Configure->init( [rescan => BOOL])
 110
 111 Initialize the configure with other config files than just
 112 the default 'CPANPLUS::Config'.
 113
 114 Called from C<new()> to load user/system configurations
 115
 116 If the C<rescan> option is provided, your disk will be
 117 examined again to see if there are new config files that
 118 could be read. Defaults to C<false>.
 119
 120 Returns true on success, false on failure.
 121
 122 =cut
 123
 124 ### move the Module::Pluggable detection to runtime, rather
 125 ### than compile time, so that a simple 'require CPANPLUS'
 126 ### doesn't start running over your filesystem for no good
 127 ### reason. Make sure we only do the M::P call once though.
 128 ### we use $loaded to mark it
 129 {   my $loaded;
 130     my $warned;
 131     sub init {
 132         my $self    = shift;
 133         my $obj     = $self->conf;
 134         my %hash    = @_;
 135
 136         my ($rescan);
 137         my $tmpl    = {
 138             rescan  => { default => 0, store => \$rescan },
 139         };
 140
 141         check( $tmpl, \%hash ) or (
 142             warn Params::Check->last_error, return
 143         );
 144
 145         ### warn if we find an old style config specified
 146         ### via environment variables
 147         {   my $env = ENV_CPANPLUS_CONFIG;
 148             if( $ENV{$env} and not $warned ) {
 149                 $warned++;
 150                 error(loc("Specifying a config file in your environment " .
 151                           "using %1 is obsolete.\nPlease follow the ".
 152                           "directions outlined in %2 or use the '%3' command\n".
 153                           "in the default shell to use custom config files.",
 154                           $env, "CPANPLUS::Configure->save", 's save'));
 155             }
 156         }
 157
 158         ### make sure that the homedir is included now
 159         local @INC = ( CONFIG_USER_LIB_DIR->(), @INC );
 160
 161         ### only set it up once
 162         if( !$loaded++ or $rescan ) {
 163             ### find plugins & extra configs
 164             ### check $home/.cpanplus/lib as well
 165             require Module::Pluggable;
 166
 167             Module::Pluggable->import(
 168                 search_path => ['CPANPLUS::Config'],
 169                 search_dirs => [ CONFIG_USER_LIB_DIR ],
 170                 except      => qr/::SUPER$/,
 171                 sub_name    => 'configs'
 172             );
 173         }
 174
 175
 176         ### do system config, user config, rest.. in that order
 177         ### apparently, on a 2nd invocation of -->configs, a
 178         ### ::ISA::CACHE package can appear.. that's bad...
 179         my %confs = map  { $_ => $_ }
 180                     grep { $_ !~ /::ISA::/ } __PACKAGE__->configs;
 181         my @confs = grep { defined }
 182                     map  { delete $confs{$_} } CONFIG_SYSTEM, CONFIG_USER;
 183         push @confs, sort keys %confs;
 184
 185         for my $plugin ( @confs ) {
 186             msg(loc("Found config '%1'", $plugin),0);
 187
 188             ### if we already did this the /last/ time around dont
 189             ### run the setup agian.
 190             if( my $loc = Module::Loaded::is_loaded( $plugin ) ) {
 191                 msg(loc("  Already loaded '%1' (%2)", $plugin, $loc), 0);
 192                 next;
 193             } else {
 194                 msg(loc("  Loading config '%1'", $plugin),0);
 195
 196                 eval { load $plugin };
 197                 msg(loc("  Loaded '%1' (%2)",
 198                         $plugin, Module::Loaded::is_loaded( $plugin ) ), 0);
 199             }
 200
 201             if( $@ ) {
 202                 error(loc("Could not load '%1': %2", $plugin, $@));
 203                 next;
 204             }
 205
 206             my $sub = $plugin->can('setup');
 207             $sub->( $self ) if $sub;
 208         }
 209
 210         ### clean up the paths once more, just in case
 211         $obj->_clean_up_paths;
 212
 213         return 1;
 214     }
 215 }
 216 =pod
 217
 218 =head2 can_save( [$config_location] )
 219
 220 Check if we can save the configuration to the specified file.
 221 If no file is provided, defaults to your personal config.
 222
 223 Returns true if the file can be saved, false otherwise.
 224
 225 =cut
 226
 227 sub can_save {
 228     my $self = shift;
 229     my $file = shift || CONFIG_USER_FILE->();
 230
 231     return 1 unless -e $file;
 232
 233     chmod 0644, $file;
 234     return (-w $file);
 235 }
 236
 237 =pod
 238
 239 =head2 $file = $conf->save( [$package_name] )
 240
 241 Saves the configuration to the package name you provided.
 242 If this package is not C<CPANPLUS::Config::System>, it will
 243 be saved in your C<.cpanplus> directory, otherwise it will
 244 be attempted to be saved in the system wide directory.
 245
 246 If no argument is provided, it will default to your personal
 247 config.
 248
 249 Returns the full path to the file if the config was saved,
 250 false otherwise.
 251
 252 =cut
 253
 254 sub _config_pm_to_file {
 255     my $self = shift;
 256     my $pm   = shift or return;
 257     my $dir  = shift || CONFIG_USER_LIB_DIR->();
 258
 259     ### only 3 types of files know: home, system and 'other'
 260     ### so figure out where to save them based on their type
 261     my $file;
 262     if( $pm eq CONFIG_USER ) {
 263         $file = CONFIG_USER_FILE->();
 264
 265     } elsif ( $pm eq CONFIG_SYSTEM ) {
 266         $file = CONFIG_SYSTEM_FILE->();
 267
 268     ### third party file
 269     } else {
 270         my $cfg_pkg = CONFIG . '::';
 271         unless( $pm =~ /^$cfg_pkg/ ) {
 272             error(loc(
 273                 "WARNING: Your config package '%1' is not in the '%2' ".
 274                 "namespace and will not be automatically detected by %3",
 275                 $pm, $cfg_pkg, 'CPANPLUS'
 276             ));
 277         }
 278
 279         $file = File::Spec->catfile(
 280             $dir,
 281             split( '::', $pm )
 282         ) . '.pm';
 283     }
 284
 285     return $file;
 286 }
 287
 288
 289 sub save {
 290     my $self    = shift;
 291     my $pm      = shift || CONFIG_USER;
 292     my $savedir = shift || '';
 293
 294     my $file = $self->_config_pm_to_file( $pm, $savedir ) or return;
 295     my $dir  = dirname( $file );
 296
 297     unless( -d $dir ) {
 298         $self->_mkdir( dir => $dir ) or (
 299             error(loc("Can not create directory '%1' to save config to",$dir)),
 300             return
 301         )
 302     }
 303     return unless $self->can_save($file);
 304
 305     ### find only accesors that are not private
 306     my @acc = sort grep { $_ !~ /^_/ } $self->conf->ls_accessors;
 307
 308     ### for dumping the values
 309     use Data::Dumper;
 310
 311     my @lines;
 312     for my $acc ( @acc ) {
 313
 314         push @lines, "### $acc section", $/;
 315
 316         for my $key ( $self->conf->$acc->ls_accessors ) {
 317             my $val = Dumper( $self->conf->$acc->$key );
 318
 319             $val =~ s/\$VAR1\s+=\s+//;
 320             $val =~ s/;\n//;
 321
 322             push @lines, '$'. "conf->set_${acc}( $key => $val );", $/;
 323         }
 324         push @lines, $/,$/;
 325
 326     }
 327
 328     my $str = join '', map { "    $_" } @lines;
 329
 330     ### use a variable to make sure the pod parser doesn't snag it
 331     my $is      = '=';
 332     my $time    = gmtime;
 333
 334
 335     my $msg     = <<_END_OF_CONFIG_;
 336 ###############################################
 337 ###
 338 ###  Configuration structure for $pm
 339 ###
 340 ###############################################
 341
 342 #last changed: $time GMT
 343
 344 ### minimal pod, so you can find it with perldoc -l, etc
 345 ${is}pod
 346
 347 ${is}head1 NAME
 348
 349 $pm
 350
 351 ${is}head1 DESCRIPTION
 352
 353 This is a CPANPLUS configuration file. Editing this
 354 config changes the way CPANPLUS will behave
 355
 356 ${is}cut
 357
 358 package $pm;
 359
 360 use strict;
 361
 362 sub setup {
 363     my \$conf = shift;
 364
 365 $str
 366
 367     return 1;
 368 }
 369
 370 1;
 371
 372 _END_OF_CONFIG_
 373
 374     $self->_move( file => $file, to => "$file~" ) if -f $file;
 375
 376     my $fh = new FileHandle;
 377     $fh->open(">$file")
 378         or (error(loc("Could not open '%1' for writing: %2", $file, $!)),
 379             return );
 380
 381     $fh->print($msg);
 382     $fh->close;
 383
 384     return $file;
 385 }
 386
 387 =pod
 388
 389 =head2 options( type => TYPE )
 390
 391 Returns a list of all valid config options given a specific type
 392 (like for example C<conf> of C<program>) or false if the type does
 393 not exist
 394
 395 =cut
 396
 397 sub options {
 398     my $self = shift;
 399     my $conf = $self->conf;
 400     my %hash = @_;
 401
 402     my $type;
 403     my $tmpl = {
 404         type    => { required       => 1, default   => '',
 405                      strict_type    => 1, store     => \$type },
 406     };
 407
 408     check($tmpl, \%hash) or return;
 409
 410     my %seen;
 411     return sort grep { !$seen{$_}++ }
 412                 map { $_->$type->ls_accessors if $_->can($type)  }
 413                 $self->conf;
 414     return;
 415 }
 416
 417 =pod
 418
 419 =head1 ACCESSORS
 420
 421 Accessors that start with a C<_> are marked private -- regular users
 422 should never need to use these.
 423
 424 =head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] );
 425
 426 The C<get_*> style accessors merely retrieves one or more desired
 427 config options.
 428
 429 =head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
 430
 431 The C<set_*> style accessors set the current value for one
 432 or more config options and will return true upon success, false on
 433 failure.
 434
 435 =head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
 436
 437 The C<add_*> style accessor adds a new key to a config key.
 438
 439 Currently, the following accessors exist:
 440
 441 =over 4
 442
 443 =item set|get_conf
 444
 445 Simple configuration directives like verbosity and favourite shell.
 446
 447 =item set|get_program
 448
 449 Location of helper programs.
 450
 451 =item _set|_get_build
 452
 453 Locations of where to put what files for CPANPLUS.
 454
 455 =item _set|_get_source
 456
 457 Locations and names of source files locally.
 458
 459 =item _set|_get_mirror
 460
 461 Locations and names of source files remotely.
 462
 463 =item _set|_get_dist
 464
 465 Mapping of distribution format names to modules.
 466
 467 =item _set|_get_fetch
 468
 469 Special settings pertaining to the fetching of files.
 470
 471 =item _set|_get_daemon
 472
 473 Settings for C<cpanpd>, the CPANPLUS daemon.
 474
 475 =back
 476
 477 =cut
 478
 479 sub AUTOLOAD {
 480     my $self    = shift;
 481     my $conf    = $self->conf;
 482
 483     my $name    = $AUTOLOAD;
 484     $name       =~ s/.+:://;
 485
 486     my ($private, $action, $field) =
 487                 $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/;
 488
 489     my $type = '';
 490     $type .= '_'    if $private;
 491     $type .= $field if $field;
 492
 493     unless ( $conf->can($type) ) {
 494         error( loc("Invalid method type: '%1'", $name) );
 495         return;
 496     }
 497
 498     unless( scalar @_ ) {
 499         error( loc("No arguments provided!") );
 500         return;
 501     }
 502
 503     ### retrieve a current value for an existing key ###
 504     if( $action eq 'get' ) {
 505         for my $key (@_) {
 506             my @list = ();
 507
 508             ### get it from the user config first
 509             if( $conf->can($type) and $conf->$type->can($key) ) {
 510                 push @list, $conf->$type->$key;
 511
 512             ### XXX EU::AI compatibility hack to provide lookups like in
 513             ### cpanplus 0.04x; we renamed ->_get_build('base') to
 514             ### ->get_conf('base')
 515             } elsif ( $type eq '_build' and $key eq 'base' ) {
 516                 return $self->get_conf($key);
 517
 518             } else {
 519                 error( loc(q[No such key '%1' in field '%2'], $key, $type) );
 520                 return;
 521             }
 522
 523             return wantarray ? @list : $list[0];
 524         }
 525
 526     ### set an existing key to a new value ###
 527     } elsif ( $action eq 'set' ) {
 528         my %args = @_;
 529
 530         while( my($key,$val) = each %args ) {
 531
 532             if( $conf->can($type) and $conf->$type->can($key) ) {
 533                 $conf->$type->$key( $val );
 534
 535             } else {
 536                 error( loc(q[No such key '%1' in field '%2'], $key, $type) );
 537                 return;
 538             }
 539         }
 540
 541         return 1;
 542
 543     ### add a new key to the config ###
 544     } elsif ( $action eq 'add' ) {
 545         my %args = @_;
 546
 547         while( my($key,$val) = each %args ) {
 548
 549             if( $conf->$type->can($key) ) {
 550                 error( loc( q[Key '%1' already exists for field '%2'],
 551                             $key, $type));
 552                 return;
 553             } else {
 554                 $conf->$type->mk_accessors( $key );
 555                 $conf->$type->$key( $val );
 556             }
 557         }
 558         return 1;
 559
 560     } else {
 561
 562         error( loc(q[Unknown action '%1'], $action) );
 563         return;
 564     }
 565 }
 566
 567 sub DESTROY { 1 };
 568
 569 1;
 570
 571 =pod
 572
 573 =head1 BUG REPORTS
 574
 575 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
 576
 577 =head1 AUTHOR
 578
 579 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
 580
 581 =head1 COPYRIGHT
 582
 583 The CPAN++ interface (of which this module is a part of) is copyright (c)
 584 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
 585
 586 This library is free software; you may redistribute and/or modify it
 587 under the same terms as Perl itself.
 588
 589 =head1 SEE ALSO
 590
 591 L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>
 592
 593 =cut
 594
 595 # Local variables:
 596 # c-indentation-style: bsd
 597 # c-basic-offset: 4
 598 # indent-tabs-mode: nil
 599 # End:
 600 # vim: expandtab shiftwidth=4:
 601