[p5sagit/p5-mst-13.2.git] / ext / CPANPLUS / lib / CPANPLUS / Configure.pm

package CPANPLUS::Configure;
use strict;


use CPANPLUS::Internals::Constants;
use CPANPLUS::Error;
use CPANPLUS::Config;

use Log::Message;
use Module::Load                qw[load];
use Params::Check               qw[check];
use File::Basename              qw[dirname];
use Module::Loaded              ();
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

use vars                        qw[$AUTOLOAD $VERSION $MIN_CONFIG_VERSION];
use base                        qw[CPANPLUS::Internals::Utils];

local $Params::Check::VERBOSE = 1;

### require, avoid circular use ###
require CPANPLUS::Internals;
$VERSION = $CPANPLUS::Internals::VERSION = $CPANPLUS::Internals::VERSION;

### can't use O::A as we're using our own AUTOLOAD to get to
### the config options.
for my $meth ( qw[conf _lib _perl5lib]) {
    no strict 'refs';
    
    *$meth = sub {
        my $self = shift;
        $self->{'_'.$meth} = $_[0] if @_;
        return $self->{'_'.$meth};
    }     
}


=pod

=head1 NAME

CPANPLUS::Configure

=head1 SYNOPSIS

    $conf   = CPANPLUS::Configure->new( );

    $bool   = $conf->can_save;
    $bool   = $conf->save( $where );

    @opts   = $conf->options( $type );

    $make       = $conf->get_program('make');
    $verbose    = $conf->set_conf( verbose => 1 );

=head1 DESCRIPTION

This module deals with all the configuration issues for CPANPLUS.
Users can use objects created by this module to alter the behaviour
of CPANPLUS.

Please refer to the C<CPANPLUS::Backend> documentation on how to
obtain a C<CPANPLUS::Configure> object.

=head1 METHODS

=head2 $Configure = CPANPLUS::Configure->new( load_configs => BOOL )

This method returns a new object. Normal users will never need to
invoke the C<new> method, but instead retrieve the desired object via
a method call on a C<CPANPLUS::Backend> object.

=item load_configs

Controls wether or not additional user configurations are to be loaded 
or not. Defaults to C<true>.

=cut

### store teh CPANPLUS::Config object in a closure, so we only
### initialize it once.. otherwise, on a 2nd ->new, settings
### from configs on top of this one will be reset
{   my $Config;

    sub new {
        my $class   = shift;
        my %hash    = @_;
        
        ### XXX pass on options to ->init() like rescan?
        my ($load);
        my $tmpl    = {
            load_configs    => { default => 1, store => \$load },
        };

        check( $tmpl, \%hash ) or (
            warn Params::Check->last_error, return
        );
        
        $Config     ||= CPANPLUS::Config->new;
        my $self    = bless {}, $class;
        $self->conf( $Config );

        ### you want us to load other configs?
        ### these can override things in the default config
        $self->init if $load;

        ### after processing the config files, check what 
        ### @INC and PERL5LIB are set to.
        $self->_lib( \@INC );
        $self->_perl5lib( $ENV{'PERL5LIB'} );
    
        return $self;
    }
}

=head2 $bool = $Configure->init( [rescan => BOOL])

Initialize the configure with other config files than just
the default 'CPANPLUS::Config'.

Called from C<new()> to load user/system configurations

If the C<rescan> option is provided, your disk will be
examined again to see if there are new config files that
could be read. Defaults to C<false>.

Returns true on success, false on failure.

=cut

### move the Module::Pluggable detection to runtime, rather
### than compile time, so that a simple 'require CPANPLUS'
### doesn't start running over your filesystem for no good
### reason. Make sure we only do the M::P call once though.
### we use $loaded to mark it
{   my $loaded;
    my $warned;
    sub init {
        my $self    = shift;
        my $obj     = $self->conf;
        my %hash    = @_;
        
        my ($rescan);
        my $tmpl    = {
            rescan  => { default => 0, store => \$rescan },
        };
        
        check( $tmpl, \%hash ) or (
            warn Params::Check->last_error, return
        );        
        
        ### if the base dir is changed, we have to rescan it
        ### for any CPANPLUS::Config::* files as well, so keep
        ### track of it
        my $cur_base = $self->get_conf('base');
        
        ### warn if we find an old style config specified
        ### via environment variables
        {   my $env = ENV_CPANPLUS_CONFIG;
            if( $ENV{$env} and not $warned ) {
                $warned++;
                error(loc("Specifying a config file in your environment " .
                          "using %1 is obsolete.\nPlease follow the ".
                          "directions outlined in %2 or use the '%3' command\n".
                          "in the default shell to use custom config files.",
                          $env, "CPANPLUS::Configure->save", 's save'));
            }
        }            
        
        {   ### make sure that the homedir is included now
            local @INC = ( LIB_DIR->($cur_base), @INC );
        
            ### only set it up once
            if( !$loaded++ or $rescan ) {   
                ### find plugins & extra configs
                ### check $home/.cpanplus/lib as well
                require Module::Pluggable;
                
                Module::Pluggable->import(
                    search_path => ['CPANPLUS::Config'],
                    search_dirs => [ LIB_DIR->($cur_base) ],
                    except      => qr/::SUPER$/,
                    sub_name    => 'configs'
                );
            }
            
            
            ### do system config, user config, rest.. in that order
            ### apparently, on a 2nd invocation of -->configs, a
            ### ::ISA::CACHE package can appear.. that's bad...
            my %confs = map  { $_ => $_ } 
                        grep { $_ !~ /::ISA::/ } __PACKAGE__->configs;
            my @confs = grep { defined } 
                        map  { delete $confs{$_} } CONFIG_SYSTEM, CONFIG_USER;
            push @confs, sort keys %confs;                    
        
            for my $plugin ( @confs ) {
                msg(loc("Found config '%1'", $plugin),0);
                
                ### if we already did this the /last/ time around dont 
                ### run the setup agian.
                if( my $loc = Module::Loaded::is_loaded( $plugin ) ) {
                    msg(loc("  Already loaded '%1' (%2)", $plugin, $loc), 0);
                    next;
                } else {
                    msg(loc("  Loading config '%1'", $plugin),0);
                
                    if( eval { load $plugin; 1 } ) {
                        msg(loc("  Loaded '%1' (%2)", 
                            $plugin, Module::Loaded::is_loaded( $plugin ) ), 0);
                    } else {
                        error(loc("  Error loading '%1': %2", $plugin, $@));
                    }                        
                }                   
                
                if( $@ ) {
                    error(loc("Could not load '%1': %2", $plugin, $@));
                    next;
                }     
                
                my $sub = $plugin->can('setup');
                $sub->( $self ) if $sub;
            }
        }
        
        ### did one of the plugins change the base dir? then we should
        ### scan the dirs again
        if( $cur_base ne $self->get_conf('base') ) {
            msg(loc("Base dir changed from '%1' to '%2', rescanning",
                    $cur_base, $self->get_conf('base')), 0);
            $self->init( @_, rescan => 1 );
        }      
            
        ### clean up the paths once more, just in case
        $obj->_clean_up_paths;

        ### XXX in case the 'lib' param got changed, we need to
        ### add that now, or it's not propagating ;(
        {   my $lib = $self->get_conf('lib');
            my %inc = map { $_ => $_ } @INC;
            for my $l ( @$lib ) {
                push @INC, $l unless $inc{$l};
            }                
            $self->_lib( \@INC );
        }
    
        return 1;
    }
}
=pod

=head2 can_save( [$config_location] )

Check if we can save the configuration to the specified file.
If no file is provided, defaults to your personal config.

Returns true if the file can be saved, false otherwise.

=cut

sub can_save {
    my $self = shift;
    my $file = shift || CONFIG_USER_FILE->();
    
    return 1 unless -e $file;

    chmod 0644, $file;
    return (-w $file);
}

=pod

=head2 $file = $conf->save( [$package_name] )

Saves the configuration to the package name you provided.
If this package is not C<CPANPLUS::Config::System>, it will
be saved in your C<.cpanplus> directory, otherwise it will
be attempted to be saved in the system wide directory.

If no argument is provided, it will default to your personal
config.

Returns the full path to the file if the config was saved, 
false otherwise.

=cut

sub _config_pm_to_file {
    my $self = shift;
    my $pm   = shift or return;
    my $dir  = shift || CONFIG_USER_LIB_DIR->();

    ### only 3 types of files know: home, system and 'other'
    ### so figure out where to save them based on their type
    my $file;
    if( $pm eq CONFIG_USER ) {
        $file = CONFIG_USER_FILE->();   

    } elsif ( $pm eq CONFIG_SYSTEM ) {
        $file = CONFIG_SYSTEM_FILE->();
        
    ### third party file        
    } else {
        my $cfg_pkg = CONFIG . '::';
        unless( $pm =~ /^$cfg_pkg/ ) {
            error(loc(
                "WARNING: Your config package '%1' is not in the '%2' ".
                "namespace and will not be automatically detected by %3",
                $pm, $cfg_pkg, 'CPANPLUS'
            ));        
        }                        
    
        $file = File::Spec->catfile(
            $dir,
            split( '::', $pm )
        ) . '.pm';        
    }

    return $file;
}


sub save {
    my $self    = shift;
    my $pm      = shift || CONFIG_USER;
    my $savedir = shift || '';
    
    my $file = $self->_config_pm_to_file( $pm, $savedir ) or return;
    my $dir  = dirname( $file );
    
    unless( -d $dir ) {
        $self->_mkdir( dir => $dir ) or (
            error(loc("Can not create directory '%1' to save config to",$dir)),
            return
        )
    }       
    return unless $self->can_save($file);

    ### find only accesors that are not private
    my @acc = sort grep { $_ !~ /^_/ } $self->conf->ls_accessors;

    ### for dumping the values
    use Data::Dumper;
    
    my @lines;
    for my $acc ( @acc ) {
        
        push @lines, "### $acc section", $/;
        
        for my $key ( $self->conf->$acc->ls_accessors ) {
            my $val = Dumper( $self->conf->$acc->$key );
        
            $val =~ s/\$VAR1\s+=\s+//;
            $val =~ s/;\n//;
        
            push @lines, '$'. "conf->set_${acc}( $key => $val );", $/;
        }
        push @lines, $/,$/;

    }

    my $str = join '', map { "    $_" } @lines;

    ### use a variable to make sure the pod parser doesn't snag it
    my $is      = '=';
    my $time    = gmtime;
   
    
    my $msg     = <<_END_OF_CONFIG_;
###############################################
###                                         
###  Configuration structure for $pm        
###                                         
###############################################

#last changed: $time GMT

### minimal pod, so you can find it with perldoc -l, etc
${is}pod

${is}head1 NAME

$pm

${is}head1 DESCRIPTION

This is a CPANPLUS configuration file. Editing this
config changes the way CPANPLUS will behave

${is}cut

package $pm;

use strict;

sub setup {
    my \$conf = shift;
    
$str

    return 1;    
} 

1;

_END_OF_CONFIG_

    $self->_move( file => $file, to => "$file~" ) if -f $file;

    my $fh = new FileHandle;
    $fh->open(">$file")
        or (error(loc("Could not open '%1' for writing: %2", $file, $!)),
            return );

    $fh->print($msg);
    $fh->close;

    return $file;
}

=pod

=head2 options( type => TYPE )

Returns a list of all valid config options given a specific type
(like for example C<conf> of C<program>) or false if the type does
not exist

=cut

sub options {
    my $self = shift;
    my $conf = $self->conf;
    my %hash = @_;

    my $type;
    my $tmpl = {
        type    => { required       => 1, default   => '',
                     strict_type    => 1, store     => \$type },
    };

    check($tmpl, \%hash) or return;

    my %seen;
    return sort grep { !$seen{$_}++ }
                map { $_->$type->ls_accessors if $_->can($type)  } 
                $self->conf;
    return;
}

=pod

=head1 ACCESSORS

Accessors that start with a C<_> are marked private -- regular users
should never need to use these.

See the C<CPANPLUS::Config> documentation for what items can be
set and retrieved.

=head2 get_SOMETHING( ITEM, [ITEM, ITEM, ... ] );

The C<get_*> style accessors merely retrieves one or more desired
config options.

=head2 set_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );

The C<set_*> style accessors set the current value for one
or more config options and will return true upon success, false on
failure.

=head2 add_SOMETHING( ITEM => VAL, [ITEM => VAL, ITEM => VAL, ... ] );

The C<add_*> style accessor adds a new key to a config key.

Currently, the following accessors exist:

=over 4

=item set|get_conf

Simple configuration directives like verbosity and favourite shell.

=item set|get_program

Location of helper programs.

=item _set|_get_build

Locations of where to put what files for CPANPLUS.

=item _set|_get_source

Locations and names of source files locally.

=item _set|_get_mirror

Locations and names of source files remotely.

=item _set|_get_fetch

Special settings pertaining to the fetching of files.

=back

=cut

sub AUTOLOAD {
    my $self    = shift;
    my $conf    = $self->conf;

    my $name    = $AUTOLOAD;
    $name       =~ s/.+:://;

    my ($private, $action, $field) =
                $name =~ m/^(_)?((?:[gs]et|add))_([a-z]+)$/;

    my $type = '';
    $type .= '_'    if $private;
    $type .= $field if $field;

    unless ( $conf->can($type) ) {
        error( loc("Invalid method type: '%1'", $name) );
        return;
    }

    unless( scalar @_ ) {
        error( loc("No arguments provided!") );
        return;
    }

    ### retrieve a current value for an existing key ###
    if( $action eq 'get' ) {
        for my $key (@_) {
            my @list = ();

            ### get it from the user config first
            if( $conf->can($type) and $conf->$type->can($key) ) {
                push @list, $conf->$type->$key;

            ### XXX EU::AI compatibility hack to provide lookups like in
            ### cpanplus 0.04x; we renamed ->_get_build('base') to
            ### ->get_conf('base')
            } elsif ( $type eq '_build' and $key eq 'base' ) {
                return $self->get_conf($key);  
                
            } else {     
                error( loc(q[No such key '%1' in field '%2'], $key, $type) );
                return;
            }

            return wantarray ? @list : $list[0];
        }

    ### set an existing key to a new value ###
    } elsif ( $action eq 'set' ) {
        my %args = @_;

        while( my($key,$val) = each %args ) {

            if( $conf->can($type) and $conf->$type->can($key) ) {
                $conf->$type->$key( $val );
                
            } else {
                error( loc(q[No such key '%1' in field '%2'], $key, $type) );
                return;
            }
        }

        return 1;

    ### add a new key to the config ###
    } elsif ( $action eq 'add' ) {
        my %args = @_;

        while( my($key,$val) = each %args ) {

            if( $conf->$type->can($key) ) {
                error( loc( q[Key '%1' already exists for field '%2'],
                            $key, $type));
                return;
            } else {
                $conf->$type->mk_accessors( $key );
                $conf->$type->$key( $val );
            }
        }
        return 1;

    } else {

        error( loc(q[Unknown action '%1'], $action) );
        return;
    }
}

sub DESTROY { 1 };

1;

=pod

=head1 BUG REPORTS

Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.

=head1 AUTHOR

This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.

=head1 COPYRIGHT

The CPAN++ interface (of which this module is a part of) is copyright (c) 
2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.

This library is free software; you may redistribute and/or modify it 
under the same terms as Perl itself.

=head1 SEE ALSO

L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Config>

=cut

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
Commit	Line	Data
6aaee015	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.
4443dd53	27	for my $meth ( qw[conf _lib _perl5lib]) {
6aaee015	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
4443dd53	73	=item load_configs
	74
	75	Controls wether or not additional user configurations are to be loaded
	76	or not. Defaults to C<true>.
6aaee015	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	};
4443dd53	94
6aaee015	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 );
4443dd53	102
6aaee015	103	### you want us to load other configs?
	104	### these can override things in the default config
	105	$self->init if $load;
4443dd53	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'} );
6aaee015	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
4443dd53	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
6aaee015	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
4443dd53	170	{ ### make sure that the homedir is included now
4443dd53	171	local @INC = ( LIB_DIR->($cur_base), @INC );
6aaee015	172
4443dd53	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	}
6aaee015	186
6aaee015	187
4443dd53	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	}
6aaee015	224	}
6aaee015	225
4443dd53	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
6aaee015	234	### clean up the paths once more, just in case
6aaee015	235	$obj->_clean_up_paths;
4443dd53	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	}
6aaee015	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 accesors 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
622d31ac	458	See the C<CPANPLUS::Config> documentation for what items can be
	459	set and retrieved.
	460
6aaee015	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
6aaee015	500	=item _set\|_get_fetch
	501
	502	Special settings pertaining to the fetching of files.
	503
6aaee015	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
622d31ac	620	L<CPANPLUS::Backend>, L<CPANPLUS::Configure::Setup>, L<CPANPLUS::Config>
6aaee015	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