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;

#

#   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 (

                "verbose:+"     => \$opt_verbose,

                "info:+"        => \$opt_info,

                "age=i"         => \$opt_age,

                );

die ("Bad options") if ! $result;

#

#   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;

}