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