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.1.2.2 2004/03/09 19:45:57 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 => "ProjectCache.db", # Name of global project cache;
      BFCACHE => {},                  # BuildFile cache;
      DIRCACHE => {},                 # Source code cache;
      TOPLEVELDATA => {},             # Data for top-level BuildFile only;
      BUILDFILEDATA => {},            # Path/data pairs;
      ALLDIRS => [],                  # All directories (except CVS dirs);
      STATUS => 0,                    # Status of cache: 1 => something changed. If so, force save;
      VERBOSE => 0                    # Verbose mode (0/1);
      };
              
   bless $self,$class;
   return $self;
   }


#### The methods ####
sub store_data
   {
   my $self=shift;
   my ($path, $data)=@_;

   # See if this BuildFile is under config directory. If it is, it's
   # the top-level (master) so store it separate to the others:
   if ($path =~ /(.*)?\Q$ENV{SCRAM_CONFIGDIR}\L/)
      {
      $self->{TOPLEVELDATA}->{$path} = $data;
      }
   else
      {
      # Store the content of this BuildFile in cache:
      $self->{BUILDFILEDATA}->{$path} = $data;
      }
   
   return $self;
   }

sub remove_data
   {
   my $self=shift;
   my ($datapath)=@_;
   
   if ($datapath =~ /(.*)?\Q$ENV{SCRAM_CONFIGDIR}\L/)
      {
      # This will probably never happen:
      delete $self->{TOPLEVELDATA}->{$datapath};
      }
   else
      {
      # Delete main entry in build data, then delete child entries:
      delete $self->{BUILDFILEDATA}->{$datapath};
      }
   
   return $self;
   }

sub getdir
   {
   my $self=shift;
   my ($path) = @_;
   opendir (DIR, $path) || die "$path: cannot read: $!\n";
   my @items = map { "$path/$_" } grep ($_ ne "." && $_ ne "..", 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.
   
   # 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])
      {
      $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])
      {
      $self->logmsg("SCRAM: $path: modified: updating cache\n");
      $self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9], @items = $self->getdir($path) ];
      $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 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:
   $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}})
      {
      my $datapath;
      $self->logmsg("SCRAM: $path: removed. Removing build data from cache.\n");
      $self->cachestatus(1);      
      ($datapath = $path) =~ s|^\Q$ENV{SCRAM_SOURCEDIR}\L/||;
      $datapath =~ s|(.*)/BuildFile$|$1|g;
      # Remove the buildfile data:
      $self->remove_data($datapath);
      }
   
   # Save the BuildFile cache:
   delete $self->{BFCACHE};
   $self->{BFCACHE} = $newcache;

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

sub buildclass
   {
   my $self=shift;
   my ($path,$cache)=@_;
   # Associate a path with ClassPath setting (FIXME: belongs elsewhere!).
   # For now, just assumes global data has been scanned and class settings
   # are already known (in $self->{TOPLEVELDATA}->{config/BuildFile}->classpath()).
   
   # Generate more optimal classpath data structure, only once.
   # Split every cache definition into an array of pairs, directory
   # name and class.  So ClassPath of type "+foo/+bar/src+library"
   # becomes [ [ "" "foo" ] [ "" "bar" ] [ "src" "library" ] ]
   if (! scalar @$cache)
      {
      foreach my $classpath (@{$self->{TOPLEVELDATA}->{"$ENV{LOCALTOP}/$ENV{SCRAM_CONFIGDIR}"}->classpath()})
         {
         push (@$cache, [map { [ split(/\+/, $_) ] } split(/\//, $classpath)]);
         }
      }
   
   print "WARNING: No ClassPath definitions, nothing will be done!\n"
      if (! scalar @$cache);
   
   # Now scan the class paths.  All the classpaths are given a rank
   # to mark how relevant they are, and then the best match is chosen.
   #
   # The ranking logic is as follows.  We scan each class path and
   # drop if it doesn't match at all.  For paths that match, we
   # record how many components of the class was *not* used to match
   # on the class: for a short $path, many classes will match.
   # For each path component we record whether the match was exact
   # (if the class part is empty, i.e. "", it's a wildcard that
   # matches everything).  Given these rankings, we pick
   #   - the *first* class that
   #   - has least *unmatched* components
   #   - with *first* or *longest* exact match sequence in
   #     left-to-right order.
   my @ranks = ();
   my @dirs = split(/\/+/, $path);
   CLASS: foreach my $class (@$cache)
      {
      # The first two members of $rank are fixed: how much of path
      # was and was not used in the match.
      my $rank = [[], [@dirs]];
      foreach my $component (@$class)
         {
         my $dir = $rank->[1][0];
         if (! defined $dir)
            {
            # Path exhausted.  Leave used/unused as is.
            last;
            }
         elsif ($component->[0] eq "")
            {
            # Wildcard match, push class and use up path
            push(@$rank, [1, $component->[1]]);
            push(@{$rank->[0]}, shift(@{$rank->[1]}));
            }
         elsif ($component->[0] eq $dir)
            {
            # Exact match, push class and use up path
            push(@$rank, [0, $component->[1]]);
            push(@{$rank->[0]}, shift(@{$rank->[1]}));
            }
         else
            {
            # Unmatched, leave used/unused as is.
            last;
            }
         }

      push(@ranks, $rank);
      }

   # If no classes match, bail out
   if (! scalar @ranks)
      {
      return "";
      }
   
   # Sort in ascending order by how much was of class was not used;
   # the first entry has least "extra" trailing match data.  Then
   # truncate to only those equal to the best rank.
   my @sorted = sort { scalar(@{$a->[1]}) <=> scalar(@{$b->[1]}) } @ranks;
   my @best = grep(scalar(@{$_->[1]}) == scalar(@{$sorted[0][1]}), @sorted);

   # Now figure which of the best-ranking lasses have the longest
   # exact match in left-to-right order (= which one is first, and
   # those with equal first exact match, longest exact match).
   my $n = 0;

   my $class = $best[$n][scalar @{$best[$n]}-1];
   my $result = [ $best[$n][0], $best[$n][1], $class ];
   return $result;
   }

sub buildpaths
   {
   my $self=shift;
   # Classify each directory in the dircache according to the classpath
   # settings (FIXME: classpath handling is not really in the scope of
   # a mere cache!), and return a list of directories and what to do in
   # them.  Note that most of the directories won't have a buildfile!
   # Use builddata() to retrieve more detailed build information for
   # each returned directory.

   my $paths = {};
   my $cache = [];
   $self->{ALLDIRS} = [];
   
   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|\Q$ENV{SCRAM_CONFIGDIR}\L|;
         # Store entries in a location easily accessed from
         # template-generating step:
         push(@{$self->{ALLDIRS}},$path);
         $paths->{$path} = $self->buildclass($path, $cache);
         }
      }
   
   return $paths;
   }

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 read
   {
   my $self=shift;
   my @MODIFIED;
   $self->{STATUSSRC} = 0;
   # Return a list of modified 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 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 buildobject
   {
   my $self=shift;
   my ($path)=@_;
   my $buildobject;
   
   # See if this path looks like it points to the
   # config area. If so return the TOPLEVEL data:
   if ($path =~ m|.*?/\Q$ENV{SCRAM_CONFIGDIR}\L|)
      {
      $buildobject = $self->{TOPLEVELDATA}->{$path};
      }
   else
      {
      $buildobject=$self->{BUILDFILEDATA}->{$path};
      }
   
   # return the BuildFile object:
   return $buildobject;
   }

sub addgroup
   {
   my $self=shift;
   my ($grouparray,$path)=@_;
   
   foreach my $group (@{$grouparray})
      {
      # Only give a warning if the group is defined already in a
      # BuildFile other than the one at $path (avoids errors because KNOWNGROUPS
      # is not reset before re-parsing a BuildFile in which a group is defined):
      if (exists $self->{KNOWNGROUPS}->{$group}
          && $self->{KNOWNGROUPS}->{$group} ne $path)
         {
         print "WARNING: Group \"",$group,"\" already defined in ",
         $self->{KNOWNGROUPS}->{$group}."/BuildFile","","\n";
         exit(0); # For now, we exit.
         }
      else
         {
         $self->{KNOWNGROUPS}->{$group} = $path;
         }
      }
   }

sub findgroup
   {
   my $self=shift;
   my ($groupname) = @_;

   if (exists $self->{KNOWNGROUPS}->{$groupname})
      {
      return $self->{KNOWNGROUPS}->{$groupname};
      }
   else
      {
      print "WARNING: Group \"",$groupname,"\" not defined in any BuildFile.","\n";
      exit(0); # For now, we exit.
      }
   }

sub knowngroups
   {
   my $self=shift;
   @_ ? $self->{KNOWNGROUPS}=shift
      : $self->{KNOWNGROUPS}
   }

sub alldirs
   {
   my $self=shift;
   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 name of the cache to use:
   @_ ? $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.1.2.3
Committed:	Wed Mar 10 14:38:16 2004 UTC (21 years, 2 months ago) by sashby
Content type:	text/plain
Branch:	SCRAM_V1_BRANCH
CVS Tags:	V1_pre0
Branch point for:	V1_pre1
Changes since 1.1.2.2:	+86 -25 lines
Log Message:	Some changes to cache. Check files in config. Any change triggers reparse of buildfiles and rebuild of makefiles.
#	User	Rev	Content
1	sashby	1.1.2.1	#____________________________________________________________________
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.1.2.3	# Revision: $Id: Cache.pm,v 1.1.2.2 2004/03/09 19:45:57 sashby Exp $
9	sashby	1.1.2.1	#
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 => "ProjectCache.db", # Name of global project cache;
35			BFCACHE => {}, # BuildFile cache;
36			DIRCACHE => {}, # Source code cache;
37			TOPLEVELDATA => {}, # Data for top-level BuildFile only;
38			BUILDFILEDATA => {}, # Path/data pairs;
39			ALLDIRS => [], # All directories (except CVS dirs);
40			STATUS => 0, # Status of cache: 1 => something changed. If so, force save;
41			VERBOSE => 0 # Verbose mode (0/1);
42			};
43
44			bless $self,$class;
45			return $self;
46			}
47
48
49			#### The methods ####
50			sub store_data
51			{
52			my $self=shift;
53			my ($path, $data)=@_;
54
55			# See if this BuildFile is under config directory. If it is, it's
56			# the top-level (master) so store it separate to the others:
57			if ($path =~ /(.*)?\Q$ENV{SCRAM_CONFIGDIR}\L/)
58			{
59			$self->{TOPLEVELDATA}->{$path} = $data;
60			}
61			else
62			{
63			# Store the content of this BuildFile in cache:
64			$self->{BUILDFILEDATA}->{$path} = $data;
65			}
66
67			return $self;
68			}
69
70			sub remove_data
71			{
72			my $self=shift;
73			my ($datapath)=@_;
74
75			if ($datapath =~ /(.*)?\Q$ENV{SCRAM_CONFIGDIR}\L/)
76			{
77			# This will probably never happen:
78			delete $self->{TOPLEVELDATA}->{$datapath};
79			}
80			else
81			{
82			# Delete main entry in build data, then delete child entries:
83			delete $self->{BUILDFILEDATA}->{$datapath};
84			}
85
86			return $self;
87			}
88
89			sub getdir
90			{
91			my $self=shift;
92			my ($path) = @_;
93			opendir (DIR, $path) \|\| die "$path: cannot read: $!\n";
94			my @items = map { "$path/$_" } grep ($_ ne "." && $_ ne "..", readdir(DIR));
95			closedir (DIR);
96			return @items;
97			}
98
99			sub prune
100			{
101			my $self=shift;
102			my ($path) = @_;
103			$self->cachestatus(1);
104			return if ! exists $self->{DIRCACHE}->{$path};
105			my (undef, undef, @subs) = @{$self->{DIRCACHE}->{$path}};
106			delete $self->{DIRCACHE}->{$path};
107			foreach my $sub (@subs)
108			{
109			$self->prune($sub);
110			}
111			}
112
113			sub checktree
114			{
115			my ($self, $path, $required, $dofiles) = @_;
116			# Check if this path needs to be checked. If it exists, has the same mode
117			# and the same time stamp, it's up to date and doesn't need to be checked.
118			# Otherwise if it is a directory whose time-stamp has changed, rescan it.
119			# If the path has be removed, prune it from the cache. Note that we skip
120			# non-directories unless $dofiles is set. Considering only directories is
121			# dramatically faster.
122
123			# NB: We stat each path only once ever. The special "_" file handle uses
124			# the results from the last stat we've made. See man perlfunc/stat.
125			if (! stat($path))
126			{
127			die "$path: $!\n" if $required;
128			$self->logmsg("SCRAM: $path: missing: removing from cache\n");
129			$self->prune($path);
130			# Something changed so force write of cache:
131			$self->cachestatus(1);
132			return;
133			}
134
135			# If the entry in the cache is not the same mode or time, force an update.
136			# Otherwise use the cache as the list of items we need to change.
137			my $cached = $self->{DIRCACHE}->{$path};
138			my @items = ();
139	sashby	1.1.2.3
140	sashby	1.1.2.1	if (! -d _)
141			{
142			if ($dofiles)
143			{
144			$self->logmsg("SCRAM: $path: updating cache\n");
145			$self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9] ];
146			}
147			else
148			{
149			$self->logmsg("SCRAM: $path: not a directory: removing from parent's list\n");
150			my $parent = $path;
151			$parent =~ s\|(.*)/[^/]+$\|$1\|;
152			if ($parent ne $path && exists $self->{DIRCACHE}->{$parent})
153			{
154			my ($mode, $time, @subs) = @{$self->{DIRCACHE}->{$parent}};
155			$self->{DIRCACHE}->{$parent} = [ $mode, $time, grep ($_ ne $path, @subs) ];
156			}
157			$self->cachestatus(1);
158			}
159			}
160			elsif (! $cached \|\| $cached->[0] != (stat(_))[2])
161			{
162			$self->logmsg("SCRAM: $path: new or changed: pruning and recreating cache\n");
163			$self->prune($path);
164			$self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9], @items = $self->getdir($path) ];
165			$required = 1;
166			$self->cachestatus(1);
167			}
168			elsif ($cached->[1] != (stat(_))[9])
169			{
170			$self->logmsg("SCRAM: $path: modified: updating cache\n");
171			$self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9], @items = $self->getdir($path) ];
172			$required = 1;
173			$self->cachestatus(1);
174			}
175			else
176			{
177			$self->logmsg("SCRAM: $path: valid: using cached directory list\n");
178			(undef, undef, @items) = @{$self->{DIRCACHE}->{$path}};
179			$required = 0;
180			}
181
182			# Process sub-directories
183			foreach my $item (@items)
184			{
185			$self->checktree($item, $required, $dofiles);
186			}
187			}
188
189			sub dirtree
190			{
191			my $self=shift;
192	sashby	1.1.2.3	my ($dir,$dofiles) = @_;
193	sashby	1.1.2.1
194			# Get the directory tree:
195	sashby	1.1.2.3	$self->checktree($dir, 1, $dofiles);
196	sashby	1.1.2.1	return $self;
197			}
198
199	sashby	1.1.2.3	sub checkfiles
200	sashby	1.1.2.1	{
201			my $self=shift;
202	sashby	1.1.2.3	# Scan config dir for top-level data, then start from src:
203			my @scandirs=($ENV{LOCALTOP}."/".$ENV{SCRAM_CONFIGDIR}, $ENV{SCRAM_SOURCEDIR});
204			my $dofiles=1;
205	sashby	1.1.2.1	# Loop over all directories that need scanning (normally just src and config):
206			foreach my $scand (@scandirs)
207			{
208	sashby	1.1.2.3	$self->logmsg("SCRAM: Scanning $scand [dofiles set to ".$dofiles."]\n");
209	sashby	1.1.2.1	# Check the directory tree:
210	sashby	1.1.2.3	$self->dirtree($scand, $dofiles);
211			$dofiles=0;
212	sashby	1.1.2.1	}
213
214	sashby	1.1.2.3	# Mark everything in the cache old:
215	sashby	1.1.2.1	map { $_->[0] = 0 } values %{$self->{BFCACHE}};
216	sashby	1.1.2.3	map { $_->[0] = 0 } values %{$self->{CONFIGCACHE}};
217	sashby	1.1.2.1
218	sashby	1.1.2.3	# Remember which directories have buildfiles in them:
219	sashby	1.1.2.1	my %files = map { -f $_ ? ($_ => [ (stat(_))[9] ]) : () }
220			map { "$_/BuildFile" }
221			keys %{$self->{DIRCACHE}};
222
223	sashby	1.1.2.3	# Get list of files in config dir:
224			my $configcache = {};
225			my %configfiles = map { -f $_ &&
226			$_ =~ m\|$ENV{LOCALTOP}/$ENV{SCRAM_CONFIGDIR}.*?$\|
227			? ($_ => [ (stat(_))[9] ]) : () } keys %{$self->{DIRCACHE}};
228
229			# Also add ToolCache.db to the cache:
230			$configfiles{$ENV{LOCALTOP}."/.SCRAM/".$ENV{SCRAM_ARCH}."/ToolCache.db"} =
231			[ (stat($ENV{LOCALTOP}."/.SCRAM/".$ENV{SCRAM_ARCH}."/ToolCache.db"))[9] ];
232
233			# Compare or add to config file cache. We need this to be separate so we can tell if a
234			# file affecting our build has been changed:
235			while (my ($path, $vals) = each %configfiles)
236			{
237			if ($self->{CONFIGCACHE}->{$path} && $self->{CONFIGCACHE}->{$path}[1] == $vals->[0])
238			{
239			$configcache->{$path} = $self->{CONFIGCACHE}->{$path};
240			delete $self->{CONFIGCACHE}->{$path};
241			}
242			else
243			{
244			$self->{STATUSCONFIG}=1;
245			$self->logmsg("SCRAM: $path: changed\n");
246			$configcache->{$path} = [ 1, @$vals ];
247			delete $self->{CONFIGCACHE}->{$path};
248			}
249			}
250
251	sashby	1.1.2.1	# Compare with existing cache: remove from cache what no longer
252			# exists, then check which build files are newer than the cache.
253			my $newcache = {};
254
255			while (my ($path, $vals) = each %files)
256			{
257			if ($self->{BFCACHE}->{$path} && $self->{BFCACHE}->{$path}[1] == $vals->[0])
258			{
259			$newcache->{$path} = $self->{BFCACHE}->{$path};
260			delete $self->{BFCACHE}->{$path};
261			}
262			else
263			{
264	sashby	1.1.2.3	$self->{STATUSSRC}=1;
265	sashby	1.1.2.1	$self->logmsg("SCRAM: $path: changed\n");
266			$newcache->{$path} = [ 1, @$vals ];
267			delete $self->{BFCACHE}->{$path};
268			}
269			}
270
271			# If there were BuildFiles that were removed, force update of cache
272			# and remove the BUILDFILEDATA entries:
273			foreach my $path (keys %{$self->{BFCACHE}})
274			{
275			my $datapath;
276			$self->logmsg("SCRAM: $path: removed. Removing build data from cache.\n");
277			$self->cachestatus(1);
278			($datapath = $path) =~ s\|^\Q$ENV{SCRAM_SOURCEDIR}\L/\|\|;
279			$datapath =~ s\|(.*)/BuildFile$\|$1\|g;
280			# Remove the buildfile data:
281			$self->remove_data($datapath);
282			}
283
284			# Save the BuildFile cache:
285			delete $self->{BFCACHE};
286			$self->{BFCACHE} = $newcache;
287
288	sashby	1.1.2.3	# Save the config cache:
289			delete $self->{CONFIGCACHE};
290			$self->{CONFIGCACHE} = $configcache;
291
292	sashby	1.1.2.1	return $self;
293			}
294
295			sub buildclass
296			{
297			my $self=shift;
298			my ($path,$cache)=@_;
299			# Associate a path with ClassPath setting (FIXME: belongs elsewhere!).
300			# For now, just assumes global data has been scanned and class settings
301			# are already known (in $self->{TOPLEVELDATA}->{config/BuildFile}->classpath()).
302
303			# Generate more optimal classpath data structure, only once.
304			# Split every cache definition into an array of pairs, directory
305			# name and class. So ClassPath of type "+foo/+bar/src+library"
306			# becomes [ [ "" "foo" ] [ "" "bar" ] [ "src" "library" ] ]
307			if (! scalar @$cache)
308			{
309			foreach my $classpath (@{$self->{TOPLEVELDATA}->{"$ENV{LOCALTOP}/$ENV{SCRAM_CONFIGDIR}"}->classpath()})
310			{
311			push (@$cache, [map { [ split(/\+/, $_) ] } split(/\//, $classpath)]);
312			}
313			}
314
315			print "WARNING: No ClassPath definitions, nothing will be done!\n"
316			if (! scalar @$cache);
317
318			# Now scan the class paths. All the classpaths are given a rank
319			# to mark how relevant they are, and then the best match is chosen.
320			#
321			# The ranking logic is as follows. We scan each class path and
322			# drop if it doesn't match at all. For paths that match, we
323			# record how many components of the class was not used to match
324			# on the class: for a short $path, many classes will match.
325			# For each path component we record whether the match was exact
326			# (if the class part is empty, i.e. "", it's a wildcard that
327			# matches everything). Given these rankings, we pick
328			# - the first class that
329			# - has least unmatched components
330			# - with first or longest exact match sequence in
331			# left-to-right order.
332			my @ranks = ();
333			my @dirs = split(/\/+/, $path);
334			CLASS: foreach my $class (@$cache)
335			{
336			# The first two members of $rank are fixed: how much of path
337			# was and was not used in the match.
338			my $rank = [[], [@dirs]];
339			foreach my $component (@$class)
340			{
341			my $dir = $rank->[1][0];
342			if (! defined $dir)
343			{
344			# Path exhausted. Leave used/unused as is.
345			last;
346			}
347			elsif ($component->[0] eq "")
348			{
349			# Wildcard match, push class and use up path
350			push(@$rank, [1, $component->[1]]);
351			push(@{$rank->[0]}, shift(@{$rank->[1]}));
352			}
353			elsif ($component->[0] eq $dir)
354			{
355			# Exact match, push class and use up path
356			push(@$rank, [0, $component->[1]]);
357			push(@{$rank->[0]}, shift(@{$rank->[1]}));
358			}
359			else
360			{
361			# Unmatched, leave used/unused as is.
362			last;
363			}
364			}
365
366			push(@ranks, $rank);
367			}
368
369			# If no classes match, bail out
370			if (! scalar @ranks)
371			{
372			return "";
373			}
374
375			# Sort in ascending order by how much was of class was not used;
376			# the first entry has least "extra" trailing match data. Then
377			# truncate to only those equal to the best rank.
378			my @sorted = sort { scalar(@{$a->[1]}) <=> scalar(@{$b->[1]}) } @ranks;
379			my @best = grep(scalar(@{$_->[1]}) == scalar(@{$sorted[0][1]}), @sorted);
380
381			# Now figure which of the best-ranking lasses have the longest
382			# exact match in left-to-right order (= which one is first, and
383			# those with equal first exact match, longest exact match).
384			my $n = 0;
385
386			my $class = $best[$n][scalar @{$best[$n]}-1];
387			my $result = [ $best[$n][0], $best[$n][1], $class ];
388			return $result;
389			}
390
391			sub buildpaths
392			{
393			my $self=shift;
394			# Classify each directory in the dircache according to the classpath
395			# settings (FIXME: classpath handling is not really in the scope of
396			# a mere cache!), and return a list of directories and what to do in
397			# them. Note that most of the directories won't have a buildfile!
398			# Use builddata() to retrieve more detailed build information for
399			# each returned directory.
400
401			my $paths = {};
402			my $cache = [];
403			$self->{ALLDIRS} = [];
404
405			foreach my $path (keys %{$self->{DIRCACHE}})
406			{
407	sashby	1.1.2.3	if ( ! -d $path && $path != m\|$ENV{LOCALTOP}/$ENV{SCRAM_CONFIGDIR}.*?$\|)
408			{
409	sashby	1.1.2.1	$self->logmsg("SCRAM: $path no longer exists. Clearing from cache.\n");
410			$self->cachestatus(1);
411			delete $self->{DIRCACHE}->{$path};
412			}
413			else
414			{
415			next if $path =~ m\|/CVS$\|; # Ignore CVS directories.
416			next if $path =~ m\|\Q$ENV{SCRAM_CONFIGDIR}\L\|;
417			# Store entries in a location easily accessed from
418			# template-generating step:
419			push(@{$self->{ALLDIRS}},$path);
420	sashby	1.1.2.3	$paths->{$path} = $self->buildclass($path, $cache);
421	sashby	1.1.2.1	}
422			}
423
424			return $paths;
425			}
426
427	sashby	1.1.2.3	sub filestatus
428	sashby	1.1.2.1	{
429			my $self=shift;
430	sashby	1.1.2.3	# Here we want to return a true or false value depending on whether
431			# or not a buildfile was changed:
432			return $self->{STATUSSRC};
433			}
434
435			sub configstatus
436			{
437			my $self=shift;
438			# Here we want to return a true or false value depending on whether or not a file
439			# in config dir was changed:
440			return $self->{STATUSCONFIG};
441			}
442	sashby	1.1.2.1
443	sashby	1.1.2.3	sub read
444			{
445			my $self=shift;
446			my @MODIFIED;
447			$self->{STATUSSRC} = 0;
448			# Return a list of modified buildfiles to be reread. Note that we only do this
449			# if the status was changed (i.e. don't have to read through the list of BFs to know
450			# whether something changed as the flags STATUSSRC is set as the src tree is checked).
451			# Also we check to see if STATUSCONFIG is true. If so all BuildFiles are marked to be read:
452			if ($self->{STATUSCONFIG})
453			{
454			$self->{STATUSCONFIG} = 0;
455			# Return all the buildfiles since they'll all be read:
456			return @{[ keys %{$self->{BFCACHE}} ]};
457			}
458			else
459			{
460			# Only return the files that changed:
461			map { ( $self->{BFCACHE}{$_}->[0] == 1 ) && push(@MODIFIED, $_) } keys %{$self->{BFCACHE}};
462			# Reset the flag:
463			$self->{STATUSCONFIG} = 0;
464			}
465			return @MODIFIED;
466	sashby	1.1.2.1	}
467
468			sub buildobject
469			{
470			my $self=shift;
471			my ($path)=@_;
472			my $buildobject;
473
474			# See if this path looks like it points to the
475			# config area. If so return the TOPLEVEL data:
476			if ($path =~ m\|.*?/\Q$ENV{SCRAM_CONFIGDIR}\L\|)
477			{
478			$buildobject = $self->{TOPLEVELDATA}->{$path};
479			}
480			else
481			{
482			$buildobject=$self->{BUILDFILEDATA}->{$path};
483			}
484
485			# return the BuildFile object:
486			return $buildobject;
487			}
488
489			sub addgroup
490			{
491			my $self=shift;
492			my ($grouparray,$path)=@_;
493
494			foreach my $group (@{$grouparray})
495			{
496			# Only give a warning if the group is defined already in a
497			# BuildFile other than the one at $path (avoids errors because KNOWNGROUPS
498			# is not reset before re-parsing a BuildFile in which a group is defined):
499			if (exists $self->{KNOWNGROUPS}->{$group}
500			&& $self->{KNOWNGROUPS}->{$group} ne $path)
501			{
502			print "WARNING: Group \"",$group,"\" already defined in ",
503			$self->{KNOWNGROUPS}->{$group}."/BuildFile","","\n";
504			exit(0); # For now, we exit.
505			}
506			else
507			{
508			$self->{KNOWNGROUPS}->{$group} = $path;
509			}
510			}
511			}
512
513			sub findgroup
514			{
515			my $self=shift;
516			my ($groupname) = @_;
517	sashby	1.1.2.2
518	sashby	1.1.2.1	if (exists $self->{KNOWNGROUPS}->{$groupname})
519			{
520			return $self->{KNOWNGROUPS}->{$groupname};
521			}
522			else
523			{
524			print "WARNING: Group \"",$groupname,"\" not defined in any BuildFile.","\n";
525			exit(0); # For now, we exit.
526			}
527			}
528
529			sub knowngroups
530			{
531			my $self=shift;
532			@_ ? $self->{KNOWNGROUPS}=shift
533			: $self->{KNOWNGROUPS}
534			}
535
536			sub alldirs
537			{
538			my $self=shift;
539			return @{$self->{ALLDIRS}};
540			}
541
542			sub verbose
543			{
544			my $self=shift;
545			# Turn on verbose mode:
546			@_ ? $self->{VERBOSE} = shift
547			: $self->{VERBOSE}
548			}
549
550			sub cachestatus()
551			{
552			my $self=shift;
553			# Set/return the name of the cache to use:
554			@_ ? $self->{STATUS} = shift
555			: $self->{STATUS}
556			}
557
558			sub logmsg
559			{
560			my $self=shift;
561			# Print a message to STDOUT if VERBOSE is true:
562			print STDERR @_ if $self->verbose();
563			}
564
565			sub name()
566			{
567			my $self=shift;
568			# Set/return the name of the cache to use:
569			@_ ? $self->{CACHENAME} = shift
570			: $self->{CACHENAME}
571			}
572
573			1;