src/BuildSystem/TreeItem.pm

#____________________________________________________________________ 
# File: TreeItem.pm
#____________________________________________________________________ 
#  
# Author: Shaun Ashby <Shaun.Ashby@cern.ch>
# Update: 2004-06-24 12:24:57+0200
# Revision: $Id: TreeItem.pm,v 1.2 2004/12/10 13:41:38 sashby Exp $ 
#
# Copyright: 2004 (C) Shaun Ashby
#
#--------------------------------------------------------------------
package BuildSystem::TreeItem;
require 5.004;
use Exporter;
@ISA=qw(Exporter);
@EXPORT_OK=qw( );

sub new()
  ###############################################################
  # new                                                         #
  ###############################################################
  # modified : Thu Jun 24 12:25:02 2004 / SFA                   #
  # params   :                                                  #
  #          :                                                  #
  # function :                                                  #
  #          :                                                  #
  ###############################################################
  {
  my $proto=shift;
  my $class=ref($proto) || $proto;
  my $self={};
 
  bless $self,$class;
  $self->{METABF} = [];
  return $self;
  }

sub safepath()
   {
   my $self=shift;
   
   if ($self->{PATH})
      {
      # Make a safe path from our path:
      ($safepath = $self->{PATH}) =~ s|/|_|g;
      $self->{SAFEPATH} = $safepath;
      }

   # Return the safe version of the current path:
   return $self->{SAFEPATH};
   }

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

sub class()
   {
   my $self=shift;
   my ($class)=@_;
   # Set/return the part of the ClassPath that matched a template name.
   # Note that we store it as uppercase! The template name is, of course,
   # exactly as it appears in the ClassPath:
   if ($class)
      {
      # Store template name. We add the standard suffix:
      $self->template($class."_template.tmpl");
      $self->{CLASS} = uc($class);
      }
   else
      {
      return $self->{CLASS};
      }
   }

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

sub classdir()
   {
   my $self=shift;
   # Set/return the part of the ClassPath that matched:
   @_ ? $self->{CLASSDIR} = shift
      : $self->{CLASSDIR};
   }

sub suffix()
   {
   my $self=shift;
   # Set/return the part of the ClassPath that didn't match:
   @_ ? $self->{SUFFIX} = shift
      : $self->{SUFFIX};
   }

sub skip()
   {
   my $self=shift;
   # Skip/unskip a directory:
   @_ ? $self->{SKIP} = shift
      : $self->{SKIP};
   }

sub name()
   {
   my $self=shift;

   # Don't bother doing any work if the NAME exists already - just return it:
   if (! exists($self->{NAME}))
      {
      my $classdir = $self->{CLASSDIR}; # Make a copy for protection      
      # Here we want to return a name that can be used in the templates.
      # The name could be the name of the subsystem or the package:
      if ($self->{CLASS} eq 'PACKAGE')
         {
         ($self->{NAME}) = ($classdir =~ m|^.*/(.*)?$|);         
         }
      elsif ($self->{CLASS} eq 'SUBSYSTEM')
         {
         # We want the name of the subsystem:
         ($self->{NAME}) = ($classdir =~ m|^.*/(.*)?$|);
         }
      else
         {
         # Here we have a path that ends in src/bin/test/doc etc. (for real
         # build products). We still want to return the package name:
         ($self->{NAME}) = ($classdir =~ m|^.*/(.*)/.*?$|);
         }
      }
   else  
      {
      return $self->{NAME};
      }
   }

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

   if ($rawdata)
      {
      $self->{RAWDATA} = $rawdata;
      return $self;
      }
   else
      {      
      if (exists ($self->{RAWDATA}))
         {
         return $self->{RAWDATA};
         }
      else
         {
         return undef;
         }
      }
   }

sub parent()
   {
   my $self=shift;
   my ($datapath)=@_;
   my $thisloc;

   if ($datapath)
      {
      # We don't want to store the parent of src (it has no parent):
      if ($datapath eq $ENV{SCRAM_SOURCEDIR})
         {
         return;
         }
      
      # Given a path like a/b/c we want to return the parent a/b:
      ($thisloc) = ($datapath =~ m|^(.*)/.*?$|);

      if ($thisloc ne '')
         {
         $self->{PARENT} = $thisloc;
         }
      else
         {
         $self->{PARENT} = $ENV{SCRAM_SOURCEDIR};
         }
      }
   else
      {
      (exists ($self->{PARENT})) ? return $self->{PARENT} : '' ;
      }
   }

sub children()
   {
   my $self=shift;
   my ($filecache) = @_;
   my $safesubs=[];
   
   if ($filecache)
      {
      if (exists $filecache->{$self->{PATH}})
         {
         # Get array ref:
         my @subdirs=@{$filecache->{$self->{PATH}}};
         my $children=[];

         foreach my $SD (@subdirs)
            {
            # We don't want timestamps or CVS directories:
            if ($SD !~ /.*CVS/ && $SD !~ /^[0-9]+$/)
               {
               my $datapath;
               # We want to store the data paths for the children:
               ($datapath = $SD) =~ s|^\Q$ENV{SCRAM_SOURCEDIR}\L/||;
               push(@$children,$datapath);
               push(@$safesubs,$SD);
               }
            }
         
         # Store the children only if there were some:
         if ($#$children > -1)
            {
            $self->{CHILDREN} = $children;
            # Make safe versions of each subdir:
            $self->safesubdirs(@$safesubs);
            }
         }
      }
   else
      {
      (exists ($self->{CHILDREN})) ? return @{$self->{CHILDREN}} : undef ;
      }
   }

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

   if (@metabf)
      {      
      foreach my $mbf (@metabf)
         {
         if (! grep($mbf eq $_, @{$self->{METABF}})) # Remove duplicates!!
            {
            push(@{$self->{METABF}}, $mbf);
            }
         }
      }
   else
      {
      return $self->{METABF};
      }
   }

sub branchmetadata()
   {
   my $self=shift;
   my ($meta)=@_;

   # Method to store/retrieve data for complete branch:
   if ($meta)
      {
      # Delete unneeded entries:
      $meta->clean(qw( EXPORT DEFINED_GROUP CLASSPATH SKIPPEDDIRS ));
      $self->{BRANCHMETA} = $meta;
      }
   else
      {
      return $self->{BRANCHMETA};
      }
   }

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

sub clearmeta()
   {
   my $self=shift;
   delete $self->{BRANCHDATA}, if (exists $self->{BRANCHDATA});
   }

sub updatechildlist()
   {
   my $self=shift;
   my ($child)=@_;

   # Loop over list of children, removing the one specified:
   my $uchildren = [];
   my $uchilddirs = [];
   
   foreach my $c (@{$self->{CHILDREN}})
      {
      if ($c ne $child)
         {
         push(@$uchildren, $c);
         # Convert this datapath into a path to be converted to a safepath:
         push(@{$uchilddirs}, 'src/'.$c);
         }
      else
         {
         print "TreeItem: Removing $child from parents child list.","\n",if ($ENV{SCRAM_DEBUG});
         }
      }
   
   # Now store the new list of children:
   $self->{CHILDREN} = [ @$uchildren ];
   # Update the safe subdir names:
   $self->updatesafesubdirs(@$uchilddirs);   
   }

sub updatesafesubdirs()
   {
   my $self=shift;
   my (@subdirs)=@_;
   # Reset the SAFESUBDIRS to the list of subdirs given:
   delete $self->{SAFESUBDIRS};
   $self->safesubdirs(@subdirs);
   }

sub updateparentstatus()
   {
   my $self=shift;
   my ($child) = @_;

   # Add child to CHILDREN (check to make sure it isn't there already):
   if (exists($self->{CHILDREN}))
      {
      if (! grep($child eq $_, @{$self->{CHILDREN}})) # Remove duplicates!!
         {
         push(@{$self->{CHILDREN}},$child);
         }
      }
   else
      {
      $self->{CHILDREN} = [ $child ];
      }

   # Add the SAFESUBDIRS:
   my $safedir = [ 'src/'.$child ];
   $self->safesubdirs(@$safedir);
   }

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

sub safesubdirs()
   {
   my $self=shift;
   my (@subdirs)=@_;
   
   if (@subdirs)
      {      
      # If we already have SAFESUBDIRS, add to them, don't overwrite:
      if (exists($self->{SAFESUBDIRS}))
         {
         # Store the safe paths of all the children:
         foreach my $sd (@subdirs)
            {
            $sd =~ s|/|_|g;
            if (! grep($sd eq $_, @{$self->{SAFESUBDIRS}})) # Remove duplicates!!
               {
               push(@{$self->{SAFESUBDIRS}}, $sd);
               }
            }
         }
      else
         {
         my $safesubs=[];
         map {$_ =~ s|/|_|g; push(@$safesubs, $_)} @subdirs;
         $self->{SAFESUBDIRS} = $safesubs;
         }
      }
   else
      {
      # Return formatted as a string:
      return join(" ",@{$self->{SAFESUBDIRS}});
      }
   }

sub scramprojectbases()
   {
   my $self=shift;
   # This is needed at project level only:
   @_ ? $self->{SCRAM_PROJECT_BASES} = shift
      : $self->{SCRAM_PROJECT_BASES};
   }

sub clean()
   {
   my $self=shift;
   delete $self->{BRANCHMETA};
   }

1;
Revision:	1.3
Committed:	Wed Mar 9 19:28:20 2005 UTC (20 years, 2 months ago) by sashby
Content type:	text/plain
Branch:	MAIN
CVS Tags:	v102p1, V1_0_1
Changes since 1.2:	+11 -3 lines
Log Message:	Started adding support for skipping builds in some dirs.
#	User	Rev	Content
1	sashby	1.2	#____________________________________________________________________
2			# File: TreeItem.pm
3			#____________________________________________________________________
4			#
5			# Author: Shaun Ashby <Shaun.Ashby@cern.ch>
6			# Update: 2004-06-24 12:24:57+0200
7	sashby	1.3	# Revision: $Id: TreeItem.pm,v 1.2 2004/12/10 13:41:38 sashby Exp $
8	sashby	1.2	#
9			# Copyright: 2004 (C) Shaun Ashby
10			#
11			#--------------------------------------------------------------------
12			package BuildSystem::TreeItem;
13			require 5.004;
14			use Exporter;
15			@ISA=qw(Exporter);
16			@EXPORT_OK=qw( );
17
18			sub new()
19			###############################################################
20			# new #
21			###############################################################
22			# modified : Thu Jun 24 12:25:02 2004 / SFA #
23			# params : #
24			# : #
25			# function : #
26			# : #
27			###############################################################
28			{
29			my $proto=shift;
30			my $class=ref($proto) \|\| $proto;
31			my $self={};
32
33			bless $self,$class;
34			$self->{METABF} = [];
35			return $self;
36			}
37
38			sub safepath()
39			{
40			my $self=shift;
41
42			if ($self->{PATH})
43			{
44			# Make a safe path from our path:
45			($safepath = $self->{PATH}) =~ s\|/\|_\|g;
46			$self->{SAFEPATH} = $safepath;
47			}
48
49			# Return the safe version of the current path:
50			return $self->{SAFEPATH};
51			}
52
53			sub path()
54			{
55			my $self=shift;
56			@_ ? $self->{PATH} = shift
57			: $self->{PATH};
58			}
59
60			sub class()
61			{
62			my $self=shift;
63			my ($class)=@_;
64			# Set/return the part of the ClassPath that matched a template name.
65			# Note that we store it as uppercase! The template name is, of course,
66			# exactly as it appears in the ClassPath:
67			if ($class)
68			{
69			# Store template name. We add the standard suffix:
70			$self->template($class."_template.tmpl");
71			$self->{CLASS} = uc($class);
72			}
73			else
74			{
75			return $self->{CLASS};
76			}
77			}
78
79			sub template()
80			{
81			my $self=shift;
82			@_ ? $self->{TEMPLATE} = shift
83			: $self->{TEMPLATE};
84			}
85
86			sub classdir()
87			{
88			my $self=shift;
89			# Set/return the part of the ClassPath that matched:
90			@_ ? $self->{CLASSDIR} = shift
91			: $self->{CLASSDIR};
92			}
93
94			sub suffix()
95			{
96			my $self=shift;
97			# Set/return the part of the ClassPath that didn't match:
98			@_ ? $self->{SUFFIX} = shift
99			: $self->{SUFFIX};
100			}
101
102	sashby	1.3	sub skip()
103			{
104			my $self=shift;
105			# Skip/unskip a directory:
106			@_ ? $self->{SKIP} = shift
107			: $self->{SKIP};
108			}
109
110	sashby	1.2	sub name()
111			{
112			my $self=shift;
113
114			# Don't bother doing any work if the NAME exists already - just return it:
115			if (! exists($self->{NAME}))
116			{
117			my $classdir = $self->{CLASSDIR}; # Make a copy for protection
118			# Here we want to return a name that can be used in the templates.
119			# The name could be the name of the subsystem or the package:
120			if ($self->{CLASS} eq 'PACKAGE')
121			{
122			($self->{NAME}) = ($classdir =~ m\|^./(.)?$\|);
123			}
124			elsif ($self->{CLASS} eq 'SUBSYSTEM')
125			{
126			# We want the name of the subsystem:
127			($self->{NAME}) = ($classdir =~ m\|^./(.)?$\|);
128			}
129			else
130			{
131			# Here we have a path that ends in src/bin/test/doc etc. (for real
132			# build products). We still want to return the package name:
133			($self->{NAME}) = ($classdir =~ m\|^./(.)/.*?$\|);
134			}
135			}
136			else
137			{
138			return $self->{NAME};
139			}
140			}
141
142			sub rawdata()
143			{
144			my $self=shift;
145			my ($rawdata)=@_;
146	sashby	1.3
147	sashby	1.2	if ($rawdata)
148			{
149			$self->{RAWDATA} = $rawdata;
150			return $self;
151			}
152			else
153			{
154			if (exists ($self->{RAWDATA}))
155			{
156			return $self->{RAWDATA};
157			}
158			else
159			{
160			return undef;
161			}
162			}
163			}
164
165			sub parent()
166			{
167			my $self=shift;
168			my ($datapath)=@_;
169			my $thisloc;
170
171			if ($datapath)
172			{
173			# We don't want to store the parent of src (it has no parent):
174			if ($datapath eq $ENV{SCRAM_SOURCEDIR})
175			{
176			return;
177			}
178
179			# Given a path like a/b/c we want to return the parent a/b:
180			($thisloc) = ($datapath =~ m\|^(.)/.?$\|);
181
182			if ($thisloc ne '')
183			{
184			$self->{PARENT} = $thisloc;
185			}
186			else
187			{
188			$self->{PARENT} = $ENV{SCRAM_SOURCEDIR};
189			}
190			}
191			else
192			{
193			(exists ($self->{PARENT})) ? return $self->{PARENT} : '' ;
194			}
195			}
196
197			sub children()
198			{
199			my $self=shift;
200			my ($filecache) = @_;
201			my $safesubs=[];
202
203			if ($filecache)
204			{
205			if (exists $filecache->{$self->{PATH}})
206			{
207			# Get array ref:
208			my @subdirs=@{$filecache->{$self->{PATH}}};
209			my $children=[];
210
211			foreach my $SD (@subdirs)
212			{
213			# We don't want timestamps or CVS directories:
214			if ($SD !~ /.*CVS/ && $SD !~ /^[0-9]+$/)
215			{
216			my $datapath;
217			# We want to store the data paths for the children:
218			($datapath = $SD) =~ s\|^\Q$ENV{SCRAM_SOURCEDIR}\L/\|\|;
219			push(@$children,$datapath);
220			push(@$safesubs,$SD);
221			}
222			}
223
224			# Store the children only if there were some:
225			if ($#$children > -1)
226			{
227			$self->{CHILDREN} = $children;
228			# Make safe versions of each subdir:
229			$self->safesubdirs(@$safesubs);
230			}
231			}
232			}
233			else
234			{
235			(exists ($self->{CHILDREN})) ? return @{$self->{CHILDREN}} : undef ;
236			}
237			}
238
239			sub metabf()
240			{
241			my $self=shift;
242			my (@metabf) = @_;
243
244			if (@metabf)
245			{
246			foreach my $mbf (@metabf)
247			{
248			if (! grep($mbf eq $_, @{$self->{METABF}})) # Remove duplicates!!
249			{
250			push(@{$self->{METABF}}, $mbf);
251			}
252			}
253			}
254			else
255			{
256			return $self->{METABF};
257			}
258			}
259
260			sub branchmetadata()
261			{
262			my $self=shift;
263			my ($meta)=@_;
264
265			# Method to store/retrieve data for complete branch:
266			if ($meta)
267			{
268			# Delete unneeded entries:
269	sashby	1.3	$meta->clean(qw( EXPORT DEFINED_GROUP CLASSPATH SKIPPEDDIRS ));
270	sashby	1.2	$self->{BRANCHMETA} = $meta;
271			}
272			else
273			{
274			return $self->{BRANCHMETA};
275			}
276			}
277
278			sub branchdata()
279			{
280			my $self=shift;
281			@_ ? $self->{BRANCHDATA} = shift
282			: $self->{BRANCHDATA};
283			}
284
285			sub clearmeta()
286			{
287			my $self=shift;
288			delete $self->{BRANCHDATA}, if (exists $self->{BRANCHDATA});
289			}
290
291			sub updatechildlist()
292			{
293			my $self=shift;
294			my ($child)=@_;
295
296			# Loop over list of children, removing the one specified:
297			my $uchildren = [];
298			my $uchilddirs = [];
299
300			foreach my $c (@{$self->{CHILDREN}})
301			{
302			if ($c ne $child)
303			{
304			push(@$uchildren, $c);
305			# Convert this datapath into a path to be converted to a safepath:
306			push(@{$uchilddirs}, 'src/'.$c);
307			}
308			else
309			{
310			print "TreeItem: Removing $child from parents child list.","\n",if ($ENV{SCRAM_DEBUG});
311			}
312			}
313
314			# Now store the new list of children:
315			$self->{CHILDREN} = [ @$uchildren ];
316			# Update the safe subdir names:
317			$self->updatesafesubdirs(@$uchilddirs);
318			}
319
320			sub updatesafesubdirs()
321			{
322			my $self=shift;
323			my (@subdirs)=@_;
324			# Reset the SAFESUBDIRS to the list of subdirs given:
325			delete $self->{SAFESUBDIRS};
326			$self->safesubdirs(@subdirs);
327			}
328
329			sub updateparentstatus()
330			{
331			my $self=shift;
332			my ($child) = @_;
333
334			# Add child to CHILDREN (check to make sure it isn't there already):
335			if (exists($self->{CHILDREN}))
336			{
337			if (! grep($child eq $_, @{$self->{CHILDREN}})) # Remove duplicates!!
338			{
339			push(@{$self->{CHILDREN}},$child);
340			}
341			}
342			else
343			{
344			$self->{CHILDREN} = [ $child ];
345			}
346
347			# Add the SAFESUBDIRS:
348			my $safedir = [ 'src/'.$child ];
349			$self->safesubdirs(@$safedir);
350			}
351
352			sub template()
353			{
354			my $self=shift;
355			@_ ? $self->{TEMPLATE} = shift
356			: $self->{TEMPLATE};
357			}
358
359			sub safesubdirs()
360			{
361			my $self=shift;
362			my (@subdirs)=@_;
363
364			if (@subdirs)
365			{
366			# If we already have SAFESUBDIRS, add to them, don't overwrite:
367			if (exists($self->{SAFESUBDIRS}))
368			{
369			# Store the safe paths of all the children:
370			foreach my $sd (@subdirs)
371			{
372			$sd =~ s\|/\|_\|g;
373			if (! grep($sd eq $_, @{$self->{SAFESUBDIRS}})) # Remove duplicates!!
374			{
375			push(@{$self->{SAFESUBDIRS}}, $sd);
376			}
377			}
378			}
379			else
380			{
381			my $safesubs=[];
382			map {$_ =~ s\|/\|_\|g; push(@$safesubs, $_)} @subdirs;
383			$self->{SAFESUBDIRS} = $safesubs;
384			}
385			}
386			else
387			{
388			# Return formatted as a string:
389			return join(" ",@{$self->{SAFESUBDIRS}});
390			}
391			}
392
393			sub scramprojectbases()
394			{
395			my $self=shift;
396			# This is needed at project level only:
397			@_ ? $self->{SCRAM_PROJECT_BASES} = shift
398			: $self->{SCRAM_PROJECT_BASES};
399			}
400
401			sub clean()
402			{
403			my $self=shift;
404			delete $self->{BRANCHMETA};
405			}
406
407			1;