src/BuildSystem/XMLReqUtils.pm

#____________________________________________________________________ 
# File: XMLReqUtils.pm
#____________________________________________________________________ 
#  
# Author: Shaun ASHBY <Shaun.Ashby@cern.ch>
# Update: 2005-07-26 14:58:38+0200
# Revision: $Id: XMLReqUtils.pm,v 1.1.4.1 2007/01/24 13:24:35 sashby Exp $ 
#
# Copyright: 2005 (C) Shaun ASHBY
#
#--------------------------------------------------------------------
package BuildSystem::XMLReqUtils;

BEGIN
   {
   die "\n\n".__PACKAGE__.": this package can be dropped from releases.\n\n";
   }

require 5.004;

use Exporter;

@ISA=qw(Exporter);
@EXPORT_OK=qw( );

# This package provides all subroutines for supported tags found
# in requirements docs:
sub new
  {
  my $proto=shift;
  my $class=ref($proto) || $proto;
  my $self={};
              
  bless $self,$class;
  return $self;
  }

#### Core XML Register Functions ####
sub OpenTagHandler()
   {
   my $xmlparser=shift;
   my ($element, %attributes)=@_;

   # Elementary doc checks:
   if ($element eq 'doc')
      {
      if ($attributes{'type'} ne 'Requirements')
         {
         die "SCRAM Error: Unable to parse this document! Wrong type!","\n";
         }
      return;
      }
   
   # Store the name of the current tag environment:
   $self->{currentenv} = $element;
   $self->simplexmldoc()->checkattributes($element, \%attributes);
   &{$self->simplexmldoc()->gettagfunction($element)}($element, \%attributes);
   }

sub ClosingTagHandler()
   {
   my $xmlparser=shift;
   my ($element)=@_;

   if ($element eq 'doc')
      {
      return;
      }
   
   if (grep($element eq $_, @{$self->simplexmldoc()->nested()}))
      {
      &{$self->simplexmldoc()->gettagfunction($element)}($element, {}, 1);
      }
   
   # Reset the current env (i.e. delete entry):
   delete $self->{currentenv};
   }

sub CharHandler()
   {
   my ($xmlparser, @items) = @_;
   return if ($items[0] =~ /\s*/);

   # Check to see if there's a content entry in $self
   # for the current tag. If so, append the line to it:
   if (grep($self->{currentenv} eq $_, @{$self->simplexmldoc()->nested()}))
      {
      &{$self->simplexmldoc()->gettagfunction($self->{currentenv})}($self->{currentenv},
                                                                       {}, 2, [ @items ]);
      }
   }

## Tag routines ##
sub requirementstaghandler()
   {
   my ($name, $hashref, $nesting) = @_;
   # Do nothing for char handler:
   return if ($nesting == 2);
   
   if ($nesting == 1)
      {
      # Cleanup whatever needs to be cleaned up:
      
      }   
   else
      {
         
      }
   
   # Return here only if the current element is "requirements":
   return;
   }

sub usetaghandler()
   {
   my ($name, $hashref) = @_;
   push(@{$self->{"$self->{levels}->[$self->{nested}]".content}->{USE}},$$hashref{'name'});
   }

sub libtaghandler()
   {
   my ($name, $hashref) = @_;
   push(@{$self->{"$self->{levels}->[$self->{nested}]".content}->{LIB}},$$hashref{'name'});   
   }

sub infotaghandler()
   {
   my ($name, $hashref) = @_;
   $self->{"$self->{levels}->[$self->{nested}]".content}->{INFO} = $hashref;
   }

sub flagstaghandler()
   {
   my ($name, $hashref, $nesting) = @_;
   # Do nothing for char handler:
   return if ($nesting == 2);
   # Do nothing for closing tag handler:
   return if ($nesting == 1);
   
   # Extract the flag name and its value:
   my ($flagname,$flagvaluestring) = each %{$hashref};
   $flagname =~ tr/[a-z]/[A-Z]/; # Keep flag name uppercase
   chomp($flagvaluestring);
   # Split the value on whitespace so we can push all
   # individual flags into an array:
   my @flagvalues = split(' ',$flagvaluestring);

   # Is current tag within another tag block?
   if ($self->{nested} > 0)
      {
      # Check to see if the current flag name is already stored in the hash. If so,
      # just add the new values to the array of flag values:
      if (exists ($self->{"$self->{levels}->[$self->{nested}]".content}->{FLAGS}->{$flagname}))
         {
         push(@{$self->{"$self->{levels}->[$self->{nested}]".content}->{FLAGS}->{$flagname}},@flagvalues);
         }
      else
         {
         $self->{"$self->{levels}->[$self->{nested}]".content}->{FLAGS}->{$flagname} = [ @flagvalues ];
         }
      }
   else
      {
      if (exists ($self->{content}->{FLAGS}->{$flagname}))
         {
         push(@{$self->{content}->{FLAGS}->{$flagname}},@flagvalues);
         }
      else
         {
         $self->{content}->{FLAGS}->{$flagname} = [ @flagvalues ];
         }
      }
   }

sub environmenttaghandler()
   {
   my ($name, $hashref, $nesting) = @_;
   # Do nothing for char handler:
   return if ($nesting == 2);
   # Do nothing for closing tag handler:
   return if ($nesting == 1);

   # Save a copy of the name of this environment:
   my $envname=$$hashref{'name'};
   delete $$hashref{'name'}; # Delete name entry so hash is more tidy
   # Break the value/default value into its constituent parts:
   foreach my $t (qw(value default))
      {
      if (exists ($$hashref{$t}))
         {
         $hashref->{ELEMENTS} = [];
         map
            {
            if ($_ =~ m|\$(.*)?|)
               {
               push(@{$hashref->{ELEMENTS}},$1);
               }
            } split("/",$hashref->{$t});
         }
      }

   # Before we save $hashref we need to know if there are already
   # any env tags with the same name. If there are, we must save all
   # data to an aray of hashes:
   if (exists ($self->{"$self->{levels}->[$self->{nested}]".content}->{ENVIRONMENT}->{$envname}))
      {
      push(@{$self->{"$self->{levels}->[$self->{nested}]".content}->{ENVIRONMENT}->{$envname}},$hashref);
      }
   else
      {
      # No entry yet so just store the hashref:
      $self->{"$self->{levels}->[$self->{nested}]".content}->{ENVIRONMENT}->{$envname} = [ $hashref ];
      }
   }

sub runtimetaghandler()
   {
   my ($name, $hashref, $nesting) = @_;
   # Do nothing for char handler:
   return if ($nesting == 2);
   # Do nothing for closing tag handler:
   return if ($nesting == 1);

   my $envname;
   
   # Break the value/default value into its constituent parts:
   foreach my $t (qw(value default))
      {
      if (exists ($$hashref{$t}))
         {
         $hashref->{ELEMENTS} = [];
         map
            {
            # In some cases, we might set a runtime path (e.g. LD_LIBRARY_PATH) to
            # a proper path value i.e. X:Y. In this case, don't bother adding the string
            # as a "variable" to ELEMENTS:
            if ($_ =~ m|\$(.*)?| && $_ !~ /:/) 
               {
               push(@{$hashref->{ELEMENTS}},$1);
               }
            } split("/",$hashref->{$t});
         }
      }
   
   # Check to see if we have a "type" arg. If so, we use this to create the key:
   if (exists ($hashref->{'type'}))
      {
      my $type=$hashref->{'type'};
      # Make the type uppercase:
      $type =~ tr/[a-z]/[A-Z]/;
      # Rename the environment as "<type>:<env name>":
      $envname = $type.":".$$hashref{'name'};
      }
   else
      {
      $envname = $$hashref{'name'};
      }
   
   # Delete name entry so hash is more tidy
   delete $$hashref{'name'};
   
   # Before we save $hashref we need to know if there are already
   # any runtime tags with the same name. If there are, we must save all
   # data to an aray of hashes:
   if (exists ($self->{"$self->{levels}->[$self->{nested}]".content}->{RUNTIME}->{$envname}))
      {
      push(@{$self->{"$self->{levels}->[$self->{nested}]".content}->{RUNTIME}->{$envname}},$hashref);
      }
   else
      {
      # No entry yet so just store the hashref:
      $self->{"$self->{levels}->[$self->{nested}]".content}->{RUNTIME}->{$envname} = [ $hashref ];
      }
   }

sub makefiletaghandler()
   {
   my ($name, $hashref, $nesting, $string)=@_;
   
   if ($nesting == 1)
      {
      push(@{$self->{"$self->{levels}->[$self->{nested}]".content}->{MAKEFILE}},
           join('',@{$self->{makefilecontent}}));
      delete $self->{makefilecontent};
      }
   elsif ($nesting == 2)
      {
      # Store the text content:
      push(@{$self->{makefilecontent}}, @$string);
      }
   else
      {
      # Start the tag:
      $self->{makefilecontent} = [];
      }
   }

sub clienttaghandler()
   {
   my ($name, $hashref, $nesting) = @_;
   # Do nothing for char handler:
   return if ($nesting == 2);
   
   if ($nesting == 1)
      {
      if ($self->{isarch} == 1)
         {
         # If we already have an architecture tag, we must write to tagcontent hash:
         $self->{tagcontent}->{CLIENT}=$self->{nexttagcontent};
         delete $self->{nexttagcontent};
         }
      else
         {
         $self->{content}->{CLIENT}=$self->{tagcontent};
         }
      
      $self->poplevel();
      }
   else
      {
      $self->pushlevel();
      }
   }

sub archtaghandler()
   {
   my ($name, $hashref, $nesting) = @_;
   # Do nothing for char handler:
   return if ($nesting == 2);

   if ($nesting == 1)
      {
      # Need to be able to cope with multiple arch blocks with same arch string:
      if (exists ($self->{content}->{ARCH}->{$self->{id}->{'name'}}))
         {
         # Already have an architecture tag for this arch:
         while (my ($k,$v) = each %{$self->{tagcontent}})
            {
            # If this tag (e.g. LIB, USE, MAKEFILE) already exists and (as we know
            # it should be) its data is an ARRAY, push it to the store:
            if (exists ($self->{content}->{ARCH}->{$self->{id}->{'name'}}->{$k}) && 
                ref($v) eq 'ARRAY')
               {
               push(@{$self->{content}->{ARCH}->{$self->{id}->{'name'}}->{$k}},@$v);
               }
            else
               {
               # Otherwise (for HASH data) we just store it. Note that, because we do
               # not loop over the HASH content and check for already existsing keys,
               # if two arch blocks with same arch name define the same tag (e.g, ENV),
               # the last occurrence will be kept (i.e. the two values won't be added
               # to one ENV hash): //FIXME for later....
               $self->{content}->{ARCH}->{$self->{id}->{'name'}}->{$k} = $v;
               }
            }
         }
      else
         {
         $self->{content}->{ARCH}->{$self->{id}->{'name'}}=$self->{tagcontent};
         }
      
      delete $self->{isarch};
      $self->poplevel();            
      }
   else
      {
      $self->pushlevel($hashref, 1); # Set nested to 1;
      }
   }

# Data-handling utility functions:
sub datastore()
   {
   my $obj=shift;
   $self = $obj;
   }

1;
Revision:	1.4
Committed:	Fri Dec 14 09:03:49 2007 UTC (17 years, 4 months ago) by muzaffar
Content type:	text/plain
Branch:	MAIN
CVS Tags:	V1_1_7, V1_1_6, V1_1_5, V1_1_4, V1_1_3, V1_1_2, V1_1_0_reltag8, V1_1_0_reltag7, V1_1_0_reltag6, V1_1_1, V1_1_0_reltag5, V1_1_0_reltag4, V1_1_0_reltag3, V1_1_0_reltag2, V1_1_0_reltag1, V1_1_0_reltag, V1_1_0, V1_1_0_cand3, V1_1_0_cand2, V1_1_0_cand1
Branch point for:	forBinLess_SCRAM
Changes since 1.3:	+1 -1 lines
Log Message:	replace head with xml branch
#	User	Rev	Content
1	sashby	1.1	#____________________________________________________________________
2			# File: XMLReqUtils.pm
3			#____________________________________________________________________
4			#
5			# Author: Shaun ASHBY <Shaun.Ashby@cern.ch>
6			# Update: 2005-07-26 14:58:38+0200
7	muzaffar	1.4	# Revision: $Id: XMLReqUtils.pm,v 1.1.4.1 2007/01/24 13:24:35 sashby Exp $
8	sashby	1.1	#
9			# Copyright: 2005 (C) Shaun ASHBY
10			#
11			#--------------------------------------------------------------------
12			package BuildSystem::XMLReqUtils;
13	sashby	1.2
14			BEGIN
15			{
16			die "\n\n".__PACKAGE__.": this package can be dropped from releases.\n\n";
17			}
18
19	sashby	1.1	require 5.004;
20
21			use Exporter;
22
23			@ISA=qw(Exporter);
24			@EXPORT_OK=qw( );
25
26			# This package provides all subroutines for supported tags found
27			# in requirements docs:
28			sub new
29			{
30			my $proto=shift;
31			my $class=ref($proto) \|\| $proto;
32			my $self={};
33
34			bless $self,$class;
35			return $self;
36			}
37
38			#### Core XML Register Functions ####
39			sub OpenTagHandler()
40			{
41			my $xmlparser=shift;
42			my ($element, %attributes)=@_;
43
44			# Elementary doc checks:
45			if ($element eq 'doc')
46			{
47			if ($attributes{'type'} ne 'Requirements')
48			{
49			die "SCRAM Error: Unable to parse this document! Wrong type!","\n";
50			}
51			return;
52			}
53
54			# Store the name of the current tag environment:
55			$self->{currentenv} = $element;
56			$self->simplexmldoc()->checkattributes($element, \%attributes);
57			&{$self->simplexmldoc()->gettagfunction($element)}($element, \%attributes);
58			}
59
60			sub ClosingTagHandler()
61			{
62			my $xmlparser=shift;
63			my ($element)=@_;
64
65			if ($element eq 'doc')
66			{
67			return;
68			}
69
70			if (grep($element eq $_, @{$self->simplexmldoc()->nested()}))
71			{
72			&{$self->simplexmldoc()->gettagfunction($element)}($element, {}, 1);
73			}
74
75			# Reset the current env (i.e. delete entry):
76			delete $self->{currentenv};
77			}
78
79			sub CharHandler()
80			{
81			my ($xmlparser, @items) = @_;
82			return if ($items[0] =~ /\s*/);
83
84			# Check to see if there's a content entry in $self
85			# for the current tag. If so, append the line to it:
86			if (grep($self->{currentenv} eq $_, @{$self->simplexmldoc()->nested()}))
87			{
88			&{$self->simplexmldoc()->gettagfunction($self->{currentenv})}($self->{currentenv},
89			{}, 2, [ @items ]);
90			}
91			}
92
93			## Tag routines ##
94			sub requirementstaghandler()
95			{
96			my ($name, $hashref, $nesting) = @_;
97			# Do nothing for char handler:
98			return if ($nesting == 2);
99
100			if ($nesting == 1)
101			{
102			# Cleanup whatever needs to be cleaned up:
103
104			}
105			else
106			{
107
108			}
109
110			# Return here only if the current element is "requirements":
111			return;
112			}
113
114			sub usetaghandler()
115			{
116			my ($name, $hashref) = @_;
117			push(@{$self->{"$self->{levels}->[$self->{nested}]".content}->{USE}},$$hashref{'name'});
118			}
119
120			sub libtaghandler()
121			{
122			my ($name, $hashref) = @_;
123			push(@{$self->{"$self->{levels}->[$self->{nested}]".content}->{LIB}},$$hashref{'name'});
124			}
125
126			sub infotaghandler()
127			{
128			my ($name, $hashref) = @_;
129			$self->{"$self->{levels}->[$self->{nested}]".content}->{INFO} = $hashref;
130			}
131
132			sub flagstaghandler()
133			{
134			my ($name, $hashref, $nesting) = @_;
135			# Do nothing for char handler:
136			return if ($nesting == 2);
137			# Do nothing for closing tag handler:
138			return if ($nesting == 1);
139
140			# Extract the flag name and its value:
141			my ($flagname,$flagvaluestring) = each %{$hashref};
142			$flagname =~ tr/[a-z]/[A-Z]/; # Keep flag name uppercase
143			chomp($flagvaluestring);
144			# Split the value on whitespace so we can push all
145			# individual flags into an array:
146			my @flagvalues = split(' ',$flagvaluestring);
147
148			# Is current tag within another tag block?
149			if ($self->{nested} > 0)
150			{
151			# Check to see if the current flag name is already stored in the hash. If so,
152			# just add the new values to the array of flag values:
153			if (exists ($self->{"$self->{levels}->[$self->{nested}]".content}->{FLAGS}->{$flagname}))
154			{
155			push(@{$self->{"$self->{levels}->[$self->{nested}]".content}->{FLAGS}->{$flagname}},@flagvalues);
156			}
157			else
158			{
159			$self->{"$self->{levels}->[$self->{nested}]".content}->{FLAGS}->{$flagname} = [ @flagvalues ];
160			}
161			}
162			else
163			{
164			if (exists ($self->{content}->{FLAGS}->{$flagname}))
165			{
166			push(@{$self->{content}->{FLAGS}->{$flagname}},@flagvalues);
167			}
168			else
169			{
170			$self->{content}->{FLAGS}->{$flagname} = [ @flagvalues ];
171			}
172			}
173			}
174
175			sub environmenttaghandler()
176			{
177			my ($name, $hashref, $nesting) = @_;
178			# Do nothing for char handler:
179			return if ($nesting == 2);
180			# Do nothing for closing tag handler:
181			return if ($nesting == 1);
182
183			# Save a copy of the name of this environment:
184			my $envname=$$hashref{'name'};
185			delete $$hashref{'name'}; # Delete name entry so hash is more tidy
186			# Break the value/default value into its constituent parts:
187			foreach my $t (qw(value default))
188			{
189			if (exists ($$hashref{$t}))
190			{
191			$hashref->{ELEMENTS} = [];
192			map
193			{
194			if ($_ =~ m\|\$(.*)?\|)
195			{
196			push(@{$hashref->{ELEMENTS}},$1);
197			}
198			} split("/",$hashref->{$t});
199			}
200			}
201
202			# Before we save $hashref we need to know if there are already
203			# any env tags with the same name. If there are, we must save all
204			# data to an aray of hashes:
205			if (exists ($self->{"$self->{levels}->[$self->{nested}]".content}->{ENVIRONMENT}->{$envname}))
206			{
207			push(@{$self->{"$self->{levels}->[$self->{nested}]".content}->{ENVIRONMENT}->{$envname}},$hashref);
208			}
209			else
210			{
211			# No entry yet so just store the hashref:
212			$self->{"$self->{levels}->[$self->{nested}]".content}->{ENVIRONMENT}->{$envname} = [ $hashref ];
213			}
214			}
215
216			sub runtimetaghandler()
217			{
218			my ($name, $hashref, $nesting) = @_;
219			# Do nothing for char handler:
220			return if ($nesting == 2);
221			# Do nothing for closing tag handler:
222			return if ($nesting == 1);
223
224			my $envname;
225
226			# Break the value/default value into its constituent parts:
227			foreach my $t (qw(value default))
228			{
229			if (exists ($$hashref{$t}))
230			{
231			$hashref->{ELEMENTS} = [];
232			map
233			{
234			# In some cases, we might set a runtime path (e.g. LD_LIBRARY_PATH) to
235			# a proper path value i.e. X:Y. In this case, don't bother adding the string
236			# as a "variable" to ELEMENTS:
237			if ($_ =~ m\|\$(.*)?\| && $_ !~ /:/)
238			{
239			push(@{$hashref->{ELEMENTS}},$1);
240			}
241			} split("/",$hashref->{$t});
242			}
243			}
244
245			# Check to see if we have a "type" arg. If so, we use this to create the key:
246			if (exists ($hashref->{'type'}))
247			{
248			my $type=$hashref->{'type'};
249			# Make the type uppercase:
250			$type =~ tr/[a-z]/[A-Z]/;
251			# Rename the environment as "<type>:<env name>":
252			$envname = $type.":".$$hashref{'name'};
253			}
254			else
255			{
256			$envname = $$hashref{'name'};
257			}
258
259			# Delete name entry so hash is more tidy
260			delete $$hashref{'name'};
261
262			# Before we save $hashref we need to know if there are already
263			# any runtime tags with the same name. If there are, we must save all
264			# data to an aray of hashes:
265			if (exists ($self->{"$self->{levels}->[$self->{nested}]".content}->{RUNTIME}->{$envname}))
266			{
267			push(@{$self->{"$self->{levels}->[$self->{nested}]".content}->{RUNTIME}->{$envname}},$hashref);
268			}
269			else
270			{
271			# No entry yet so just store the hashref:
272			$self->{"$self->{levels}->[$self->{nested}]".content}->{RUNTIME}->{$envname} = [ $hashref ];
273			}
274			}
275
276			sub makefiletaghandler()
277			{
278			my ($name, $hashref, $nesting, $string)=@_;
279
280			if ($nesting == 1)
281			{
282			push(@{$self->{"$self->{levels}->[$self->{nested}]".content}->{MAKEFILE}},
283			join('',@{$self->{makefilecontent}}));
284			delete $self->{makefilecontent};
285			}
286			elsif ($nesting == 2)
287			{
288			# Store the text content:
289			push(@{$self->{makefilecontent}}, @$string);
290			}
291			else
292			{
293			# Start the tag:
294			$self->{makefilecontent} = [];
295			}
296			}
297
298			sub clienttaghandler()
299			{
300			my ($name, $hashref, $nesting) = @_;
301			# Do nothing for char handler:
302			return if ($nesting == 2);
303
304			if ($nesting == 1)
305			{
306			if ($self->{isarch} == 1)
307			{
308			# If we already have an architecture tag, we must write to tagcontent hash:
309			$self->{tagcontent}->{CLIENT}=$self->{nexttagcontent};
310			delete $self->{nexttagcontent};
311			}
312			else
313			{
314			$self->{content}->{CLIENT}=$self->{tagcontent};
315			}
316
317			$self->poplevel();
318			}
319			else
320			{
321			$self->pushlevel();
322			}
323			}
324
325			sub archtaghandler()
326			{
327			my ($name, $hashref, $nesting) = @_;
328			# Do nothing for char handler:
329			return if ($nesting == 2);
330
331			if ($nesting == 1)
332			{
333			# Need to be able to cope with multiple arch blocks with same arch string:
334			if (exists ($self->{content}->{ARCH}->{$self->{id}->{'name'}}))
335			{
336			# Already have an architecture tag for this arch:
337			while (my ($k,$v) = each %{$self->{tagcontent}})
338			{
339			# If this tag (e.g. LIB, USE, MAKEFILE) already exists and (as we know
340			# it should be) its data is an ARRAY, push it to the store:
341			if (exists ($self->{content}->{ARCH}->{$self->{id}->{'name'}}->{$k}) &&
342			ref($v) eq 'ARRAY')
343			{
344			push(@{$self->{content}->{ARCH}->{$self->{id}->{'name'}}->{$k}},@$v);
345			}
346			else
347			{
348			# Otherwise (for HASH data) we just store it. Note that, because we do
349			# not loop over the HASH content and check for already existsing keys,
350			# if two arch blocks with same arch name define the same tag (e.g, ENV),
351			# the last occurrence will be kept (i.e. the two values won't be added
352			# to one ENV hash): //FIXME for later....
353			$self->{content}->{ARCH}->{$self->{id}->{'name'}}->{$k} = $v;
354			}
355			}
356			}
357			else
358			{
359			$self->{content}->{ARCH}->{$self->{id}->{'name'}}=$self->{tagcontent};
360			}
361
362			delete $self->{isarch};
363			$self->poplevel();
364			}
365			else
366			{
367			$self->pushlevel($hashref, 1); # Set nested to 1;
368			}
369			}
370
371			# Data-handling utility functions:
372			sub datastore()
373			{
374			my $obj=shift;
375			$self = $obj;
376			}
377
378			1;