ViewVC Help
View File | Revision Log | Show Annotations | Root Listing
root/cvsroot/COMP/SCRAM/src/Cache/Cache.pm
Revision: 1.5
Committed: Wed Aug 17 11:20:54 2005 UTC (19 years, 8 months ago) by sashby
Content type: text/plain
Branch: MAIN
Changes since 1.4: +48 -1 lines
Log Message:
More POD doc plus tidy up of some packages.

File Contents

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