view release on metacpan or  search on metacpan

lib/CPAN/HandleConfig.pm  view on Meta::CPAN

        }
    }
}

sub prettyprint {
    my($self,$k) = @_;
    my $v = $CPAN::Config->{$k};
    if (ref $v) {
        my(@report);
        if (ref $v eq "ARRAY") {
            @report = map {"\t$_ \[$v->[$_]]\n"} 0..$#$v;
        } else {
            @report = map
                {
                    sprintf "\t%-18s => %s\n",
                               "[$_]",
                                        defined $v->{$_} ? "[$v->{$_}]" : "undef"
                } sort keys %$v;
        }
        $CPAN::Frontend->myprint(
                                 join(
                                      "",
                                      sprintf(
                                              "    %-18s\n",
                                              $k
                                             ),
                                      @report
                                     )
                                );
    } elsif (defined $v) {
        $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
    } else {
        $CPAN::Frontend->myprint(sprintf "    %-18s undef\n", $k);
    }
}

# generally, this should be called without arguments so that the currently
# loaded config file is where changes are committed.
sub commit {
    my($self,@args) = @_;
    CPAN->debug("args[@args]") if $CPAN::DEBUG;
    if ($CPAN::RUN_DEGRADED) {
        $CPAN::Frontend->mydie(
            "'o conf commit' disabled in ".
            "degraded mode. Maybe try\n".
            " !undef \$CPAN::RUN_DEGRADED\n"
        );
    }
    my ($configpm, $must_reload);

    # XXX does anything do this? can it be simplified? -- dagolden, 2011-01-19
    if (@args) {
      if ($args[0] eq "args") {
        # we have not signed that contract
      } else {
        $configpm = $args[0];
      }
    }

    # use provided name or the current config or create a new MyConfig
    $configpm ||= require_myconfig_or_config() || make_new_config();

    # commit to MyConfig if we can't write to Config
    if ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm} ) {
        my $myconfig = _new_config_name();
        $CPAN::Frontend->mywarn(
            "Your $configpm file\n".
            "is not writable. I will attempt to write your configuration to\n" .
            "$myconfig instead.\n\n"
        );
        $configpm = make_new_config();
        $must_reload++; # so it gets loaded as $INC{'CPAN/MyConfig.pm'}
    }

    # XXX why not just "-w $configpm"? -- dagolden, 2011-01-19
    my($mode);
    if (-f $configpm) {
        $mode = (stat $configpm)[2];
        if ($mode && ! -w _) {
            _die_cant_write_config($configpm);
        }
    }

    $self->_write_config_file($configpm);
    require_myconfig_or_config() if $must_reload;

    #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
    #chmod $mode, $configpm;
###why was that so?    $self->defaults;
    $CPAN::Frontend->myprint("commit: wrote '$configpm'\n");
    $CPAN::CONFIG_DIRTY = 0;
    1;
}

sub _write_config_file {
    my ($self, $configpm) = @_;
    my $msg;
    $msg = <<EOF if $configpm =~ m{CPAN/Config\.pm};

# This is CPAN.pm's systemwide configuration file. This file provides
# defaults for users, and the values can be changed in a per-user
# configuration file.

EOF
    $msg ||= "\n";
    my($fh) = FileHandle->new;
    rename $configpm, "$configpm~" if -f $configpm;
    open $fh, ">$configpm" or
        $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
    $fh->print(qq[$msg\$CPAN::Config = \{\n]);
    foreach (sort keys %$CPAN::Config) {
        unless (exists $keys{$_}) {
            # do not drop them: forward compatibility!
            $CPAN::Frontend->mywarn("Unknown config variable '$_'\n");
            next;
        }
        $fh->print(
            "  '$_' => ",
            $self->neatvalue($CPAN::Config->{$_}),
            ",\n"
        );

lib/CPAN/HandleConfig.pm  view on Meta::CPAN

    }
}

# Load a module, but ignore "can't locate..." errors
# Optionally take a list of directories to add to @INC for the load
sub _try_loading {
    my ($module, @dirs) = @_;
    (my $file = $module) =~ s{::}{/}g;
    $file .= ".pm";

    local @INC = @INC;
    for my $dir ( @dirs ) {
        if ( -f File::Spec->catfile($dir, $file) ) {
            unshift @INC, $dir;
            last;
        }
    }

    eval { require $file };
    my $err_myconfig = $@;
    if ($err_myconfig and $err_myconfig !~ m#locate \Q$file\E#) {
        die "Error while requiring ${module}:\n$err_myconfig";
    }
    return $INC{$file};
}

# prioritized list of possible places for finding "CPAN/MyConfig.pm"
sub cpan_home_dir_candidates {
    my @dirs;
    my $old_v = $CPAN::Config->{load_module_verbosity};
    $CPAN::Config->{load_module_verbosity} = q[none];
    if ($CPAN::META->has_usable('File::HomeDir')) {
        if ($^O ne 'darwin') {
            push @dirs, File::HomeDir->my_data;
            # my_data is ~/Library/Application Support on darwin,
            # which causes issues in the toolchain.
        }
        push @dirs, File::HomeDir->my_home;
    }
    # Windows might not have HOME, so check it first
    push @dirs, $ENV{HOME} if $ENV{HOME};
    # Windows might have these instead
    push( @dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') )
      if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
    push @dirs, $ENV{USERPROFILE} if $ENV{USERPROFILE};

    $CPAN::Config->{load_module_verbosity} = $old_v;
    my $dotcpan = $^O eq 'VMS' ? '_cpan' : '.cpan';
    @dirs = map { File::Spec->catdir($_, $dotcpan) } grep { defined } @dirs;
    return wantarray ? @dirs : $dirs[0];
}

sub load {
    my($self, %args) = @_;
    $CPAN::Be_Silent+=0; # protect against 'used only once'
    $CPAN::Be_Silent++ if $args{be_silent}; # do not use; planned to be removed in 2011
    my $do_init = delete $args{do_init} || 0;
    my $make_myconfig = delete $args{make_myconfig};
    $loading = 0 unless defined $loading;

    my $configpm = require_myconfig_or_config;
    my @miss = $self->missing_config_data;
    CPAN->debug("do_init[$do_init]loading[$loading]miss[@miss]") if $CPAN::DEBUG;
    return unless $do_init || @miss;
    if (@miss==1 and $miss[0] eq "pushy_https" && !$do_init) {
        $CPAN::Frontend->myprint(<<'END');

Starting with version 2.29 of the cpan shell, a new download mechanism
is the default which exclusively uses cpan.org as the host to download
from. The configuration variable pushy_https can be used to (de)select
the new mechanism. Please read more about it and make your choice
between the old and the new mechanism by running

    o conf init pushy_https

Once you have done that and stored the config variable this dialog
will disappear.
END

        return;
    }

    # I'm not how we'd ever wind up in a recursive loop, but I'm leaving
    # this here for safety's sake -- dagolden, 2011-01-19
    return if $loading;
    local $loading = ($loading||0) + 1;

    # Warn if we have a config file, but things were found missing
    if ($configpm && @miss && !$do_init) {
        if ($make_myconfig || ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm})) {
            $configpm = make_new_config();
            $CPAN::Frontend->myprint(<<END);
The system CPAN configuration file has provided some default values,
but you need to complete the configuration dialog for CPAN.pm.
Configuration will be written to
 <<$configpm>>
END
        }
        else {
            $CPAN::Frontend->myprint(<<END);
Sorry, we have to rerun the configuration dialog for CPAN.pm due to
some missing parameters. Configuration will be written to
 <<$configpm>>

END
        }
    }

    require CPAN::FirstTime;
    return CPAN::FirstTime::init($configpm || make_new_config(), %args);
}

# Creates a new, empty config file at the preferred location
# Any existing will be renamed with a ".bak" suffix if possible
# If the file cannot be created, an exception is thrown
sub make_new_config {
    my $configpm = _new_config_name();
    my $configpmdir = File::Basename::dirname( $configpm );
    File::Path::mkpath($configpmdir) unless -d $configpmdir;

    if ( -w $configpmdir ) {