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.5 2004/02/16 13:24:32 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] ];
         $self->cachestatus(1);
         }
      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) = @_;

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

sub checkbuildfiles
   {
   my $self=shift;
   my (@scandirs)=@_;

   # Loop over all directories that need scanning (normally just src and config):
   foreach my $scand (@scandirs)
      {
      $self->logmsg("SCRAM: Scanning $scand\n");
      # Check the directory tree:
      $self->dirtree($scand);
      }
   
   # Mark everything in the cache old
   map { $_->[0] = 0 } values %{$self->{BFCACHE}};

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

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

   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;

   # FIXME: class path association has to depend on cache time stamp
   # so this calculation is remade again when the cache changes (and
   # thus class paths have changed).  Note that the makefile generation
   # will also have to depend on the time stamps of all the templates
   # involved.
   }

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)
         {
         $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 modified
   {
   my $self=shift;
   my (@modified);
   map { ( $self->{BFCACHE}{$_}->[0] == 1 ) &&  push(@modified, $_) } keys %{$self->{BFCACHE}};

   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.1
Committed:	Fri Feb 27 16:08:16 2004 UTC (21 years, 2 months ago) by sashby
Content type:	text/plain
Branch:	SCRAM_V1_BRANCH
Changes since 1.1:	+512 -0 lines
Log Message:	* empty log message *
#	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			# Revision: $Id: Cache.pm,v 1.5 2004/02/16 13:24:32 sashby Exp $
9			#
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
140			if (! -d _)
141			{
142			if ($dofiles)
143			{
144			$self->logmsg("SCRAM: $path: updating cache\n");
145			$self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9] ];
146			$self->cachestatus(1);
147			}
148			else
149			{
150			$self->logmsg("SCRAM: $path: not a directory: removing from parent's list\n");
151			my $parent = $path;
152			$parent =~ s\|(.*)/[^/]+$\|$1\|;
153			if ($parent ne $path && exists $self->{DIRCACHE}->{$parent})
154			{
155			my ($mode, $time, @subs) = @{$self->{DIRCACHE}->{$parent}};
156			$self->{DIRCACHE}->{$parent} = [ $mode, $time, grep ($_ ne $path, @subs) ];
157			}
158			$self->cachestatus(1);
159			}
160			}
161			elsif (! $cached \|\| $cached->[0] != (stat(_))[2])
162			{
163			$self->logmsg("SCRAM: $path: new or changed: pruning and recreating cache\n");
164			$self->prune($path);
165			$self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9], @items = $self->getdir($path) ];
166			$required = 1;
167			$self->cachestatus(1);
168			}
169			elsif ($cached->[1] != (stat(_))[9])
170			{
171			$self->logmsg("SCRAM: $path: modified: updating cache\n");
172			$self->{DIRCACHE}->{$path} = [ (stat(_))[2, 9], @items = $self->getdir($path) ];
173			$required = 1;
174			$self->cachestatus(1);
175			}
176			else
177			{
178			$self->logmsg("SCRAM: $path: valid: using cached directory list\n");
179			(undef, undef, @items) = @{$self->{DIRCACHE}->{$path}};
180			$required = 0;
181			}
182
183			# Process sub-directories
184			foreach my $item (@items)
185			{
186			$self->checktree($item, $required, $dofiles);
187			}
188			}
189
190			sub dirtree
191			{
192			my $self=shift;
193			my ($dir) = @_;
194
195			# Get the directory tree:
196			$self->checktree($dir, 1, 0);
197			return $self;
198			}
199
200			sub checkbuildfiles
201			{
202			my $self=shift;
203			my (@scandirs)=@_;
204
205			# Loop over all directories that need scanning (normally just src and config):
206			foreach my $scand (@scandirs)
207			{
208			$self->logmsg("SCRAM: Scanning $scand\n");
209			# Check the directory tree:
210			$self->dirtree($scand);
211			}
212
213			# Mark everything in the cache old
214			map { $_->[0] = 0 } values %{$self->{BFCACHE}};
215
216			# Remember which directories have build files in them
217			my %files = map { -f $_ ? ($_ => [ (stat(_))[9] ]) : () }
218			map { "$_/BuildFile" }
219			keys %{$self->{DIRCACHE}};
220
221			# Compare with existing cache: remove from cache what no longer
222			# exists, then check which build files are newer than the cache.
223			my $newcache = {};
224
225			while (my ($path, $vals) = each %files)
226			{
227			if ($self->{BFCACHE}->{$path} && $self->{BFCACHE}->{$path}[1] == $vals->[0])
228			{
229			$newcache->{$path} = $self->{BFCACHE}->{$path};
230			delete $self->{BFCACHE}->{$path};
231			}
232			else
233			{
234			$self->logmsg("SCRAM: $path: changed\n");
235			$newcache->{$path} = [ 1, @$vals ];
236			delete $self->{BFCACHE}->{$path};
237			}
238			}
239
240			# If there were BuildFiles that were removed, force update of cache
241			# and remove the BUILDFILEDATA entries:
242			foreach my $path (keys %{$self->{BFCACHE}})
243			{
244			my $datapath;
245			$self->logmsg("SCRAM: $path: removed. Removing build data from cache.\n");
246			$self->cachestatus(1);
247			($datapath = $path) =~ s\|^\Q$ENV{SCRAM_SOURCEDIR}\L/\|\|;
248			$datapath =~ s\|(.*)/BuildFile$\|$1\|g;
249			# Remove the buildfile data:
250			$self->remove_data($datapath);
251			}
252
253			# Save the BuildFile cache:
254			delete $self->{BFCACHE};
255			$self->{BFCACHE} = $newcache;
256
257			return $self;
258			}
259
260			sub buildclass
261			{
262			my $self=shift;
263			my ($path,$cache)=@_;
264			# Associate a path with ClassPath setting (FIXME: belongs elsewhere!).
265			# For now, just assumes global data has been scanned and class settings
266			# are already known (in $self->{TOPLEVELDATA}->{config/BuildFile}->classpath()).
267
268			# Generate more optimal classpath data structure, only once.
269			# Split every cache definition into an array of pairs, directory
270			# name and class. So ClassPath of type "+foo/+bar/src+library"
271			# becomes [ [ "" "foo" ] [ "" "bar" ] [ "src" "library" ] ]
272			if (! scalar @$cache)
273			{
274			foreach my $classpath (@{$self->{TOPLEVELDATA}->{"$ENV{LOCALTOP}/$ENV{SCRAM_CONFIGDIR}"}->classpath()})
275			{
276			push (@$cache, [map { [ split(/\+/, $_) ] } split(/\//, $classpath)]);
277			}
278			}
279
280			print "WARNING: No ClassPath definitions, nothing will be done!\n"
281			if (! scalar @$cache);
282
283			# Now scan the class paths. All the classpaths are given a rank
284			# to mark how relevant they are, and then the best match is chosen.
285			#
286			# The ranking logic is as follows. We scan each class path and
287			# drop if it doesn't match at all. For paths that match, we
288			# record how many components of the class was not used to match
289			# on the class: for a short $path, many classes will match.
290			# For each path component we record whether the match was exact
291			# (if the class part is empty, i.e. "", it's a wildcard that
292			# matches everything). Given these rankings, we pick
293			# - the first class that
294			# - has least unmatched components
295			# - with first or longest exact match sequence in
296			# left-to-right order.
297			my @ranks = ();
298			my @dirs = split(/\/+/, $path);
299			CLASS: foreach my $class (@$cache)
300			{
301			# The first two members of $rank are fixed: how much of path
302			# was and was not used in the match.
303			my $rank = [[], [@dirs]];
304			foreach my $component (@$class)
305			{
306			my $dir = $rank->[1][0];
307			if (! defined $dir)
308			{
309			# Path exhausted. Leave used/unused as is.
310			last;
311			}
312			elsif ($component->[0] eq "")
313			{
314			# Wildcard match, push class and use up path
315			push(@$rank, [1, $component->[1]]);
316			push(@{$rank->[0]}, shift(@{$rank->[1]}));
317			}
318			elsif ($component->[0] eq $dir)
319			{
320			# Exact match, push class and use up path
321			push(@$rank, [0, $component->[1]]);
322			push(@{$rank->[0]}, shift(@{$rank->[1]}));
323			}
324			else
325			{
326			# Unmatched, leave used/unused as is.
327			last;
328			}
329			}
330
331			push(@ranks, $rank);
332			}
333
334			# If no classes match, bail out
335			if (! scalar @ranks)
336			{
337			return "";
338			}
339
340			# Sort in ascending order by how much was of class was not used;
341			# the first entry has least "extra" trailing match data. Then
342			# truncate to only those equal to the best rank.
343			my @sorted = sort { scalar(@{$a->[1]}) <=> scalar(@{$b->[1]}) } @ranks;
344			my @best = grep(scalar(@{$_->[1]}) == scalar(@{$sorted[0][1]}), @sorted);
345
346			# Now figure which of the best-ranking lasses have the longest
347			# exact match in left-to-right order (= which one is first, and
348			# those with equal first exact match, longest exact match).
349			my $n = 0;
350
351			my $class = $best[$n][scalar @{$best[$n]}-1];
352			my $result = [ $best[$n][0], $best[$n][1], $class ];
353			return $result;
354
355			# FIXME: class path association has to depend on cache time stamp
356			# so this calculation is remade again when the cache changes (and
357			# thus class paths have changed). Note that the makefile generation
358			# will also have to depend on the time stamps of all the templates
359			# involved.
360			}
361
362			sub buildpaths
363			{
364			my $self=shift;
365			# Classify each directory in the dircache according to the classpath
366			# settings (FIXME: classpath handling is not really in the scope of
367			# a mere cache!), and return a list of directories and what to do in
368			# them. Note that most of the directories won't have a buildfile!
369			# Use builddata() to retrieve more detailed build information for
370			# each returned directory.
371
372			my $paths = {};
373			my $cache = [];
374			$self->{ALLDIRS} = [];
375
376			foreach my $path (keys %{$self->{DIRCACHE}})
377			{
378			if ( ! -d $path)
379			{
380			$self->logmsg("SCRAM: $path no longer exists. Clearing from cache.\n");
381			$self->cachestatus(1);
382			delete $self->{DIRCACHE}->{$path};
383			}
384			else
385			{
386			next if $path =~ m\|/CVS$\|; # Ignore CVS directories.
387			next if $path =~ m\|\Q$ENV{SCRAM_CONFIGDIR}\L\|;
388			# Store entries in a location easily accessed from
389			# template-generating step:
390			push(@{$self->{ALLDIRS}},$path);
391			$paths->{$path} = $self->buildclass ($path, $cache);
392			}
393			}
394
395			return $paths;
396			}
397
398			sub modified
399			{
400			my $self=shift;
401			my (@modified);
402			map { ( $self->{BFCACHE}{$_}->[0] == 1 ) && push(@modified, $_) } keys %{$self->{BFCACHE}};
403
404			return (@modified);
405			}
406
407			sub buildobject
408			{
409			my $self=shift;
410			my ($path)=@_;
411			my $buildobject;
412
413			# See if this path looks like it points to the
414			# config area. If so return the TOPLEVEL data:
415			if ($path =~ m\|.*?/\Q$ENV{SCRAM_CONFIGDIR}\L\|)
416			{
417			$buildobject = $self->{TOPLEVELDATA}->{$path};
418			}
419			else
420			{
421			$buildobject=$self->{BUILDFILEDATA}->{$path};
422			}
423
424			# return the BuildFile object:
425			return $buildobject;
426			}
427
428			sub addgroup
429			{
430			my $self=shift;
431			my ($grouparray,$path)=@_;
432
433			foreach my $group (@{$grouparray})
434			{
435			# Only give a warning if the group is defined already in a
436			# BuildFile other than the one at $path (avoids errors because KNOWNGROUPS
437			# is not reset before re-parsing a BuildFile in which a group is defined):
438			if (exists $self->{KNOWNGROUPS}->{$group}
439			&& $self->{KNOWNGROUPS}->{$group} ne $path)
440			{
441			print "WARNING: Group \"",$group,"\" already defined in ",
442			$self->{KNOWNGROUPS}->{$group}."/BuildFile","","\n";
443			exit(0); # For now, we exit.
444			}
445			else
446			{
447			$self->{KNOWNGROUPS}->{$group} = $path;
448			}
449			}
450			}
451
452			sub findgroup
453			{
454			my $self=shift;
455			my ($groupname) = @_;
456
457			if (exists $self->{KNOWNGROUPS}->{$groupname})
458			{
459			return $self->{KNOWNGROUPS}->{$groupname};
460			}
461			else
462			{
463			print "WARNING: Group \"",$groupname,"\" not defined in any BuildFile.","\n";
464			exit(0); # For now, we exit.
465			}
466			}
467
468			sub knowngroups
469			{
470			my $self=shift;
471			@_ ? $self->{KNOWNGROUPS}=shift
472			: $self->{KNOWNGROUPS}
473			}
474
475			sub alldirs
476			{
477			my $self=shift;
478			return @{$self->{ALLDIRS}};
479			}
480
481			sub verbose
482			{
483			my $self=shift;
484			# Turn on verbose mode:
485			@_ ? $self->{VERBOSE} = shift
486			: $self->{VERBOSE}
487			}
488
489			sub cachestatus()
490			{
491			my $self=shift;
492			# Set/return the name of the cache to use:
493			@_ ? $self->{STATUS} = shift
494			: $self->{STATUS}
495			}
496
497			sub logmsg
498			{
499			my $self=shift;
500			# Print a message to STDOUT if VERBOSE is true:
501			print STDERR @_ if $self->verbose();
502			}
503
504			sub name()
505			{
506			my $self=shift;
507			# Set/return the name of the cache to use:
508			@_ ? $self->{CACHENAME} = shift
509			: $self->{CACHENAME}
510			}
511
512			1;