Subversion Repositories DevTools

#! perl
########################################################################
# Copyright (C) 1998-2004 ERG Limited, All rights reserved
#
# Module name   : cache_dpkg
# Module type   : Makefile system
# Compiler(s)   : n/a
# Environment(s): jats
#
# Description:
#       Maintain a local cache of dpkg_Archive
#
# Notes:
#       Stopped using the JATS "cp.exe" utility as there was a weird problem under
#       windows. The package orahops-ssw-install/1.0.1000.ssw could not be installed
#       correctly. It appears that the 'cp' could not process the subdir pair
#       "DBMGR/DBMGR". Change the name it was OK.
#
#       Solution: Avoid system functions
#
#......................................................................#

use strict;
use warnings;
use JatsError;
use FileUtils;
use File::Find;
use File::Path;
use File::Copy;

use Getopt::Long;
use Pod::Usage;                             # required for help support

my $VERSION = "1.4.0";


#
#   Options
#
my $opt_debug   = $ENV{'GBE_DEBUG'};        # Allow global debug
my $opt_verbose = $ENV{'GBE_VERBOSE'};      # Allow global verbose
my $opt_help = 0;
my $opt_clear;
my $opt_flush;
my $opt_refresh;
my $opt_refresh_all;
my $opt_list;
my $opt_list_short;
my $opt_export;
my $opt_quiet;
my $opt_update_all;
my $opt_age;
my $opt_test;

#
#   Global Variables
#
my $GBE_DPKG        = $ENV{'GBE_DPKG'};                     # The Master repository
my $GBE_DPKG_CACHE  = $ENV{'GBE_DPKG_CACHE'} || "";         # Caches
my $GBE_DPKG_LOCAL  = $ENV{'GBE_DPKG_LOCAL'} || "";         # Local scratch
my $GBE_DPKG_STORE  = $ENV{'GBE_DPKG_STORE'} || "";         # Global Store
my $GBE_BIN         = $ENV{'GBE_BIN'};

my $gstore;
my $archive;
my $cache;
my $parchive;
my $local = '';
my $local_pkg;
my @package_list;
my @refresh_list;
#
#   Globals for recursive copy
#
my $copyFind_dst;
my $copyFind_src;
my $copyFind_src_len;

#
#   Globals for error recovery
#
my  $remove_on_error;

#-------------------------------------------------------------------------------
# Function        : Mainline Entry Point
#
# Description     :
#
# Inputs          :
#
my $result = GetOptions (
                "help|h:+"                  => \$opt_help,
                "manual:3"                  => \$opt_help,
                "verbose:+"                 => \$opt_verbose,           # flag, multiple use allowed
                "debug:+"                   => \$opt_debug,             # flag, multiple use allowed
                "flush"                     => \$opt_flush,             # flag
                "clear"                     => \$opt_clear,             # flag
                "refresh!"                  => \$opt_refresh,           # flag
                "refresh_all|refresh-all"   => \$opt_refresh_all,       # flag
                "update_all|update-all"     => \$opt_update_all,        # flag
                "list"                      => \$opt_list,              # flag
                "dir"                       => \$opt_list_short,        # flag
                "export"                    => \$opt_export,            # flag
                "quiet"                     => \$opt_quiet,             # flag
                "age=i"                     => \$opt_age,               # integer
                "test"                      => \$opt_test,              # flag
                );

                #
                #   UPDATE THE DOCUMENTATION AT THE END OF THIS FILE !!!
                #

#
#   Process help and manual options
#
pod2usage(-verbose => 0, -message => "Version: $VERSION")  if ($opt_help == 1  || ! $result);
pod2usage(-verbose => 1)  if ($opt_help == 2 );
pod2usage(-verbose => 2)  if ($opt_help > 2);

#
#   Configure the error reporting process now that we have the user options
#
ErrorConfig( 'name'    =>'CACHE',
             'verbose' => $opt_verbose,
             'debug'   => $opt_debug );

#
#   Validate user options
#
Error( "GBE_BIN not defined in the environment" ) unless ( defined($GBE_BIN) );
Error( "GBE_DPKG not defined in the environment" ) unless ( defined($GBE_DPKG) );

#
#   No cache - nothing to do
#   Generate a status message and exit
#
unless ( defined($GBE_DPKG_CACHE) )
{
    Warning ( "GBE_DPKG_CACHE not defined in the environment" );
    return 0;
}


$opt_refresh = 1
    if ( $opt_refresh_all );

#
#   Locate the archive cache
#
#   Determine the archive to work on
#   Search the cache archive list for one with the keyword "_cache"
#   or use the last one.
#
$GBE_DPKG =~ tr~\\/~/~s;
$GBE_DPKG =~ s~/$~~;

my @pkg_list = split ( ';', $GBE_DPKG_CACHE );
for (@pkg_list)
{
    $cache = $_
        if ( m/_cache/ );
}
$cache = pop @pkg_list unless ( $cache );
$archive = $GBE_DPKG;
$local = $GBE_DPKG_LOCAL;
$gstore = $GBE_DPKG_STORE;

Error ("No dpkg_archive_cache found") unless ( $cache );
Error ("dpkg_archive_cache is the main archive") if ( $cache eq $archive );
Error ("main archive is local archive" )         if ( $local && $local eq $archive );
Warning  ("dpkg_archive_cache is local_archive" )   if ( $local && $local eq $cache );

#
#   Export the list of cache entries
#
if ( $opt_export or $opt_refresh_all or $opt_list_short or $opt_update_all )
{
    opendir (DIR, $cache) || die "Cannot open $cache\n";
    my @dir_list = readdir(DIR);
    closedir DIR;

    for my $fn ( @dir_list)
    {
        my $count = 0;
        next if ( $fn =~ m/^\./ );
        next unless ( -d "$cache/$fn" );

        opendir( DIR, "$cache/$fn" ) || die "Cannot open $cache/$fn\n";
        while ( my $fn1 = readdir(DIR) )
        {
            next if ( $fn1 =~ m/^\./ );
            push @package_list, "$fn/$fn1";
        }
        closedir DIR;
    }

    if ( $opt_refresh_all or $opt_update_all )
    {
        @refresh_list = @package_list
    }

    #
    #   Simply export a list of packages in the cache
    #   Used by other programs
    #
    if ( $opt_export )
    {
        print join ' ', @package_list;
        exit 0;
    }
}

#
#   Display cache information
#   This is done AFTER the export - since the export command does not
#   need this header.
if ( $opt_verbose || $#ARGV < 0 )
{
    print  "dpkg_store        : $gstore\n" if ($gstore);
    print  "dpkg_archive      : $archive\n";
    print  "dpkg_archive cache: $cache\n";
    print  "dpkg_archive local: $local\n";
    Verbose ("args:               @ARGV");
}

#
#   List the contents of the cache
#
if ( $opt_list_short )
{
    print join "\n", @package_list;
}

if ( $opt_list )
{
    #
    #   Process user commands
    #   List: A nice pretty display of the cache
    #
    opendir (DIR, $cache) || die "Cannot open $cache\n";
    my @dir_list = readdir(DIR);
    closedir DIR;

    #
    #   Determine max length of a name so that the display is nicely aligned
    #
    my $nl = 10;
    for my $fn ( @dir_list)
    {
        my $ns = length($fn);
        $nl = $ns if ( $ns > $nl )
    }

    #
    #   Display information by package
    #   A nicely formatted list with line wrapping
    #
    for my $fn ( @dir_list)
    {
        my $count = 0;
        next if ( $fn =~ m/^\./ );
        next unless ( -d "$cache/$fn" );

        opendir( DIR, "$cache/$fn" ) || die "Cannot open $cache/$fn\n";
        printf "%-*s :", $nl, $fn;
        while ( my $fn1 = readdir(DIR) )
        {
            next if ( $fn1 =~ m/^\./ );
            if ( $count++ >= 4 )
            {
                $count = 1;
                printf "\n%*s  ", $nl, "";
            }
            printf " %14.14s", $fn1;
        }
        closedir DIR;
        print "\n";
    }
}

#
#   Clear the cache
#
if ( $opt_clear )
{
    Warning   ( "Deleting the ENTIRE cache");
    rmtree( $cache, $opt_debug );
    mkpath( $cache, $opt_debug, 0777);
}

#
#   Perform cache aging
#
if ( $opt_age )
{
    Error ("Age parameter cannot be negative") if ( $opt_age < 0 );
    age_the_cache();
}

#
#   Process the command line arguments
#   These MUST be of the form
#       packagename
#       packagename/version
#

for (@ARGV, @refresh_list)
{
    $remove_on_error = undef;
    if ( $opt_flush )
    {
        unless ( -d "$cache/$_" )
        {
            Warning ("Package not in cache: $_")
                unless ( $opt_quiet );
        }
        else
        {
            rmtree( "$cache/$_", $opt_debug );
            print "Package removed: $_\n"
                unless ( $opt_quiet );
        }
    }
    else
    {
        #
        #   Speed up - for remote access
        #   If the package is found in the local archive and we aren't doing
        #   anything fancy then don't access the remote archive
        #
        my $local_pkg = ( -d "$local/$_" || -f "$local/$_.lnk" );
        if ( $local_pkg )
        {
            if ( !$opt_refresh )
            {
                print "Cache SkipLocal: $_ Local copy found\n";

                #
                # Delete the cache copy
                # The user is playing with local copy
                #
                if ( -d "$cache/$_" )
                {
                    print  "Cache SkipLocalDelete: $_ -> $cache\n";
                    Verbose ( "Remove: $_" );
                    rmtree( "$cache/$_", $opt_debug );
                    Verbose ( "Remove Complete: $_" );
                }
                next;
            }
        }

        #
        #   Locate package.
        #   It may be in GBE_DPKG or GBE_DPKG_STORE
        #
        $parchive = "$archive/$_";
        unless ( -d $parchive )
        {
            $parchive = "$gstore/$_";
            unless ( $gstore && -d $parchive )
            {
                Warning ("Package not in archive: $_")
                    unless ( $opt_quiet );
                next;
            }
        }

        ########################################################################
        #   We have a package to process
        #

        my $dir_found = ( -d "$cache/$_" ) ;
        my $force_update = 0;
        my $opr = "Update";


        #
        #   Setup error recovery
        #       1) Tag the directory to be deleted on error
        #
        $remove_on_error = "$cache/$_";
        ErrorConfig( 'on_exit' => \&error_recovery );

        #
        #   Not a forced refresh. Ensure that the cached copy is
        #   up to date. Examine descpkg
        #
        if ( $dir_found )
        {
            if ( -f "$cache/$_/built.cache" )
            {
                $force_update = 1;
                $opr = "Incomplete";
                Verbose ("Cache Copy Incomplete: $_");
            }
            elsif ( FileIsNewer( "$parchive/descpkg", "$cache/$_/descpkg" ) )
            {
                $force_update = 1;
                $opr = "OutOfDate";
                Verbose ("Cache out-of-date: $_");
            }
        }

        #
        #   If we need to refresh the cache copy - delete it first
        #
        if ( ($opt_refresh || $force_update) && $dir_found )
        {
            print  "Cache $opr: $_ -> $cache\n";
            Verbose ( "Remove: $_" );
            rmtree( "$cache/$_", $opt_debug );
            Verbose ( "Remove Complete: $_" );

            #
            #   Force transfer, but without the status message
            #
            $dir_found = 0;
            $opr = '';
        }

        #
        #   If its not in the cache then copy it in
        #
        unless ( $dir_found )
        {
            print "Cache $opr: $_ -> $cache\n" if $opr;
            mkpath( "$cache/$_", $opt_debug, 0777);
            TouchFile ( "$cache/$_/built.cache", "Marks the cache copy as incomplete");
            Verbose ( "Copy in: $_" );
            $copyFind_dst = "$cache/$_";
            $copyFind_src = $parchive;
            $copyFind_src_len = length( $copyFind_src );
            File::Find::find( \&copyFind, $parchive );
            rmtree( "$cache/$_/built.cache", $opt_debug );  # Works on files too !!
        }
        else
        {
            $opr = "Skip";
            print "Cache $opr: $_ -> $cache\n";
        }
    }
}

#-------------------------------------------------------------------------------
# Function        : copyFind
#
# Description     : File:Find:find callback function to transfer files
#
# Inputs          : None
#                   Global: $copyFind_dst       : Target directory
#                   Global: $copyFind_src       : Source directory
#                   Global: $copyFind_src_len   : Length of Source dir
#
# Returns         : 
#

sub copyFind
{
    my $item = $File::Find::name;

    #
    #   Calculate the target directory name
    #
    my $target = $copyFind_dst . substr($item, $copyFind_src_len );
    if ( -d $item )
    {
        #
        #   Directories are handled differently
        #       - Directories are created with nice permissions
        #
        if ( ! -d $target )
        {
            mkpath( $target, $opt_debug, 0755);
        }
    }
    else
    {
        #
        #   File copy
        #
        #
        #   Copy file to destination
        #   If the file is a link, then duplicate the link contents
        #   Use: Unix libraries are created as two files:
        #        lib.xxxx.so -> libxxxx.so.vv.vv.vv
        #
        if ( -l $item )
        {
            Debug("Clone Link: $target");
            my $link = readlink $item;
            Debug( "Link: $item, $link");
            symlink ($link, $target );
            unless ( $link && -l $target )
            {
                Error("Failed to copy link [$item] to [$target]: $!");
            }
        }
        elsif (File::Copy::copy($item, $target))
        {
            Debug("Copying File: $target");

            #   Make the file ReadOnly
            my $perm = (stat $item)[2] & 07777;
            CORE::chmod $perm & 0555, $target;
        }
        else
        {
            Error("Failed to copy file [$item] to [$target]: $!");
        }
    }
}

#-------------------------------------------------------------------------------
# Function        : error_recovery
#
# Description     : Error recovery routine
#                   Delete the cached entry
#
# Inputs          :  Globals
#
# Returns         : None
#
sub error_recovery
{
    if ( $remove_on_error )
    {
        ReportError ("Error cleanup. Delete cache entry: $remove_on_error");
        rmtree( $remove_on_error, $opt_debug );
        $remove_on_error = undef;
    }
}


#-------------------------------------------------------------------------------
# Function        : age_the_cache
#
# Description     : Age cache entries
#                   Determine the age by:
#                       Use used.cache file if present
#                       Use descpkg file
#                       Not a proper entry - delete
#
# Inputs          : opt_age         - Delete packages older than XX days
#
# Returns         : Nothing
#
sub age_the_cache
{
    my $now = time;

    opendir (DIR, $cache) || die "Cannot open $cache\n";
    my @dir_list = readdir(DIR);
    closedir DIR;

    for my $fn ( @dir_list)
    {
        my $keep_dir = 0;
        next if ( $fn =~ m/^\./ );
        next unless ( -d "$cache/$fn" );
        next if ( $fn eq "core_devl" );

        opendir( DIR, "$cache/$fn" ) || die "Cannot open $cache/$fn\n";
        while ( my $fn1 = readdir(DIR) )
        {
            next if ( $fn1 =~ m/^\./ );
            my $dir = "$cache/$fn/$fn1";
            my $file = "$dir/used.cache" ;
            $file = "$dir/descpkg" unless ( -f $file );

            if ( ! -f $file )
            {
                #
                #   No descpkg file
                #   This is a badly formed entry - so delete it
                #
                if ( $opt_test )
                {
                    Message("Would Purge: $fn/$fn1" );
                    $keep_dir = 1;
                }
                else
                {
                    Message("Purging: $fn/$fn1" );
                    rmtree( $dir, $opt_debug );
                }
            }
            else
            {
                #
                #   used.cache or descpkg file found
                #   How old is it
                #
                my $timestamp = (stat($file))[9] || 0;
                my $age = int( ($now - $timestamp) / (60 * 60 * 24));
            
                if ( $age > $opt_age )
                {
                    if ( $opt_test )
                    {
                        Message("Could Age: $fn/$fn1, $age" );
                        $keep_dir = 1;
                    } else {
                        Message("Aging: $fn/$fn1, $age" );
                        rmtree( $dir, $opt_debug );
                    }
                }
                else
                {
                    Verbose("Age of: $fn/$fn1, $age" );
                    $keep_dir = 1;
                }
            }
        }
        closedir DIR;

        #
        #   Delete the entire directory if is is empty
        #
        unless ( $keep_dir )
        {
            Message("Remove Empty Dir: $cache/$fn"  );
            rmtree( "$cache/$fn", $opt_debug );
        }
    }
}

#-------------------------------------------------------------------------------
#   Documentation
#

=pod

=for htmltoc    SYSUTIL::

=head1 NAME

cache_dpkg - Maintain a local cache of packages

=head1 SYNOPSIS

 jats cache_dpkg.pl [options] package/version ...

 Options:
    -help              - brief help message
    -help -help        - Detailed help message
    -man               - Full documentation
    -clear             - Delete the entire cache
    -flush             - Flush all named packages
    -[no]refresh       - Refresh package in cache
    -list              - List cache contents with nice format
    -dir               - List cache contents
    -export            - Generate a list of cached packages
    -refresh_all       - Refresh all packages within the cache
    -update_all        - Update all packages within the cache as required
    -quiet             - Suppress warnings
    -age=nn            - Remove all packages older than nn days
    -test              - Use with -age to report ages

=head1 OPTIONS

=over 8

=item B<-help>

Print a brief help message and exits.

=item B<-help -help>

Print a detailed help message with an explanation for each option.

=item B<-man>

Prints the manual page and exits.

=item B<-clear>

Delete the B<entire> contents of the dpkg_archive cache. This will occur before
any new packages are copied into the cache.

=item B<-flush>

If set then the utility will delete the named packages from the cache. All named
packaged will be deleted. This option affects all named packages. It is not
possible to flush and copy packages with the same command.

=item B<-[no]refresh>

If the B<refresh> option has been specified then packages will be deleted, from
the cache and then a new copy will be copied in. If not specified then no copy
will occur if the package is present in the cache.

=item B<-list>

Display a list of all packages in the cache. A formatted display is generated.

This will be done before any packages are transferred.

=item B<-dir>

Display a list of all packages in the cache. This is a raw directory like
listing of the cache.

This will be done before any packages are transferred.

=item B<-export>

Generate a space separated list of cached packages as a single line. This is
intended to allow a list be exported for later import.

=item B<-refresh_all>

This option will force the program to refresh all the packages in the cache.
This forces a B<-refresh> and may be combined with other packages specified
on the command line.

=item B<-update_all>

This option will force the program to examine all packages within the cache and
refresh packages that are out of date. This option may be combined with other
packages specified on the command line.

A package is deemed to be out-of-date if the modification time of the package's
descpkg file in the cache is older than the one in the archive.

=item B<-quiet>

This option will suppress almost all of the progress messages, except for a single
copy message. It is intended to be used when the program is called from another
script.

=item B<-age=nn>

This option will delete all package versions that are older than the nn days.
The age of a package is calculated from the timestamp of the descpkg file.

=item B<-test>

This option modifies the operation of the B<-age=nn> option such that it will not
delete old package-versions. It will simply report what would be deleted.

=back

=head1 DESCRIPTION

This program simplifies the operation of maintaining a local copy of
used packages from the maintaining dpkg_archive store. The cache should be
stored on your local disk for speed.

The local cache and the master cache are both determined from the environment
variable GBE_DPKG.

=head2 Location of the cache

The local cache is located by examining the paths specified in GBE_DPKG. The
local cache is taken to be the last directory with the keys string B<_cache> in it.

The local cache cannot be the same as the main cache.

The suggested named for the cache is: F<dpkg_archive_cache>

=head2 Location of the maintaining archive

The main cache is located by examining the paths specified in GBE_DPKG. The
main cache is taken to be the last directory with list.

=head2 Interaction with local_dpkg_archive

If a package is located in the users local_dpkg_archive and we are doing a
simple cache update then the package will be deleted from the cache. This is
done to speed use on slow remote links and ensure cache consistency.

=head1 EXAMPLE

=head2 jats dpkg_cache -list

This will list the current contents of the cache.

=head2 jats dpkg_cache -refresh crc/1.0.4.cr

This will delete any cached copy of the package crc/1.0.4.cr, if one exists,
and then copy in a new version.

=head2 jats dpkg_cache crc

This will copy in all versions of the crc package. This may not be desirable.

=head2 jats dpkg_cache -update_all

This will examine all packages in the cache and refresh those packages that are
out of date.

=cut