source.pm

source of perl for linux application,

            l   => loc('LGPL: "GNU Lesser General Public License" (previously known as "GNU Library General Public License")'),
            b   => loc('BSD: The BSD License'),
            a   => loc('Artistic license alone'),
            o   => loc('other (but distribution allowed without restrictions)'),
        }],
    ];

    return $aref;
}

=head2 $file = $cb->_add_custom_module_source( uri => URI, [verbose => BOOL] ); 

Adds a custom source index and updates it based on the provided URI.

Returns the full path to the index file on success or false on failure.

=cut

sub _add_custom_module_source {
    my $self = shift;
    my $conf = $self->configure_object;
    my %hash = @_;
    
    my($verbose,$uri);
    my $tmpl = {   
        verbose => { default => $conf->get_conf('verbose'),
                     store   => \$verbose },
        uri     => { required => 1, store => \$uri }
    };
    
    check( $tmpl, \%hash ) or return;
    
    ### what index file should we use on disk?
    my $index = $self->__custom_module_source_index_file( uri => $uri );

    ### already have it.
    if( IS_FILE->( $index ) ) {
        msg(loc("Source '%1' already added", $uri));
        return 1;
    }        
        
    ### do we need to create the targe dir?        
    {   my $dir = dirname( $index );
        unless( IS_DIR->( $dir ) ) {
            $self->_mkdir( dir => $dir ) or return
        }
    }  
    
    ### write the file
    my $fh = OPEN_FILE->( $index => '>' ) or do {
        error(loc("Could not open index file for '%1'", $uri));
        return;
    };
    
    ### basically we 'touched' it. Check the return value, may be 
    ### important on win32 and similar OS, where there's file length
    ### limits
    close $fh or do {
        error(loc("Could not write index file to disk for '%1'", $uri));
        return;
    };        
        
    $self->__update_custom_module_source(
                remote  => $uri,
                local   => $index,
                verbose => $verbose,
            ) or do {
                ### we faild to update it, we probably have an empty
                ### possibly silly filename on disk now -- remove it
                1 while unlink $index;
                return;                
            };
            
    return $index;
}

=head2 $index = $cb->__custom_module_source_index_file( uri => $uri );

Returns the full path to the encoded index file for C<$uri>, as used by
all C<custom module source> routines.

=cut

sub __custom_module_source_index_file {
    my $self = shift;
    my $conf = $self->configure_object;
    my %hash = @_;
    
    my($verbose,$uri);
    my $tmpl = {   
        uri     => { required => 1, store => \$uri }
    };
    
    check( $tmpl, \%hash ) or return;
    
    my $index = File::Spec->catfile(
                    $conf->get_conf('base'),
                    $conf->_get_build('custom_sources'),        
                    $self->_uri_encode( uri => $uri ),
                );     

    return $index;
}

=head2 $file = $cb->_remove_custom_module_source( uri => URI, [verbose => BOOL] ); 

Removes a custom index file based on the URI provided.

Returns the full path to the index file on success or false on failure.

=cut

sub _remove_custom_module_source {
    my $self = shift;
    my $conf = $self->configure_object;
    my %hash = @_;
    
    my($verbose,$uri);
    my $tmpl = {   
        verbose => { default => $conf->get_conf('verbose'),
                     store   => \$verbose },
        uri     => { required => 1, store => \$uri }
    };
    
    check( $tmpl, \%hash ) or return;

    ### use uri => local, instead of the other way around
    my %files = reverse $self->__list_custom_module_sources;
    
    ### On VMS the case of key to %files can be either exact or lower case
    ### XXX abstract this lookup out? --kane
    my $file = $files{ $uri };
    $file    = $files{ lc $uri } if !defined($file) && ON_VMS;

    unless (defined $file) {
        error(loc("No such custom source '%1'", $uri));
        return;
    };
                
    1 while unlink $file;
 
    if( IS_FILE->( $file ) ) {
        error(loc("Could not remove index file '%1' for custom source '%2'",
                    $file, $uri));
        return;
    }    
            
    msg(loc("Successfully removed index file for '%1'", $uri), $verbose);

    return $file;
}

=head2 %files = $cb->__list_custom_module_sources

This method scans the 'custom-sources' directory in your base directory
for additional sources to include in your module tree.

Returns a list of key value pairs as follows:

  /full/path/to/source/file%3Fencoded => http://decoded/mirror/path

=cut

sub __list_custom_module_sources {
    my $self = shift;
    my $conf = $self->configure_object;

    my $dir = File::Spec->catdir(
                    $conf->get_conf('base'),
                    $conf->_get_build('custom_sources'),
                );

    unless( IS_DIR->( $dir ) ) {
        msg(loc("No '%1' dir, skipping custom sources", $dir));
        return;
    }
    
    ### unencode the files
    ### skip ones starting with # though
    my %files = map {            
        my $org = $_;            
        my $dec = $self->_uri_decode( uri => $_ );            
        File::Spec->catfile( $dir, $org ) => $dec
    } grep { $_ !~ /^#/ } READ_DIR->( $dir );        

    return %files;    
}

=head2 $bool = $cb->__update_custom_module_sources( [verbose => BOOL] );

Attempts to update all the index files to your custom module sources.

If the index is missing, and it's a C<file://> uri, it will generate
a new local index for you.

Return true on success, false on failure.

=cut

sub __update_custom_module_sources {
    my $self = shift;
    my $conf = $self->configure_object;
    my %hash = @_;
    
    my $verbose;
    my $tmpl = {   
        verbose => { default => $conf->get_conf('verbose'),
                     store   => \$verbose }
    };
    
    check( $tmpl, \%hash ) or return;
    
    my %files = $self->__list_custom_module_sources;
    
    ### uptodate check has been done a few levels up.   
    my $fail;
    while( my($local,$remote) = each %files ) {
        
        $self->__update_custom_module_source(
                    remote  => $remote,
                    local   => $local,
                    verbose => $verbose,
                ) or ( $fail++, next );         
    }
    
    error(loc("Failed updating one or more remote sources files")) if $fail;
    
    return if $fail;
    return 1;
}

=head2 $ok = $cb->__update_custom_module_source 

Attempts to update all the index files to your custom module sources.

If the index is missing, and it's a C<file://> uri, it will generate
a new local index for you.

Return true on success, false on failure.

=cut

sub __update_custom_module_source {
    my $self = shift;
    my $conf = $self->configure_object;
    my %hash = @_;
    
    my($verbose,$local,$remote);
    my $tmpl = {   
        verbose => { default  => $conf->get_conf('verbose'),
                     store    => \$verbose },
        local   => { store    => \$local, allow => FILE_EXISTS },
        remote  => { required => 1, store => \$remote },
    };

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

    msg( loc("Updating sources from '%1'", $remote), $verbose);
    
    ### if you didn't provide a local file, we'll look in your custom
    ### dir to find the local encoded version for you
    $local ||= do {
        ### find all files we know of
        my %files = reverse $self->__list_custom_module_sources or do {
            error(loc("No custom modules sources defined -- need '%1' argument",
                      'local'));
            return;                      
        };

        ### On VMS the case of key to %files can be either exact or lower case
        ### XXX abstract this lookup out? --kane
        my $file = $files{ $remote };
        $file    = $files{ lc $remote } if !defined ($file) && ON_VMS;

        ### return the local file we're supposed to use
        $file or do {
            error(loc("Remote source '%1' unknown -- needs '%2' argument",
                      $remote, 'local'));
            return;
        };         
    };
    
    my $uri =  join '/', $remote, $conf->_get_source('custom_index');
    my $ff  =  File::Fetch->new( uri => $uri );           

    ### tempdir doesn't clean up by default, as opposed to tempfile()
    ### so add it explicitly.
    my $dir =  tempdir( CLEANUP => 1 );
    
    my $res =  do {  local $File::Fetch::WARN = 0;
                    local $File::Fetch::WARN = 0;
                    $ff->fetch( to => $dir );
                };

    ### couldn't get the file
    unless( $res ) {
        
        ### it's not a local scheme, so can't auto index
        unless( $ff->scheme eq 'file' ) {
            error(loc("Could not update sources from '%1': %2",
                      $remote, $ff->error ));
            return;   
                        
        ### it's a local uri, we can index it ourselves
        } else {
            msg(loc("No index file found at '%1', generating one",
                    $ff->uri), $verbose );
            
            ### ON VMS, if you are working with a UNIX file specification,
            ### you need currently use the UNIX variants of the File::Spec.
            my $ff_path = do {
                my $file_class = 'File::Spec';
                $file_class .= '::Unix' if ON_VMS;
                $file_class->catdir( File::Spec::Unix->splitdir( $ff->path ) );
            };      

            $self->__write_custom_module_index(
                path    => $ff_path,
                to      => $local,
                verbose => $verbose,
            ) or return;
            
            ### XXX don't write that here, __write_custom_module_index
            ### already prints this out
            #msg(loc("Index file written to '%1'", $to), $verbose);
        }
    
    ### copy it to the real spot and update it's timestamp
    } else {            
        $self->_move( file => $res, to => $local ) or return;
        $self->_update_timestamp( file => $local );
        
        msg(loc("Index file saved to '%1'", $local), $verbose);
    }
    
    return $local;
}

=head2 $bool = $cb->__write_custom_module_index( path => /path/to/packages, [to => /path/to/index/file, verbose => BOOL] )

Scans the C<path> you provided for packages and writes an index with all 
the available packages to C<$path/packages.txt>. If you'd like the index
to be written to a different file, provide the C<to> argument.

Returns true on success and false on failure.

=cut

sub __write_custom_module_index {
    my $self = shift;
    my $conf = $self->configure_object;
    my %hash = @_;
    
    my ($verbose, $path, $to);
    my $tmpl = {   
        verbose => { default => $conf->get_conf('verbose'),
                     store   => \$verbose },
        path    => { required => 1, allow => DIR_EXISTS, store => \$path },
        to      => { store => \$to },
    };
    
    check( $tmpl, \%hash ) or return;    

    ### no explicit to? then we'll use our default
    $to ||= File::Spec->catfile( $path, $conf->_get_source('custom_index') );

    my @files;
    require File::Find;
    File::Find::find( sub { 
        ### let's see if A::E can even parse it
        my $ae = do {
            local $Archive::Extract::WARN = 0;
            local $Archive::Extract::WARN = 0;
            Archive::Extract->new( archive => $File::Find::name ) 
        } or return; 

        ### it's a type A::E recognize, so we can add it
        $ae->type or return;

        ### neither $_ nor $File::Find::name have the chunk of the path in
        ### it starting $path -- it's either only the filename, or the full
        ### path, so we have to strip it ourselves
        ### make sure to remove the leading slash as well.
        my $copy = $File::Find::name;
        my $re   = quotemeta($path);        
        $copy    =~ s|^$re[\\/]?||i;
        
        push @files, $copy;
        
    }, $path );

    ### does the dir exist? if not, create it.
    {   my $dir = dirname( $to );
        unless( IS_DIR->( $dir ) ) {
            $self->_mkdir( dir => $dir ) or return
        }
    }        

    ### create the index file
    my $fh = OPEN_FILE->( $to => '>' ) or return;
    
    print $fh "$_\n" for @files;
    close $fh;
    
    msg(loc("Successfully written index file to '%1'", $to), $verbose);
    
    return $to;
}


=head2 $bool = $cb->__create_custom_module_entries( [verbose => BOOL] ) 

Creates entries in the module tree based upon the files as returned
by C<__list_custom_module_sources>.

Returns true on success, false on failure.

=cut 

### use $auth_obj as a persistant version, so we don't have to recreate
### modules all the time
{   my $auth_obj; 

    sub __create_custom_module_entries {
        my $self    = shift;
        my $conf    = $self->configure_object;
        my %hash    = @_;
        
        my $verbose;
        my $tmpl = {
            verbose     => { default => $conf->get_conf('verbose'), store => \$verbose },
        };
    
        check( $tmpl, \%hash ) or return undef;
        
        my %files = $self->__list_custom_module_sources;     
    
        while( my($file,$name) = each %files ) {
            
            msg(loc("Adding packages from custom source '%1'", $name), $verbose);
    
            my $fh = OPEN_FILE->( $file ) or next;
    
            while( <$fh> ) {
                chomp;
                next if /^#/;
                next unless /\S+/;
                
                ### join on / -- it's a URI after all!
                my $parse = join '/', $name, $_;
    
                ### try to make a module object out of it
                my $mod = $self->parse_module( module => $parse ) or (
                    error(loc("Could not parse '%1'", $_)),
                    next
                );
                
                ### mark this object with a custom author
                $auth_obj ||= do {
                    my $id = CUSTOM_AUTHOR_ID;
                    
                    ### if the object is being created for the first time,
                    ### make sure there's an entry in the author tree as
                    ### well, so we can search on the CPAN ID
                    $self->author_tree->{ $id } = 
                        CPANPLUS::Module::Author::Fake->new( cpanid => $id );          
                };
                
                $mod->author( $auth_obj );
                
                ### and now add it to the modlue tree -- this MAY
                ### override things of course
                if( my $old_mod = $self->module_tree( $mod->module ) ) {

                    ### On VMS use the old module name to get the real case
                    $mod->module( $old_mod->module ) if ON_VMS;

                    msg(loc("About to overwrite module tree entry for '%1' with '%2'",
                            $mod->module, $mod->package), $verbose);
                }
                
                ### mark where it came from
                $mod->description( loc("Custom source from '%1'",$name) );
                
                ### store it in the module tree
                $self->module_tree->{ $mod->module } = $mod;
            }
        }
        
        return 1;
    }
}


# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:

1;