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.3 2005/03/09 19:28:20 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|^.*/(.*)?$|);
         }
      elsif ($self->{CLASS} eq 'DOMAIN')
         {
         # We want the name of the domain:
         ($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.4
Committed:	Tue May 24 09:09:42 2005 UTC (19 years, 11 months ago) by sashby
Content type:	text/plain
Branch:	MAIN
CVS Tags:	V1_0_3-p4, V1_0_3-p3, V1_0_3-p2, V1_1_0, v110p1, V110p6, V110p5, V110p4, V110p3, before110xmlBRmerge, V110p2, V110p1, V1_0_4p1, V1_0_3-p1, V1_0_3, V1_0_2, V1_0_2_p1
Branch point for:	v200branch, v103_with_xml, v103_branch
Changes since 1.3:	+6 -1 lines
Log Message:	* empty log message *
#	Content
1	#____________________________________________________________________
2	# File: TreeItem.pm
3	#____________________________________________________________________
4	#
5	# Author: Shaun Ashby <Shaun.Ashby@cern.ch>
6	# Update: 2004-06-24 12:24:57+0200
7	# Revision: $Id: TreeItem.pm,v 1.3 2005/03/09 19:28:20 sashby Exp $
8	#
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	sub skip()
103	{
104	my $self=shift;
105	# Skip/unskip a directory:
106	@_ ? $self->{SKIP} = shift
107	: $self->{SKIP};
108	}
109
110	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	elsif ($self->{CLASS} eq 'DOMAIN')
130	{
131	# We want the name of the domain:
132	($self->{NAME}) = ($classdir =~ m\|^./(.)?$\|);
133	}
134	else
135	{
136	# Here we have a path that ends in src/bin/test/doc etc. (for real
137	# build products). We still want to return the package name:
138	($self->{NAME}) = ($classdir =~ m\|^./(.)/.*?$\|);
139	}
140	}
141	else
142	{
143	return $self->{NAME};
144	}
145	}
146
147	sub rawdata()
148	{
149	my $self=shift;
150	my ($rawdata)=@_;
151
152	if ($rawdata)
153	{
154	$self->{RAWDATA} = $rawdata;
155	return $self;
156	}
157	else
158	{
159	if (exists ($self->{RAWDATA}))
160	{
161	return $self->{RAWDATA};
162	}
163	else
164	{
165	return undef;
166	}
167	}
168	}
169
170	sub parent()
171	{
172	my $self=shift;
173	my ($datapath)=@_;
174	my $thisloc;
175
176	if ($datapath)
177	{
178	# We don't want to store the parent of src (it has no parent):
179	if ($datapath eq $ENV{SCRAM_SOURCEDIR})
180	{
181	return;
182	}
183
184	# Given a path like a/b/c we want to return the parent a/b:
185	($thisloc) = ($datapath =~ m\|^(.)/.?$\|);
186
187	if ($thisloc ne '')
188	{
189	$self->{PARENT} = $thisloc;
190	}
191	else
192	{
193	$self->{PARENT} = $ENV{SCRAM_SOURCEDIR};
194	}
195	}
196	else
197	{
198	(exists ($self->{PARENT})) ? return $self->{PARENT} : '' ;
199	}
200	}
201
202	sub children()
203	{
204	my $self=shift;
205	my ($filecache) = @_;
206	my $safesubs=[];
207
208	if ($filecache)
209	{
210	if (exists $filecache->{$self->{PATH}})
211	{
212	# Get array ref:
213	my @subdirs=@{$filecache->{$self->{PATH}}};
214	my $children=[];
215
216	foreach my $SD (@subdirs)
217	{
218	# We don't want timestamps or CVS directories:
219	if ($SD !~ /.*CVS/ && $SD !~ /^[0-9]+$/)
220	{
221	my $datapath;
222	# We want to store the data paths for the children:
223	($datapath = $SD) =~ s\|^\Q$ENV{SCRAM_SOURCEDIR}\L/\|\|;
224	push(@$children,$datapath);
225	push(@$safesubs,$SD);
226	}
227	}
228
229	# Store the children only if there were some:
230	if ($#$children > -1)
231	{
232	$self->{CHILDREN} = $children;
233	# Make safe versions of each subdir:
234	$self->safesubdirs(@$safesubs);
235	}
236	}
237	}
238	else
239	{
240	(exists ($self->{CHILDREN})) ? return @{$self->{CHILDREN}} : undef ;
241	}
242	}
243
244	sub metabf()
245	{
246	my $self=shift;
247	my (@metabf) = @_;
248
249	if (@metabf)
250	{
251	foreach my $mbf (@metabf)
252	{
253	if (! grep($mbf eq $_, @{$self->{METABF}})) # Remove duplicates!!
254	{
255	push(@{$self->{METABF}}, $mbf);
256	}
257	}
258	}
259	else
260	{
261	return $self->{METABF};
262	}
263	}
264
265	sub branchmetadata()
266	{
267	my $self=shift;
268	my ($meta)=@_;
269
270	# Method to store/retrieve data for complete branch:
271	if ($meta)
272	{
273	# Delete unneeded entries:
274	$meta->clean(qw( EXPORT DEFINED_GROUP CLASSPATH SKIPPEDDIRS ));
275	$self->{BRANCHMETA} = $meta;
276	}
277	else
278	{
279	return $self->{BRANCHMETA};
280	}
281	}
282
283	sub branchdata()
284	{
285	my $self=shift;
286	@_ ? $self->{BRANCHDATA} = shift
287	: $self->{BRANCHDATA};
288	}
289
290	sub clearmeta()
291	{
292	my $self=shift;
293	delete $self->{BRANCHDATA}, if (exists $self->{BRANCHDATA});
294	}
295
296	sub updatechildlist()
297	{
298	my $self=shift;
299	my ($child)=@_;
300
301	# Loop over list of children, removing the one specified:
302	my $uchildren = [];
303	my $uchilddirs = [];
304
305	foreach my $c (@{$self->{CHILDREN}})
306	{
307	if ($c ne $child)
308	{
309	push(@$uchildren, $c);
310	# Convert this datapath into a path to be converted to a safepath:
311	push(@{$uchilddirs}, 'src/'.$c);
312	}
313	else
314	{
315	print "TreeItem: Removing $child from parents child list.","\n",if ($ENV{SCRAM_DEBUG});
316	}
317	}
318
319	# Now store the new list of children:
320	$self->{CHILDREN} = [ @$uchildren ];
321	# Update the safe subdir names:
322	$self->updatesafesubdirs(@$uchilddirs);
323	}
324
325	sub updatesafesubdirs()
326	{
327	my $self=shift;
328	my (@subdirs)=@_;
329	# Reset the SAFESUBDIRS to the list of subdirs given:
330	delete $self->{SAFESUBDIRS};
331	$self->safesubdirs(@subdirs);
332	}
333
334	sub updateparentstatus()
335	{
336	my $self=shift;
337	my ($child) = @_;
338
339	# Add child to CHILDREN (check to make sure it isn't there already):
340	if (exists($self->{CHILDREN}))
341	{
342	if (! grep($child eq $_, @{$self->{CHILDREN}})) # Remove duplicates!!
343	{
344	push(@{$self->{CHILDREN}},$child);
345	}
346	}
347	else
348	{
349	$self->{CHILDREN} = [ $child ];
350	}
351
352	# Add the SAFESUBDIRS:
353	my $safedir = [ 'src/'.$child ];
354	$self->safesubdirs(@$safedir);
355	}
356
357	sub template()
358	{
359	my $self=shift;
360	@_ ? $self->{TEMPLATE} = shift
361	: $self->{TEMPLATE};
362	}
363
364	sub safesubdirs()
365	{
366	my $self=shift;
367	my (@subdirs)=@_;
368
369	if (@subdirs)
370	{
371	# If we already have SAFESUBDIRS, add to them, don't overwrite:
372	if (exists($self->{SAFESUBDIRS}))
373	{
374	# Store the safe paths of all the children:
375	foreach my $sd (@subdirs)
376	{
377	$sd =~ s\|/\|_\|g;
378	if (! grep($sd eq $_, @{$self->{SAFESUBDIRS}})) # Remove duplicates!!
379	{
380	push(@{$self->{SAFESUBDIRS}}, $sd);
381	}
382	}
383	}
384	else
385	{
386	my $safesubs=[];
387	map {$_ =~ s\|/\|_\|g; push(@$safesubs, $_)} @subdirs;
388	$self->{SAFESUBDIRS} = $safesubs;
389	}
390	}
391	else
392	{
393	# Return formatted as a string:
394	return join(" ",@{$self->{SAFESUBDIRS}});
395	}
396	}
397
398	sub scramprojectbases()
399	{
400	my $self=shift;
401	# This is needed at project level only:
402	@_ ? $self->{SCRAM_PROJECT_BASES} = shift
403	: $self->{SCRAM_PROJECT_BASES};
404	}
405
406	sub clean()
407	{
408	my $self=shift;
409	delete $self->{BRANCHMETA};
410	}
411
412	1;