WebSVN – DevTools – Diff – /lxr_manager/trunk/src/jats_lxr.pl

 my $opt_createVersions = 1;
 my $opt_index = 1;
 my $opt_purge = 1;
 my $opt_extract = 1;
 my $opt_logfile = 1;
+my $opt_config;
+#
 #   Globals
+#
                 "verbose:+"         => \$opt_verbose,           # flag
                 "createVersions!"   => \$opt_createVersions,
                 "purge!"            => \$opt_purge,
                 "index!"            => \$opt_index,
                 "extract!"          => \$opt_extract,
-                "logfile!"         => \$opt_logfile,
+                "logfile!"          => \$opt_logfile,
+                "config:s"          => \$opt_config,
                 );
+#
 #   Process help and manual options
+#
 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 ;
         #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 ) {
+        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");
+                    my $rv = JatsCmd ('jats_vcsrelease', '-devmode=escrow', '-extractfiles', "-view=$fullName", "-label=$entry->{vcs}", "-root=$PackageStore", "-noprefix");
-                print "$fullName : SUCCESS\n" unless $rv;
+                    print "$fullName : SUCCESS\n" unless $rv;
-                print "$fullName : ERROR\n" if $rv;
+                    print "$fullName : ERROR\n" if $rv;
-                $entry->{bad} = 1;
+                    $entry->{bad} = 1;
+                }
+            }
+        }
+        else
+        {
+            #   Package already extracted
+            #   Ensure that it does not get aged out
+            deleteAgeMarker($fullPath);
+        }
+    }
+}
 #-------------------------------------------------------------------------------
 # Function        : createReleaseViews
 # 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 repplace a glue together
+#                   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
 # 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 ( keys %ReleaseData )
+    foreach my $rtagid ( sort ReleaseDataSort keys %ReleaseData )
+    {
         my $entry = $ReleaseData{$rtagid};
-        Information("Entry:$entry->{release}{Name}, $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';
         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 - remove it
+            #   Release is no longer configured - age it out
             #   Assume $rdirEntry is an rtag_id
-            Message("Delete Release: $rdirEntry");
+            if (processAgeMarker($vdirName, $config->{'releaseAge'} ))
-            RmDirTree($vdirName);
+            {
-            my $entry = $ReleaseData{$rdirEntry};
+                Message("Delete Release: $rdirEntry");
-            #DebugDumpData("ReleaseData:",$entry);
+                RmDirTree($vdirName);
-            System('--NoExit', '--NoShell', catfile($scriptDir, 'lxr.dropdb.sh'), genDatabaseName($rdirEntry));
+                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
+            #
         next if ($pdirEntry =~ m~^\.~);
         my $pdirName = catdir($PackageStore, $pdirEntry );
         next unless ( -d $pdirName );
         next if (exists $pkgsUsed{$pdirEntry} );
+        if (processAgeMarker($pdirName, $config->{packageAge}))
+        {
-        Message("Cleanup: $pdirEntry");
+            Message("Purge Package: $pdirEntry");
-        RmDirTree($pdirName);
+            RmDirTree($pdirName);
+        }
+    }
     close ($pdir);
     #DebugDumpData("pkgsUsed", \%pkgsUsed);
+}
 # 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
             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
+#
     -[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<-[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.

Subversion Repositories DevTools

(root)/lxr_manager/trunk/src/jats_lxr.pl – Rev 5209 → 5211