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.9 2007/11/06 14:13: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> 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",     # 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}";
   if (($self->{convertxml}) && (!-f "${bf}.xml") && (-f "$bf"))
       {
       my $fref;
       $self->{nonxml} = $self->{nonxml}+1;
       if (open($fref,">${bf}.xml"))
          {
          print ">> Converting $bf => ${bf}.xml\n";
          $self->{convertxml}->clean();
          my $xml=$self->{convertxml}->convert($bf);
          foreach my $line (@$xml){print $fref "$line\n";}
          close($fref);
          $self->{convertxml}->clean();
          }
       else
          {
          print STDERR "**** WARNING: Can not open file for writing: ${bf}.xml\n";
          }
       }
   foreach my $ext (".xml","")
      {
      my $bfn="$bf$ext";
      if (! stat ($bfn))
         {
         if (exists $self->{BFCACHE}{$bfn})
            {
            $self->{REMOVEDBF}{$bfn}=1;
            delete $self->{BFCACHE}{$bfn};
            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}))
            {
            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}")
               {
               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;
   $self->{convertxml}=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):
   if ($self->{convertxml})
      {
      eval ("use SCRAM::Doc2XML");
      if (!$@)
         {
         $self->{convertxml} = SCRAM::Doc2XML->new();
         }
      else
         {
         print STDERR "**** WARNING: Can not convert $ENV{SCRAM_BUILDFILE} in to XML format. Missing SCRAM::Doc2XML perl module.\n";
         }
      }
   $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> (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.7.2.2
Committed:	Thu Nov 8 15:25:28 2007 UTC (17 years, 6 months ago) by muzaffar
Content type:	text/plain
Branch:	v103_with_xml
CVS Tags:	forV1_1_0
Changes since 1.7.2.1:	+197 -183 lines
Log Message:	updated the new scram in the v103_with_xml branch
#	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.7.2.2	# Revision: $Id: Cache.pm,v 1.9 2007/11/06 14:13: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.7.2.2	use Utilities::AddDir;
39	sashby	1.2	@ISA=qw(Exporter);
40			#
41	sashby	1.5
42			=item C<new()>
43
44			Create a new Cache::Cache object. The name of the cache is B<DirCache.db> by default.
45
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			CACHENAME => "DirCache.db", # Name of global file/dir cache;
64			BFCACHE => {}, # BuildFile cache;
65			DIRCACHE => {}, # Source code cache;
66	muzaffar	1.7.2.2	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.7.2.2	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.7.2.2	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.7.2.2	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.7.2.2	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.7.2.2	$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.7.2.2	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.7.2.2	my $cached = $self->{DIRCACHE}{$path};
170	sashby	1.2	my @items = ();
171
172			if (! -d _)
173			{
174	muzaffar	1.7.2.2	$self->prune($path);
175			return;
176	sashby	1.2	}
177	muzaffar	1.7.2.2	elsif (! $cached)
178	sashby	1.2	{
179			# When a directory is added, this block is activated
180	muzaffar	1.7.2.2	$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.7.2.2	elsif ($cached->[0] != (stat(_))[9])
186	sashby	1.2	{
187	muzaffar	1.7.2.2	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.7.2.2	#$self->modified_parentdirs($path);
193	sashby	1.2	# Current subdirs:
194	muzaffar	1.7.2.2	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	sashby	1.2	{
202	muzaffar	1.7.2.2	$self->prune($d,1);
203	sashby	1.2	}
204	muzaffar	1.7.2.2	}
205	sashby	1.2
206	muzaffar	1.7.2.2	foreach my $d (keys %curdirs)
207			{
208			if (!exists $olddirs{$d})
209			{
210			if ($self->extra_suffix($d))
211			{
212			delete $curdirs{$d};
213			}
214			}
215			}
216
217			$self->{ADDEDDIR}{$path}=1;
218	sashby	1.2	$self->cachestatus(1);
219	muzaffar	1.7.2.2	@items = keys %curdirs;
220			$required = 0;
221			$self->{DIRCACHE}{$path} = [ $ntime, @items ];
222	sashby	1.2	}
223			else
224			{
225	muzaffar	1.7.2.2	(undef, @items) = @{$self->{DIRCACHE}{$path}};
226	sashby	1.2	$required = 0;
227			}
228	muzaffar	1.7.2.2	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.7.2.2	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			if (($self->{convertxml}) && (!-f "${bf}.xml") && (-f "$bf"))
238			{
239			my $fref;
240			$self->{nonxml} = $self->{nonxml}+1;
241			if (open($fref,">${bf}.xml"))
242			{
243			print ">> Converting $bf => ${bf}.xml\n";
244			$self->{convertxml}->clean();
245			my $xml=$self->{convertxml}->convert($bf);
246			foreach my $line (@$xml){print $fref "$line\n";}
247			close($fref);
248			$self->{convertxml}->clean();
249			}
250			else
251			{
252			print STDERR "**** WARNING: Can not open file for writing: ${bf}.xml\n";
253			}
254			}
255			foreach my $ext (".xml","")
256			{
257			my $bfn="$bf$ext";
258			if (! stat ($bfn))
259			{
260			if (exists $self->{BFCACHE}{$bfn})
261			{
262			$self->{REMOVEDBF}{$bfn}=1;
263			delete $self->{BFCACHE}{$bfn};
264			AddDir::adddir($bfcachedir);
265			open(BF,">${bfcachedir}/$ENV{SCRAM_BUILDFILE}");close(BF);
266			$self->cachestatus(1);
267			}
268			}
269			else
270			{
271			$bftime = (stat(_))[9];
272			if ((! exists $self->{BFCACHE}{$bfn}) \|\|
273			($bftime != $self->{BFCACHE}{$bfn}))
274			{
275			AddDir::adddir($bfcachedir);
276			open(BF,">${bfcachedir}/$ENV{SCRAM_BUILDFILE}");close(BF);
277			$self->{ADDEDBF}{$bfn}=1;
278			delete $self->{BFCACHE}{"${path}/$ENV{SCRAM_BUILDFILE}"};
279			$self->{BFCACHE}{$bfn}=$bftime;
280			if ($ext eq ""){$self->{nonxml}+=1;}
281			$self->cachestatus(1);
282			}
283			elsif($self->{cachereset})
284			{
285			$self->{ADDEDBF}{$bfn}=1;
286			if ($ext eq ""){$self->{nonxml}+=1;}
287			if (!-f "${bfcachedir}/$ENV{SCRAM_BUILDFILE}")
288			{
289			AddDir::adddir($bfcachedir);
290			open(BF,">${bfcachedir}/$ENV{SCRAM_BUILDFILE}");close(BF);
291			}
292			$self->cachestatus(1);
293			}
294			last;
295			}
296			}
297	sashby	1.2	# Process sub-directories
298			foreach my $item (@items)
299			{
300	muzaffar	1.7.2.2	$self->checktree($item, $required);
301	sashby	1.2	}
302			}
303
304	sashby	1.6	=item C<clean_cache_recursive($startdir)>
305
306			Recursive remove cached data for directories under $startdir.
307
308			=cut
309
310	sashby	1.2	sub clean_cache_recursive()
311			{
312			my $self=shift;
313			my ($startdir) = @_;
314			my $children = $self->{DIRCACHE}->{$startdir};
315
316			for (my $i = 2; $i <= $#$children; $i++)
317			{
318			# Remove all children:
319			$self->schedremoval($children->[$i]);
320			$self->clean_cache_recursive($children->[$i]);
321			}
322
323			delete $self->{DIRCACHE}->{$startdir};
324			return $self;
325			}
326
327	sashby	1.6	=item C<dirtree($dir,$dofiles)>
328
329			Starting from $dir, scan the directory tree. Ignore files unless $dofiles is set. This
330			function just calls checktree().
331
332			=cut
333
334	sashby	1.2	sub dirtree()
335			{
336			my $self=shift;
337	muzaffar	1.7.2.2	my ($dir) = @_;
338	sashby	1.2
339			# Get the directory tree:
340	muzaffar	1.7.2.2	$self->checktree($dir, 1);
341	sashby	1.2	return $self;
342			}
343
344	sashby	1.6	=item C<checkfiles()>
345
346			Function to actually run the timestamp checks. This is only run from
347			SCRAM::CMD::build().
348
349			=cut
350
351	sashby	1.2	sub checkfiles()
352			{
353			my $self=shift;
354	muzaffar	1.7.2.2	$self->{cachereset}=shift \|\| 0;
355			$self->{convertxml}=shift \|\| 0;
356	sashby	1.2	# Scan config dir for top-level data, then start from src:
357	muzaffar	1.7.2.2	my @scandirs=($ENV{SCRAM_CONFIGDIR}, $ENV{SCRAM_SOURCEDIR});
358	sashby	1.2	# Loop over all directories that need scanning (normally just src and config):
359	muzaffar	1.7.2.2	if ($self->{convertxml})
360	sashby	1.2	{
361	muzaffar	1.7.2.2	eval ("use SCRAM::Doc2XML");
362			if (!$@)
363			{
364			$self->{convertxml} = SCRAM::Doc2XML->new();
365	sashby	1.2	}
366			else
367	muzaffar	1.7.2.2	{
368			print STDERR "**** WARNING: Can not convert $ENV{SCRAM_BUILDFILE} in to XML format. Missing SCRAM::Doc2XML perl module.\n";
369	sashby	1.2	}
370			}
371	muzaffar	1.7.2.2	$self->{nonxml}=0;
372			foreach my $scand (@scandirs)
373	sashby	1.2	{
374	muzaffar	1.7.2.2	$self->logmsg("SCRAM: Scanning $scand [dofiles set to ".$dofiles."]\n");
375			# Check the directory tree:
376			$self->dirtree($scand);
377			}
378			if ($self->cachestatus())
379			{
380			foreach my $bf ("$ENV{SCRAM_BUILDFILE}.xml","$ENV{SCRAM_BUILDFILE}")
381			{
382			if (exists $self->{BFCACHE}{"$ENV{SCRAM_CONFIGDIR}/${bf}"})
383			{
384			$self->{ADDEDBF}{"$ENV{SCRAM_CONFIGDIR}/${bf}"}=1;
385			last;
386			}
387	sashby	1.2	}
388			}
389	muzaffar	1.7.2.2	if ($self->{nonxml} > 0)
390	sashby	1.2	{
391	muzaffar	1.7.2.2	print STDERR "**** WARNING: ",$self->{nonxml}," non-xml based $ENV{SCRAM_BUILDFILE} were read.\n";
392	sashby	1.2	}
393			return $self;
394			}
395
396	sashby	1.6	=item C<dircache()>
397
398			Return a reference to the directory cache hash.
399
400			=cut
401
402	sashby	1.2	sub dircache()
403			{
404			my $self=shift;
405			# Return the file cache:
406			return $self->{DIRCACHE};
407			}
408
409	sashby	1.6	=item C<added_dirs($path)>
410
411			Add $path to the list of directories added since last scan, or return
412			the list of added directories if no argument given.
413
414			=cut
415
416	sashby	1.2	sub added_dirs()
417			{
418			my $self=shift;
419			my ($path) = @_;
420
421			# If we have a path to add, add it.
422			if ($path)
423			{
424			if (exists($self->{ADDEDDIRS}))
425			{
426			push(@{$self->{ADDEDDIRS}}, $path);
427			}
428			else
429			{
430			$self->{ADDEDDIRS} = [ $path ];
431			}
432			}
433			else
434			{
435			# Otherwise, return the array of added dirs:
436			my @addeddirs = @{$self->{ADDEDDIRS}};
437			delete $self->{ADDEDDIRS};
438			return \@addeddirs;
439			}
440			}
441
442	sashby	1.6	=item C<modified_parentdirs($path)>
443
444			Add a directory $path to the list of parent directories (directories
445			having subdirectories), or return a reference to the list.
446			Storing this parent allows any update to be taken recursively from this
447			location.
448
449			=cut
450
451	sashby	1.2	sub modified_parentdirs()
452			{
453			my $self=shift;
454			my ($path) = @_;
455
456			# If we have a path to add, add it.
457			# Don't bother if it's the main source dir as we don't
458			# want to rescan everything from src (that would be silly):
459			if ($path && $path ne $ENV{SCRAM_SOURCEDIR})
460			{
461			if (exists($self->{MODPARENTDIRS}))
462			{
463			push(@{$self->{MODPARENTDIRS}}, $path);
464			}
465			else
466			{
467			$self->{MODPARENTDIRS} = [ $path ];
468			}
469			}
470			else
471			{
472			# Otherwise, return the array of added dirs:
473			my @moddeddirs = @{$self->{MODPARENTDIRS}};
474			delete $self->{MODPARENTDIRS};
475			return \@moddeddirs;
476			}
477			}
478
479	sashby	1.6	=item C<schedremoval($d)>
480
481			Add directory $d to list of directories that should be removed
482			recursively from the cache.
483			If no arguments given, return a reference to a list of
484			directories to be removed.
485
486			=cut
487
488	sashby	1.2	sub schedremoval()
489			{
490			my $self=shift;
491			my ($d)=@_;
492
493			if ($d)
494			{
495			if (exists($self->{REMOVEDATA}))
496			{
497			push(@{$self->{REMOVEDATA}},$d);
498			}
499			else
500			{
501			$self->{REMOVEDATA} = [ $d ];
502			}
503			}
504			else
505			{
506			my $remove = [ @{$self->{REMOVEDATA}} ];
507			$self->{REMOVEDATA} = [];
508			return $remove;
509			}
510			}
511
512	sashby	1.6	=item C<filestatus()>
513
514			Return a true or false value depending on whether
515			a BuildFile was changed or not.
516
517			=cut
518
519	sashby	1.2	sub filestatus()
520			{
521			my $self=shift;
522			# Here we want to return a true or false value depending on whether
523			# or not a buildfile was changed:
524			return $self->{STATUSSRC};
525			}
526
527	sashby	1.6	=item C<configstatus()>
528
529			Return a true or false value depending on whether
530			a file in the config directory was changed or not.
531
532			=cut
533
534	sashby	1.2	sub configstatus()
535			{
536			my $self=shift;
537			# Here we want to return a true or false value depending on whether or not a file
538			# in config dir was changed:
539			return $self->{STATUSCONFIG};
540			}
541
542	sashby	1.6	=item C<bf_for_scanning()>
543
544			Return a list of BuildFiles to re-read. Note that this is only done
545			if the status was changed (i.e. not necessary to read through the list
546			of BuildFiles to know whether something changed as the flag B<STATUSSRC>
547			is set as the source tree is checked).
548			If B<STATUSCONFIG> is true, all BuildFiles are marked to be read.
549
550			=cut
551
552	sashby	1.2	sub bf_for_scanning()
553			{
554			my $self=shift;
555			my $MODIFIED = [];
556	muzaffar	1.7.2.2	map { push(@$MODIFIED, $_) } @{$self->{ADDEDBF}};
557	sashby	1.2	return $MODIFIED;
558			}
559
560	sashby	1.6	=item C<paths()>
561
562			Return a reference to an array of directories for the current source tree.
563
564			=cut
565
566	sashby	1.2	sub paths()
567			{
568			my $self=shift;
569			my $paths = {};
570
571	muzaffar	1.7.2.2	my $ALLDIRS = [];
572			map { push(@$ALLDIRS, $_) } keys %{$self->{DIRCACHE}};
573			return $ALLDIRS;
574	sashby	1.2	}
575
576	sashby	1.6	=item C<verbose()>
577
578			Turn verbosity for the cache on or off.
579
580			=cut
581
582	sashby	1.2	sub verbose()
583			{
584			my $self=shift;
585			# Turn on verbose mode:
586			@_ ? $self->{VERBOSE} = shift
587			: $self->{VERBOSE}
588			}
589
590	sashby	1.6	=item C<cachestatus()>
591
592			Set or return the cache status to indicate whether or not a file
593			timestamp has changed since the last pass.
594
595			=cut
596
597	sashby	1.2	sub cachestatus()
598			{
599			my $self=shift;
600			# Set/return the status of the cache:
601			@_ ? $self->{STATUS} = shift
602			: $self->{STATUS}
603			}
604
605	sashby	1.6	=item C<logmsg(@message)>
606
607			Print a message to B<STDERR>. This is only used in
608			checktree(), checkfiles() and paths().
609
610			=cut
611
612	sashby	1.2	sub logmsg()
613			{
614			my $self=shift;
615			# Print a message to STDOUT if VERBOSE is true:
616			print STDERR @_ if $self->verbose();
617			}
618
619	sashby	1.6	=item C<name()>
620
621			Set or return the name of the cache. Normally set
622			to B<DirCache.db> (and not architecture dependent).
623
624			=cut
625
626	sashby	1.2	sub name()
627			{
628			my $self=shift;
629			# Set/return the name of the cache to use:
630			@_ ? $self->{CACHENAME} = shift
631			: $self->{CACHENAME}
632			}
633
634	muzaffar	1.7.2.2	sub get_data()
635			{
636			my $self=shift;
637			my $type=shift;
638			@_ ? $self->{$type} = shift
639			: $self->{$type};
640			}
641
642			sub extra_suffix()
643			{
644			my $self=shift;
645			my $path=shift;
646			@_ ? $self->{EXTRASUFFIX}{$path}=shift
647			: exists $self->{EXTRASUFFIX}{$path};
648			}
649
650			sub get_nonxml()
651			{
652			my $self=shift;
653			return $self->{nonxml};
654			}
655
656	sashby	1.2	1;
657	sashby	1.5
658			=back
659
660			=head1 AUTHOR
661
662			Shaun Ashby (with contribution from Lassi Tuura)
663
664			=head1 MAINTAINER
665
666			Shaun Ashby
667
668			=cut
669