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



#           Just keep one
#
#       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;

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 %ReleaseData;
my %Packages;
my $PackageStore;
my $ReleaseStore;
my $StampTime = time;
 
my $lockFile = '/tmp/JATSLXR_LOCK';
 
#-------------------------------------------------------------------------------
# Function        : Main
#

                "purge!"            => \$opt_purge,
                "index!"            => \$opt_index,
                "extract!"          => \$opt_extract,
                "logfile!"          => \$opt_logfile,
                "config:s"          => \$opt_config,
                "forceViews!"       => \$opt_forceViews,
                );
 
#
#   Process help and manual options
#

$Config->{'releaseAge'} = 0;
$Config->{'packageAge'} = 0;
$Config->{'logAge'} = 0;
$Config->{'verbose'} = 0;
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.

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

        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");
            }
        }
        else
        {
            #   Package already extracted

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

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

#
# 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+$~~;
 
            $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});
        $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;
}
 
#-------------------------------------------------------------------------------

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

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

            if (processAgeMarker($vdirName, $Config->{'releaseAge'} ))
            {
                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 );
                    RmDirTree($glimpseData);
                }
            }
        }
        else
        {
            deleteAgeMarker($vdirName);

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

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

    close ($pdir);
 
    #DebugDumpData("pkgsUsed", \%pkgsUsed);
}
 
 
#-------------------------------------------------------------------------------
# Function        : getReleaseData 
#
# Description     : Get all the required Release Data 
#

    }
    else
    {
        Error("Couldn't open configuration file \"$cfile\".", $!);
    }
 
 
 
 
 
}
 
#-------------------------------------------------------------------------------
# Function        : startLogFile 
#

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

Rev 5213	Rev 5231
Line 16...	Line 16...
16	`# Just keep one`	16	`# Just keep one`
17	`#`	17	`#`
18	`# Cots packages`	18	`# Cots packages`
19	`# Use contents from dpkg_archive instead of the package`	19	`# Use contents from dpkg_archive instead of the package`
20	`#`	20	`#`
-		21	`# Better Version-Aging algorithm`
-		22	`# Currently keep the last 5`
-		23	`# Perhaps keep one from a month ago and one from 6 months ago.`
-		24	`#`
-		25	`# Indication back into ReleaseManager of Releases that are present`
-		26	`#`
21	`# Usage : See POD at the end of this file`	27	`# Usage : See POD at the end of this file`
22	`#`	28	`#`
23	`#......................................................................#`	29	`#......................................................................#`
24		30
25	`require 5.008_002;`	31	`require 5.008_002;`
Line 48...	Line 54...
48	`my $opt_createVersions = 1;`	54	`my $opt_createVersions = 1;`
49	`my $opt_index = 1;`	55	`my $opt_index = 1;`
50	`my $opt_purge = 1;`	56	`my $opt_purge = 1;`
51	`my $opt_extract = 1;`	57	`my $opt_extract = 1;`
52	`my $opt_logfile = 1;`	58	`my $opt_logfile = 1;`
-		59	`my $opt_forceViews;`
53	`my $opt_config;`	60	`my $opt_config;`
54		61
55		62
56	`#`	63	`#`
57	`# Globals`	64	`# Globals`
Line 63...	Line 70...
63	`my %ReleaseData;`	70	`my %ReleaseData;`
64	`my %Packages;`	71	`my %Packages;`
65	`my $PackageStore;`	72	`my $PackageStore;`
66	`my $ReleaseStore;`	73	`my $ReleaseStore;`
67	`my $StampTime = time;`	74	`my $StampTime = time;`
68	`my $dateTag = localtime($StampTime);`	-
69	`my $lockFile = '/tmp/JATSLXR_LOCK';`	75	`my $lockFile = '/tmp/JATSLXR_LOCK';`
70		76
71	`#-------------------------------------------------------------------------------`	77	`#-------------------------------------------------------------------------------`
72	`# Function : Main`	78	`# Function : Main`
73	`#`	79	`#`
Line 87...	Line 93...
87	`"purge!" => \$opt_purge,`	93	`"purge!" => \$opt_purge,`
88	`"index!" => \$opt_index,`	94	`"index!" => \$opt_index,`
89	`"extract!" => \$opt_extract,`	95	`"extract!" => \$opt_extract,`
90	`"logfile!" => \$opt_logfile,`	96	`"logfile!" => \$opt_logfile,`
91	`"config:s" => \$opt_config,`	97	`"config:s" => \$opt_config,`
-		98	`"forceViews!" => \$opt_forceViews,`
92	`);`	99	`);`
93		100
94	`#`	101	`#`
95	`# Process help and manual options`	102	`# Process help and manual options`
96	`#`	103	`#`
Line 119...	Line 126...
119	`$Config->{'releaseAge'} = 0;`	126	`$Config->{'releaseAge'} = 0;`
120	`$Config->{'packageAge'} = 0;`	127	`$Config->{'packageAge'} = 0;`
121	`$Config->{'logAge'} = 0;`	128	`$Config->{'logAge'} = 0;`
122	`$Config->{'verbose'} = 0;`	129	`$Config->{'verbose'} = 0;`
123	`readConfig();`	130	`readConfig();`
124	`Error ("No LXR Data directory defined", $Config->{lxrFiles}) unless( exists $Config->{lxrFiles});`	-
125	`Error ("No LXR Data directory found", $Config->{lxrFiles}) unless( -d $Config->{lxrFiles});`	-
126	`Error ("No LXR Install directory defined",$Config->{lxr}) unless( exists $Config->{lxr});`	-
127	`Error ("No LXR Install directory found",$Config->{lxr}) unless( -d $Config->{lxr});`	-
128	`ErrorConfig( 'verbose' => $Config->{'verbose'} );`	-
129		131
130	`#`	132	`#`
131	`# Start logging`	133	`# Start logging`
132	`#`	134	`#`
133	`startLogFile();`	135	`startLogFile();`
134	`Message ("Start of LXR. " . localtime(time) ) if $opt_logfile;`	136	`Message ("Start of LXR. " . localtime(time) ) if $opt_logfile;`
135	`Message("ScriptDir: $scriptDir");`	137	`Message("ScriptDir: $scriptDir");`
-		138	`DebugDumpData("Config", \$Config) if (IsVerbose(1));`
-		139
-		140	`#`
-		141	`# Sanity Testing`
-		142	`#`
-		143
-		144	`Error ("No LXR Data directory defined") unless( exists $Config->{lxrFiles});`
-		145	`Error ("No LXR Data directory found", $Config->{lxrFiles}) unless( -d $Config->{lxrFiles});`
-		146
-		147	`Error ("No LXR Install directory defined") unless( exists $Config->{lxr});`
-		148	`Error ("No LXR Install directory found",$Config->{lxr}) unless( -d $Config->{lxr});`
-		149
-		150	`Error ("No Glimpse Data directory defined") unless( exists $Config->{glimpseDir});`
-		151	`Warning ("No Glimpse Data directory found",$Config->{glimpseDir}) unless( -d $Config->{glimpseDir});`
-		152
-		153	`ErrorConfig( 'verbose' => $Config->{'verbose'} );`
136		154
137	`#`	155	`#`
138	`# Prevent multiple instances of the program running`	156	`# Prevent multiple instances of the program running`
139	`#`	157	`#`
140	`# PerlMonks say to use $0 as the lock file, but that did not work.`	158	`# PerlMonks say to use $0 as the lock file, but that did not work.`
Line 164...	Line 182...
164	`#`	182	`#`
165	`my ($canonname, $aliases, $addrtype, $length, @addrs) = gethostbyname($ENV{GBE_HOSTNAME});`	183	`my ($canonname, $aliases, $addrtype, $length, @addrs) = gethostbyname($ENV{GBE_HOSTNAME});`
166	`push @addressList, $canonname ;`	184	`push @addressList, $canonname ;`
167	`push (@addressList, $aliases) if ($aliases) ;`	185	`push (@addressList, $aliases) if ($aliases) ;`
168	`push (@addressList, $ENV{GBE_HOSTNAME});`	186	`push (@addressList, $ENV{GBE_HOSTNAME});`
169	`foreach ( @addrs) {`	187	`foreach (@addrs) {`
170	`push @addressList, inet_ntoa($_);`	188	`push @addressList, inet_ntoa($_);`
171	`}`	189	`}`
172	`Message("IpAddress: @addressList");`	190	`Message("IpAddress: @addressList");`
173		191
174	`#`	192	`#`
Line 213...	Line 231...
213	`my $fullPath = catfile($PackageStore , $fullName);`	231	`my $fullPath = catfile($PackageStore , $fullName);`
214	`next unless defined $entry->{vcs};`	232	`next unless defined $entry->{vcs};`
215	`next if ( $entry->{vcs} ) =~ m~^UC::~;`	233	`next if ( $entry->{vcs} ) =~ m~^UC::~;`
216	`unless (-d $fullPath )`	234	`unless (-d $fullPath )`
217	`{`	235	`{`
218	`Message("Need to extract: $entry->{name}, $entry->{ver}");`	236	`Message("Extracting: $entry->{name}, $entry->{ver}");`
219	`if ($opt_extract)`	237	`if ($opt_extract)`
220	`{`	238	`{`
221	`Verbose0("Extracting into: $fullPath");`	239	`Verbose("Extracting into: $fullPath");`
-		240	`my $result = 'ERROR';`
222	`if ($entry->{vcs} =~ m~/MASS_Dev_Crypto/~)`	241	`if ($entry->{vcs} =~ m~/MASS_Dev_Crypto/~)`
223	`{`	242	`{`
224	`print "$fullName : SUPPRESSED\n";`	243	`$result = 'SUPPRESSED';`
225	`}`	244	`}`
226	`else`	245	`else`
227	`{`	246	`{`
228	`my $rv = JatsCmd ('jats_vcsrelease', '-devmode=escrow', '-extractfiles', "-view=$fullName", "-label=$entry->{vcs}", "-root=$PackageStore", "-noprefix");`	247	`my $rv = JatsCmd ('jats_vcsrelease', '-devmode=escrow', '-extractfiles', "-view=$fullName", "-label=$entry->{vcs}", "-root=$PackageStore", "-noprefix");`
229	`print "$fullName : SUCCESS\n" unless $rv;`	248	`if ($rv)`
-		249	`{`
230	`print "$fullName : ERROR\n" if $rv;`	250	`$result = 'ERROR';`
231	`$entry->{bad} = 1;`	251	`$entry->{bad} = 1;`
-		252	`}`
-		253	`else`
-		254	`{`
-		255	`$result = 'SUCCESS';`
-		256	`}`
232	`}`	257	`}`
-		258	`Message("Extraction Result: $result");`
233	`}`	259	`}`
234	`}`	260	`}`
235	`else`	261	`else`
236	`{`	262	`{`
237	`# Package already extracted`	263	`# Package already extracted`
Line 255...	Line 281...
255	`#`	281	`#`
256	`# Process each known Release`	282	`# Process each known Release`
257	`#`	283	`#`
258	`foreach my $rtagid (sort keys \%ReleaseData)`	284	`foreach my $rtagid (sort keys \%ReleaseData)`
259	`{`	285	`{`
-		286	`Verbose("updateReleaseViews: $rtagid");`
260	`if ($ReleaseData{$rtagid}{release}{ACTIVE})`	287	`if ($ReleaseData{$rtagid}{release}{ACTIVE})`
261	`{`	288	`{`
262	`#`	289	`#`
263	`# Determinte last created view in this Release`	290	`# Determinte last created view in this Release`
264	`#`	291	`#`
265	`my ($latestView, $latestAge) = getLatestVersion(catdir($ReleaseStore, $rtagid ));`	292	`my ($latestView, $latestAge) = getLatestVersion(catdir($ReleaseStore, $rtagid ));`
266	`if ( ! defined($latestView) \|\| $latestAge > 1 )`	293	`if ( ! defined($latestView) \|\| $latestAge > 1 \|\| $opt_forceViews)`
267	`{`	294	`{`
268	`#`	295	`#`
269	`# If there is no latest view, then we need to create a new view`	296	`# If there is no latest view, then we need to create a new view`
270	`# If there is a recent view, but its older than a day then we may need`	297	`# If there is a recent view, but its older than a day then we may need`
271	`# to refresh it.`	298	`# to refresh it.`
272	`#`	299	`#`
273	`getReleasePakageData($rtagid);`	300	`getReleasePakageData($rtagid);`
274	`if (checkViewDiffs($latestView,$rtagid) )`	301	`if (checkViewDiffs($latestView,$rtagid) \|\| $opt_forceViews)`
275	`{`	302	`{`
276	`#`	303	`#`
277	`# Need to create a view`	304	`# Need to create a view`
278	`# Either one does not exist`	305	`# Either one does not exist`
279	`# Content has changed`	306	`# Content has changed`
Line 286...	Line 313...
286	`# Do need to tag it so that we don't examine it again ( for a while )`	313	`# Do need to tag it so that we don't examine it again ( for a while )`
287	`Message("No Changes to LXR View: $rtagid");`	314	`Message("No Changes to LXR View: $rtagid");`
288	`if (defined $latestView)`	315	`if (defined $latestView)`
289	`{`	316	`{`
290	`my $rv = utime $StampTime,$StampTime, $latestView;`	317	`my $rv = utime $StampTime,$StampTime, $latestView;`
291	`Debug0("Utime $rv: $latestView");`	318	`Debug("Utime $rv: $latestView");`
292	`}`	319	`}`
293	`}`	320	`}`
294	`}`	321	`}`
295	`else`	322	`else`
296	`{`	323	`{`
Line 312...	Line 339...
312	`#`	339	`#`
313	`# Inputs : $vdir - View entry to process`	340	`# Inputs : $vdir - View entry to process`
314	`# $rtagid - RtagId`	341	`# $rtagid - RtagId`
315	`#`	342	`#`
316	`# Returns : True, If we need to create a new view`	343	`# Returns : True, If we need to create a new view`
-		344	`# No view exists`
-		345	`# View does not match Release Content`
317	`#`	346	`#`
318	`sub checkViewDiffs`	347	`sub checkViewDiffs`
319	`{`	348	`{`
320	`my ($vdir, $rtagid) = @_;`	349	`my ($vdir, $rtagid) = @_;`
321		350
322	`# No entry to process, then we need to create a view`	351	`# No entry to process, then we need to create a view`
323	`return 1 if not defined $vdir;`	352	`return 1 if not defined $vdir;`
324		353
-		354	`#`
-		355	`# Read in the View List`
-		356	`#`
325	`my %pkgsUsed;`	357	`my %pkgsUsed;`
326	`my $needNewView = 0;`	358	`my $releaseListFile = catfile($vdir, '.lxrRelease');`
327		-
328	`if (opendir (my $ldir, $vdir))`	359	`if (open (my $rf, '<', $releaseListFile ))`
329	`{`	360	`{`
330	`while (my $ldirEntry = readdir($ldir))`	361	`while (my $data = <$rf>)`
331	`{`	362	`{`
332	`# Skip hidden files`	-
333	`next if ($ldirEntry =~ m~^\.~);`	-
334	`my $dirName = catdir($vdir, $ldirEntry );`	-
335		-
336	`#`	-
337	`# Process each entry within the Version`	-
338	`#`	-
339	`my $pkgName = $ldirEntry;`	-
340	`if (-l $dirName)`	-
341	`{`	-
342	`$pkgName = readlink($dirName);`	-
343	`$pkgName =~ s~.*/~~;`	363	`$data =~ s~\s+$~~;`
344	`}`	-
345	`$pkgsUsed{$pkgName} = 2;`	364	`$pkgsUsed{$data} = 2;`
346	`}`	365	`}`
-		366	`}`
-		367	`else`
-		368	`{`
-		369	`Warning ("Cannot find Release List: $releaseListFile", $!);`
347	`close ($ldir);`	370	`return 1;`
-		371	`}`
348		372
349	`#`	373	`#`
350	`# Compare Package-Versions against those we need`	374	`# Compare the packages in the Release against those required`
351	`#`	375	`#`
352	`foreach my $pvid (keys %{$ReleaseData{$rtagid}{data}})`	376	`foreach my $pvid (keys %{$ReleaseData{$rtagid}{data}})`
353	`{`	377	`{`
354	`my $entry = $Packages{$pvid};`	378	`my $entry = $Packages{$pvid};`
355	`my $fullName = join('_', $entry->{name}, $entry->{ver});`	379	`my $fullName = join('_', $entry->{name}, $entry->{ver});`
356	`$pkgsUsed{$fullName}++;`	380	`$pkgsUsed{$fullName}++;`
357	`}`	381	`}`
358		382
-		383	`my $needNewView = 0;`
359	`#`	384	`#`
360	`# Scan the pkgUsed`	385	`# Scan the pkgUsed`
361	`# A value of 1 indicates that it is used only in the New Version`	386	`# A value of 1 indicates that it is used only in the New Version`
362	`# A value of 2 indicates that it is only used on the Last Version`	387	`# A value of 2 indicates that it is only used on the Last Version`
363	`# A value of 3 indicates that its used in both`	388	`# A value of 3 indicates that its used in both`
364	`# Detect those that are not a 3`	389	`# Detect those that are not a 3`
365	`#`	390	`#`
366	`foreach ( keys %pkgsUsed)`	391	`foreach ( keys %pkgsUsed)`
-		392	`{`
-		393	`if ($pkgsUsed{$_} != 3)`
367	`{`	394	`{`
368	`if ($pkgsUsed{$_} != 3)`	-
369	`{`	-
370	`$needNewView = 1;`	395	`$needNewView = 1;`
371	`last;`	396	`last;`
372	`}`	-
373	`}`	397	`}`
374	`}`	398	`}`
375	`else`	-
376	`{`	-
377	`Warning ("Cannot open directory: $vdir", $!);`	399	`Warning("Release Contents don't match: $rtagid") if $needNewView;`
378	`$needNewView = 1;`	-
379	`}`	-
380	`#DebugDumpData("pkgsUsed",\%pkgsUsed);`	400	`#DebugDumpData("pkgsUsed",\%pkgsUsed);`
381	`return $needNewView;`	401	`return $needNewView;`
382	`}`	402	`}`
383		403
384	`#-------------------------------------------------------------------------------`	404	`#-------------------------------------------------------------------------------`
Line 391...	Line 411...
391	`# Returns :`	411	`# Returns :`
392	`#`	412	`#`
393	`sub createReleaseView`	413	`sub createReleaseView`
394	`{`	414	`{`
395	`my ($rtagid) = @_;`	415	`my ($rtagid) = @_;`
-		416	`my @ReleaseList;`
396		417
397	`#`	418	`#`
398	`# Ensure that packages have been extracted`	419	`# Ensure that packages have been extracted`
399	`#`	420	`#`
400	`extractPackages($rtagid);`	421	`extractPackages($rtagid);`
401		422
402	`#`	423	`#`
403	`# Create the actual view directory`	424	`# Create the actual view directory`
404	`# Its simply a bunch of symlinks back to the package store`	425	`# Its simply a bunch of symlinks back to the package store`
405	`#`	426	`#`
-		427
-		428	`#`
-		429	`# Create directory for the new view`
-		430	`# Based on current date. Some tools (glimpse and ctags) can't handle spaces in paths`
-		431	`#`
-		432	`my $dateTag = localtime($StampTime);`
-		433	`$dateTag =~ s~\s+~_~g;`
-		434
406	`Message("Creating LXR View: $rtagid, $dateTag");`	435	`Message("Creating LXR View: $rtagid, $dateTag");`
407	`my $releaseDir = catdir($ReleaseStore, $rtagid, $dateTag);`	436	`my $releaseDir = catdir($ReleaseStore, $rtagid, $dateTag);`
408	`mkpath($releaseDir);`	437	`mkpath($releaseDir);`
409	`if (-d $releaseDir)`	438	`if (-d $releaseDir)`
410	`{`	439	`{`
Line 412...	Line 441...
412	`{`	441	`{`
413	`my $entry = $Packages{$pvid};`	442	`my $entry = $Packages{$pvid};`
414	`my $alias = join('', $entry->{name}, $entry->{ext});`	443	`my $alias = join('', $entry->{name}, $entry->{ext});`
415	`my $fullName = join('_', $entry->{name}, $entry->{ver});`	444	`my $fullName = join('_', $entry->{name}, $entry->{ver});`
416	`my $PackageStore = catdir($PackageStore , $fullName);`	445	`my $PackageStore = catdir($PackageStore , $fullName);`
417	`my $releaseDir = catdir($releaseDir, $alias );`	446	`my $pkgDir = catdir($releaseDir, $alias );`
-		447	`push @ReleaseList, $fullName;`
418	`next if -l $releaseDir;`	448	`next if -l $pkgDir;`
-		449	`next if -d $pkgDir;`
419		450
-		451	`#`
420	`Verbose("Symlink $PackageStore, $releaseDir");`	452	`#`
421	`my $rv = symlink ($PackageStore, $releaseDir);`	453	`# Glimpse will not follow symlinks - which would be nice`
422	`unless ($rv)`	454	`# Clone the Package using hardlinks - still saves space`
423	`{`	455	`#`
-		456	`Verbose("HardLink $PackageStore, $releaseDir");`
-		457	`my $rv = System('--NoExit', '--NoShell', 'cp','-al', $PackageStore, $pkgDir);`
424	`Warning("Could not link $PackageStore, $releaseDir")`	458	`Warning("Could not duplicate $PackageStore, $releaseDir") if $rv;`
-		459
-		460
-		461	`# Verbose("Symlink $PackageStore, $releaseDir");`
425	`}`	462	`# my $rv = symlink ($PackageStore, $releaseDir);`
-		463	`# Warning("Could not link $PackageStore, $releaseDir") unless ($rv);`
426	`}`	464	`}`
-		465
-		466	`#`
-		467	`# Generate a list of package-vesrions in the release`
-		468	`# Used so that we can detect changes to the release`
-		469	`#`
-		470	`FileCreate(catfile($releaseDir, '.lxrRelease'), \@ReleaseList);`
427	`}`	471	`}`
-		472	`Verbose("createReleaseView - End");`
428	`}`	473	`}`
429		474
430	`#-------------------------------------------------------------------------------`	475	`#-------------------------------------------------------------------------------`
431	`# Function : rebuildLxrConfig`	476	`# Function : rebuildLxrConfig`
432	`#`	477	`#`
Line 656...	Line 701...
656	`if (processAgeMarker($vdirName, $Config->{'releaseAge'} ))`	701	`if (processAgeMarker($vdirName, $Config->{'releaseAge'} ))`
657	`{`	702	`{`
658	`Message("Delete Release: $rdirEntry");`	703	`Message("Delete Release: $rdirEntry");`
659	`RmDirTree($vdirName);`	704	`RmDirTree($vdirName);`
660	`System('--NoExit', '--NoShell', catfile($scriptDir, 'lxr.dropdb.sh'), genDatabaseName($rdirEntry));`	705	`System('--NoExit', '--NoShell', catfile($scriptDir, 'lxr.dropdb.sh'), genDatabaseName($rdirEntry));`
-		706	`if ( defined $Config->{glimpseDir} )`
-		707	`{`
-		708	`my $glimpseData = catdir( $Config->{glimpseDir}, $rdirEntry );`
-		709	`RmDirTree($glimpseData);`
-		710	`}`
661	`}`	711	`}`
662	`}`	712	`}`
663	`else`	713	`else`
664	`{`	714	`{`
665	`deleteAgeMarker($vdirName);`	715	`deleteAgeMarker($vdirName);`
Line 763...	Line 813...
763	`}`	813	`}`
764		814
765	`#-------------------------------------------------------------------------------`	815	`#-------------------------------------------------------------------------------`
766	`# Function : cleanPackageStore`	816	`# Function : cleanPackageStore`
767	`#`	817	`#`
768	`# Description : Delete unused PAckages fromthe package store`	818	`# Description : Delete unused Packages from the package store`
-		819	`# Each View in each Release will have a .lxrRelease file that contains the`
-		820	`# package versions that the view needs.`
769	`#`	821	`#`
770	`# Inputs :`	822	`# Inputs :`
771	`#`	823	`#`
772	`# Returns :`	824	`# Returns :`
773	`#`	825	`#`
774	`sub cleanPackageStore`	826	`sub cleanPackageStore`
775	`{`	827	`{`
-		828	`Verbose ("cleanPackageStore");`
776	`my %pkgsUsed;`	829	`my %pkgsUsed;`
777	`#`	830	`#`
778	`# Examime ALL versions in ALL Releases and build up a hash of`	831	`# Examime ALL versions in ALL Releases and build up a hash of`
779	`# Package Versions used`	832	`# Package Versions used`
780	`#`	833	`#`
Line 796...	Line 849...
796	`next if ($vdirEntry =~ m~^\.~);`	849	`next if ($vdirEntry =~ m~^\.~);`
797	`my $ldirName = catdir($vdirName, $vdirEntry );`	850	`my $ldirName = catdir($vdirName, $vdirEntry );`
798	`next unless ( -d $ldirName );`	851	`next unless ( -d $ldirName );`
799		852
800	`#`	853	`#`
801	`# Process each entry within the Version`	854	`# Read in the View List`
802	`#`	855	`#`
803	`opendir (my $ldir, $ldirName) \|\| Warning ("Cannot open directory: $ldirName", $!);`	856	`my $releaseListFile = catfile($ldirName, '.lxrRelease');`
804	`while (my $ldirEntry = readdir($ldir))`	857	`if (open (my $rf, '<', $releaseListFile ))`
805	`{`	858	`{`
806	`# Skip hidden files and directories (also borken symlinks )`	-
807	`next if ($ldirEntry =~ m~^\.~);`	-
808	`my $dirName = catdir($ldirName, $ldirEntry );`	-
809	`next unless ( -d $dirName );`	859	`Verbose2("Found ", $releaseListFile);`
810		-
811	`#`	-
812	`# Process each entry within the Version`	-
813	`#`	-
814	`my $pkgName = $ldirEntry;`	-
815	`if (-l $dirName)`	860	`while (my $data = <$rf>)`
816	`{`	861	`{`
817	`$pkgName = readlink($dirName);`	862	`$data =~ s~\s+$~~;`
818	`$pkgName =~ s~.*/~~;`	863	`$pkgsUsed{$data}++;`
819	`}`	864	`}`
820	`$pkgsUsed{$pkgName}++;`	-
821	`}`	865	`}`
822	`close ($ldir);`	866	`else`
-		867	`{`
-		868	`Warning ("Cannot find Release List: $releaseListFile", $!);`
-		869	`}`
823	`}`	870	`}`
824	`close ($vdir);`	871	`close ($vdir);`
825	`}`	872	`}`
826	`close ($rdir);`	873	`close ($rdir);`
827		874
Line 849...	Line 896...
849	`close ($pdir);`	896	`close ($pdir);`
850		897
851	`#DebugDumpData("pkgsUsed", \%pkgsUsed);`	898	`#DebugDumpData("pkgsUsed", \%pkgsUsed);`
852	`}`	899	`}`
853		900
854		-
855	`#-------------------------------------------------------------------------------`	901	`#-------------------------------------------------------------------------------`
856	`# Function : getReleaseData`	902	`# Function : getReleaseData`
857	`#`	903	`#`
858	`# Description : Get all the required Release Data`	904	`# Description : Get all the required Release Data`
859	`#`	905	`#`
Line 1081...	Line 1127...
1081	`}`	1127	`}`
1082	`else`	1128	`else`
1083	`{`	1129	`{`
1084	`Error("Couldn't open configuration file \"$cfile\".", $!);`	1130	`Error("Couldn't open configuration file \"$cfile\".", $!);`
1085	`}`	1131	`}`
1086		-
1087	`if (IsVerbose(1))`	-
1088	`{`	-
1089	`DebugDumpData("Config", \$Config);`	-
1090	`}`	-
1091	`}`	1132	`}`
1092		1133
1093	`#-------------------------------------------------------------------------------`	1134	`#-------------------------------------------------------------------------------`
1094	`# Function : startLogFile`	1135	`# Function : startLogFile`
1095	`#`	1136	`#`
Line 1249...	Line 1290...
1249	`-[no]createVersions - Create new versions. Default:Create`	1290	`-[no]createVersions - Create new versions. Default:Create`
1250	`-[no]extract - Extract source code. Default:Extract`	1291	`-[no]extract - Extract source code. Default:Extract`
1251	`-[no]index - Index new LXR versions. Default:Index`	1292	`-[no]index - Index new LXR versions. Default:Index`
1252	`-[no]purge - Purge unused packages. Default:Purge`	1293	`-[no]purge - Purge unused packages. Default:Purge`
1253	`-[no]logfile - Capture out to a log file. Default:Log`	1294	`-[no]logfile - Capture out to a log file. Default:Log`
-		1295	`-[no]forceViews - Force creation of new views. Default:NoForceView`
1254	`-config=file - Alternate config file`	1296	`-config=file - Alternate config file`
1255		1297
1256	`=head1 OPTIONS`	1298	`=head1 OPTIONS`
1257		1299
1258	`=over 8`	1300	`=over 8`
Line 1287...	Line 1329...
1287		1329
1288	`=item B<-[no]purge>`	1330	`=item B<-[no]purge>`
1289		1331
1290	`This option can be used to suppress purging of packages that are no longer used by any of the LXR Trees.`	1332	`This option can be used to suppress purging of packages that are no longer used by any of the LXR Trees.`
1291		1333
-		1334	`=item B<-[no]forceViews>`
-		1335
-		1336	`This option can be used to force the creation of a new View in each Release.`
-		1337
1292	`=item B<-config=file>`	1338	`=item B<-config=file>`
1293		1339
1294	`This option can be used to override the standard config file. Used in testing.`	1340	`This option can be used to override the standard config file. Used in testing.`
1295		1341
1296	`=back`	1342	`=back`

Subversion Repositories DevTools

(root)/lxr_manager/trunk/src/jats_lxr.pl – Rev 5213 → 5231