src/Cache/Cache.pm

#____________________________________________________________________ 
# File: Cache.pm
#____________________________________________________________________ 
#  
# Author: Shaun Ashby <Shaun.Ashby@cern.ch>
#         (with contribution from Lassi.Tuura@cern.ch)
# Update: 2003-11-27 16:45:18+0100
# Revision: $Id: Cache.pm,v 1.3 2005/03/11 18:55:28 sashby Exp $ 
#
# Copyright: 2003 (C) Shaun Ashby
#
#--------------------------------------------------------------------
package Cache::Cache;
require 5.004;

use Exporter;
@ISA=qw(Exporter);
#
sub new()
   ###############################################################
   # new                                                         #
   ###############################################################
   # modified : Thu Nov 27 16:45:27 2003 / SFA                   #
   # params   :                                                  #
   #          :                                                  #
   # function :                                                  #
   #          :                                                  #
   ###############################################################
   {
   my $proto=shift;
   my $class=ref($proto) || $proto;
   my $self=
      {
      CACHENAME => "DirCache.db",     # Name of global file/dir cache;
      BFCACHE => {},                  # BuildFile cache;
      DIRCACHE => {},                 # Source code cache;
      STATUS => 0,                    # Status of cache: 1 => something changed. If so, force save;
      VERBOSE => 0                    # Verbose mode (0/1);
      };

   bless $self,$class;
   return $self;
   }

sub getdir()
   {
   my $self=shift;
   my ($path) = @_;
   opendir (DIR, $path) || die "$path: cannot read: $!\n";
   # Skip .admin and CVS subdirectories too.
   # Also skip files that look like backup files or files being modified with emacs:
   my @items = map { "$path/$_" } grep (
                                        $_ ne "." && $_ ne ".." && $_ ne "CVS" && 
                                        $_ ne ".admin" && $_ !~ m|\.#*|,
                                        readdir(DIR)
                                        );   
   closedir (DIR);
   return @items;
   }

sub prune()
   {
   my $self=shift;
   my ($path) = @_;
   $self->cachestatus(1);
   return if ! exists $self->{DIRCACHE}->{$path};
   my (undef, undef, @subs) = @{$self->{DIRCACHE}->{$path}};
   delete $self->{DIRCACHE}->{$path};
   foreach my $sub (@subs)
      {
      $self->prune($sub);
      }
   }

sub checktree()
   {
   my ($self, $path, $required, $dofiles) = @_;
   # Check if this path needs to be checked.  If it exists, has the same mode
   # and the same time stamp, it's up to date and doesn't need to be checked.
   # Otherwise if it is a directory whose time-stamp has changed, rescan it.
   # If the path has be removed, prune it from the cache.  Note that we skip 
   # non-directories unless $dofiles is set.  Considering only directories is
   # dramatically faster.
   next if ($path =~ /\.admin/); # skip .admin dirs
   next if ($path =~ /.*CVS/);

   # NB: We stat each path only once ever.  The special "_" file handle uses
   # the results from the last stat we've made.  See man perlfunc/stat.
   if (! stat($path))
      {
      die "$path: $!\n" if $required;
      $self->logmsg("SCRAM: $path: missing: removing from cache\n");
      $self->prune($path);
      # Something changed so force write of cache:
      $self->cachestatus(1);
      return;
      }

   # If the entry in the cache is not the same mode or time, force an update.
   # Otherwise use the cache as the list of items we need to change.
   my $cached = $self->{DIRCACHE}->{$path};   
   my @items = ();

   if (! -d _)
      {
      if ($dofiles)
         {
         $self->logmsg("SCRAM: $path: updating cache\n");
         $self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9] ];
         }
      else
         {
         $self->logmsg("SCRAM: $path: not a directory: removing from parent's list\n");
         my $parent = $path;
         $parent =~ s|(.*)/[^/]+$|$1|;
         if ($parent ne $path && exists $self->{DIRCACHE}->{$parent})
            {
            my ($mode, $time, @subs) = @{$self->{DIRCACHE}->{$parent}};
            $self->{DIRCACHE}->{$parent} = [ $mode, $time, grep ($_ ne $path, @subs) ];
            }
         $self->cachestatus(1);
         }
      }
   elsif (! $cached || $cached->[0] != (stat(_))[2])
      {
      # When a directory is added, this block is activated
      $self->added_dirs($path); # Store the newly-added dir
      $self->logmsg("SCRAM: $path: new or changed: pruning and recreating cache\n");
      $self->prune($path);
      $self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9], @items = $self->getdir($path) ];
      $required = 1;
      $self->cachestatus(1);
      }
   elsif ($cached->[1] != (stat(_))[9])
      {
      # When a subdirectory is removed, this block is activated
      #
      # This is a parent directory. We store this as any
      # update can be taken recursively from this dir:
      $self->modified_parentdirs($path);
      
      $self->logmsg("SCRAM: $path: modified: updating cache\n");
      # Current subdirs:
      @items = $self->getdir($path);
      
      # Start checking from element number 2:
      for (my $i = 2; $i <= $#$cached; $i++)
         {
         if (! grep($cached->[$i] eq $_, @items))
            {
            # Add the removed path to a store for later access
            # from the project cache. This info is needed to update
            # the cached data:
            $self->schedremoval($cached->[$i]);
            # Remove all child data:
            $self->clean_cache_recursive($cached->[$i]);
            }
         }      
      
      $self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9], @items ];
      $required = 1;
      $self->cachestatus(1);
      }
   else
      {
      $self->logmsg("SCRAM: $path: valid: using cached directory list\n");
      (undef, undef, @items) = @{$self->{DIRCACHE}->{$path}};
      $required = 0;
      }
   
   # Process sub-directories
   foreach my $item (@items)
      {
      $self->checktree($item, $required, $dofiles);
      }
   }

sub clean_cache_recursive()
   {
   my $self=shift;
   my ($startdir) = @_;
   my $children = $self->{DIRCACHE}->{$startdir};
   
   for (my $i = 2; $i <= $#$children; $i++) 
      {
      # Remove all children:
      $self->schedremoval($children->[$i]);
      $self->clean_cache_recursive($children->[$i]); 
      }
   
   delete $self->{DIRCACHE}->{$startdir};
   return $self;
   }

sub dirtree()
   {
   my $self=shift;
   my ($dir,$dofiles) = @_;

   # Get the directory tree:
   $self->checktree($dir, 1, $dofiles);
   return $self;
   }

sub checkfiles()
   {
   my $self=shift;
   # Scan config dir for top-level data, then start from src:
   my @scandirs=($ENV{LOCALTOP}."/".$ENV{SCRAM_CONFIGDIR}, $ENV{SCRAM_SOURCEDIR});
   my $dofiles=1;
   # Loop over all directories that need scanning (normally just src and config):
   foreach my $scand (@scandirs)
      {
      $self->logmsg("SCRAM: Scanning $scand [dofiles set to ".$dofiles."]\n");
      # Check the directory tree:
      $self->dirtree($scand, $dofiles);
      $dofiles=0;
      }
   
   # Mark everything in the cache old:
   map { $_->[0] = 0 } values %{$self->{BFCACHE}};
   map { $_->[0] = 0 } values %{$self->{CONFIGCACHE}};

   # Remember which directories have buildfiles in them:
   my %files = map { -f $_ ? ($_ => [ (stat(_))[9] ]) : () }
               map { "$_/BuildFile" }
               keys %{$self->{DIRCACHE}};

   # Get list of files in config dir:
   my $configcache = {};
   my %configfiles = map { -f $_ && 
                              $_ =~ m|$ENV{LOCALTOP}/$ENV{SCRAM_CONFIGDIR}.*?$|
                              ? ($_ => [ (stat(_))[9] ]) : () } keys %{$self->{DIRCACHE}};

   # Also add ToolCache.db to the cache: FIXME: should probably use aglob here so
   #                                     that all SCRAM_ARCHs are taken into account.
   $configfiles{$ENV{LOCALTOP}."/.SCRAM/".$ENV{SCRAM_ARCH}."/ToolCache.db"} =
      [ (stat($ENV{LOCALTOP}."/.SCRAM/".$ENV{SCRAM_ARCH}."/ToolCache.db"))[9] ];
   
   # Compare or add to config file cache. We need this to be separate so we can tell if a
   # file affecting our build has been changed:
   while (my ($path, $vals) = each %configfiles)
      {
      if ($self->{CONFIGCACHE}->{$path} && $self->{CONFIGCACHE}->{$path}[1] == $vals->[0])
         {
         $configcache->{$path} = $self->{CONFIGCACHE}->{$path};
         delete $self->{CONFIGCACHE}->{$path};
         }
      else
         {
         $self->{STATUSCONFIG}=1;
         $self->logmsg("SCRAM: $path: changed\n");
         $configcache->{$path} = [ 1, @$vals ];
         delete $self->{CONFIGCACHE}->{$path};
         }
      }
   
   # Compare with existing cache: remove from cache what no longer
   # exists, then check which build files are newer than the cache.
   my $newcache = {};

   while (my ($path, $vals) = each %files)
      {
      if ($self->{BFCACHE}->{$path} && $self->{BFCACHE}->{$path}[1] == $vals->[0])
         {
         $newcache->{$path} = $self->{BFCACHE}->{$path};
         delete $self->{BFCACHE}->{$path};
         }
      else
         {
         $self->{STATUSSRC}=1;
         $self->logmsg("SCRAM: $path: changed\n");
         $newcache->{$path} = [ 1, @$vals ];
         delete $self->{BFCACHE}->{$path};
         }
      }

   # If there were BuildFiles that were removed, force update of cache
   # and remove the BUILDFILEDATA entries:
   foreach my $path (keys %{$self->{BFCACHE}})
      {
      $self->logmsg("SCRAM: $path: removed. Build data will be removed from build cache.\n");
      $self->cachestatus(1);      
      # Store this so that later, we can tell the BuildDataStore to remove it:
      $self->schedremoval($path);
      }
   
   # Save the BuildFile cache:
   delete $self->{BFCACHE};
   $self->{BFCACHE} = $newcache;

   # Save the config cache:
   delete $self->{CONFIGCACHE};
   $self->{CONFIGCACHE} = $configcache;
   return $self;
   }

sub dircache()
   {
   my $self=shift;
   # Return the file cache:
   return $self->{DIRCACHE};
   }

sub added_dirs()
   {
   my $self=shift;
   my ($path) = @_;

   # If we have a path to add, add it.
   if ($path)
      {
      if (exists($self->{ADDEDDIRS}))
         {
         push(@{$self->{ADDEDDIRS}}, $path);
         }
      else
         {
         $self->{ADDEDDIRS} = [ $path ];
         }
      }
   else
      {
      # Otherwise, return the array of added dirs:
      my @addeddirs = @{$self->{ADDEDDIRS}};
      delete $self->{ADDEDDIRS};
      return \@addeddirs;
      }
   }

sub modified_parentdirs()
   {
   my $self=shift;
   my ($path) = @_;
   
   # If we have a path to add, add it.
   # Don't bother if it's the main source dir as we don't
   # want to rescan everything from src (that would be silly):
   if ($path && $path ne $ENV{SCRAM_SOURCEDIR})
      {
      if (exists($self->{MODPARENTDIRS}))
         {
         push(@{$self->{MODPARENTDIRS}}, $path);
         }
      else
         {
         $self->{MODPARENTDIRS} = [ $path ];
         }
      }
   else
      {
      # Otherwise, return the array of added dirs:
      my @moddeddirs = @{$self->{MODPARENTDIRS}};
      delete $self->{MODPARENTDIRS};
      return \@moddeddirs;
      }
   }

sub schedremoval()
   {
   my $self=shift;
   my ($d)=@_;

   if ($d)
      {
      if (exists($self->{REMOVEDATA}))
         {
         push(@{$self->{REMOVEDATA}},$d);
         }
      else
         {
         $self->{REMOVEDATA} = [ $d ];
         }
      }
   else
      {
      my $remove = [ @{$self->{REMOVEDATA}} ];
      $self->{REMOVEDATA} = [];
      return $remove;
      }
   }

sub filestatus()
   {
   my $self=shift;
   # Here we want to return a true or false value depending on whether
   # or not a buildfile was changed:
   return $self->{STATUSSRC};
   }

sub configstatus()
   {
   my $self=shift;
   # Here we want to return a true or false value depending on whether or not a file
   # in config dir was changed:
   return $self->{STATUSCONFIG};
   }

sub bf_for_scanning()
   {
   my $self=shift;
   my $MODIFIED = [];
   
   $self->{STATUSSRC} = 0;

   # Return a list of buildfiles to be reread. Note that we only do this
   # if the status was changed (i.e. don't have to read through the list of BFs to know
   # whether something changed as the flags STATUSSRC is set as the src tree is checked).
   # Also we check to see if STATUSCONFIG is true. If so all BuildFiles are marked to be read:
   if ($self->{STATUSCONFIG})
      {
      $self->{STATUSCONFIG} = 0;
      # Return all the buildfiles since they'll all to be read:
      return [ keys %{$self->{BFCACHE}} ];
      }
   else
      {
      # Only return the files that changed:
      map { ( $self->{BFCACHE}{$_}->[0] == 1 ) && push(@$MODIFIED, $_) } keys %{$self->{BFCACHE}};
      # Reset the flag:
      $self->{STATUSCONFIG} = 0;
      }
   return $MODIFIED;
   }

sub paths()
   {
   my $self=shift;
   my $paths = {};
   
   $self->{ALLDIRS} = [];
   
   # Pass over each dir, skipping those that are not wanted and
   # storing those that are relevant to an array:
   foreach my $path (keys %{$self->{DIRCACHE}})
      {
      if ( ! -d $path && $path != m|$ENV{LOCALTOP}/$ENV{SCRAM_CONFIGDIR}.*?$|)
         {      
         $self->logmsg("SCRAM: $path no longer exists. Clearing from cache.\n");
         $self->cachestatus(1);
         delete $self->{DIRCACHE}->{$path};
         }
      else
         {
         next if $path =~ m|/CVS$|;     # Ignore CVS directories.
         next if $path =~ m|/\.admin$|; # Ignore .admin directories.
         next if $path =~ m|\Q$ENV{LOCALTOP}/$ENV{SCRAM_CONFIGDIR}\L|;
         push(@{$self->{ALLDIRS}},$path);
         }
      }
   
   # Return the array:
   return $self->{ALLDIRS};
   }

sub verbose()
   {
   my $self=shift;
   # Turn on verbose mode:
   @_ ? $self->{VERBOSE} = shift
      : $self->{VERBOSE}
   }

sub cachestatus()
   {
   my $self=shift;
   # Set/return the status of the cache:
   @_ ? $self->{STATUS} = shift
      : $self->{STATUS}
   }

sub logmsg()
   {
   my $self=shift;
   # Print a message to STDOUT if VERBOSE is true:
   print STDERR @_ if $self->verbose();
   }

sub name()
   {
   my $self=shift;
   # Set/return the name of the cache to use:
   @_ ? $self->{CACHENAME} = shift
      : $self->{CACHENAME}
   }

1;
Revision:	1.4
Committed:	Tue Jun 28 19:08:55 2005 UTC (19 years, 10 months ago) by sashby
Content type:	text/plain
Branch:	MAIN
Changes since 1.3:	+4 -3 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	sashby	1.2	#____________________________________________________________________
2			# File: Cache.pm
3			#____________________________________________________________________
4			#
5			# Author: Shaun Ashby <Shaun.Ashby@cern.ch>
6			# (with contribution from Lassi.Tuura@cern.ch)
7			# Update: 2003-11-27 16:45:18+0100
8	sashby	1.4	# Revision: $Id: Cache.pm,v 1.3 2005/03/11 18:55:28 sashby Exp $
9	sashby	1.2	#
10			# Copyright: 2003 (C) Shaun Ashby
11			#
12			#--------------------------------------------------------------------
13			package Cache::Cache;
14			require 5.004;
15
16			use Exporter;
17			@ISA=qw(Exporter);
18			#
19			sub new()
20			###############################################################
21			# new #
22			###############################################################
23			# modified : Thu Nov 27 16:45:27 2003 / SFA #
24			# params : #
25			# : #
26			# function : #
27			# : #
28			###############################################################
29			{
30			my $proto=shift;
31			my $class=ref($proto) \|\| $proto;
32			my $self=
33			{
34			CACHENAME => "DirCache.db", # Name of global file/dir cache;
35			BFCACHE => {}, # BuildFile cache;
36			DIRCACHE => {}, # Source code cache;
37			STATUS => 0, # Status of cache: 1 => something changed. If so, force save;
38			VERBOSE => 0 # Verbose mode (0/1);
39			};
40
41			bless $self,$class;
42			return $self;
43			}
44
45			sub getdir()
46			{
47			my $self=shift;
48			my ($path) = @_;
49			opendir (DIR, $path) \|\| die "$path: cannot read: $!\n";
50	sashby	1.4	# Skip .admin and CVS subdirectories too.
51	sashby	1.3	# Also skip files that look like backup files or files being modified with emacs:
52			my @items = map { "$path/$_" } grep (
53	sashby	1.4	$_ ne "." && $_ ne ".." && $_ ne "CVS" &&
54	sashby	1.3	$_ ne ".admin" && $_ !~ m\|\.#*\|,
55			readdir(DIR)
56			);
57	sashby	1.2	closedir (DIR);
58			return @items;
59			}
60
61			sub prune()
62			{
63			my $self=shift;
64			my ($path) = @_;
65			$self->cachestatus(1);
66			return if ! exists $self->{DIRCACHE}->{$path};
67			my (undef, undef, @subs) = @{$self->{DIRCACHE}->{$path}};
68			delete $self->{DIRCACHE}->{$path};
69			foreach my $sub (@subs)
70			{
71			$self->prune($sub);
72			}
73			}
74
75			sub checktree()
76			{
77			my ($self, $path, $required, $dofiles) = @_;
78			# Check if this path needs to be checked. If it exists, has the same mode
79			# and the same time stamp, it's up to date and doesn't need to be checked.
80			# Otherwise if it is a directory whose time-stamp has changed, rescan it.
81			# If the path has be removed, prune it from the cache. Note that we skip
82			# non-directories unless $dofiles is set. Considering only directories is
83			# dramatically faster.
84			next if ($path =~ /\.admin/); # skip .admin dirs
85	sashby	1.4	next if ($path =~ /.*CVS/);
86	sashby	1.2
87			# NB: We stat each path only once ever. The special "_" file handle uses
88			# the results from the last stat we've made. See man perlfunc/stat.
89			if (! stat($path))
90			{
91			die "$path: $!\n" if $required;
92			$self->logmsg("SCRAM: $path: missing: removing from cache\n");
93			$self->prune($path);
94			# Something changed so force write of cache:
95			$self->cachestatus(1);
96			return;
97			}
98
99			# If the entry in the cache is not the same mode or time, force an update.
100			# Otherwise use the cache as the list of items we need to change.
101			my $cached = $self->{DIRCACHE}->{$path};
102			my @items = ();
103
104			if (! -d _)
105			{
106			if ($dofiles)
107			{
108			$self->logmsg("SCRAM: $path: updating cache\n");
109			$self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9] ];
110			}
111			else
112			{
113			$self->logmsg("SCRAM: $path: not a directory: removing from parent's list\n");
114			my $parent = $path;
115			$parent =~ s\|(.*)/[^/]+$\|$1\|;
116			if ($parent ne $path && exists $self->{DIRCACHE}->{$parent})
117			{
118			my ($mode, $time, @subs) = @{$self->{DIRCACHE}->{$parent}};
119			$self->{DIRCACHE}->{$parent} = [ $mode, $time, grep ($_ ne $path, @subs) ];
120			}
121			$self->cachestatus(1);
122			}
123			}
124			elsif (! $cached \|\| $cached->[0] != (stat(_))[2])
125			{
126			# When a directory is added, this block is activated
127			$self->added_dirs($path); # Store the newly-added dir
128			$self->logmsg("SCRAM: $path: new or changed: pruning and recreating cache\n");
129			$self->prune($path);
130			$self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9], @items = $self->getdir($path) ];
131			$required = 1;
132			$self->cachestatus(1);
133			}
134			elsif ($cached->[1] != (stat(_))[9])
135			{
136			# When a subdirectory is removed, this block is activated
137			#
138			# This is a parent directory. We store this as any
139			# update can be taken recursively from this dir:
140			$self->modified_parentdirs($path);
141
142			$self->logmsg("SCRAM: $path: modified: updating cache\n");
143			# Current subdirs:
144			@items = $self->getdir($path);
145
146			# Start checking from element number 2:
147			for (my $i = 2; $i <= $#$cached; $i++)
148			{
149			if (! grep($cached->[$i] eq $_, @items))
150			{
151			# Add the removed path to a store for later access
152			# from the project cache. This info is needed to update
153			# the cached data:
154			$self->schedremoval($cached->[$i]);
155			# Remove all child data:
156			$self->clean_cache_recursive($cached->[$i]);
157			}
158			}
159
160			$self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9], @items ];
161			$required = 1;
162			$self->cachestatus(1);
163			}
164			else
165			{
166			$self->logmsg("SCRAM: $path: valid: using cached directory list\n");
167			(undef, undef, @items) = @{$self->{DIRCACHE}->{$path}};
168			$required = 0;
169			}
170
171			# Process sub-directories
172			foreach my $item (@items)
173			{
174			$self->checktree($item, $required, $dofiles);
175			}
176			}
177
178			sub clean_cache_recursive()
179			{
180			my $self=shift;
181			my ($startdir) = @_;
182			my $children = $self->{DIRCACHE}->{$startdir};
183
184			for (my $i = 2; $i <= $#$children; $i++)
185			{
186			# Remove all children:
187			$self->schedremoval($children->[$i]);
188			$self->clean_cache_recursive($children->[$i]);
189			}
190
191			delete $self->{DIRCACHE}->{$startdir};
192			return $self;
193			}
194
195			sub dirtree()
196			{
197			my $self=shift;
198			my ($dir,$dofiles) = @_;
199
200			# Get the directory tree:
201			$self->checktree($dir, 1, $dofiles);
202			return $self;
203			}
204
205			sub checkfiles()
206			{
207			my $self=shift;
208			# Scan config dir for top-level data, then start from src:
209			my @scandirs=($ENV{LOCALTOP}."/".$ENV{SCRAM_CONFIGDIR}, $ENV{SCRAM_SOURCEDIR});
210			my $dofiles=1;
211			# Loop over all directories that need scanning (normally just src and config):
212			foreach my $scand (@scandirs)
213			{
214			$self->logmsg("SCRAM: Scanning $scand [dofiles set to ".$dofiles."]\n");
215			# Check the directory tree:
216			$self->dirtree($scand, $dofiles);
217			$dofiles=0;
218			}
219
220			# Mark everything in the cache old:
221			map { $_->[0] = 0 } values %{$self->{BFCACHE}};
222			map { $_->[0] = 0 } values %{$self->{CONFIGCACHE}};
223
224			# Remember which directories have buildfiles in them:
225			my %files = map { -f $_ ? ($_ => [ (stat(_))[9] ]) : () }
226			map { "$_/BuildFile" }
227			keys %{$self->{DIRCACHE}};
228
229			# Get list of files in config dir:
230			my $configcache = {};
231			my %configfiles = map { -f $_ &&
232			$_ =~ m\|$ENV{LOCALTOP}/$ENV{SCRAM_CONFIGDIR}.*?$\|
233			? ($_ => [ (stat(_))[9] ]) : () } keys %{$self->{DIRCACHE}};
234
235			# Also add ToolCache.db to the cache: FIXME: should probably use aglob here so
236			# that all SCRAM_ARCHs are taken into account.
237			$configfiles{$ENV{LOCALTOP}."/.SCRAM/".$ENV{SCRAM_ARCH}."/ToolCache.db"} =
238			[ (stat($ENV{LOCALTOP}."/.SCRAM/".$ENV{SCRAM_ARCH}."/ToolCache.db"))[9] ];
239
240			# Compare or add to config file cache. We need this to be separate so we can tell if a
241			# file affecting our build has been changed:
242			while (my ($path, $vals) = each %configfiles)
243			{
244			if ($self->{CONFIGCACHE}->{$path} && $self->{CONFIGCACHE}->{$path}[1] == $vals->[0])
245			{
246			$configcache->{$path} = $self->{CONFIGCACHE}->{$path};
247			delete $self->{CONFIGCACHE}->{$path};
248			}
249			else
250			{
251			$self->{STATUSCONFIG}=1;
252			$self->logmsg("SCRAM: $path: changed\n");
253			$configcache->{$path} = [ 1, @$vals ];
254			delete $self->{CONFIGCACHE}->{$path};
255			}
256			}
257
258			# Compare with existing cache: remove from cache what no longer
259			# exists, then check which build files are newer than the cache.
260			my $newcache = {};
261
262			while (my ($path, $vals) = each %files)
263			{
264			if ($self->{BFCACHE}->{$path} && $self->{BFCACHE}->{$path}[1] == $vals->[0])
265			{
266			$newcache->{$path} = $self->{BFCACHE}->{$path};
267			delete $self->{BFCACHE}->{$path};
268			}
269			else
270			{
271			$self->{STATUSSRC}=1;
272			$self->logmsg("SCRAM: $path: changed\n");
273			$newcache->{$path} = [ 1, @$vals ];
274			delete $self->{BFCACHE}->{$path};
275			}
276			}
277
278			# If there were BuildFiles that were removed, force update of cache
279			# and remove the BUILDFILEDATA entries:
280			foreach my $path (keys %{$self->{BFCACHE}})
281			{
282			$self->logmsg("SCRAM: $path: removed. Build data will be removed from build cache.\n");
283			$self->cachestatus(1);
284			# Store this so that later, we can tell the BuildDataStore to remove it:
285			$self->schedremoval($path);
286			}
287
288			# Save the BuildFile cache:
289			delete $self->{BFCACHE};
290			$self->{BFCACHE} = $newcache;
291
292			# Save the config cache:
293			delete $self->{CONFIGCACHE};
294			$self->{CONFIGCACHE} = $configcache;
295			return $self;
296			}
297
298			sub dircache()
299			{
300			my $self=shift;
301			# Return the file cache:
302			return $self->{DIRCACHE};
303			}
304
305			sub added_dirs()
306			{
307			my $self=shift;
308			my ($path) = @_;
309
310			# If we have a path to add, add it.
311			if ($path)
312			{
313			if (exists($self->{ADDEDDIRS}))
314			{
315			push(@{$self->{ADDEDDIRS}}, $path);
316			}
317			else
318			{
319			$self->{ADDEDDIRS} = [ $path ];
320			}
321			}
322			else
323			{
324			# Otherwise, return the array of added dirs:
325			my @addeddirs = @{$self->{ADDEDDIRS}};
326			delete $self->{ADDEDDIRS};
327			return \@addeddirs;
328			}
329			}
330
331			sub modified_parentdirs()
332			{
333			my $self=shift;
334			my ($path) = @_;
335
336			# If we have a path to add, add it.
337			# Don't bother if it's the main source dir as we don't
338			# want to rescan everything from src (that would be silly):
339			if ($path && $path ne $ENV{SCRAM_SOURCEDIR})
340			{
341			if (exists($self->{MODPARENTDIRS}))
342			{
343			push(@{$self->{MODPARENTDIRS}}, $path);
344			}
345			else
346			{
347			$self->{MODPARENTDIRS} = [ $path ];
348			}
349			}
350			else
351			{
352			# Otherwise, return the array of added dirs:
353			my @moddeddirs = @{$self->{MODPARENTDIRS}};
354			delete $self->{MODPARENTDIRS};
355			return \@moddeddirs;
356			}
357			}
358
359			sub schedremoval()
360			{
361			my $self=shift;
362			my ($d)=@_;
363
364			if ($d)
365			{
366			if (exists($self->{REMOVEDATA}))
367			{
368			push(@{$self->{REMOVEDATA}},$d);
369			}
370			else
371			{
372			$self->{REMOVEDATA} = [ $d ];
373			}
374			}
375			else
376			{
377			my $remove = [ @{$self->{REMOVEDATA}} ];
378			$self->{REMOVEDATA} = [];
379			return $remove;
380			}
381			}
382
383			sub filestatus()
384			{
385			my $self=shift;
386			# Here we want to return a true or false value depending on whether
387			# or not a buildfile was changed:
388			return $self->{STATUSSRC};
389			}
390
391			sub configstatus()
392			{
393			my $self=shift;
394			# Here we want to return a true or false value depending on whether or not a file
395			# in config dir was changed:
396			return $self->{STATUSCONFIG};
397			}
398
399			sub bf_for_scanning()
400			{
401			my $self=shift;
402			my $MODIFIED = [];
403
404			$self->{STATUSSRC} = 0;
405
406			# Return a list of buildfiles to be reread. Note that we only do this
407			# if the status was changed (i.e. don't have to read through the list of BFs to know
408			# whether something changed as the flags STATUSSRC is set as the src tree is checked).
409			# Also we check to see if STATUSCONFIG is true. If so all BuildFiles are marked to be read:
410			if ($self->{STATUSCONFIG})
411			{
412			$self->{STATUSCONFIG} = 0;
413			# Return all the buildfiles since they'll all to be read:
414			return [ keys %{$self->{BFCACHE}} ];
415			}
416			else
417			{
418			# Only return the files that changed:
419			map { ( $self->{BFCACHE}{$_}->[0] == 1 ) && push(@$MODIFIED, $_) } keys %{$self->{BFCACHE}};
420			# Reset the flag:
421			$self->{STATUSCONFIG} = 0;
422			}
423			return $MODIFIED;
424			}
425
426			sub paths()
427			{
428			my $self=shift;
429			my $paths = {};
430
431			$self->{ALLDIRS} = [];
432
433			# Pass over each dir, skipping those that are not wanted and
434			# storing those that are relevant to an array:
435			foreach my $path (keys %{$self->{DIRCACHE}})
436			{
437			if ( ! -d $path && $path != m\|$ENV{LOCALTOP}/$ENV{SCRAM_CONFIGDIR}.*?$\|)
438			{
439			$self->logmsg("SCRAM: $path no longer exists. Clearing from cache.\n");
440			$self->cachestatus(1);
441			delete $self->{DIRCACHE}->{$path};
442			}
443			else
444			{
445			next if $path =~ m\|/CVS$\|; # Ignore CVS directories.
446			next if $path =~ m\|/\.admin$\|; # Ignore .admin directories.
447			next if $path =~ m\|\Q$ENV{LOCALTOP}/$ENV{SCRAM_CONFIGDIR}\L\|;
448			push(@{$self->{ALLDIRS}},$path);
449			}
450			}
451
452			# Return the array:
453			return $self->{ALLDIRS};
454			}
455
456			sub verbose()
457			{
458			my $self=shift;
459			# Turn on verbose mode:
460			@_ ? $self->{VERBOSE} = shift
461			: $self->{VERBOSE}
462			}
463
464			sub cachestatus()
465			{
466			my $self=shift;
467			# Set/return the status of the cache:
468			@_ ? $self->{STATUS} = shift
469			: $self->{STATUS}
470			}
471
472			sub logmsg()
473			{
474			my $self=shift;
475			# Print a message to STDOUT if VERBOSE is true:
476			print STDERR @_ if $self->verbose();
477			}
478
479			sub name()
480			{
481			my $self=shift;
482			# Set/return the name of the cache to use:
483			@_ ? $self->{CACHENAME} = shift
484			: $self->{CACHENAME}
485			}
486
487			1;