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.12 2011/09/05 09:01:19 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;
   my $ignore=shift || 'CVS|\\..*';
   my $match=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/$_") && ($_=~/^($match)$/) && ($_!~/^($ignore)$/),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 = ();
   my $matchdir='[a-zA-Z0-9][a-zA-Z0-9-_]*';

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