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.6.2.1 2006/06/21 14:46:45 sashby Exp $ 
#
# Copyright: 2003 (C) Shaun Ashby
#
#--------------------------------------------------------------------

=head1 NAME

Cache::Cache - A generic directory cache object.

=head1 SYNOPSIS
   
      my $cacheobject=Cache::Cache->new();

=head1 DESCRIPTION

A package to provide caching of directory information. Directory timestamps
are tracked on further reading of an existing cache and lists of modified
directories and BuildFiles can be obtained.

=head1 METHODS

=over

=cut

package Cache::Cache;
require 5.004;

use Exporter;
@ISA=qw(Exporter);
#

=item   C<new()>

Create a new Cache::Cache object. The name of the cache is B<DirCache.db> by default.

=cut

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

=item   C<getdir($path)>

Return a list of directories starting from $path.

=cut

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

=item   C<prune($path)>

Recursively remove directories from the cache starting at $path.

=cut

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

=item   C<checktree($path, $required, $dofiles)>

A timestamp checking routine. Starting from $path, check all timestamps of
directories and their files. Skip all files unless $dofiles is 1. 

=cut

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

=item   C<clean_cache_recursive($startdir)>

Recursive remove cached data for directories under $startdir.

=cut

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

=item   C<dirtree($dir,$dofiles)>

Starting from $dir, scan the directory tree. Ignore files unless $dofiles is set. This
function just calls checktree().

=cut

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

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

=item   C<checkfiles()>

Function to actually run the timestamp checks. This is only run from
SCRAM::CMD::build().

=cut

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|\Q$ENV{LOCALTOP}\E/$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;
   }

=item   C<dircache()>

Return a reference to the directory cache hash.

=cut

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

=item   C<added_dirs($path)>

Add $path to the list of directories added since last scan, or return
the list of added directories if no argument given.

=cut

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

=item   C<modified_parentdirs($path)>

Add a directory $path to the list of parent directories (directories
having subdirectories), or return a reference to the list.
Storing this parent allows any update to be taken recursively from this 
location.
   
=cut

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

=item   C<schedremoval($d)>

Add directory $d to list of directories that should be removed
recursively from the cache.
If no arguments given, return a reference to a list of
directories to be removed.
   
=cut

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

=item   C<filestatus()>

Return a true or false value depending on whether
a BuildFile was changed or not.

=cut

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

=item   C<configstatus()>

Return a true or false value depending on whether
a file in the config directory was changed or not.

=cut

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

=item   C<bf_for_scanning()>

Return a list of BuildFiles to re-read. Note that this is only done
if the status was changed (i.e. not necessary to read through the list
of BuildFiles to know whether something changed as the flag B<STATUSSRC>
is set as the source tree is checked).
If B<STATUSCONFIG> is true, all BuildFiles are marked to be read. 

=cut

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

=item   C<paths()>

Return a reference to an array of directories for the current source tree.

=cut

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|\Q$ENV{LOCALTOP}\E/$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};
   }

=item   C<verbose()>

Turn verbosity for the cache on or off.

=cut

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

=item   C<cachestatus()>

Set or return the cache status to indicate whether or not a file
timestamp has changed since the last pass.

=cut

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

=item   C<logmsg(@message)>

Print a message to B<STDERR>. This is only used in
checktree(), checkfiles() and paths().

=cut

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

=item   C<name()>

Set or return the name of the cache. Normally set
to B<DirCache.db> (and not architecture dependent).

=cut

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

1;

=back

=head1 AUTHOR

Shaun Ashby (with contribution from Lassi Tuura)

=head1 MAINTAINER

Shaun Ashby
   
=cut

Revision:	1.7
Committed:	Mon Sep 11 13:48:33 2006 UTC (18 years, 7 months ago) by sashby
Content type:	text/plain
Branch:	MAIN
CVS Tags:	V1_0_3-p4, V1_0_3-p3, V1_0_3-p2, before110xmlBRmerge, V1_0_3-p1, V1_0_3
Branch point for:	v103_with_xml
Changes since 1.6:	+3 -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.7	# Revision: $Id: Cache.pm,v 1.6.2.1 2006/06/21 14:46:45 sashby Exp $
9	sashby	1.2	#
10			# Copyright: 2003 (C) Shaun Ashby
11			#
12			#--------------------------------------------------------------------
13	sashby	1.5
14			=head1 NAME
15
16			Cache::Cache - A generic directory cache object.
17
18			=head1 SYNOPSIS
19	sashby	1.6
20			my $cacheobject=Cache::Cache->new();
21	sashby	1.5
22			=head1 DESCRIPTION
23
24			A package to provide caching of directory information. Directory timestamps
25			are tracked on further reading of an existing cache and lists of modified
26			directories and BuildFiles can be obtained.
27
28			=head1 METHODS
29
30			=over
31
32			=cut
33
34	sashby	1.2	package Cache::Cache;
35			require 5.004;
36
37			use Exporter;
38			@ISA=qw(Exporter);
39			#
40	sashby	1.5
41			=item C<new()>
42
43			Create a new Cache::Cache object. The name of the cache is B<DirCache.db> by default.
44
45			=cut
46
47	sashby	1.2	sub new()
48			###############################################################
49			# new #
50			###############################################################
51			# modified : Thu Nov 27 16:45:27 2003 / SFA #
52			# params : #
53			# : #
54			# function : #
55			# : #
56			###############################################################
57			{
58			my $proto=shift;
59			my $class=ref($proto) \|\| $proto;
60			my $self=
61			{
62			CACHENAME => "DirCache.db", # Name of global file/dir cache;
63			BFCACHE => {}, # BuildFile cache;
64			DIRCACHE => {}, # Source code cache;
65			STATUS => 0, # Status of cache: 1 => something changed. If so, force save;
66			VERBOSE => 0 # Verbose mode (0/1);
67			};
68
69			bless $self,$class;
70			return $self;
71			}
72
73	sashby	1.5	=item C<getdir($path)>
74
75	sashby	1.6	Return a list of directories starting from $path.
76	sashby	1.5
77			=cut
78
79	sashby	1.2	sub getdir()
80			{
81			my $self=shift;
82			my ($path) = @_;
83			opendir (DIR, $path) \|\| die "$path: cannot read: $!\n";
84	sashby	1.4	# Skip .admin and CVS subdirectories too.
85	sashby	1.3	# Also skip files that look like backup files or files being modified with emacs:
86			my @items = map { "$path/$_" } grep (
87	sashby	1.4	$_ ne "." && $_ ne ".." && $_ ne "CVS" &&
88	sashby	1.3	$_ ne ".admin" && $_ !~ m\|\.#*\|,
89			readdir(DIR)
90			);
91	sashby	1.2	closedir (DIR);
92			return @items;
93			}
94
95	sashby	1.6	=item C<prune($path)>
96
97			Recursively remove directories from the cache starting at $path.
98
99			=cut
100
101	sashby	1.2	sub prune()
102			{
103			my $self=shift;
104			my ($path) = @_;
105			$self->cachestatus(1);
106			return if ! exists $self->{DIRCACHE}->{$path};
107			my (undef, undef, @subs) = @{$self->{DIRCACHE}->{$path}};
108			delete $self->{DIRCACHE}->{$path};
109			foreach my $sub (@subs)
110			{
111			$self->prune($sub);
112			}
113			}
114
115	sashby	1.6	=item C<checktree($path, $required, $dofiles)>
116
117			A timestamp checking routine. Starting from $path, check all timestamps of
118			directories and their files. Skip all files unless $dofiles is 1.
119
120			=cut
121
122	sashby	1.2	sub checktree()
123			{
124			my ($self, $path, $required, $dofiles) = @_;
125			# Check if this path needs to be checked. If it exists, has the same mode
126			# and the same time stamp, it's up to date and doesn't need to be checked.
127			# Otherwise if it is a directory whose time-stamp has changed, rescan it.
128			# If the path has be removed, prune it from the cache. Note that we skip
129			# non-directories unless $dofiles is set. Considering only directories is
130			# dramatically faster.
131			next if ($path =~ /\.admin/); # skip .admin dirs
132	sashby	1.4	next if ($path =~ /.*CVS/);
133	sashby	1.2
134			# NB: We stat each path only once ever. The special "_" file handle uses
135			# the results from the last stat we've made. See man perlfunc/stat.
136			if (! stat($path))
137			{
138			die "$path: $!\n" if $required;
139			$self->logmsg("SCRAM: $path: missing: removing from cache\n");
140			$self->prune($path);
141			# Something changed so force write of cache:
142			$self->cachestatus(1);
143			return;
144			}
145
146			# If the entry in the cache is not the same mode or time, force an update.
147			# Otherwise use the cache as the list of items we need to change.
148			my $cached = $self->{DIRCACHE}->{$path};
149			my @items = ();
150
151			if (! -d _)
152			{
153			if ($dofiles)
154			{
155			$self->logmsg("SCRAM: $path: updating cache\n");
156			$self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9] ];
157			}
158			else
159			{
160			$self->logmsg("SCRAM: $path: not a directory: removing from parent's list\n");
161			my $parent = $path;
162			$parent =~ s\|(.*)/[^/]+$\|$1\|;
163			if ($parent ne $path && exists $self->{DIRCACHE}->{$parent})
164			{
165			my ($mode, $time, @subs) = @{$self->{DIRCACHE}->{$parent}};
166			$self->{DIRCACHE}->{$parent} = [ $mode, $time, grep ($_ ne $path, @subs) ];
167			}
168			$self->cachestatus(1);
169			}
170			}
171			elsif (! $cached \|\| $cached->[0] != (stat(_))[2])
172			{
173			# When a directory is added, this block is activated
174			$self->added_dirs($path); # Store the newly-added dir
175			$self->logmsg("SCRAM: $path: new or changed: pruning and recreating cache\n");
176			$self->prune($path);
177			$self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9], @items = $self->getdir($path) ];
178			$required = 1;
179			$self->cachestatus(1);
180			}
181			elsif ($cached->[1] != (stat(_))[9])
182			{
183			# When a subdirectory is removed, this block is activated
184			#
185			# This is a parent directory. We store this as any
186			# update can be taken recursively from this dir:
187			$self->modified_parentdirs($path);
188
189			$self->logmsg("SCRAM: $path: modified: updating cache\n");
190			# Current subdirs:
191			@items = $self->getdir($path);
192
193			# Start checking from element number 2:
194			for (my $i = 2; $i <= $#$cached; $i++)
195			{
196			if (! grep($cached->[$i] eq $_, @items))
197			{
198			# Add the removed path to a store for later access
199			# from the project cache. This info is needed to update
200			# the cached data:
201			$self->schedremoval($cached->[$i]);
202			# Remove all child data:
203			$self->clean_cache_recursive($cached->[$i]);
204			}
205			}
206
207			$self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9], @items ];
208			$required = 1;
209			$self->cachestatus(1);
210			}
211			else
212			{
213			$self->logmsg("SCRAM: $path: valid: using cached directory list\n");
214			(undef, undef, @items) = @{$self->{DIRCACHE}->{$path}};
215			$required = 0;
216			}
217
218			# Process sub-directories
219			foreach my $item (@items)
220			{
221			$self->checktree($item, $required, $dofiles);
222			}
223			}
224
225	sashby	1.6	=item C<clean_cache_recursive($startdir)>
226
227			Recursive remove cached data for directories under $startdir.
228
229			=cut
230
231	sashby	1.2	sub clean_cache_recursive()
232			{
233			my $self=shift;
234			my ($startdir) = @_;
235			my $children = $self->{DIRCACHE}->{$startdir};
236
237			for (my $i = 2; $i <= $#$children; $i++)
238			{
239			# Remove all children:
240			$self->schedremoval($children->[$i]);
241			$self->clean_cache_recursive($children->[$i]);
242			}
243
244			delete $self->{DIRCACHE}->{$startdir};
245			return $self;
246			}
247
248	sashby	1.6	=item C<dirtree($dir,$dofiles)>
249
250			Starting from $dir, scan the directory tree. Ignore files unless $dofiles is set. This
251			function just calls checktree().
252
253			=cut
254
255	sashby	1.2	sub dirtree()
256			{
257			my $self=shift;
258			my ($dir,$dofiles) = @_;
259
260			# Get the directory tree:
261			$self->checktree($dir, 1, $dofiles);
262			return $self;
263			}
264
265	sashby	1.6	=item C<checkfiles()>
266
267			Function to actually run the timestamp checks. This is only run from
268			SCRAM::CMD::build().
269
270			=cut
271
272	sashby	1.2	sub checkfiles()
273			{
274			my $self=shift;
275			# Scan config dir for top-level data, then start from src:
276			my @scandirs=($ENV{LOCALTOP}."/".$ENV{SCRAM_CONFIGDIR}, $ENV{SCRAM_SOURCEDIR});
277			my $dofiles=1;
278			# Loop over all directories that need scanning (normally just src and config):
279			foreach my $scand (@scandirs)
280			{
281			$self->logmsg("SCRAM: Scanning $scand [dofiles set to ".$dofiles."]\n");
282			# Check the directory tree:
283			$self->dirtree($scand, $dofiles);
284			$dofiles=0;
285			}
286
287			# Mark everything in the cache old:
288			map { $_->[0] = 0 } values %{$self->{BFCACHE}};
289			map { $_->[0] = 0 } values %{$self->{CONFIGCACHE}};
290
291			# Remember which directories have buildfiles in them:
292			my %files = map { -f $_ ? ($_ => [ (stat(_))[9] ]) : () }
293			map { "$_/BuildFile" }
294			keys %{$self->{DIRCACHE}};
295
296			# Get list of files in config dir:
297			my $configcache = {};
298			my %configfiles = map { -f $_ &&
299	sashby	1.7	$_ =~ m\|\Q$ENV{LOCALTOP}\E/$ENV{SCRAM_CONFIGDIR}.*?$\|
300	sashby	1.2	? ($_ => [ (stat(_))[9] ]) : () } keys %{$self->{DIRCACHE}};
301
302			# Also add ToolCache.db to the cache: FIXME: should probably use aglob here so
303			# that all SCRAM_ARCHs are taken into account.
304			$configfiles{$ENV{LOCALTOP}."/.SCRAM/".$ENV{SCRAM_ARCH}."/ToolCache.db"} =
305			[ (stat($ENV{LOCALTOP}."/.SCRAM/".$ENV{SCRAM_ARCH}."/ToolCache.db"))[9] ];
306
307			# Compare or add to config file cache. We need this to be separate so we can tell if a
308			# file affecting our build has been changed:
309			while (my ($path, $vals) = each %configfiles)
310			{
311			if ($self->{CONFIGCACHE}->{$path} && $self->{CONFIGCACHE}->{$path}[1] == $vals->[0])
312			{
313			$configcache->{$path} = $self->{CONFIGCACHE}->{$path};
314			delete $self->{CONFIGCACHE}->{$path};
315			}
316			else
317			{
318			$self->{STATUSCONFIG}=1;
319			$self->logmsg("SCRAM: $path: changed\n");
320			$configcache->{$path} = [ 1, @$vals ];
321			delete $self->{CONFIGCACHE}->{$path};
322			}
323			}
324
325			# Compare with existing cache: remove from cache what no longer
326			# exists, then check which build files are newer than the cache.
327			my $newcache = {};
328
329			while (my ($path, $vals) = each %files)
330			{
331			if ($self->{BFCACHE}->{$path} && $self->{BFCACHE}->{$path}[1] == $vals->[0])
332			{
333			$newcache->{$path} = $self->{BFCACHE}->{$path};
334			delete $self->{BFCACHE}->{$path};
335			}
336			else
337			{
338			$self->{STATUSSRC}=1;
339			$self->logmsg("SCRAM: $path: changed\n");
340			$newcache->{$path} = [ 1, @$vals ];
341			delete $self->{BFCACHE}->{$path};
342			}
343			}
344
345			# If there were BuildFiles that were removed, force update of cache
346			# and remove the BUILDFILEDATA entries:
347			foreach my $path (keys %{$self->{BFCACHE}})
348			{
349			$self->logmsg("SCRAM: $path: removed. Build data will be removed from build cache.\n");
350			$self->cachestatus(1);
351			# Store this so that later, we can tell the BuildDataStore to remove it:
352			$self->schedremoval($path);
353			}
354
355			# Save the BuildFile cache:
356			delete $self->{BFCACHE};
357			$self->{BFCACHE} = $newcache;
358
359			# Save the config cache:
360			delete $self->{CONFIGCACHE};
361			$self->{CONFIGCACHE} = $configcache;
362			return $self;
363			}
364
365	sashby	1.6	=item C<dircache()>
366
367			Return a reference to the directory cache hash.
368
369			=cut
370
371	sashby	1.2	sub dircache()
372			{
373			my $self=shift;
374			# Return the file cache:
375			return $self->{DIRCACHE};
376			}
377
378	sashby	1.6	=item C<added_dirs($path)>
379
380			Add $path to the list of directories added since last scan, or return
381			the list of added directories if no argument given.
382
383			=cut
384
385	sashby	1.2	sub added_dirs()
386			{
387			my $self=shift;
388			my ($path) = @_;
389
390			# If we have a path to add, add it.
391			if ($path)
392			{
393			if (exists($self->{ADDEDDIRS}))
394			{
395			push(@{$self->{ADDEDDIRS}}, $path);
396			}
397			else
398			{
399			$self->{ADDEDDIRS} = [ $path ];
400			}
401			}
402			else
403			{
404			# Otherwise, return the array of added dirs:
405			my @addeddirs = @{$self->{ADDEDDIRS}};
406			delete $self->{ADDEDDIRS};
407			return \@addeddirs;
408			}
409			}
410
411	sashby	1.6	=item C<modified_parentdirs($path)>
412
413			Add a directory $path to the list of parent directories (directories
414			having subdirectories), or return a reference to the list.
415			Storing this parent allows any update to be taken recursively from this
416			location.
417
418			=cut
419
420	sashby	1.2	sub modified_parentdirs()
421			{
422			my $self=shift;
423			my ($path) = @_;
424
425			# If we have a path to add, add it.
426			# Don't bother if it's the main source dir as we don't
427			# want to rescan everything from src (that would be silly):
428			if ($path && $path ne $ENV{SCRAM_SOURCEDIR})
429			{
430			if (exists($self->{MODPARENTDIRS}))
431			{
432			push(@{$self->{MODPARENTDIRS}}, $path);
433			}
434			else
435			{
436			$self->{MODPARENTDIRS} = [ $path ];
437			}
438			}
439			else
440			{
441			# Otherwise, return the array of added dirs:
442			my @moddeddirs = @{$self->{MODPARENTDIRS}};
443			delete $self->{MODPARENTDIRS};
444			return \@moddeddirs;
445			}
446			}
447
448	sashby	1.6	=item C<schedremoval($d)>
449
450			Add directory $d to list of directories that should be removed
451			recursively from the cache.
452			If no arguments given, return a reference to a list of
453			directories to be removed.
454
455			=cut
456
457	sashby	1.2	sub schedremoval()
458			{
459			my $self=shift;
460			my ($d)=@_;
461
462			if ($d)
463			{
464			if (exists($self->{REMOVEDATA}))
465			{
466			push(@{$self->{REMOVEDATA}},$d);
467			}
468			else
469			{
470			$self->{REMOVEDATA} = [ $d ];
471			}
472			}
473			else
474			{
475			my $remove = [ @{$self->{REMOVEDATA}} ];
476			$self->{REMOVEDATA} = [];
477			return $remove;
478			}
479			}
480
481	sashby	1.6	=item C<filestatus()>
482
483			Return a true or false value depending on whether
484			a BuildFile was changed or not.
485
486			=cut
487
488	sashby	1.2	sub filestatus()
489			{
490			my $self=shift;
491			# Here we want to return a true or false value depending on whether
492			# or not a buildfile was changed:
493			return $self->{STATUSSRC};
494			}
495
496	sashby	1.6	=item C<configstatus()>
497
498			Return a true or false value depending on whether
499			a file in the config directory was changed or not.
500
501			=cut
502
503	sashby	1.2	sub configstatus()
504			{
505			my $self=shift;
506			# Here we want to return a true or false value depending on whether or not a file
507			# in config dir was changed:
508			return $self->{STATUSCONFIG};
509			}
510
511	sashby	1.6	=item C<bf_for_scanning()>
512
513			Return a list of BuildFiles to re-read. Note that this is only done
514			if the status was changed (i.e. not necessary to read through the list
515			of BuildFiles to know whether something changed as the flag B<STATUSSRC>
516			is set as the source tree is checked).
517			If B<STATUSCONFIG> is true, all BuildFiles are marked to be read.
518
519			=cut
520
521	sashby	1.2	sub bf_for_scanning()
522			{
523			my $self=shift;
524			my $MODIFIED = [];
525
526			$self->{STATUSSRC} = 0;
527
528			# Return a list of buildfiles to be reread. Note that we only do this
529			# if the status was changed (i.e. don't have to read through the list of BFs to know
530			# whether something changed as the flags STATUSSRC is set as the src tree is checked).
531			# Also we check to see if STATUSCONFIG is true. If so all BuildFiles are marked to be read:
532			if ($self->{STATUSCONFIG})
533			{
534			$self->{STATUSCONFIG} = 0;
535			# Return all the buildfiles since they'll all to be read:
536			return [ keys %{$self->{BFCACHE}} ];
537			}
538			else
539			{
540			# Only return the files that changed:
541			map { ( $self->{BFCACHE}{$_}->[0] == 1 ) && push(@$MODIFIED, $_) } keys %{$self->{BFCACHE}};
542			# Reset the flag:
543			$self->{STATUSCONFIG} = 0;
544			}
545			return $MODIFIED;
546			}
547
548	sashby	1.6	=item C<paths()>
549
550			Return a reference to an array of directories for the current source tree.
551
552			=cut
553
554	sashby	1.2	sub paths()
555			{
556			my $self=shift;
557			my $paths = {};
558
559			$self->{ALLDIRS} = [];
560
561			# Pass over each dir, skipping those that are not wanted and
562			# storing those that are relevant to an array:
563			foreach my $path (keys %{$self->{DIRCACHE}})
564			{
565	sashby	1.7	if ( ! -d $path && $path != m\|\Q$ENV{LOCALTOP}\E/$ENV{SCRAM_CONFIGDIR}.*?$\|)
566	sashby	1.2	{
567			$self->logmsg("SCRAM: $path no longer exists. Clearing from cache.\n");
568			$self->cachestatus(1);
569			delete $self->{DIRCACHE}->{$path};
570			}
571			else
572			{
573			next if $path =~ m\|/CVS$\|; # Ignore CVS directories.
574			next if $path =~ m\|/\.admin$\|; # Ignore .admin directories.
575			next if $path =~ m\|\Q$ENV{LOCALTOP}/$ENV{SCRAM_CONFIGDIR}\L\|;
576			push(@{$self->{ALLDIRS}},$path);
577			}
578			}
579
580			# Return the array:
581			return $self->{ALLDIRS};
582			}
583
584	sashby	1.6	=item C<verbose()>
585
586			Turn verbosity for the cache on or off.
587
588			=cut
589
590	sashby	1.2	sub verbose()
591			{
592			my $self=shift;
593			# Turn on verbose mode:
594			@_ ? $self->{VERBOSE} = shift
595			: $self->{VERBOSE}
596			}
597
598	sashby	1.6	=item C<cachestatus()>
599
600			Set or return the cache status to indicate whether or not a file
601			timestamp has changed since the last pass.
602
603			=cut
604
605	sashby	1.2	sub cachestatus()
606			{
607			my $self=shift;
608			# Set/return the status of the cache:
609			@_ ? $self->{STATUS} = shift
610			: $self->{STATUS}
611			}
612
613	sashby	1.6	=item C<logmsg(@message)>
614
615			Print a message to B<STDERR>. This is only used in
616			checktree(), checkfiles() and paths().
617
618			=cut
619
620	sashby	1.2	sub logmsg()
621			{
622			my $self=shift;
623			# Print a message to STDOUT if VERBOSE is true:
624			print STDERR @_ if $self->verbose();
625			}
626
627	sashby	1.6	=item C<name()>
628
629			Set or return the name of the cache. Normally set
630			to B<DirCache.db> (and not architecture dependent).
631
632			=cut
633
634	sashby	1.2	sub name()
635			{
636			my $self=shift;
637			# Set/return the name of the cache to use:
638			@_ ? $self->{CACHENAME} = shift
639			: $self->{CACHENAME}
640			}
641
642			1;
643	sashby	1.5
644			=back
645
646			=head1 AUTHOR
647
648			Shaun Ashby (with contribution from Lassi Tuura)
649
650			=head1 MAINTAINER
651
652			Shaun Ashby
653
654			=cut
655