[Summary view] [Print] [Text view]

   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_fetch
 467  
 468  Special settings pertaining to the fetching of files.
 469  
 470  =back
 471  
 472  =cut
 473  
 474  sub AUTOLOAD {
 475      my $self    = shift;
 476      my $conf    = $self->conf;
 477  
 478      my $name    = $AUTOLOAD;
 479      $name       =~ s/.+:://;
 480  
 481      my ($private, $action, $field) =
 482                  $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/;
 483  
 484      my $type = '';
 485      $type .= '_'    if $private;
 486      $type .= $field if $field;
 487  
 488      unless ( $conf->can($type) ) {
 489          error( loc("Invalid method type: '%1'", $name) );
 490          return;
 491      }
 492  
 493      unless( scalar @_ ) {
 494          error( loc("No arguments provided!") );
 495          return;
 496      }
 497  
 498      ### retrieve a current value for an existing key ###
 499      if( $action eq 'get' ) {
 500          for my $key (@_) {
 501              my @list = ();
 502  
 503              ### get it from the user config first
 504              if( $conf->can($type) and $conf->$type->can($key) ) {
 505                  push @list, $conf->$type->$key;
 506  
 507              ### XXX EU::AI compatibility hack to provide lookups like in
 508              ### cpanplus 0.04x; we renamed ->_get_build('base') to
 509              ### ->get_conf('base')
 510              } elsif ( $type eq '_build' and $key eq 'base' ) {
 511                  return $self->get_conf($key);  
 512                  
 513              } else {     
 514                  error( loc(q[No such key '%1' in field '%2'], $key, $type) );
 515                  return;
 516              }
 517  
 518              return wantarray ? @list : $list[0];
 519          }
 520  
 521      ### set an existing key to a new value ###
 522      } elsif ( $action eq 'set' ) {
 523          my %args = @_;
 524  
 525          while( my($key,$val) = each %args ) {
 526  
 527              if( $conf->can($type) and $conf->$type->can($key) ) {
 528                  $conf->$type->$key( $val );
 529                  
 530              } else {
 531                  error( loc(q[No such key '%1' in field '%2'], $key, $type) );
 532                  return;
 533              }
 534          }
 535  
 536          return 1;
 537  
 538      ### add a new key to the config ###
 539      } elsif ( $action eq 'add' ) {
 540          my %args = @_;
 541  
 542          while( my($key,$val) = each %args ) {
 543  
 544              if( $conf->$type->can($key) ) {
 545                  error( loc( q[Key '%1' already exists for field '%2'],
 546                              $key, $type));
 547                  return;
 548              } else {
 549                  $conf->$type->mk_accessors( $key );
 550                  $conf->$type->$key( $val );
 551              }
 552          }
 553          return 1;
 554  
 555      } else {
 556  
 557          error( loc(q[Unknown action '%1'], $action) );
 558          return;
 559      }
 560  }
 561  
 562  sub DESTROY { 1 };
 563  
 564  1;
 565  
 566  =pod
 567  
 568  =head1 BUG REPORTS
 569  
 570  Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
 571  
 572  =head1 AUTHOR
 573  
 574  This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
 575  
 576  =head1 COPYRIGHT
 577  
 578  The CPAN++ interface (of which this module is a part of) is copyright (c) 
 579  2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
 580  
 581  This library is free software; you may redistribute and/or modify it 
 582  under the same terms as Perl itself.
 583  
 584  =head1 SEE ALSO
 585  
 586  L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Config>
 587  
 588  =cut
 589  
 590  # Local variables:
 591  # c-indentation-style: bsd
 592  # c-basic-offset: 4
 593  # indent-tabs-mode: nil
 594  # End:
 595  # vim: expandtab shiftwidth=4:
 596