Subversion Repositories DevTools

Rev

Rev 5209 | Rev 5212 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed 

########################################################################
# Copyright (c) VIX TECHNOLOGY (AUST) LTD
#
# Module name   : jats_lxr.pl
# Module type   : JATS Utility
# Compiler(s)   : Perl
# Environment(s): jats
#
# Description   : Tiools to maintain LXR information
#
# Usage         : See POD at the end of this file
#
#......................................................................#

require 5.008_002;
use strict;
use warnings;

use Pod::Usage;
use Getopt::Long;
use File::Path;
use FindBin;
use Socket;

use JatsError;
use JatsRmApi;
use DBI;
use JatsSystem;
use FileUtils;

#
#   Config Options
#
my $VERSION = "1.0.0";                      # Update this
my $opt_help = 0;
my $opt_verbose = $ENV{'GBE_VERBOSE'};      # Allow global verbose
my $opt_createVersions = 1;
my $opt_index = 1;
my $opt_purge = 1;
my $opt_extract = 1;
my $opt_logfile = 1;
my $opt_config;


#
#   Globals
#
my $scriptDir;
my $RM_DB;
our $config;
my @addressList;
my %ReleaseData;
my %Packages;
my $PackageStore;
my $ReleaseStore;
my $stamptime = time;

#-------------------------------------------------------------------------------
# Function        : Main
#
# Description     : Main entry point
#                   Parse user options
#
# Inputs          :
#
# Returns         :
#

my $result = GetOptions (
                "help:+"            => \$opt_help,              # flag, multiple use allowed
                "manual:3"          => \$opt_help,              # flag, multiple use allowed
                "verbose:+"         => \$opt_verbose,           # flag
                "createVersions!"   => \$opt_createVersions,
                "purge!"            => \$opt_purge,
                "index!"            => \$opt_index,
                "extract!"          => \$opt_extract,
                "logfile!"          => \$opt_logfile,
                "config:s"          => \$opt_config,
                );

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

#
#   Capture all logging to a file
#   Could be done by the jats wrapper, but this way we can control its location
#
ErrorConfig( 'name'    => 'LXR',
             'verbose' => $opt_verbose );

#
#   Sanity test
#

$scriptDir = $FindBin::Bin;
InitFileUtils();

#
#   Read the tool configuration
#
readConfig();
Error ("No LXR Data directory defined", $config->{lxrFiles}) unless( exists $config->{lxrFiles});
Error ("No LXR Data directory found", $config->{lxrFiles}) unless( -d $config->{lxrFiles});
Error ("No LXR Install directory defined",$config->{lxr}) unless( exists $config->{lxr});
Error ("No LXR Install directory found",$config->{lxr}) unless( -d $config->{lxr});

#
#   Start logging
#
startLogFile();
Message ("Start of LXR. " . localtime(time) ) if $opt_logfile;
Message("ScriptDir: $scriptDir");

#
#   Check required paths exist
#
$PackageStore = catdir($config->{lxrFiles}, 'Packages');
$ReleaseStore = catdir($config->{lxrFiles}, 'Releases');
mkpath($PackageStore);
mkpath($ReleaseStore);
Error ("Package Store not found ",$PackageStore) unless( -d $PackageStore);
Error ("Release Store not found ",$ReleaseStore) unless( -d $ReleaseStore);

#
#   Default config
#
$config->{'releaseAge'} = 0 unless exists $config->{'releaseAge'};
$config->{'packageAge'} = 0 unless exists $config->{'packageAge'};

#
#   Determine the various names for this machine
#   Include all the IP addresses too
#
my ($canonname, $aliases, $addrtype, $length, @addrs) = gethostbyname($ENV{GBE_HOSTNAME});
push @addressList, $canonname ;
push (@addressList, $aliases) if ($aliases) ;
push (@addressList, $ENV{GBE_HOSTNAME});
foreach ( @addrs) {
    push @addressList, inet_ntoa($_); 
}
Message("IpAddress: @addressList");

#
#   Perform the hard work
#
getReleaseData();
determineDataToExtract();
createReleaseViews() if $opt_createVersions;
cleanReleaseViews();
rebuildLxrConfig();
buildIndexes() if $opt_index;
cleanPackageStore() if $opt_purge;
cleanupLogFiles() if $opt_purge;

#
#   All done
#
Message ("End of LXR. " . localtime(time) ) if $opt_logfile;
exit 0;

#-------------------------------------------------------------------------------
# Function        : determineDataToExtract 
#
# Description     : Determine the packages that need to be extracted
#                   Don't extract them if they already exist
#
# Inputs          : 
#
# Returns         : 
#
sub determineDataToExtract
{
    foreach my $pvid ( keys{%Packages})
    {
        my $entry = $Packages{$pvid};
        #DebugDumpData("Entry", \$entry);
        my $fullName = join('_', $entry->{name}, $entry->{ver});
        my $fullPath = catfile($PackageStore , $fullName);
        next unless defined $entry->{vcs};
        next if ( $entry->{vcs} ) =~ m~^UC::~;
        unless (-d $fullPath ) 
        {
            Message("Need to extract: $entry->{name}, $entry->{ver}");
            if ($opt_extract)
            {
                Verbose0("Extracting into: $fullPath");
                if ($entry->{vcs} ~= m~/MASS_Dev_Crypto/~)
                {
                    print "$fullName : SUPPRESSED\n";
                }
                else
                {
                    my $rv = JatsCmd ('jats_vcsrelease', '-devmode=escrow', '-extractfiles', "-view=$fullName", "-label=$entry->{vcs}", "-root=$PackageStore", "-noprefix");
                    print "$fullName : SUCCESS\n" unless $rv;
                    print "$fullName : ERROR\n" if $rv;
                    $entry->{bad} = 1;
                }
            }
        }
        else
        {
            #   Package already extracted
            #   Ensure that it does not get aged out
            deleteAgeMarker($fullPath);
        }
    }
}

#-------------------------------------------------------------------------------
# Function        : createReleaseViews 
#
# Description     : Create a new view for each Release
#                   Each view is basically a bunch of symlinks
#
# Inputs          : 
#
# Returns         : 
#
sub createReleaseViews
{
    #
    #   Create a name for the releases - based on a date-time
    #   Will be unqiue(ish)
    #
    my $dateTag = localtime($stamptime);

    foreach my $rtagid (keys \%ReleaseData)
    {
        my $entry = $ReleaseData{$rtagid};
        my $latestView = getLatestVersion(catdir($ReleaseStore, $rtagid));
        my  $needNewView = 1;

        #
        #   Check to see if we really need to create a new view
        #   If the LATEST view contins all the package-versions that we need then
        #   don't create a new one.
        #
        #   Scan each entry within the Last View
        #
        if ($latestView)
        {
            my %pkgsUsed;
            opendir (my $ldir, $latestView) || Warning ("Cannot open directory: $latestView", $!);
            while (my $ldirEntry = readdir($ldir))
            {
                #   Skip hidden files
                next if ($ldirEntry =~ m~^\.~);
                my $dirName = catdir($latestView, $ldirEntry );

                #
                #   Process each entry within the Version
                #
                my $pkgName = $ldirEntry;
                if (-l $dirName)
                {
                    $pkgName = readlink($dirName);
                    $pkgName =~ s~.*/~~;
                }
                $pkgsUsed{$pkgName} = 2;
            }
            close ($ldir);

            #
            #   Compare Package-Versions against those we need
            # 
            foreach my $pvid (keys $entry->{data})
            {
                my $entry = $Packages{$pvid};
                my $fullName = join('_', $entry->{name}, $entry->{ver});
                $pkgsUsed{$fullName}++;
            }
            
            #
            #   Scan the pkgUsed
            #   A value of 1 indicates that it is used only in the New Version
            #   A value of 2 indicates that it is only used on the Last Version
            #   A value of 3 indicates that its used in both
            #   Detect those that are not a 3
            #
            $needNewView = 0;
            foreach ( keys %pkgsUsed)
            {
                if ($pkgsUsed{$_} != 3)
                {
                    $needNewView = 1;
                    last;
                }
            }
            #DebugDumpData("pkgsUsed",\%pkgsUsed);
        }

        unless ($needNewView)
        {
            Message("No Changes to LXR View: $rtagid");
        }
        else
        {
            Message("Creating LXR View: $rtagid, $dateTag");
            my $releaseDir = catdir($ReleaseStore, $rtagid, $dateTag);
            mkpath($releaseDir);
            if (-d $releaseDir)
            {
                #
                #   Insert metadata
                #   Used to allow ordering and aging of the releases
                #    
                my $metaDataName = catfile( $releaseDir, '.jatslxr');
                open (my $md, '>' , $metaDataName) || Error ("Cannot create $metaDataName, $!");
                print $md $stamptime;
                close $md;

                #
                #   Populate with symlinks to the actual package-versions
                #
                foreach my $pvid (keys $entry->{data})
                {
                    my $entry = $Packages{$pvid};
                    my $alias = join('', $entry->{name}, $entry->{ext});
                    my $fullName = join('_', $entry->{name}, $entry->{ver});
                    my $PackageStore = catdir($PackageStore , $fullName);
                    my $releaseDir = catdir($releaseDir, $alias );
                    next if -l $releaseDir;

                    Verbose("Symlink $PackageStore, $releaseDir");
                    my $rv = symlink ($PackageStore, $releaseDir);
                    unless ($rv)
                    {
                        Warning("Could not link $PackageStore, $releaseDir")
                    }
                }
            }
        }
    }
}

#-------------------------------------------------------------------------------
# Function        : rebuildLxrConfig 
#
# Description     : Rebuild the LXR Configuration file
#                   This MAY be a bit LXR version specific, but since LXR doesn't
#                   provide a scriptable way to update configuration
#
#                   Uses template files that have been handcrafted after taken from
#                   LXR. Basically we to a text replace and a glue together
#
#                   For each release we need
#                       Long Release Name
#                       Short Release Name
#                       List of Versions
#
#
# Inputs          : Assumes Data has been added to %ReleaseData by other subroutines
#
# Returns         : 
#
sub rebuildLxrConfig
{
    my @lxrTreeText;

    #
    #   Sort Sub
    #   Sort ReleaseData by Project and Name
    #   $a and $b are special to the sort
    #
    sub ReleaseDataSort
    {
        my $rv = lc($ReleaseData{$a}{release}{Project}) cmp lc($ReleaseData{$b}{release}{Project});
        if ($rv == 0)
        {
            $rv = lc($ReleaseData{$a}{release}{Name}) cmp lc($ReleaseData{$b}{release}{Name});
        }
        return $rv;
    }

    #
    #   Process configured releases
    #   Generate inthe order we wich to display the Releases
    #
    #DebugDumpData("ReleaseData", \%ReleaseData);
    foreach my $rtagid ( sort ReleaseDataSort keys %ReleaseData )
    {
        my $entry = $ReleaseData{$rtagid};
        Information("Entry: $entry->{release}{Project}, $entry->{release}{Name}, $rtagid");
        $entry->{release}{VersionsString} = join( ',', map { '"' . $_ .'"'} @{$entry->{Versions}} );
        $entry->{release}{dbName} = genDatabaseName($rtagid);
        #DebugDumpData("ENTRY", \$entry);

        my $tfileName = 'lxr.tree.template';
        open( my $tf, '<', $tfileName) || Error ("Cannot open $tfileName. $!");
        while (my $line = <$tf>)
        {
            # Chomp trailing write space
            $line =~ s~\s+$~~;

            #   Replace known bits in the template
            $line =~ s~\@CAPTION\@~$entry->{release}{Project}::$entry->{release}{Name}~g;
            $line =~ s~\@SHORT_NAME\@~$rtagid~g;
            $line =~ s~\@RELEASE_ROOT\@~$entry->{release}{root}~g;
            $line =~ s~\@VERSIONS_LIST\@~$entry->{release}{VersionsString}~g;
            $line =~ s~\@DBNAME\@~$entry->{release}{dbName}~g;
            push @lxrTreeText, $line
        }
        close $tf;
    }

    #
    #   Insert tree sections into the main config file template
    #
    my $hostList = join( ',', map { '\'http://' . $_ .'\''} @addressList );

    my $tfileName = catfile($scriptDir, 'lxr.template');
    my $lxrFileName = catfile($config->{lxr}, 'lxr.new.conf');
    unlink $lxrFileName;
    open( my $tf, '<', $tfileName) || Error ("Cannot open $tfileName. $!");
    open( my $to, '>', $lxrFileName) || Error ("Cannot open $lxrFileName. $!");
    while (my $line = <$tf>)
    {
        # Chomp trailing write space
        $line =~ s~\s+$~~;

        #   Replace known bits in the template
        if ($line =~ m~\@TREE_SECTIONS\@~)
        {
            foreach (@lxrTreeText)
            {
                print $to $_, "\n";
            }
        }
        else
        {
            $line =~ s~\@HOSTLIST\@~$hostList~g;
            print $to $line, "\n";
        }
    }
    close $tf;
    close $to;

    #
    #   Install the new config files
    #
    my $lxrLive = catfile($config->{lxr}, 'lxr.conf');
    my $lxrBackup = catfile($config->{lxr}, 'lxr.conf.bak');
    unlink $lxrBackup;
    rename ($lxrLive, $lxrBackup) || Warning("Renaming $lxrLive, $lxrBackup", $!);
    rename ($lxrFileName, $lxrLive) || Warning("Renaming $lxrFileName, $lxrLive", $!);

    #
    #   Create new database tables if required
    #   Use a customized shell script to do the hard work
    #
    foreach my $rtagid ( keys %ReleaseData )
    {
        my $entry = $ReleaseData{$rtagid};
        Information("Database:$entry->{release}{Name}, $entry->{release}{dbName} ");
        System('--NoExit', '--NoShell', catfile($scriptDir, 'lxr.initdb.sh'), $entry->{release}{dbName});
    }
}

#-------------------------------------------------------------------------------
# Function        : buildIndexes 
#
# Description     : Build (Generate) indexes for all versions of all releases
#                   that don't have an index
#                   
#                   Place a marker file in the 'version' directory when the
#                   index has been created
#
#                   Notes:
#                   The 'genxref' program needs to be run from the lxr insatll directory
#                   chdir to that directory for each invocation
#
#                   genxref uses DBI - and must find the proper PERL DBI and not the one
#                   within JATS.. Solution:
#                       Kill the PERL5LIB EnvVar
#
#
#
# Inputs          : 
#
# Returns         : 
#
sub buildIndexes
{
    #
    #   Prep envonment for calling genxref
    #   See notes above
    #
    chdir ($config->{lxr}) || Error ("Cannot chnage directory:$config->{lxr}, $!");
    delete $ENV{PERL5LIB};

    #
    #   Examine each Version in each Release
    #   Generate command line like:
    #   genxref --tree RTAGID --url http://HOSTNAME/lxr --version 'VERSION'
    foreach my $rtagid ( keys %ReleaseData )
    {
        my $entry = $ReleaseData{$rtagid};
        foreach my $version (@{$entry->{Versions}})
        {
            my $markerFile = catfile($entry->{release}{root}, $version, '.lxrIndexed');
            unless (-f $markerFile) {
                Message("Must index: $rtagid, $version");
                my $rv = System('--NoExit', 
                       '--NoShell', 
                       catfile($config->{lxr}, 'genxref'),
                       '--url', 'http://' . $ENV{GBE_HOSTNAME} . '/lxr',
                       '--tree', $rtagid,
                       '--version', $version
                       );
               Verbose("genxref exit: $rv");
               unless ($rv) {
                   TouchFile($markerFile);
               }
            }
            else
            {
                Verbose("Already indexed: $rtagid, $version");
            }
        }
    }
    #
    #   Restore current directory
    #
    chdir($FileUtils::CwdFull);
}


#-------------------------------------------------------------------------------
# Function        : cleanReleaseViews 
#
# Description     : Clean up unused Releases and Release Views
#                   Maintain the list of retained versions
#
#                   Two classes
#                   Active - Marked as having LXR support
#                       Retain the last 5 Versions
#
#                  InActive - Not having LXR support
#                       Retain for 10 days then delete all versions
#
# Inputs          : 
#
# Returns         : 
#
sub cleanReleaseViews
{
    #
    #   Scan Releases and delete all that are not currently configured
    #
    opendir (my $rdir, $ReleaseStore) || Error ("Cannot open directory: $ReleaseStore", $!);
    while (my $rdirEntry = readdir($rdir))
    {
        #   Skip hidden files and directories
        next if ($rdirEntry =~ m~^\.~);
        my $vdirName = catdir($ReleaseStore, $rdirEntry );
        next unless ( -d $vdirName );
        unless(exists $ReleaseData{$rdirEntry} && $ReleaseData{$rdirEntry}{release}{LXR} )
        {
            #   Release is no longer configured - age it out
            #   Assume $rdirEntry is an rtag_id
            if (processAgeMarker($vdirName, $config->{'releaseAge'} ))
            {
                Message("Delete Release: $rdirEntry");
                RmDirTree($vdirName);
                System('--NoExit', '--NoShell', catfile($scriptDir, 'lxr.dropdb.sh'), genDatabaseName($rdirEntry));
            }
        }
        else
        {
            $ReleaseData{$rdirEntry}{release}{root} = $vdirName;
            deleteAgeMarker($vdirName);

            #   Release is configured
            #   Keep the last x created
            #   Note: Create time is a kludge
            #
            #   Process each version within the Release
            #
            my @versionData;
            opendir (my $vdir, $vdirName) || Warning ("Cannot open directory: $vdirName", $!);
            while (my $vdirEntry = readdir($vdir))
            {
                #   Skip hidden files and directories
                next if ($vdirEntry =~ m~^\.~);
                my $ldirName = catdir($vdirName, $vdirEntry );
                next unless ( -d $ldirName );
                my $data;
                $data->{name} = $vdirEntry; 
                $data->{path} = $ldirName; 
                $data->{ctime} = (stat $ldirName)[9];
                push @versionData  , $data;
            }
            close ($vdir);
            #DebugDumpData("versionData",\@versionData);

            my $keepCount = 0;
            foreach my $entry ( sort { $b->{ctime} <=> $a->{ctime}} @versionData )
            {
                #DebugDumpData("Entry", $entry);
                $keepCount++;
                if ($keepCount > 5)
                {
                    #   Version is no longer needed - remove it
                    Message("Delete Version: $rdirEntry, $entry->{name}, $entry->{ctime}");
                    RmDirTree($entry->{path});
                }
                else
                {
                    #   Note which versions we have
                    push @{$ReleaseData{$rdirEntry}{Versions}}, $entry->{name};
                }
            }
        }
    }
    close ($rdir);
}

#-------------------------------------------------------------------------------
# Function        : getLatestVersion 
#
# Description     : For a specified directory return the newest subdir
#
#                   Used to determine the most recent version
#
# Inputs          : Dir to process - expecting a Release directory
#
# Returns         : 
#
sub getLatestVersion
{
    my  ($vdirName) = @_;
    my $latestName;
    my $latestAge = 0;

    opendir (my $vdir, $vdirName) || Warning ("Cannot open directory: $vdirName", $!);
    while (my $vdirEntry = readdir($vdir))
    {
        #   Skip hidden files and directories
        next if ($vdirEntry =~ m~^\.~);

        my $ldirName = catdir($vdirName, $vdirEntry );
        next unless ( -d $ldirName );

        my $age = (stat $ldirName)[9];
        Verbose3("Age: $ldirName, $age");

        if  ($age > $latestAge )
        {
            $latestAge = $age;
            $latestName = $ldirName;
        }
    }
    close ($vdir);

    Verbose("Latest: $latestName, $latestAge");
    #DebugDumpData("versionDataSorted",\@versionDataSorted);
    return $latestName;
}


#-------------------------------------------------------------------------------
# Function        : cleanPackageStore 
#
# Description     : Delete unused PAckages fromthe package store
#
# Inputs          : 
#
# Returns         : 
#
sub cleanPackageStore
{
    my %pkgsUsed;
    #
    #   Examime ALL versions in ALL Releases and build up a hash of
    #   Package Versions used
    #
    opendir (my $rdir, $ReleaseStore) || Error ("Cannot open directory: $ReleaseStore", $!);
    while (my $rdirEntry = readdir($rdir))
    {
        #   Skip hidden files and directories
        next if ($rdirEntry =~ m~^\.~);
        my $vdirName = catdir($ReleaseStore, $rdirEntry );
        next unless ( -d $vdirName );

        #
        #   Process each version within the Release
        #
        opendir (my $vdir, $vdirName) || Warning ("Cannot open directory: $vdirName", $!);
        while (my $vdirEntry = readdir($vdir))
        {
            #   Skip hidden files and directories
            next if ($vdirEntry =~ m~^\.~);
            my $ldirName = catdir($vdirName, $vdirEntry );
            next unless ( -d $ldirName );

            #
            #   Process each entry within the Version
            #
            opendir (my $ldir, $ldirName) || Warning ("Cannot open directory: $ldirName", $!);
            while (my $ldirEntry = readdir($ldir))
            {
                #   Skip hidden files and directories (also borken symlinks )
                next if ($ldirEntry =~ m~^\.~);
                my $dirName = catdir($ldirName, $ldirEntry );
                next unless ( -d $dirName );

                #
                #   Process each entry within the Version
                #
                my $pkgName = $ldirEntry;
                if (-l $dirName)
                {
                    $pkgName = readlink($dirName);
                    $pkgName =~ s~.*/~~;
                }
                $pkgsUsed{$pkgName}++;
            }
            close ($ldir);
        }
        close ($vdir);
    }
    close ($rdir);

    #
    #   Process the Packages directory and remove those not currently used
    #
    #
    #   Process each entry within the Version
    #
    opendir (my $pdir, $PackageStore) || Error ("Cannot open directory: $PackageStore", $!);
    while (my $pdirEntry = readdir($pdir))
    {
        #   Skip hidden files and directories
        next if ($pdirEntry =~ m~^\.~);
        my $pdirName = catdir($PackageStore, $pdirEntry );
        next unless ( -d $pdirName );
        next if (exists $pkgsUsed{$pdirEntry} );

        if (processAgeMarker($pdirName, $config->{packageAge})) 
        {
            Message("Purge Package: $pdirEntry");
            RmDirTree($pdirName);
        }
    }
    close ($pdir);

    #DebugDumpData("pkgsUsed", \%pkgsUsed);
}


#-------------------------------------------------------------------------------
# Function        : getReleaseData 
#
# Description     : Get all the required Release Data 
#
# Inputs          :  
#
# Returns         : 
#
sub getReleaseData
{
    my ($rtagid) = @_;
    my (@row);

    Information("getReleaseData");
    connectRM(\$RM_DB) unless $RM_DB;


    #
    # Determine which Releases need LXR support
    #
    my $m_sqlstr = 
        "SELECT rtag_id, " .
        "  rt.proj_id, " .
        "  p.PROJ_NAME, " .
        "  rtag_name, " .
        "  official, " .
        "  NVL(TRUNC (SYSDATE - rt.official_stamp),0) AS OFFICIAL_STAMP_DAYS " .
        "FROM release_tags rt, " .
        "  projects p " .
        "WHERE rt.lxr  = 'Y' " .
        "AND p.PROJ_ID = rt.proj_id ";

    my $sth = $RM_DB->prepare($m_sqlstr);
    if ( defined($sth) )
    {
        if ( $sth->execute( ) )
        {
            if ( $sth->rows )
            {
                while ( @row = $sth->fetchrow_array )
                {
                    my $rtagid = $row[0];
                    my $data;
                    $data->{Project} = $row[2];
                    $data->{Name} = $row[3];
                    $data->{official} = substr($row[4],0,1);
                    $data->{official_stamp_days} = $row[5];

                    #
                    #   Determine if this request for an LXR release is OK
                    #   Ok If the release is Open, CCB or Restricted
                    #   Ok if closed and has been closed to < 10 days
                    #
                    if (index('NRC', $data->{official}) >= 0)
                    {
                        $data->{LXR} = 1;
                    }
                    elsif ($data->{official} eq 'Y' && $data->{official_stamp_days} < 10)
                    {
                        $data->{LXR} = 2;
                    }

                    $ReleaseData{$rtagid}{release} = $data;
                }
            }
            $sth->finish();
        }
    }
    else
    {
        Error("getReleaseData:Prepare failure" );
    }

    DebugDumpData("ReleaseData", \%ReleaseData);
    foreach my $rtagid ( keys %ReleaseData)
    {
        next unless $ReleaseData{$rtagid}{release}{LXR};
        Information("Entry: RtagId $rtagid");
        getOneRelease($rtagid);
    }
}

#-------------------------------------------------------------------------------
# Function        : getOneRelease
#
# Description     : Get data for one Release
#
# Inputs          : rtagid
#
# Returns         : 
#
sub getOneRelease
{
    my ($rtagid) = @_;
    my (@row);

    connectRM(\$RM_DB) unless $RM_DB;


    # Get details for each package in the Release
    #   Don't worry about dependent packages
    #
    my $m_sqlstr = "SELECT pv.PV_ID, pkg.PKG_NAME, pv.PKG_VERSION, pv.V_EXT, release_manager.PK_RMAPI.return_vcs_tag(pv.PV_ID)".
                   " FROM RELEASE_MANAGER.RELEASE_CONTENT rc, RELEASE_MANAGER.PACKAGE_VERSIONS pv, RELEASE_MANAGER.PACKAGES pkg" .
                   " WHERE rc.RTAG_ID = $rtagid AND rc.PV_ID = pv.PV_ID AND pv.PKG_ID = pkg.PKG_ID";
    my $sth = $RM_DB->prepare($m_sqlstr);
    if ( defined($sth) )
    {
        if ( $sth->execute( ) )
        {
            if ( $sth->rows )
            {
                while ( @row = $sth->fetchrow_array )
                {
                    my $data;
                    my $pvid = $row[0];
                    unless (exists $Packages{$pvid}) {
                        $data->{pv_id} = $row[0];
                        $data->{name} = $row[1];
                        $data->{ver} = $row[2];
                        $data->{ext} = $row[3] || '';
                        $data->{vcs} = $row[4] || '';
                        $Packages{$pvid} = $data;
                    }
                    my $rdata;
                    $rdata->{required} = 1;
                    $ReleaseData{$rtagid}{data}{$pvid} = $rdata;
                }
            }
            $sth->finish();
        }
    }
    else
    {
        Error("getOneRelease:Prepare failure" );
    }
}

#-------------------------------------------------------------------------------
# Function        : genDatabaseName 
#
# Description     : Genertate the name of a database
#
# Inputs          : rtag_id 
#
# Returns         : Text Name of the database
#

sub genDatabaseName
{
    my ($rtag_id) = @_;
    return 'LXR_' . $rtag_id;
}

#-------------------------------------------------------------------------------
# Function        : readConfig 
#
# Description     : Read the basic LXR config
#                   This is held in a Perl structure 
#
# Inputs          : None 
#
# Returns         : Populate Global Data
#
sub readConfig
{
    my $cfile = catfile($scriptDir,'jats_lxr.conf');
    if ($opt_config)
    {
        Message ("Using alternate config: $opt_config");
        $cfile = $opt_config;
    }
    Error ("Expected config file not found: $cfile") unless ( -f $cfile );
    require $cfile;
     
#   #
#   #   Create data
#   #
#   my %hash = (
#   number => 42,
#   string => 'This is a string',
#   array  => [ 1 .. 10 ],
#   hash   => { apple => 'red', banana => 'yellow' },
#   );
#
#   # Print structure to file
#   open (my $out, '>', $cfile) || Error("Can't create $cfile. $!");
#   DebugDumpData("Hash", \%hash);
#   print {$out} Data::Dumper->Dump([\%hash], ['$config']);
#   close $out;

    #DebugDumpData("config", \$config);

}

#-------------------------------------------------------------------------------
# Function        : startLogFile 
#
# Description     : Start logging to a log file
#                   Generate a nice name for the log file
#
# Inputs          : 
#
# Returns         : 
#
sub startLogFile
{
    if ( $opt_logfile )
    {
        if (exists $config->{lxrLogDir})
        {
            my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($stamptime);
            my $name = sprintf("jats-lxr-%4.4d%2.2d%2.2d.%2.2d%2.2d%2.2d.log", 1900+$year, 1+$mon, $mday, $hour, $min, $sec);
            $name = catdir($config->{lxrLogDir}, $name);

            mkpath($config->{lxrLogDir}); 
            if (-d $config->{lxrLogDir} )
            {
                open STDOUT, '>', $name  or die "Can't redirect STDOUT: $!";
                open STDERR, ">&STDOUT"  or die "Can't dup STDOUT: $!";
            }
            else
            {
                Warning("Can't create log dir: $config->{lxrLogDir}. $!");
            }
        }
    }
}

#-------------------------------------------------------------------------------
# Function        : cleanupLogFiles 
#
# Description     : Remove old log files
#
# Inputs          : 
#
# Returns         : 
#
sub cleanupLogFiles
{
    if (exists $config->{lxrLogDir} && exists $config->{logAge}  && $config->{logAge} > 0 )
    {
        Verbose("cleanupLogFiles:$config->{lxrLogDir}, $config->{logAge}");
        if ( opendir my $logDir, $config->{lxrLogDir} )
        {
            foreach my $fileName (readdir $logDir)
            {
                my $file = catfile($config->{lxrLogDir}, $fileName);
                next unless -f $file;
                next unless -M $file > $config->{logAge};
                Verbose("Purge logfile: $fileName");
                unlink $file;
            }
            closedir $logDir;
        }
    }
}

#-------------------------------------------------------------------------------
# Function        : processAgeMarker 
#
# Description     : Age out directories
#                   Will create age markers as required
#
# Inputs          : $tdir       - Target Directory
#                   $age        - Configured age 
#
# Returns         : true        - Directory has reached age
#
sub processAgeMarker
{
    my ($tdir, $age) = @_;
    
    unless (-d $tdir) {
        Warning ("Expected directory not found: $tdir");
        return 0; 
    }

    #   A configured age of 0 implies delete immediatly
    if ($age == 0)
    {
        return 1;
    }

    #
    #   Create the file ONCE
    #
    my $markerfile = catfile($tdir, '.lxrAge');
    unless (-f $markerfile)
    {
        TouchFile($markerfile);
    }
    else
    {
        if (-M $markerfile > $age)
        {
            return 1
        }
    }
    return 0;
}


#-------------------------------------------------------------------------------
# Function        : deleteAgeMarker 
#
# Description     : Delete any age marker
#                   Used when a (potentially) agable directory is used to remove
#                   the aging marker
#
# Inputs          :  $tdir      - Directory
#
# Returns         : 
#
sub deleteAgeMarker
{
    my ($tdir) = @_;
    
    unless (-d $tdir) {
        Warning ("Expected directory not found: $tdir");
        return 0; 
    }

    #
    #   Use same file name as in processAgeMarker
    #
    my $markerfile = catfile($tdir, '.lxrAge');
    unlink $markerfile;
}


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

=pod

=head1 NAME

jats_lxr - Maintain LXR Releases

=head1 SYNOPSIS

  jats jats_lxr [options]

 Options:
    -help               - brief help message
    -help -help         - Detailed help message
    -man                - Full documentation
    -[no]createVersions - Create new versions. Default:Create
    -[no]extract        - Extract source code. Default:Extract
    -[no]index          - Index new LXR versions. Default:Index
    -[no]purge          - Purge unused packages. Default:Purge
    -[no]logfile        - Capture out to a log file. Default:Log
    -config=file        - Alternate config file

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

This option will display progress information as the program executes.

=item B<-[no]createVersions>

This option can be used to suppress the creation of new views.

=item B<-[no]extract>

This option can be used to suppress the extraction of source.

=item B<-[no]index>

This option can be used to suppress the indexing of newly created views.

=item B<-[no]purge>

This option can be used to suppress purging of packages that are no longer used by any of the LXR Trees.

=item B<-config=file>

This option can be used to override the standard config file. Used in testing.

=back

=head1 DESCRIPTION

This program is a tool for creating and maintaining an LXR instance within the VIX Build System.

The program can:

=over 8

=item * 

Examine the Release Manager Database and determine which Releases are a part of the set to have LXR Views created.

Releases that are Open (or Restricted or in CCB Mode) or that have been closed for less than 10 days will be processed.

=item *

Examine the Release Manager Database and determine the package-versions that are a part of the LXR Release Set.

The process will only examine the contents of a Release. It will not descend the version dependency tree.

The program will then extract new package-versions into it's Package Store. Multiple LXR Tree's will share the one 
instance of the extracted source code.

=item *

Create a new 'Version' for each Release.

The Version Name is based on the date-time at which the process is run.

Each Version is a symlink to the required package-version held in the Package Store.

This step can be suppressed though a command line option.

=item *

Remove unused LXR Trees (Releases no longer being processed) and unused Versions within each Tree.

Releases that are no longer eligable for processing will be retained for 10 days and then deleted. 
During this time the existing versions will not be aged out.

At the moment this tool simply retains the last 5 Versions of each Release. If the tool 
is run nightly then this will translate into  5 days.

=item *

Regenerate the LXR Configuration file

Create new database tables for new Releases

=item *

Run the LXR indexer for each LXR Version that has not been processed. Once processed the Version will 
be tagged to prevent further indexing.

=item *

Remove unused Package-Versions from the Package Store.

=back

=cut