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 See the C<CPANPLUS::Config> documentation for what items can be
 425 set and retrieved.
 426
 427 =head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] );
 428
 429 The C<get_*> style accessors merely retrieves one or more desired
 430 config options.
 431
 432 =head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
 433
 434 The C<set_*> style accessors set the current value for one
 435 or more config options and will return true upon success, false on
 436 failure.
 437
 438 =head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );
 439
 440 The C<add_*> style accessor adds a new key to a config key.
 441
 442 Currently, the following accessors exist:
 443
 444 =over 4
 445
 446 =item set|get_conf
 447
 448 Simple configuration directives like verbosity and favourite shell.
 449
 450 =item set|get_program
 451
 452 Location of helper programs.
 453
 454 =item _set|_get_build
 455
 456 Locations of where to put what files for CPANPLUS.
 457
 458 =item _set|_get_source
 459
 460 Locations and names of source files locally.
 461
 462 =item _set|_get_mirror
 463
 464 Locations and names of source files remotely.
 465
 466 =item _set|_get_dist
 467
 468 Mapping of distribution format names to modules.
 469
 470 =item _set|_get_fetch
 471
 472 Special settings pertaining to the fetching of files.
 473
 474 =item _set|_get_daemon
 475
 476 Settings for C<cpanpd>, the CPANPLUS daemon.
 477
 478 =back
 479
 480 =cut
 481
 482 sub AUTOLOAD {
 483     my $self    = shift;
 484     my $conf    = $self->conf;
 485
 486     my $name    = $AUTOLOAD;
 487     $name       =~ s/.+:://;
 488
 489     my ($private, $action, $field) =
 490                 $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/;
 491
 492     my $type = '';
 493     $type .= '_'    if $private;
 494     $type .= $field if $field;
 495
 496     unless ( $conf->can($type) ) {
 497         error( loc("Invalid method type: '%1'", $name) );
 498         return;
 499     }
 500
 501     unless( scalar @_ ) {
 502         error( loc("No arguments provided!") );
 503         return;
 504     }
 505
 506     ### retrieve a current value for an existing key ###
 507     if( $action eq 'get' ) {
 508         for my $key (@_) {
 509             my @list = ();
 510
 511             ### get it from the user config first
 512             if( $conf->can($type) and $conf->$type->can($key) ) {
 513                 push @list, $conf->$type->$key;
 514
 515             ### XXX EU::AI compatibility hack to provide lookups like in
 516             ### cpanplus 0.04x; we renamed ->_get_build('base') to
 517             ### ->get_conf('base')
 518             } elsif ( $type eq '_build' and $key eq 'base' ) {
 519                 return $self->get_conf($key);
 520
 521             } else {
 522                 error( loc(q[No such key '%1' in field '%2'], $key, $type) );
 523                 return;
 524             }
 525
 526             return wantarray ? @list : $list[0];
 527         }
 528
 529     ### set an existing key to a new value ###
 530     } elsif ( $action eq 'set' ) {
 531         my %args = @_;
 532
 533         while( my($key,$val) = each %args ) {
 534
 535             if( $conf->can($type) and $conf->$type->can($key) ) {
 536                 $conf->$type->$key( $val );
 537
 538             } else {
 539                 error( loc(q[No such key '%1' in field '%2'], $key, $type) );
 540                 return;
 541             }
 542         }
 543
 544         return 1;
 545
 546     ### add a new key to the config ###
 547     } elsif ( $action eq 'add' ) {
 548         my %args = @_;
 549
 550         while( my($key,$val) = each %args ) {
 551
 552             if( $conf->$type->can($key) ) {
 553                 error( loc( q[Key '%1' already exists for field '%2'],
 554                             $key, $type));
 555                 return;
 556             } else {
 557                 $conf->$type->mk_accessors( $key );
 558                 $conf->$type->$key( $val );
 559             }
 560         }
 561         return 1;
 562
 563     } else {
 564
 565         error( loc(q[Unknown action '%1'], $action) );
 566         return;
 567     }
 568 }
 569
 570 sub DESTROY { 1 };
 571
 572 1;
 573
 574 =pod
 575
 576 =head1 BUG REPORTS
 577
 578 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
 579
 580 =head1 AUTHOR
 581
 582 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
 583
 584 =head1 COPYRIGHT
 585
 586 The CPAN++ interface (of which this module is a part of) is copyright (c)
 587 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
 588
 589 This library is free software; you may redistribute and/or modify it
 590 under the same terms as Perl itself.
 591
 592 =head1 SEE ALSO
 593
 594 L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Config>
 595
 596 =cut
 597
 598 # Local variables:
 599 # c-indentation-style: bsd
 600 # c-basic-offset: 4
 601 # indent-tabs-mode: nil
 602 # End:
 603 # vim: expandtab shiftwidth=4:
 604