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.2 2008/06/02 16:20:26 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 $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;
            print "ADDED:REMOVEDBF : $bfn\n";
            delete $self->{BFCACHE}{$bfn};
            Utilities::AddDir::adddir($bfcachedir);
            open(BF,">${bfcachedir}/$ENV{SCRAM_BUILDFILE}");close(BF);
            $self->cachestatus(1);
            }
         }
      else
         {
         $bftime = (stat(_))[9];
         if ((! exists $self->{BFCACHE}{$bfn}) ||
             ($bftime != $self->{BFCACHE}{$bfn}))
            {
            Utilities::AddDir::adddir($bfcachedir);
            open(BF,">${bfcachedir}/$ENV{SCRAM_BUILDFILE}");close(BF);
            $self->{ADDEDBF}{$bfn}=1;
            delete $self->{BFCACHE}{"${path}/$ENV{SCRAM_BUILDFILE}"};
            $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 "${bfcachedir}/$ENV{SCRAM_BUILDFILE}")
               {
               Utilities::AddDir::adddir($bfcachedir);
               open(BF,">${bfcachedir}/$ENV{SCRAM_BUILDFILE}");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.3
Committed:	Wed Aug 27 11:08:03 2008 UTC (16 years, 8 months ago) by muzaffar
Content type:	text/plain
Branch:	SCRAM_V2_0
CVS Tags:	V2_2_0, sm100112, V2_1_4, V2_1_3, V2_1_2, V2_1_1, V2_1_0, V2_0_6
Changes since 1.10.2.2.2.2:	+8 -1 lines
Log Message:	fixed auto update of scram internal caches when the Products/<prod>/pkgs.txt files changes for big libraries stuff. Only needed for big libraries and will not break not releasespwd
#	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.3	# Revision: $Id: Cache.pm,v 1.10.2.2.2.2 2008/06/02 16:20:26 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			my $bftime=0;
236			my $bf="${path}/$ENV{SCRAM_BUILDFILE}";
237			foreach my $ext (".xml","")
238			{
239			my $bfn="$bf$ext";
240			if (! stat ($bfn))
241			{
242			if (exists $self->{BFCACHE}{$bfn})
243			{
244			$self->{REMOVEDBF}{$bfn}=1;
245	muzaffar	1.10.2.2.2.1	print "ADDED:REMOVEDBF : $bfn\n";
246	muzaffar	1.9	delete $self->{BFCACHE}{$bfn};
247	muzaffar	1.10.2.2	Utilities::AddDir::adddir($bfcachedir);
248	muzaffar	1.9	open(BF,">${bfcachedir}/$ENV{SCRAM_BUILDFILE}");close(BF);
249			$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	Utilities::AddDir::adddir($bfcachedir);
259	muzaffar	1.9	open(BF,">${bfcachedir}/$ENV{SCRAM_BUILDFILE}");close(BF);
260			$self->{ADDEDBF}{$bfn}=1;
261			delete $self->{BFCACHE}{"${path}/$ENV{SCRAM_BUILDFILE}"};
262			$self->{BFCACHE}{$bfn}=$bftime;
263			if ($ext eq ""){$self->{nonxml}+=1;}
264			$self->cachestatus(1);
265			}
266			elsif($self->{cachereset})
267			{
268			$self->{ADDEDBF}{$bfn}=1;
269			if ($ext eq ""){$self->{nonxml}+=1;}
270			if (!-f "${bfcachedir}/$ENV{SCRAM_BUILDFILE}")
271			{
272	muzaffar	1.10.2.2	Utilities::AddDir::adddir($bfcachedir);
273	muzaffar	1.9	open(BF,">${bfcachedir}/$ENV{SCRAM_BUILDFILE}");close(BF);
274			}
275			$self->cachestatus(1);
276			}
277			last;
278			}
279			}
280	muzaffar	1.10.2.2.2.3	if (exists $self->{ExtraDirCache})
281			{
282			eval {$self->{ExtraDirCache}->DirCache($self,$path);};
283			}
284	sashby	1.2	# Process sub-directories
285			foreach my $item (@items)
286			{
287	muzaffar	1.9	$self->checktree($item, $required);
288	sashby	1.2	}
289			}
290
291	sashby	1.6	=item C<clean_cache_recursive($startdir)>
292
293			Recursive remove cached data for directories under $startdir.
294
295			=cut
296
297	sashby	1.2	sub clean_cache_recursive()
298			{
299			my $self=shift;
300			my ($startdir) = @_;
301			my $children = $self->{DIRCACHE}->{$startdir};
302
303			for (my $i = 2; $i <= $#$children; $i++)
304			{
305			# Remove all children:
306			$self->schedremoval($children->[$i]);
307			$self->clean_cache_recursive($children->[$i]);
308			}
309
310			delete $self->{DIRCACHE}->{$startdir};
311			return $self;
312			}
313
314	sashby	1.6	=item C<dirtree($dir,$dofiles)>
315
316			Starting from $dir, scan the directory tree. Ignore files unless $dofiles is set. This
317			function just calls checktree().
318
319			=cut
320
321	sashby	1.2	sub dirtree()
322			{
323			my $self=shift;
324	muzaffar	1.9	my ($dir) = @_;
325	sashby	1.2
326			# Get the directory tree:
327	muzaffar	1.9	$self->checktree($dir, 1);
328	sashby	1.2	return $self;
329			}
330
331	sashby	1.6	=item C<checkfiles()>
332
333			Function to actually run the timestamp checks. This is only run from
334			SCRAM::CMD::build().
335
336			=cut
337
338	sashby	1.2	sub checkfiles()
339			{
340			my $self=shift;
341	muzaffar	1.9	$self->{cachereset}=shift \|\| 0;
342	sashby	1.2	# Scan config dir for top-level data, then start from src:
343	muzaffar	1.9	my @scandirs=($ENV{SCRAM_CONFIGDIR}, $ENV{SCRAM_SOURCEDIR});
344	sashby	1.2	# Loop over all directories that need scanning (normally just src and config):
345	muzaffar	1.9	$self->{nonxml}=0;
346	muzaffar	1.10.2.2.2.3	eval ("use SCRAM::Plugins::DirCache;");
347			if(!$@) {$self->{ExtraDirCache} = SCRAM::Plugins::DirCache->new();}
348	sashby	1.2	foreach my $scand (@scandirs)
349			{
350			$self->logmsg("SCRAM: Scanning $scand [dofiles set to ".$dofiles."]\n");
351			# Check the directory tree:
352	muzaffar	1.9	$self->dirtree($scand);
353	sashby	1.2	}
354	muzaffar	1.9	if ($self->cachestatus())
355	sashby	1.2	{
356	muzaffar	1.9	foreach my $bf ("$ENV{SCRAM_BUILDFILE}.xml","$ENV{SCRAM_BUILDFILE}")
357			{
358			if (exists $self->{BFCACHE}{"$ENV{SCRAM_CONFIGDIR}/${bf}"})
359			{
360			$self->{ADDEDBF}{"$ENV{SCRAM_CONFIGDIR}/${bf}"}=1;
361			last;
362			}
363	sashby	1.2	}
364			}
365	muzaffar	1.10.2.2.2.3	delete $self->{ExtraDirCache};
366	muzaffar	1.9	if ($self->{nonxml} > 0)
367	sashby	1.2	{
368	muzaffar	1.10.2.2.2.2	#print STDERR "**** WARNING: ",$self->{nonxml}," non-xml based $ENV{SCRAM_BUILDFILE} were read.\n";
369	sashby	1.2	}
370			return $self;
371			}
372
373	sashby	1.6	=item C<dircache()>
374
375			Return a reference to the directory cache hash.
376
377			=cut
378
379	sashby	1.2	sub dircache()
380			{
381			my $self=shift;
382			# Return the file cache:
383			return $self->{DIRCACHE};
384			}
385
386	sashby	1.6	=item C<added_dirs($path)>
387
388			Add $path to the list of directories added since last scan, or return
389			the list of added directories if no argument given.
390
391			=cut
392
393	sashby	1.2	sub added_dirs()
394			{
395			my $self=shift;
396			my ($path) = @_;
397
398			# If we have a path to add, add it.
399			if ($path)
400			{
401			if (exists($self->{ADDEDDIRS}))
402			{
403			push(@{$self->{ADDEDDIRS}}, $path);
404			}
405			else
406			{
407			$self->{ADDEDDIRS} = [ $path ];
408			}
409			}
410			else
411			{
412			# Otherwise, return the array of added dirs:
413			my @addeddirs = @{$self->{ADDEDDIRS}};
414			delete $self->{ADDEDDIRS};
415			return \@addeddirs;
416			}
417			}
418
419	sashby	1.6	=item C<modified_parentdirs($path)>
420
421			Add a directory $path to the list of parent directories (directories
422			having subdirectories), or return a reference to the list.
423			Storing this parent allows any update to be taken recursively from this
424			location.
425
426			=cut
427
428	sashby	1.2	sub modified_parentdirs()
429			{
430			my $self=shift;
431			my ($path) = @_;
432
433			# If we have a path to add, add it.
434			# Don't bother if it's the main source dir as we don't
435			# want to rescan everything from src (that would be silly):
436			if ($path && $path ne $ENV{SCRAM_SOURCEDIR})
437			{
438			if (exists($self->{MODPARENTDIRS}))
439			{
440			push(@{$self->{MODPARENTDIRS}}, $path);
441			}
442			else
443			{
444			$self->{MODPARENTDIRS} = [ $path ];
445			}
446			}
447			else
448			{
449			# Otherwise, return the array of added dirs:
450			my @moddeddirs = @{$self->{MODPARENTDIRS}};
451			delete $self->{MODPARENTDIRS};
452			return \@moddeddirs;
453			}
454			}
455
456	sashby	1.6	=item C<schedremoval($d)>
457
458			Add directory $d to list of directories that should be removed
459			recursively from the cache.
460			If no arguments given, return a reference to a list of
461			directories to be removed.
462
463			=cut
464
465	sashby	1.2	sub schedremoval()
466			{
467			my $self=shift;
468			my ($d)=@_;
469
470			if ($d)
471			{
472			if (exists($self->{REMOVEDATA}))
473			{
474			push(@{$self->{REMOVEDATA}},$d);
475			}
476			else
477			{
478			$self->{REMOVEDATA} = [ $d ];
479			}
480			}
481			else
482			{
483			my $remove = [ @{$self->{REMOVEDATA}} ];
484			$self->{REMOVEDATA} = [];
485			return $remove;
486			}
487			}
488
489	sashby	1.6	=item C<filestatus()>
490
491			Return a true or false value depending on whether
492			a BuildFile was changed or not.
493
494			=cut
495
496	sashby	1.2	sub filestatus()
497			{
498			my $self=shift;
499			# Here we want to return a true or false value depending on whether
500			# or not a buildfile was changed:
501			return $self->{STATUSSRC};
502			}
503
504	sashby	1.6	=item C<configstatus()>
505
506			Return a true or false value depending on whether
507			a file in the config directory was changed or not.
508
509			=cut
510
511	sashby	1.2	sub configstatus()
512			{
513			my $self=shift;
514			# Here we want to return a true or false value depending on whether or not a file
515			# in config dir was changed:
516			return $self->{STATUSCONFIG};
517			}
518
519	sashby	1.6	=item C<bf_for_scanning()>
520
521			Return a list of BuildFiles to re-read. Note that this is only done
522			if the status was changed (i.e. not necessary to read through the list
523			of BuildFiles to know whether something changed as the flag B<STATUSSRC>
524			is set as the source tree is checked).
525			If B<STATUSCONFIG> is true, all BuildFiles are marked to be read.
526
527			=cut
528
529	sashby	1.2	sub bf_for_scanning()
530			{
531			my $self=shift;
532			my $MODIFIED = [];
533	muzaffar	1.9	map { push(@$MODIFIED, $_) } @{$self->{ADDEDBF}};
534	sashby	1.2	return $MODIFIED;
535			}
536
537	sashby	1.6	=item C<paths()>
538
539			Return a reference to an array of directories for the current source tree.
540
541			=cut
542
543	sashby	1.2	sub paths()
544			{
545			my $self=shift;
546			my $paths = {};
547
548	muzaffar	1.9	my $ALLDIRS = [];
549			map { push(@$ALLDIRS, $_) } keys %{$self->{DIRCACHE}};
550			return $ALLDIRS;
551	sashby	1.2	}
552
553	sashby	1.6	=item C<verbose()>
554
555			Turn verbosity for the cache on or off.
556
557			=cut
558
559	sashby	1.2	sub verbose()
560			{
561			my $self=shift;
562			# Turn on verbose mode:
563			@_ ? $self->{VERBOSE} = shift
564			: $self->{VERBOSE}
565			}
566
567	sashby	1.6	=item C<cachestatus()>
568
569			Set or return the cache status to indicate whether or not a file
570			timestamp has changed since the last pass.
571
572			=cut
573
574	sashby	1.2	sub cachestatus()
575			{
576			my $self=shift;
577			# Set/return the status of the cache:
578			@_ ? $self->{STATUS} = shift
579			: $self->{STATUS}
580			}
581
582	sashby	1.6	=item C<logmsg(@message)>
583
584			Print a message to B<STDERR>. This is only used in
585			checktree(), checkfiles() and paths().
586
587			=cut
588
589	sashby	1.2	sub logmsg()
590			{
591			my $self=shift;
592			# Print a message to STDOUT if VERBOSE is true:
593			print STDERR @_ if $self->verbose();
594			}
595
596	sashby	1.6	=item C<name()>
597
598			Set or return the name of the cache. Normally set
599	muzaffar	1.10.2.2.2.1	to B<DirCache.db.gz> (and not architecture dependent).
600	sashby	1.6
601			=cut
602
603	sashby	1.2	sub name()
604			{
605			my $self=shift;
606			# Set/return the name of the cache to use:
607			@_ ? $self->{CACHENAME} = shift
608			: $self->{CACHENAME}
609			}
610
611	muzaffar	1.9	sub get_data()
612			{
613			my $self=shift;
614			my $type=shift;
615			@_ ? $self->{$type} = shift
616			: $self->{$type};
617			}
618
619			sub extra_suffix()
620			{
621			my $self=shift;
622			my $path=shift;
623			@_ ? $self->{EXTRASUFFIX}{$path}=shift
624			: exists $self->{EXTRASUFFIX}{$path};
625			}
626
627			sub get_nonxml()
628			{
629			my $self=shift;
630			return $self->{nonxml};
631			}
632
633	sashby	1.2	1;
634	sashby	1.5
635			=back
636
637			=head1 AUTHOR
638
639			Shaun Ashby (with contribution from Lassi Tuura)
640
641			=head1 MAINTAINER
642
643			Shaun Ashby
644
645			=cut
646