ViewVC Help

View File | Revision Log | Show Annotations | Root Listing

root/cvsroot/COMP/SCRAM/src/Cache/Cache.pm

Comparing COMP/SCRAM/src/Cache/Cache.pm (file contents):
Revision 1.1 by sashby, Fri Feb 27 16:08:16 2004 UTC vs.
Revision 1.2 by sashby, Fri Dec 10 13:41:39 2004 UTC

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

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines