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