######################################################################## # Copyright (c) VIX TECHNOLOGY (AUST) LTD # # Module name : jats_lxr.pl # Module type : JATS Utility # Compiler(s) : Perl # Environment(s): jats # # Description : Tools to maintain LXR information # # Possible imporvements # Merge ripples package versions # Just keep one # At the moment, simply ignore ripples in release comparisons. # # Cots packages # Use contents from dpkg_archive instead of the package # # Better Version-Aging algorithm # Currently keep the last 5 # Perhaps keep one from a month ago and one from 6 months ago. # # Indication back into ReleaseManager of Releases that are present # # 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 Fcntl ':flock'; 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_forceViews; my $opt_config; # # Globals # my $scriptDir; my $RM_DB; my $Config; my @addressList; my %ReleaseData; my %Packages; my $PackageStore; my $ReleaseStore; my $StampTime = time; my $lockFile = '/tmp/JATSLXR_LOCK'; #------------------------------------------------------------------------------- # 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, "forceViews!" => \$opt_forceViews, ); # # 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 # Sed with Default config # $Config->{'releaseAge'} = 0; $Config->{'packageAge'} = 0; $Config->{'logAge'} = 0; $Config->{'verbose'} = $opt_verbose; $Config->{GBE_RM_LOCATION} = $ENV{GBE_RM_LOCATION}; $Config->{GBE_RM_USERNAME} = $ENV{GBE_RM_USERNAME}; $Config->{GBE_RM_PASSWORD} = $ENV{GBE_RM_PASSWORD}; readConfig(); # # Start logging # startLogFile(); Message ("Start of LXR. " . localtime(time) ) if $opt_logfile; Message("ScriptDir: $scriptDir"); DebugDumpData("Config", \$Config) if (IsVerbose(1)); # # Sanity Testing # Error ("No LXR Data directory defined") unless( exists $Config->{lxrFiles}); Error ("No LXR Data directory found", $Config->{lxrFiles}) unless( -d $Config->{lxrFiles}); Error ("No LXR Install directory defined") unless( exists $Config->{lxr}); Error ("No LXR Install directory found",$Config->{lxr}) unless( -d $Config->{lxr}); Error ("No Glimpse Data directory defined") unless( exists $Config->{glimpseDir}); Warning ("No Glimpse Data directory found",$Config->{glimpseDir}) unless( -d $Config->{glimpseDir}); ErrorConfig( 'verbose' => $Config->{'verbose'} ); # # Prevent multiple instances of the program running # # PerlMonks say to use $0 as the lock file, but that did not work. # Perhaps the file was open in an editor # Solution: Create my own file # open( FW, '>',$lockFile); print FW ''; close FW; open (my $self, '<', $lockFile) || Error("Couldn't open self: $!"); flock ($self, (LOCK_EX | LOCK_NB)) || Error("This script is already running"); # # 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); # # 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"); # # Use local Database config - if provided # $ENV{GBE_RM_LOCATION} = $Config->{GBE_RM_LOCATION}; $ENV{GBE_RM_USERNAME} = $Config->{GBE_RM_USERNAME}; $ENV{GBE_RM_PASSWORD} = $Config->{GBE_RM_PASSWORD}; # # Perform the hard work # getReleaseData(); updateReleaseViews() if $opt_createVersions; cleanReleaseViews(); rebuildLxrConfig() if $opt_index; buildIndexes() if $opt_index; updateReleaseManager(); cleanPackageStore() if $opt_purge; cleanupLogFiles() if $opt_purge; # # All done # unlink $lockFile; Message ("End of LXR. " . localtime(time) ) if $opt_logfile; exit 0; #------------------------------------------------------------------------------- # Function : extractPackages # # Description : Extract Packages from VCS # Don't extract them if they already exist # Cleanup non-indexable files # # Kludge: Prevent extraction from MASS_Dev_Crypto Repo # # Inputs : $rtagid - Release To Process # Conatins PackageVersion data # # Returns : # sub extractPackages { my ($rtagid) = @_; foreach my $pvid (keys %{$ReleaseData{$rtagid}{data}}) { 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("Extracting: $entry->{name}, $entry->{ver}"); if ($opt_extract) { Verbose("Extracting into: $fullPath"); my $result = 'ERROR'; if ($entry->{vcs} =~ m~/MASS_Dev_Crypto/~) { $result = 'SUPPRESSED'; } else { my $rv = JatsCmd ('jats_vcsrelease', '-devmode=escrow', '-extractfiles', "-view=$fullName", "-label=$entry->{vcs}", "-root=$PackageStore", "-noprefix"); if ($rv) { $result = 'ERROR'; $entry->{bad} = 1; } else { $result = 'SUCCESS'; } } Message("Extraction Result: $result"); # # Clean up the extracted views # Use lxr_clean_dir.sh # if (-d $fullPath) { Verbose("Running lxr_clean_dir.sh"); System('--NoExit', '--NoShell', catfile($scriptDir,'lxr_clean_dir.sh') , $fullPath); } } } else { # Package already extracted # Ensure that it does not get aged out deleteAgeMarker($fullPath); } } } #------------------------------------------------------------------------------- # Function : updateReleaseViews # # Description : # # Inputs : # # Returns : # sub updateReleaseViews { # # Process each known Release # foreach my $rtagid (sort keys \%ReleaseData) { Verbose("updateReleaseViews: $rtagid"); if ($ReleaseData{$rtagid}{release}{ACTIVE}) { # # Determinte last created view in this Release # my ($latestView, $latestAge) = getLatestVersion(catdir($ReleaseStore, $rtagid )); if ( ! defined($latestView) || $latestAge > 1 || $opt_forceViews ) { # # If there is no latest view, then we need to create a new view # If there is a recent view, but its older than a day then we may need # to refresh it. # getReleasePakageData($rtagid); if (checkViewDiffs($latestView,$rtagid) || $opt_forceViews) { # # Need to create a view # Either one does not exist # Content has changed # createReleaseView($rtagid); } else { # No need to create a new view # Do need to tag it so that we don't examine it again ( for a while ) Message("No Changes to LXR View: $rtagid"); if (defined $latestView) { my $rv = utime $StampTime,$StampTime, $latestView; Debug("Utime $rv: $latestView"); } } } else { Message("Recent LXR View: $rtagid"); } } else { Message("Inactive LXR View: $rtagid"); } } } #------------------------------------------------------------------------------- # Function : checkViewDiffs # # Description : Check a view against package versions in the current Release. # Ignore ripple built packages as these only have dependent changes # # Inputs : $vdir - View entry to process # $rtagid - RtagId # # Returns : True, If we need to create a new view # No view exists # View does not match Release Content # sub checkViewDiffs { my ($vdir, $rtagid) = @_; # No entry to process, then we need to create a view return 1 if not defined $vdir; # # Read in the View List # my %pkgsUsed; my $releaseListFile = catfile($vdir, '.lxrRelease'); if (open (my $rf, '<', $releaseListFile )) { while (my $data = <$rf>) { $data =~ s~\s+$~~; $data = baseVersionNumber ($data ); $pkgsUsed{$data} = 2; } } else { Warning ("Cannot find Release List: $releaseListFile", $!); return 1; } # # Compare the packages in the Release against those required # foreach my $pvid (keys %{$ReleaseData{$rtagid}{data}}) { my $entry = $Packages{$pvid}; my $fullName = join('_', $entry->{name}, $entry->{ver}); $fullName = baseVersionNumber ($fullName ); $pkgsUsed{$fullName}++; } my $needNewView = 0; # # 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 # foreach ( keys %pkgsUsed) { if ($pkgsUsed{$_} != 3) { $needNewView = 1; last; } } Warning("Release Contents don't match: $rtagid") if $needNewView; #DebugDumpData("pkgsUsed",\%pkgsUsed); return $needNewView; } #------------------------------------------------------------------------------- # Function : createReleaseView # # Description : Create a new view for a single Release # # Inputs : $rtagid - RtagId # # Returns : # sub createReleaseView { my ($rtagid) = @_; my @ReleaseList; # # Ensure that packages have been extracted # extractPackages($rtagid); # # Create the actual view directory # Its simply a bunch of symlinks back to the package store # # # Create directory for the new view # Based on current date. Some tools (glimpse and ctags) can't handle spaces in paths # my $dateTag = localtime($StampTime); $dateTag =~ s~\s+~_~g; Message("Creating LXR View: $rtagid, $dateTag"); my $releaseDir = catdir($ReleaseStore, $rtagid, $dateTag); mkpath($releaseDir); if (-d $releaseDir) { foreach my $pvid (keys %{$ReleaseData{$rtagid}{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 $pkgDir = catdir($releaseDir, $alias ); push @ReleaseList, $fullName; next if -l $pkgDir; next if -d $pkgDir; # # # Glimpse will not follow symlinks - which would be nice # Clone the Package using hardlinks - still saves space # Verbose("HardLink $PackageStore, $releaseDir"); my $rv = System('--NoExit', '--NoShell', 'cp','-al', $PackageStore, $pkgDir); Warning("Could not duplicate $PackageStore, $releaseDir") if $rv; # Verbose("Symlink $PackageStore, $releaseDir"); # my $rv = symlink ($PackageStore, $releaseDir); # Warning("Could not link $PackageStore, $releaseDir") unless ($rv); } # # Generate a list of package-vesrions in the release # Used so that we can detect changes to the release # FileCreate(catfile($releaseDir, '.lxrRelease'), \@ReleaseList); } Verbose("createReleaseView - End"); } #------------------------------------------------------------------------------- # 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 in the order we wish to display the Releases # #DebugDumpData("ReleaseData", \%ReleaseData); foreach my $rtagid ( sort ReleaseDataSort keys %ReleaseData ) { my $entry = $ReleaseData{$rtagid}; $entry->{release}{LXRSTATE} = 'D' unless (exists $entry->{release}{LXRSTATE}); Information("Entry: $entry->{release}{Project}, $entry->{release}{Name}, $entry->{release}{LXRSTATE}, $rtagid"); next if ($entry->{release}{LXRSTATE} eq 'D'); $entry->{release}{VersionsString} = join( ',', map { '"' . $_ .'"'} @{$entry->{Versions}} ); $entry->{release}{dbName} = genDatabaseName($rtagid); $entry->{release}{root} = catdir($ReleaseStore, $rtagid ); #DebugDumpData("ENTRY", \$entry); my $stateTxt = $entry->{release}{ACTIVE} ? 'Active' : 'InActive'; #$stateTxt .= ' [' . $entry->{release}{ACTIVE} . ']'; 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; $line =~ s~\@STATE\@~$stateTxt~g; push @lxrTreeText, $line } close $tf; } # # Insert tree sections into the main config file template # my @hostItems; push @hostItems, map { '\'http://' . $_ .'\''} @addressList; push @hostItems, map { '\'https://' . $_ .'\''} @addressList; my $hostList = join( ',', @hostItems ); 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 ( sort keys %ReleaseData ) { my $entry = $ReleaseData{$rtagid}; next if ($entry->{release}{LXRSTATE} eq 'D'); Verbose("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 install 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 ( sort keys %ReleaseData ) { my $entry = $ReleaseData{$rtagid}; foreach my $version (@{$entry->{Versions}}) { my $markerFile = catfile(catdir($ReleaseStore, $rtagid ), $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 { Warning("Error indexing $rtagid ($rv)"); } } 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}{ACTIVE} ) { # Release is no longer configured - age it out # Assume $rdirEntry is an rtag_id $ReleaseData{$rdirEntry}{release}{LXRSTATE} = 'C'; if (processAgeMarker($vdirName, $Config->{'releaseAge'} )) { $ReleaseData{$rdirEntry}{release}{LXRSTATE} = 'D'; Message("Delete Release: $rdirEntry"); RmDirTree($vdirName); System('--NoExit', '--NoShell', catfile($scriptDir, 'lxr.dropdb.sh'), genDatabaseName($rdirEntry)); if ( defined $Config->{glimpseDir} ) { my $glimpseData = catdir( $Config->{glimpseDir}, $rdirEntry ); Message("Delete Glimpse Subdir: $glimpseData"); RmDirTree($glimpseData); } } else { # # Build up the list of known versions # foreach my $entry ( getReleaseVersions($vdirName) ) { push @{$ReleaseData{$rdirEntry}{Versions}}, $entry->{name}; } } } else { $ReleaseData{$rdirEntry}{release}{LXRSTATE} = 'I'; deleteAgeMarker($vdirName); # Release is configured # Keep the last x created # Note: Create time is a kludge # # Process each version within the Release # my $keepCount = 0; foreach my $entry ( getReleaseVersions($vdirName) ) { #DebugDumpData("$rdirEntry, getReleaseVersions:Entry", $entry); $keepCount++; if ($keepCount > 5) { # Version is no longer needed - remove it # Remove glimpse data too Message("Delete Version: $rdirEntry, $entry->{name}, $entry->{ctime}"); RmDirTree($entry->{path}); if ( defined $Config->{glimpseDir} ) { my $glimpseEntry = catdir( $Config->{glimpseDir}, $rdirEntry, $entry->{name} ); Message("Delete Glimpse Data: $glimpseEntry"); RmDirTree($glimpseEntry); Warning("Glimpse Data Dir still present: $glimpseEntry") if ( -d $glimpseEntry); } } else { # Note which versions we have push @{$ReleaseData{$rdirEntry}{Versions}}, $entry->{name}; } } } } close ($rdir); } #------------------------------------------------------------------------------- # Function : getReleaseVersions # # Description : Get the Versions in a Release # # Inputs : $vdirName - Path to process # # Returns : A sorted array of data items (Most recent first) # Each items consists of: # {name} # {path} # {ctime} # sub getReleaseVersions { my ($vdirName) = @_; 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 @sortedList = sort { $b->{ctime} <=> $a->{ctime}} @versionData; #DebugDumpData("SortedVersionData",\@sortedList); return @sortedList; } #------------------------------------------------------------------------------- # Function : getLatestVersion # # Description : For a specified directory return the newest subdir # # Used to determine the most recent version # # Inputs : $vdirName - Dir to process - expecting a Release directory # # Returns : latestName - Patch to the latest directory # Age (days ) - Of the named directory # sub getLatestVersion { my ($vdirName) = @_; my $latestName; my $latestAge = 0; if (-d $vdirName ) { 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); # Convert to Days ago $latestAge = ($StampTime - $latestAge) / (60*60*24); #DebugDumpData("versionDataSorted",\@versionDataSorted); Verbose("Latest: $latestName, $latestAge"); } else { Verbose("Latest: No directory found: $vdirName"); } return $latestName, $latestAge; } #------------------------------------------------------------------------------- # Function : cleanPackageStore # # Description : Delete unused Packages from the package store # Each View in each Release will have a .lxrRelease file that contains the # package versions that the view needs. # # Inputs : # # Returns : # sub cleanPackageStore { Verbose ("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 ); # # Read in the View List # my $releaseListFile = catfile($ldirName, '.lxrRelease'); if (open (my $rf, '<', $releaseListFile )) { Verbose2("Found ", $releaseListFile); while (my $data = <$rf>) { $data =~ s~\s+$~~; $pkgsUsed{$data}++; } } else { Warning ("Cannot find Release List: $releaseListFile", $!); } } 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); my @releaseList; my $partSql = ''; Verbose("getReleaseData"); connectRM(\$RM_DB) unless $RM_DB; # # Determine list of existing Releases # Build up a Clause for the extraction SQL # This is used to get data for Releases that exist in the Store but may have been # deconfigured. # if ( opendir (my $rdir, $ReleaseStore) ) { while (my $rdirEntry = readdir($rdir)) { # Skip hidden files and directories next if ($rdirEntry =~ m~^\.~); my $vdirName = catdir($ReleaseStore, $rdirEntry ); next unless ( -d $vdirName ); push @releaseList, $rdirEntry; } close $rdir; } if (@releaseList) { $partSql = ' OR rt.rtag_id in (' . join(',', @releaseList ) . ')' } # # Determine which Releases need LXR support # my $m_sqlstr = "SELECT rt.rtag_id," . " rt.proj_id," . " p.PROJ_NAME," . " rt.rtag_name," . " rt.official," . " NVL(TRUNC (SYSDATE - rt.official_stamp),0) AS OFFICIAL_STAMP_DAYS," . " rt.lxr,". " lxr.lxrserver" . " FROM release_manager.release_tags rt," . " release_manager.lxr_state lxr," . " release_manager.projects p" . " WHERE lxr.RTAG_ID(+) = rt.RTAG_ID" . " AND (rt.lxr = 'Y'" . $partSql . ")" . " AND p.PROJ_ID = rt.proj_id"; Verbose2('$m_sqlstr',$m_sqlstr); 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]; $data->{lxr} = $row[6]; $data->{lxr_state} = $row[7] || 'N'; # # 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 ($data->{lxr} eq 'Y') { if (index('NRC', $data->{official}) >= 0) { $data->{ACTIVE} = 1; } elsif ($data->{official} eq 'Y' && $data->{official_stamp_days} < 10 ) { $data->{ACTIVE} = 2; } } $ReleaseData{$rtagid}{release} = $data; } } $sth->finish(); } } else { Error("getReleaseData:Prepare failure" ); } if (IsVerbose(1)) { DebugDumpData("ReleaseData", \%ReleaseData); } # # Just a summary display for logging # foreach my $rtagid ( sort keys %ReleaseData) { my $state = $ReleaseData{$rtagid}{release}{ACTIVE} ? 'ACTIVE' : 'InActive'; Information("Release: RtagId $rtagid, $state"); } } #------------------------------------------------------------------------------- # Function : getReleasePakageData # # Description : Get PackgeVersion information for one Release # # Inputs : rtagid # # Returns : # sub getReleasePakageData { 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; } $ReleaseData{$rtagid}{data}{$pvid} = 1; } } $sth->finish(); } } else { Error("getReleasePakageData:Prepare failure" ); } } #------------------------------------------------------------------------------- # Function : updateReleaseManager # # Description : Feed the state of the releases back into the Release # manager database # # Assumes that the user has write access to ONE table # # Inputs : # # Returns : # sub updateReleaseManager { foreach my $rtagid ( keys %ReleaseData) { my $rentry = $ReleaseData{$rtagid}{release}; Verbose3("updateReleaseManager:", $rtagid, $rentry->{lxr_state}, $rentry->{LXRSTATE}); # # Only update those that have changed # if ($rentry->{lxr_state} ne $rentry->{LXRSTATE}) { my $m_sqlstr; # # Have just deleted the entry # if ($rentry->{LXRSTATE} eq 'D') { unless ($rentry->{lxr_state} eq 'N') { simpleSqlExecute('updateReleaseManager',"DELETE from release_manager.lxr_state where rtag_id = " . $rtagid); } } elsif ($rentry->{LXRSTATE} eq 'C') { my $state = 'C'; simpleSqlExecute('updateReleaseManager',"begin insert into release_manager.lxr_state (rtag_id, lxrserver) values ($rtagid, '$state'); exception when dup_val_on_index then update release_manager.lxr_state set lxrserver = '$state' where rtag_id = $rtagid; end; "); } elsif ($rentry->{LXRSTATE} eq 'I') { my $state = 'I'; simpleSqlExecute('updateReleaseManager',"begin insert into release_manager.lxr_state (rtag_id, lxrserver) values ($rtagid, '$state'); exception when dup_val_on_index then update release_manager.lxr_state set lxrserver = '$state' where rtag_id = $rtagid; end; "); } else { Warning("updateReleaseManager. No entry for $rtagid"); } } } } #------------------------------------------------------------------------------- # Function : simpleSqlExecute # # Description : Perform a simple SQL statement that does not return anything # Used to update the RM database # # Inputs : $pname - proceedure name ( for logging) # $m_sqlstr - Sql to process # # # Returns : # sub simpleSqlExecute { my ($pname,$m_sqlstr) = @_; my (@row); connectRM(\$RM_DB) unless $RM_DB; Verbose2($pname,$m_sqlstr); my $sth = $RM_DB->prepare($m_sqlstr); if ( defined($sth) ) { if ( $sth->execute( ) ) { $sth->finish(); } else { Warning("$pname.Execute failure: $m_sqlstr", $sth->errstr() ); } } else { Error("$pname: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; } # # Slurp in the file and evaluate it as a perl expression # if (open(my $CONFIG, '<', $cfile)) { local ($/) = undef; my $config_contents = <$CONFIG>; $config_contents =~ m/(.*)/s; $config_contents = $1; #untaint it my $config = eval("\n#line 1 \"configuration file\"\n" . $config_contents); Error($@) if $@; close $CONFIG; # # Merge read data with defaults # @$Config{ keys %$config } = values %$config; } else { Error("Couldn't open configuration file \"$cfile\".", $!); } } #------------------------------------------------------------------------------- # 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: $!"; STDOUT->autoflush(1); STDERR->autoflush(1); } 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 1; } # A configured age of 0 implies delete immediatly if ($age == 0) { return 1; } # Test for Age me now marker file my $purgefile = catfile($tdir, '.lxrPurge'); if (-f $purgefile ) { Verbose ("Age: ForcedPurge $tdir"); return 1; } # # Create the file ONCE # my $markerfile = catfile($tdir, '.lxrAge'); unless (-f $markerfile) { TouchFile($markerfile); } else { my $fileAge = -M $markerfile; Verbose ("Age: $fileAge, $tdir"); if ($fileAge > $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; } #------------------------------------------------------------------------------- # Function : baseVersionNumber # # Description : Remove the build number from a package-version string # # Inputs : Package-Version string # # Returns : Version String with a build # of 0 # Will return a non-standard string, but one that can be used for comparisons # sub baseVersionNumber { my ($version) = @_; my $iversion = $version; # # Look for a patchRipple.suffix # if ( $version =~ m~(.*?)\.([0-9]{4,6})(\.\w+)$~ ) { my $part1 = $1; my $patch = $2; my $suffix = $3; my $build; if ( length( $patch) >= 4 ) { $build = substr( $patch, -3 ,3); $patch = substr( $patch, 0 ,length($patch)-3); $version = $part1 . sprintf (".%3.3d.%3.3d", $patch, 0) . $suffix; } } else { Verbose("baseVersionNumber. Could not massge: $iversion"); } return $version; } #------------------------------------------------------------------------------- # 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 -[no]forceViews - Force creation of new views. Default:NoForceView -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<-[no]forceViews> This option can be used to force the creation of a new View in each Release. =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