<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package CPANPLUS::Internals;

### we /need/ perl5.6.1 or higher -- we use coderefs in @INC,
### and 5.6.0 is just too buggy
use 5.006001;

use strict;
use Config;


use CPANPLUS::Error;

use CPANPLUS::Selfupdate;

use CPANPLUS::Internals::Extract;
use CPANPLUS::Internals::Fetch;
use CPANPLUS::Internals::Utils;
use CPANPLUS::Internals::Constants;
use CPANPLUS::Internals::Search;
use CPANPLUS::Internals::Report;


require base;
use Cwd                         qw[cwd];
use Module::Load                qw[load];
use Params::Check               qw[check];
use Locale::Maketext::Simple    Class =&gt; 'CPANPLUS', Style =&gt; 'gettext';
use Module::Load::Conditional   qw[can_load];

use Object::Accessor;


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

use vars qw[@ISA $VERSION];

@ISA = qw[
            CPANPLUS::Internals::Extract
            CPANPLUS::Internals::Fetch
            CPANPLUS::Internals::Utils
            CPANPLUS::Internals::Search
            CPANPLUS::Internals::Report
        ];

$VERSION = "0.9103";

=pod

=head1 NAME

CPANPLUS::Internals

=head1 SYNOPSIS

    my $internals   = CPANPLUS::Internals-&gt;_init( _conf =&gt; $conf );
    my $backend     = CPANPLUS::Internals-&gt;_retrieve_id( $ID );

=head1 DESCRIPTION

This module is the guts of CPANPLUS -- it inherits from all other
modules in the CPANPLUS::Internals::* namespace, thus defying normal
rules of OO programming -- but if you're reading this, you already
know what's going on ;)

Please read the C&lt;CPANPLUS::Backend&gt; documentation for the normal API.

=head1 ACCESSORS

=over 4

=item _conf

Get/set the configure object

=item _id

Get/set the id

=cut

### autogenerate accessors ###
for my $key ( qw[_conf _id _modules _hosts _methods _status
                 _callbacks _selfupdate _mtree _atree]
) {
    no strict 'refs';
    *{__PACKAGE__."::$key"} = sub {
        $_[0]-&gt;{$key} = $_[1] if @_ &gt; 1;
        return $_[0]-&gt;{$key};
    }
}

=pod

=back

=head1 METHODS

=head2 $internals = CPANPLUS::Internals-&gt;_init( _conf =&gt; CONFIG_OBJ )

C&lt;_init&gt; creates a new CPANPLUS::Internals object.

You have to pass it a valid C&lt;CPANPLUS::Configure&gt; object.

Returns the object on success, or dies on failure.

=cut

{   ### NOTE:
    ### if extra callbacks are added, don't forget to update the
    ### 02-internals.t test script with them!
    my $callback_map = {
        ### name                default value    
        install_prerequisite    =&gt; 1,   # install prereqs when 'ask' is set?
        edit_test_report        =&gt; 0,   # edit the prepared test report?
        send_test_report        =&gt; 1,   # send the test report?
                                        # munge the test report
        munge_test_report       =&gt; sub { return $_[1] },
                                        # filter out unwanted prereqs
        filter_prereqs          =&gt; sub { return $_[1] },
                                        # continue if 'make test' fails?
        proceed_on_test_failure =&gt; sub { return 0 },
        munge_dist_metafile     =&gt; sub { return $_[1] },
    };
    
    my $status = Object::Accessor-&gt;new;
    $status-&gt;mk_accessors(qw[pending_prereqs]);

    my $callback = Object::Accessor-&gt;new;
    $callback-&gt;mk_accessors(keys %$callback_map);

    my $conf;
    my $Tmpl = {
        _conf       =&gt; { required =&gt; 1, store =&gt; \$conf,
                            allow =&gt; IS_CONFOBJ },
        _id         =&gt; { default =&gt; '',                 no_override =&gt; 1 },
        _authortree =&gt; { default =&gt; '',                 no_override =&gt; 1 },
        _modtree    =&gt; { default =&gt; '',                 no_override =&gt; 1 },
        _hosts      =&gt; { default =&gt; {},                 no_override =&gt; 1 },
        _methods    =&gt; { default =&gt; {},                 no_override =&gt; 1 },
        _status     =&gt; { default =&gt; '&lt;empty&gt;',          no_override =&gt; 1 },
        _callbacks  =&gt; { default =&gt; '&lt;empty&gt;',          no_override =&gt; 1 },
    };

    sub _init {
        my $class   = shift;
        my %hash    = @_;

        ### temporary warning until we fix the storing of multiple id's
        ### and their serialization:
        ### probably not going to happen --kane
        if( my $id = $class-&gt;_last_id ) {
            # make it a singleton.
            warn loc(q[%1 currently only supports one %2 object per ] .
                     qq[running program\n], 'CPANPLUS', $class);

            return $class-&gt;_retrieve_id( $id );
        }

        my $args = check($Tmpl, \%hash)
                    or die loc(qq[Could not initialize '%1' object], $class);

        bless $args, $class;

        $args-&gt;{'_id'}          = $args-&gt;_inc_id;
        $args-&gt;{'_status'}      = $status;
        $args-&gt;{'_callbacks'}   = $callback;

        ### initialize callbacks to default state ###
        for my $name ( $callback-&gt;ls_accessors ) {
            my $rv = ref $callback_map-&gt;{$name} ? 'sub return value' :
                         $callback_map-&gt;{$name} ? 'true' : 'false';
        
            $args-&gt;_callbacks-&gt;$name(
                sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'",
                              $name, $rv), $args-&gt;_conf-&gt;get_conf('debug')); 
                      return ref $callback_map-&gt;{$name} 
                                ? $callback_map-&gt;{$name}-&gt;( @_ )
                                : $callback_map-&gt;{$name};
                } 
            );
        }

        ### create a selfupdate object
        $args-&gt;_selfupdate( CPANPLUS::Selfupdate-&gt;new( $args ) );

        ### initialize it as an empty hashref ###
        $args-&gt;_status-&gt;pending_prereqs( {} );

        $conf-&gt;_set_build( startdir =&gt; cwd() ),
            or error( loc("couldn't locate current dir!") );

        $ENV{FTP_PASSIVE} = 1, if $conf-&gt;get_conf('passive');

        my $id = $args-&gt;_store_id( $args );

        unless ( $id == $args-&gt;_id ) {
            error( loc("IDs do not match: %1 != %2. Storage failed!",
                        $id, $args-&gt;_id) );
        }

        ### different source engines available now, so set them here
        {   my $store = $conf-&gt;get_conf( 'source_engine' ) 
                            || DEFAULT_SOURCE_ENGINE;

            unless( can_load( modules =&gt; { $store =&gt; '0.0' }, verbose =&gt; 1 ) ) {
                error( loc( "Could not load source engine '%1'", $store ) );
            
                if( $store ne DEFAULT_SOURCE_ENGINE ) {
                    msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 );
                   
                    load DEFAULT_SOURCE_ENGINE;
                    
                    base-&gt;import( DEFAULT_SOURCE_ENGINE );
                } else {
                    return;
                }     
            } else {
                 base-&gt;import( $store );
            }                
        }

        return $args;
    }

=pod

=head2 $bool = $internals-&gt;_flush( list =&gt; \@caches )

Flushes the designated caches from the C&lt;CPANPLUS&gt; object.

Returns true on success, false if one or more caches could not be
be flushed.

=cut

    sub _flush {
        my $self = shift;
        my $conf = $self-&gt;configure_object;
        my %hash = @_;

        my $aref;
        my $tmpl = {
            list    =&gt; { required =&gt; 1, default =&gt; [],
                            strict_type =&gt; 1, store =&gt; \$aref },
        };

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

        my $flag = 0;
        for my $what (@$aref) {
            my $cache = '_' . $what;

            ### set the include paths back to their original ###
            if( $what eq 'lib' ) {
                $ENV{PERL5LIB}  = $conf-&gt;_perl5lib || '';
                @INC            = @{$conf-&gt;_lib};

            ### give all modules a new status object -- this is slightly
            ### costly, but the best way to make sure all statuses are
            ### forgotten --kane
            } elsif ( $what eq 'modules' ) {
                for my $modobj ( values %{$self-&gt;module_tree} ) {

                    $modobj-&gt;_flush;
                }

            ### blow away the methods cache... currently, that's only
            ### File::Fetch's method fail list
            } elsif ( $what eq 'methods' ) {

                ### still fucking p4 :( ###
                $File'Fetch::METHOD_FAIL = $File'Fetch::METHOD_FAIL = {};

            ### blow away the m::l::c cache, so modules can be (re)loaded
            ### again if they become available
            } elsif ( $what eq 'load' ) {
                undef $Module::Load::Conditional::CACHE;

            } else {
                unless ( exists $self-&gt;{$cache} &amp;&amp; exists $Tmpl-&gt;{$cache} ) {
                    error( loc( "No such cache: '%1'", $what ) );
                    $flag++;
                    next;
                } else {
                    $self-&gt;$cache( {} );
                }
            }
        }
        return !$flag;
    }

### NOTE:
### if extra callbacks are added, don't forget to update the
### 02-internals.t test script with them!

=pod 

=head2 $bool = $internals-&gt;_register_callback( name =&gt; CALLBACK_NAME, code =&gt; CODEREF );

Registers a callback for later use by the internal libraries.

Here is a list of the currently used callbacks:

=over 4

=item install_prerequisite

Is called when the user wants to be C&lt;asked&gt; about what to do with
prerequisites. Should return a boolean indicating true to install
the prerequisite and false to skip it.

=item send_test_report

Is called when the user should be prompted if he wishes to send the
test report. Should return a boolean indicating true to send the 
test report and false to skip it.

=item munge_test_report

Is called when the test report message has been composed, giving
the user a chance to programatically alter it. Should return the 
(munged) message to be sent.

=item edit_test_report

Is called when the user should be prompted to edit test reports
about to be sent out by Test::Reporter. Should return a boolean 
indicating true to edit the test report in an editor and false 
to skip it.

=item proceed_on_test_failure

Is called when 'make test' or 'Build test' fails. Should return
a boolean indicating whether the install should continue even if
the test failed.

=item munge_dist_metafile

Is called when the C&lt;CPANPLUS::Dist::*&gt; metafile is created, like
C&lt;control&gt; for C&lt;CPANPLUS::Dist::Deb&gt;, giving the user a chance to
programatically alter it. Should return the (munged) text to be
written to the metafile.

=back

=cut

    sub _register_callback {
        my $self = shift or return;
        my %hash = @_;

        my ($name,$code);
        my $tmpl = {
            name    =&gt; { required =&gt; 1, store =&gt; \$name,
                         allow =&gt; [$callback-&gt;ls_accessors] },
            code    =&gt; { required =&gt; 1, allow =&gt; IS_CODEREF,
                         store =&gt; \$code },
        };

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

        $self-&gt;_callbacks-&gt;$name( $code ) or return;

        return 1;
    }

# =head2 $bool = $internals-&gt;_add_callback( name =&gt; CALLBACK_NAME, code =&gt; CODEREF );
# 
# Adds a new callback to be used from anywhere in the system. If the callback
# is already known, an error is raised and false is returned. If the callback
# is not yet known, it is added, and the corresponding coderef is registered
# using the
# 
# =cut
# 
#     sub _add_callback {
#         my $self = shift or return;
#         my %hash = @_;
#         
#         my ($name,$code);
#         my $tmpl = {
#             name    =&gt; { required =&gt; 1, store =&gt; \$name, },
#             code    =&gt; { required =&gt; 1, allow =&gt; IS_CODEREF,
#                          store =&gt; \$code },
#         };
# 
#         check( $tmpl, \%hash ) or return;
# 
#         if( $callback-&gt;can( $name ) ) {
#             error(loc("Callback '%1' is already registered"));
#             return;
#         }
# 
#         $callback-&gt;mk_accessor( $name );
# 
#         $self-&gt;_register_callback( name =&gt; $name, code =&gt; $code ) or return;
# 
#         return 1;
#     }

}

=pod

=head2 $bool = $internals-&gt;_add_to_includepath( directories =&gt; \@dirs )

Adds a list of directories to the include path.
This means they get added to C&lt;@INC&gt; as well as C&lt;$ENV{PERL5LIB}&gt;.

Returns true on success, false on failure.

=cut

sub _add_to_includepath {
    my $self = shift;
    my %hash = @_;

    my $dirs;
    my $tmpl = {
        directories =&gt; { required =&gt; 1, default =&gt; [], store =&gt; \$dirs,
                         strict_type =&gt; 1 },
    };

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

    my $s = $Config{'path_sep'};
    
    ### only add if it's not added yet
    for my $lib (@$dirs) {
        push @INC, $lib unless grep { $_ eq $lib } @INC;
        #
        ### it will be complaining if $ENV{PERL5LIB] is not defined (yet).   
        local $^W;  
        $ENV{'PERL5LIB'} .= $s . $lib 
            unless $ENV{'PERL5LIB'} =~ qr|\Q$s$lib\E|;
    }

    return 1;
}

=pod

=head2 $id = CPANPLUS::Internals-&gt;_last_id

Return the id of the last object stored.

=head2 $id = CPANPLUS::Internals-&gt;_store_id( $internals )

Store this object; return its id.

=head2 $obj = CPANPLUS::Internals-&gt;_retrieve_id( $ID )

Retrieve an object based on its ID -- return false on error.

=head2 CPANPLUS::Internals-&gt;_remove_id( $ID )

Remove the object marked by $ID from storage.

=head2 @objs = CPANPLUS::Internals-&gt;_return_all_objects

Return all stored objects.

=cut


### code for storing multiple objects
### -- although we only support one right now
### XXX when support for multiple objects comes, saving source will have
### to change
{
    my $idref = {};
    my $count = 0;

    sub _inc_id { return ++$count; }

    sub _last_id { $count }

    sub _store_id {
        my $self    = shift;
        my $obj     = shift or return;

       unless( IS_INTERNALS_OBJ-&gt;($obj) ) {
            error( loc("The object you passed has the wrong ref type: '%1'",
                        ref $obj) );
            return;
        }

        $idref-&gt;{ $obj-&gt;_id } = $obj;
        return $obj-&gt;_id;
    }

    sub _retrieve_id {
        my $self    = shift;
        my $id      = shift or return;

        my $obj = $idref-&gt;{$id};
        return $obj;
    }

    sub _remove_id {
        my $self    = shift;
        my $id      = shift or return;

        return delete $idref-&gt;{$id};
    }

    sub _return_all_objects { return values %$idref }
}

1;

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
</pre></body></html>