Subversion Repositories DevTools

#! /usr/bin/perl
########################################################################
# Copyright (C) Vix Technology, All rights reserved
#
# Module name   : pkg_purge
# Module type   :
# Compiler(s)   : Perl
# Environment(s):
#
# Description   : Dpkg_archive package purge tool
#                 Designed to be run periodically from cron
#
#                 Operations
#                 Purges packages marked for deletion
#                   Uses .deletepkg tag file
#                   Uses current ArchiveList
#
#......................................................................#

require 5.008_002;
use strict;
use warnings;

use Pod::Usage;
use Getopt::Long;
use File::Find;
use File::Path;
use POSIX qw(strftime);
use Data::Dumper;
use FindBin;                                    # Determine the current directory


#
#   Definitions
#
our $dpkg       = "$ENV{HOME}/dpkg_archive";    # Root of the archive
our $metaDir    = '.dpkg_archive';              # Name of meta directory
our $metadir    = "$dpkg/$metaDir";
our $list       = "$metadir/ArchiveList";       # Current Archive List
our $deleteTag  = '.deletepkg';                 # Tag file for deletion
our $rootDir    = $FindBin::Bin;                # This script - and its helpers

#
#   Options
#
our $opt_age        = 100;                          # Keep for xxx days
our $opt_verbose    = 0;
our $opt_info       = 0;
our $opt_help       = 0;

#
#   Globals
#
our $needPkgs;                                  # Need these packages

#-------------------------------------------------------------------------------
# Function        : Mainline Entry
#
# Description     : Designed to be used with CRON and CRON to email
#                   admin on errors
#
# Inputs          : None
#
# Returns         : None Zero on error
#

my $result = GetOptions (
                "help:+"        => \$opt_help,
                "verbose:+"     => \$opt_verbose,
                "info:+"        => \$opt_info,
                "age=i"         => \$opt_age,

                );
die ("Bad options") if ! $result;
pod2usage(-verbose => $opt_help - 1 ) if $opt_help;

#
#   Must have an archive
#
die ("Home directory MUST have link to dpkg_archive") if ( ! -d $dpkg  );
die ("No dpkg_archive metadata") if ( ! -d $metadir );
die ("No ArchiveList") if ( ! -f $list );
Log ("Start of package purge. Age: $opt_age" );

#
#   Read in current archive list
#
open (my $fh, '<', $list ) || die ("Cant open $list. $!");
while ( <$fh> )
{
    chomp;
    $needPkgs->{$_} = 1;
}
close $fh;

#
#   Scan the package tree
#
opendir(DIR, $dpkg) || die "Can't opendir $dpkg: $!";
my @dlist = readdir(DIR);
closedir DIR;

foreach my $pname ( sort @dlist )
{
    next if ( $pname eq '.' );
    next if ( $pname eq '..' );
    next if ( $pname eq $metaDir );
    my $dir = $dpkg . '/'. $pname;
    next unless ( -d $dir );

    opendir(DIR, $dir )|| die "Can't opendir $dir: $!";
    my @vlist = readdir(DIR);
    closedir DIR;

    foreach my $vname ( sort @vlist )
    {
        next if ( $vname eq '.' );
        next if ( $vname eq '..' );
        next if ( $vname =~ m~\.TMPDIR$~ );
        my $vdir = $dir . '/' . $vname;
        next if ( -l $vdir );
        next unless ( -d $vdir );

        my $pv = "$pname/$vname";
        if ( exists $needPkgs->{$pv} )
        {
            #
            #   Need this package
            #   If it has a delete tag, then remove it
            #
            if ( -f "$vdir/$deleteTag" )
            {
                RemoveTagFile ($pname, $vname)
            }
            else
            {
                Log ("Package needed: $pname $vname") if ( $opt_verbose > 1 );
            }
        }
        else
        {
            #
            #   Don't need this package
            #   Its not in the current ArchiveList
            #
            #   If it doesn't have a tag file then  it must be a
            #   stray - tag it for latter. It will get aged out one day
            #
            #   If it does, then test its age
            #
            unless ( -f "$vdir/$deleteTag" )
            {
                CreateTagFile ($pname, $vname);
            }
            elsif ( -M "$vdir/$deleteTag" > $opt_age )
            {
                DeletePackage ($pname, $vname);
            }
            else
            {
                if ( $opt_verbose > 0 )
                {
                    my $age = -M "$vdir/$deleteTag";
                    Log ("Package not old enough: $age: $pname $vname") ;
                }
            }
        }
    }
}

#-------------------------------------------------------------------------------
# Function        : RemoveTagFile
#                   DeletePackage
#                   CreateTagFile
#
# Description     : Manipulate the tag files
#                   Use existing program to do the hard work
#
# Inputs          : $pname
#                   $pver
#
# Returns         : Nothing
#
sub RemoveTagFile
{
    system ("$rootDir/delete_package", '-K', @_ ) unless $opt_info;
    Log ("Package marked for retention: @_");
}

sub DeletePackage
{
    system ("$rootDir/delete_package", @_ ) unless $opt_info;
    Log ("Package Deleted: @_");
}

sub CreateTagFile
{
    system ("$rootDir/delete_package", '-T', @_ ) unless $opt_info;
    Log ("Package Tagged: @_");
}

#-------------------------------------------------------------------------------
# Function        : Log
#
# Description     : Log action to log file
#                   If in info mode then simply display it
#
# Inputs          : $text to log
#
# Returns         : Nothing
#
sub Log
{
    my ($text) = @_;
    if ( $opt_info )
    {
        print "$text\n";
        return;
    }

    my $logfile = "$metadir/pkg_purge/";
    mkpath ($logfile);
    
    $logfile .= strftime "pkg_purge.%Y-%m-%d.txt", localtime();

    open my $fh, ">>$logfile" or die "Can't logfile $logfile: $!\n";
    print $fh localtime()." : $text\n";
    close $fh;
}

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

=pod

=head1 NAME

pkg_purge - Purge packages from the archive

=head1 SYNOPSIS

  pkg_purge [options]

 Options:
    -help               - brief help message
    -help -help         - Detailed help message
    -verbose            - Verbose operation
    -info               - Display operations that would be done
    -age=nn             - Set purge age

=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<-verbose>

Increases program output. This option may be specified multiple times

=item B<-info>

Display operations that would be done, but does not purge any files.

=item B<-age=nn>

Sets the purge age. Packages that have been flagged for deletion more than nn days ago will be purged.

=back

=cut