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.10.2.2.2.3 2008/08/27 11:08:03 muzaffar Exp $ 
#
# Copyright: 2003 (C) Shaun Ashby
#
#--------------------------------------------------------------------

=head1 NAME

Cache::Cache - A generic directory cache object.

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

=head1 DESCRIPTION

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

=head1 METHODS

=over

=cut

package Cache::Cache;
require 5.004;

use Exporter;
use Utilities::AddDir;
@ISA=qw(Exporter);
#

=item   C<new()>

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

=cut

sub new()
   ###############################################################
   # new                                                         #
   ###############################################################
   # modified : Thu Nov 27 16:45:27 2003 / SFA                   #
   # params   :                                                  #
   #          :                                                  #
   # function :                                                  #
   #          :                                                  #
   ###############################################################
   {
   my $proto=shift;
   my $class=ref($proto) || $proto;
   my $self=
      {
      CACHENAME => "DirCache.db.gz",     # Name of global file/dir cache;
      BFCACHE => {},                  # BuildFile cache;
      DIRCACHE => {},                 # Source code cache;
      EXTRASUFFIX => {},              # path with extra suffix;
      STATUS => 0,                    # Status of cache: 1 => something changed. If so, force save;
      VERBOSE => 0                    # Verbose mode (0/1);
      };

   bless $self,$class;
   return $self;
   }

=item   C<getdir($path)>

Return a list of directories starting from $path.

=cut

sub getdir()
   {
   my $self=shift;
   my $path=shift;

   opendir (DIR, $path) || die "$path: cannot read: $!\n";
   # Skip .admin and CVS subdirectories too.
   # Also skip files that look like backup files or files being modified with emacs:
   my @items = map { "$path/$_" } grep ((-d "$path/$_") && ($_!~/^(CVS|\..*)$/),readdir(DIR));
   closedir (DIR);
   return @items;
   }

=item   C<prune($path)>

Recursively remove directories from the cache starting at $path.

=cut

sub prune()
   {
   my $self=shift;
   my $path = shift;
   my $skipparent = shift || 0;
   my $suffix = shift || "";
   $self->extra_suffix($path,$suffix) if ($suffix);
   if (!$skipparent)
      {
      my $parent = $path;
      $parent =~ s|(.*)/[^/]+$|$1|;
      if ($parent ne $path && exists $self->{DIRCACHE}{$parent})
         {
         my ($time, @subs) = @{$self->{DIRCACHE}{$parent}};
         $self->{DIRCACHE}{$parent} = [ $time, grep ($_ ne $path, @subs) ];
         $self->{ADDEDDIR}{$parent}=1;
         $self->cachestatus(1);
         }
      }
   if (exists $self->{ADDEDDIR}{$path}){delete $self->{ADDEDDIR}{$path};}
   return if ! exists $self->{DIRCACHE}{$path};
   $self->cachestatus(1);
   foreach my $bf ("$ENV{SCRAM_BUILDFILE}.xml","$ENV{SCRAM_BUILDFILE}")
      {
      if (exists $self->{BFCACHE}{"${path}/${bf}"})
         {
         if (!-f "${path}/${bf}") {$self->{REMOVEDBF}{"${path}/${bf}"}=1;}
         delete $self->{BFCACHE}{"${path}/${bf}"};
         if (exists $self->{ADDEDBF}{"${path}/${bf}"}){delete $self->{ADDEDBF}{"${path}/${bf}"};}
         last;
         }
      }
   if (!-d $path) {$self->{REMOVEDDIR}{$path}=1;}
   my (undef, @subs) = @{$self->{DIRCACHE}{$path}};
   delete $self->{DIRCACHE}{$path};
   foreach my $sub (@subs)
      {
      $self->prune($sub,1);
      }
   }

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

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

=cut

sub checktree()
   {
   my ($self, $path, $required) = @_;
   # 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->prune($path);
      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 _)
      {
      $self->prune($path);
      return;
      }
   elsif (! $cached)
      {
      # When a directory is added, this block is activated
      $self->{ADDEDDIR}{$path}=1;
      $self->{DIRCACHE}{$path} = [ (stat(_))[9], @items = $self->getdir($path) ];
      $required = 1;
      $self->cachestatus(1);
      }
   elsif ($cached->[0] != (stat(_))[9])
      {
      my $ntime = (stat(_))[9];
      # When a subdirectory is removed, this block is activated
      #
      # This is a parent directory. We store this as any
      # update can be taken recursively from this dir:
      #$self->modified_parentdirs($path);
      # Current subdirs:
      my %curdirs = map { $_ => 1 } $self->getdir($path);
      my %olddirs = ();
      for (my $i = 1; $i <= $#$cached; $i++)
         {
         my $d = $cached->[$i];
         $olddirs{$d}=1;
         if (!exists $curdirs{$d})
            {
            $self->prune($d,1);
            }
         }
      
      foreach my $d (keys %curdirs)
         {
         if (!exists $olddirs{$d})
            {
            if ($self->extra_suffix($d))
               {
               delete $curdirs{$d};
               }
            }
         }

      $self->{ADDEDDIR}{$path}=1;
      $self->cachestatus(1);
      @items = keys %curdirs;
      $required = 0;
      $self->{DIRCACHE}{$path} = [ $ntime, @items ];
      }
   else
      {
      (undef, @items) = @{$self->{DIRCACHE}{$path}};
      $required = 0;
      }
   if (($self->{cachereset}) && (!exists $self->{ADDEDDIR}{$path}))
      {
      $self->{ADDEDDIR}{$path}=1;
      $self->cachestatus(1);
      }
   
   my $bfcachedir=$ENV{LOCALTOP}."/".$ENV{SCRAM_TMP}."/".$ENV{SCRAM_ARCH}."/cache/bf/${path}";
   my $cbf="${bfcachedir}/$ENV{SCRAM_BUILDFILE}";
   my $bftime=0;
   my $bf="${path}/$ENV{SCRAM_BUILDFILE}";
   foreach my $ext (".xml","")
      {
      my $bfn="$bf$ext";
      if (! stat ($bfn))
         {
         if (exists $self->{BFCACHE}{$bfn})
            {
            $self->{REMOVEDBF}{$bfn}=1;
            delete $self->{BFCACHE}{$bfn};
            Utilities::AddDir::adddir($bfcachedir);
            open(BF,">${cbf}");close(BF);
            $self->cachestatus(1);
            }
         }
      else
         {
         $bftime = (stat(_))[9];
         if ((! exists $self->{BFCACHE}{$bfn}) ||
             ($bftime != $self->{BFCACHE}{$bfn}))
            {
            if ((!-f "${cbf}") || (exists $self->{BFCACHE}{$bfn}))
               {
               Utilities::AddDir::adddir($bfcachedir);
               open(BF,">${cbf}");close(BF);
               }
            $self->{ADDEDBF}{$bfn}=1;
            delete $self->{BFCACHE}{$bf};
            $self->{BFCACHE}{$bfn}=$bftime;
            if ($ext eq ""){$self->{nonxml}+=1;}
            $self->cachestatus(1);
            }
         elsif($self->{cachereset})
            {
            $self->{ADDEDBF}{$bfn}=1;
            if ($ext eq ""){$self->{nonxml}+=1;}
            if (!-f "${cbf}")
               {
               Utilities::AddDir::adddir($bfcachedir);
               open(BF,">${cbf}");close(BF);
               }
            $self->cachestatus(1);
            }
         last;
         }
      }
   if (exists $self->{ExtraDirCache})
      {
      eval {$self->{ExtraDirCache}->DirCache($self,$path);};
      }
   # Process sub-directories
   foreach my $item (@items)
      {
      $self->checktree($item, $required);
      }
   }

=item   C<clean_cache_recursive($startdir)>

Recursive remove cached data for directories under $startdir.

=cut

sub clean_cache_recursive()
   {
   my $self=shift;
   my ($startdir) = @_;
   my $children = $self->{DIRCACHE}->{$startdir};
   
   for (my $i = 2; $i <= $#$children; $i++) 
      {
      # Remove all children:
      $self->schedremoval($children->[$i]);
      $self->clean_cache_recursive($children->[$i]); 
      }
   
   delete $self->{DIRCACHE}->{$startdir};
   return $self;
   }

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

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

=cut

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

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

=item   C<checkfiles()>

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

=cut

sub checkfiles()
   {
   my $self=shift;
   $self->{cachereset}=shift || 0;
   # Scan config dir for top-level data, then start from src:
   my @scandirs=($ENV{SCRAM_CONFIGDIR}, $ENV{SCRAM_SOURCEDIR});
   # Loop over all directories that need scanning (normally just src and config):
   $self->{nonxml}=0;
   eval ("use SCRAM::Plugins::DirCache;");
   if(!$@) {$self->{ExtraDirCache} = SCRAM::Plugins::DirCache->new();}
   foreach my $scand (@scandirs)
      {
      $self->logmsg("SCRAM: Scanning $scand [dofiles set to ".$dofiles."]\n");
      # Check the directory tree:
      $self->dirtree($scand);
      }
   if ($self->cachestatus())
      {
      foreach my $bf ("$ENV{SCRAM_BUILDFILE}.xml","$ENV{SCRAM_BUILDFILE}")
         {
         if (exists $self->{BFCACHE}{"$ENV{SCRAM_CONFIGDIR}/${bf}"})
            {
            $self->{ADDEDBF}{"$ENV{SCRAM_CONFIGDIR}/${bf}"}=1;
            last;
            }
         }
      }
   delete $self->{ExtraDirCache};
   if ($self->{nonxml} > 0)
      {
      #print STDERR "**** WARNING: ",$self->{nonxml}," non-xml based $ENV{SCRAM_BUILDFILE} were read.\n";
      }
   return $self;
   }

=item   C<dircache()>

Return a reference to the directory cache hash.

=cut

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

=item   C<added_dirs($path)>

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

=cut

sub added_dirs()
   {
   my $self=shift;
   my ($path) = @_;

   # If we have a path to add, add it.
   if ($path)
      {
      if (exists($self->{ADDEDDIRS}))
         {
         push(@{$self->{ADDEDDIRS}}, $path);
         }
      else
         {
         $self->{ADDEDDIRS} = [ $path ];
         }
      }
   else
      {
      # Otherwise, return the array of added dirs:
      my @addeddirs = @{$self->{ADDEDDIRS}};
      delete $self->{ADDEDDIRS};
      return \@addeddirs;
      }
   }

=item   C<modified_parentdirs($path)>

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

sub modified_parentdirs()
   {
   my $self=shift;
   my ($path) = @_;
   
   # If we have a path to add, add it.
   # Don't bother if it's the main source dir as we don't
   # want to rescan everything from src (that would be silly):
   if ($path && $path ne $ENV{SCRAM_SOURCEDIR})
      {
      if (exists($self->{MODPARENTDIRS}))
         {
         push(@{$self->{MODPARENTDIRS}}, $path);
         }
      else
         {
         $self->{MODPARENTDIRS} = [ $path ];
         }
      }
   else
      {
      # Otherwise, return the array of added dirs:
      my @moddeddirs = @{$self->{MODPARENTDIRS}};
      delete $self->{MODPARENTDIRS};
      return \@moddeddirs;
      }
   }

=item   C<schedremoval($d)>

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

sub schedremoval()
   {
   my $self=shift;
   my ($d)=@_;

   if ($d)
      {
      if (exists($self->{REMOVEDATA}))
         {
         push(@{$self->{REMOVEDATA}},$d);
         }
      else
         {
         $self->{REMOVEDATA} = [ $d ];
         }
      }
   else
      {
      my $remove = [ @{$self->{REMOVEDATA}} ];
      $self->{REMOVEDATA} = [];
      return $remove;
      }
   }

=item   C<filestatus()>

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

=cut

sub filestatus()
   {
   my $self=shift;
   # Here we want to return a true or false value depending on whether
   # or not a buildfile was changed:
   return $self->{STATUSSRC};
   }

=item   C<configstatus()>

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

=cut

sub configstatus()
   {
   my $self=shift;
   # Here we want to return a true or false value depending on whether or not a file
   # in config dir was changed:
   return $self->{STATUSCONFIG};
   }

=item   C<bf_for_scanning()>

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

=cut

sub bf_for_scanning()
   {
   my $self=shift;
   my $MODIFIED = [];
   map { push(@$MODIFIED, $_) } @{$self->{ADDEDBF}};
   return $MODIFIED;
   }

=item   C<paths()>

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

=cut

sub paths()
   {
   my $self=shift;
   my $paths = {};
   
   my $ALLDIRS = [];
   map { push(@$ALLDIRS, $_) } keys %{$self->{DIRCACHE}};
   return $ALLDIRS;
   }

=item   C<verbose()>

Turn verbosity for the cache on or off.

=cut

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

=item   C<cachestatus()>

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

=cut

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

=item   C<logmsg(@message)>

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

=cut

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

=item   C<name()>

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

=cut

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

sub get_data()
   {
     my $self=shift;
     my $type=shift;
     @_ ? $self->{$type} = shift
        : $self->{$type};
   }

sub extra_suffix()
   {
     my $self=shift;
     my $path=shift;
     @_ ? $self->{EXTRASUFFIX}{$path}=shift
        : exists $self->{EXTRASUFFIX}{$path};
   }
   
sub get_nonxml()
   {
   my $self=shift;
   return $self->{nonxml};
   }

1;

=back

=head1 AUTHOR

Shaun Ashby (with contribution from Lassi Tuura)

=head1 MAINTAINER

Shaun Ashby
   
=cut

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