src/BuildSystem/Tool.pm

#
# Tool.pm - Store basic tool properties
#
# Originally Written by Christopher Williams
#
# Description
# -----------
# Stores basic tool features
#
# Interface
# ---------
# new()         : A new FeatureTool object
# name()        : get/set the tools name
# version()     : get set the tool version
# url()         : get set the tool url
# features()    : return a list of features defined (ordered in relation to 
#                       their first definition)
# listtype(type) : return a list of all features of the specified type
# addfeature(name,@value) : add value(s) to the named feature
# setfeature(name,@value) : set value(s) for the named feature
# getfeature(name) : return a list of elements belonging to the named feature
#                       (with embedded dependencies)
# type(name[,type]) : get/set the type associated with a feature
# addrequirement() : add a requirement at the current parse position
# dependencies()   : return a list of dependency objects
# store(location)   : Save object to given file
# restore(location) : Restore object from specified file
# reset()           : Clean out all the features
# equals(toolobj)       : return 1 if the tools correspond in url version etc.
# runtime(hashref)      : set the runtime environment into the specified hash

package BuildSystem::Tool;
use Utilities::Verbose;
require 5.004;
@ISA=qw(Utilities::Verbose);

sub new {
        my $class=shift;
        my $self={};
        bless $self, $class;
        return $self;
}

sub name {
        my $self=shift;

        @_?$self->{name}=shift
          :$self->{name};
}

sub version {
        my $self=shift;

        @_?$self->{version}=shift
          :$self->{version};
}

sub url {
        my $self=shift;

        @_?$self->{url}=shift
          :$self->{url};
}

sub equals {
        my $self=shift;
        my $tool=shift;

        my $rv=0;
        if ( ($tool->url() eq $self->url() ) &&
             ($tool->name() eq $self->name() ) &&
             ($tool->version() eq $self->version()) ) {
          $rv=1;
        }
        return $rv;
}

sub listtype {
        my $self=shift;
        my $type=shift;

        my @list=();
        foreach $v ( $self->features() ) {
          if ( $self->type($v) eq $type ) {
                push @list, $v;
          }
        }
        return @list;
}

sub type {
        my $self=shift;
        my $name=shift;

        if ( @_ ) {
          $self->{featuretypes}{$name}=shift;
        }
        return ((defined $self->{featuretypes}{$name})?
                $self->{featuretypes}{$name}:"");
}

sub addfeature {
        my $self=shift;
        my $name=shift;
        my @value=@_;

        $self->_newfeature($name,@value);
        push @{$self->{features}{$name}}, @value;
}

sub setfeature {
        my $self=shift;
        my $name=shift;
        my @value=@_;

        $self->_newfeature($name,@value);
        @{$self->{features}{$name}}=@value;
}

# ---- runtime routines -----------
sub runtime {
        my $self=shift;
        my $hashref=shift;

        my ($val,$f);
        # -- deal with path types
        foreach $f ( $self->listtype("runtime_path")) {
         foreach $val ( $self->getfeature($f) ) {
           $self->_addpath($f,$val,$hashref);
         }
        }

        # -- regular vars
        foreach $f ( $self->listtype("runtime")) {
            foreach $val ( $self->getfeature($f) ) {
              #$self->_addvar($f,$val," ",$hashref);
              $$hashref{$f}=$val;
            }
        }

}

sub _addpath {
        my $self=shift;
        my $name=shift;
        my $val=shift;
        my $hashref=shift;

        my $n;
        my @env;
        @env=split /:/, $$hashref{$name};
        foreach $n ( (split /:/, $val ) ){
         if (  ! grep /^\Q$n\E$/, @env ) { # dont add duplicates
          $self->_addvar($name,$n,":",$hashref);
         }
        } 
}

sub _addvar {
        my $self=shift;
        my $name=shift;
        my $val=shift;
        my $sep=shift;
        my $hashref=shift;

        if ( $val ne "" ) {
        if ( defined $$hashref{$name} ) {
         $$hashref{$name}=$$hashref{$name}.$sep.$val;
        }
        else {
         $$hashref{$name}=$val;
        }
        }
}

# --- end runtime routines 

sub reset {
        my $self=shift;
        undef $self->{features};
        undef $self->{'features_ordered'};
        undef $self->{reqobjs};
        undef $self->{requireposition};
}

sub _newfeature {
        my $self=shift;
        my $name=shift;
        my @value=@_;

        # if it dosnt exist , make sure we first mark all the current reqs
        # get inserted beforehand
        if ( ! exists $self->{features}{$name} ) {
         # add feature name to our ordered list
         push @{$self->{'features_ordered'}},$name;
         for ( $i=0; $i<=$#{$self->{reqobjs}}; $i++ ) {
           $self->_recordpos( $name, $i);
         }
        }
}

sub features {
        my $self=shift;

#       return (keys %{$self->{features}});
        return @{$self->{'features_ordered'}};
}

sub getfeature {
        my $self=shift;
        my $name=shift;

        my @rv=();
        my @rep;
        # make sure we insert requirements at the right place
        for ( my $i=-1; $i<=$#{$self->{features}{$name}}; $i++ ) {
         if ( $i>=0 ) {
           push @rv, $self->{features}{$name}[$i];
         }
         my @rep=$self->_testpos($name, $i);
         my $repobj;
         foreach $repobj ( @rep ) {
             push @rv, $repobj->getfeature($name);
         }
        }
        return @rv;
}

sub clearfeature {
        my $self=shift;
        my $name=shift;

        undef @{$self->{features}{$name}};
}

sub addrequirement {
        my $self=shift;
        my $reqobj=shift;

        push @{$self->{reqobjs}}, $reqobj;
        foreach $key ( keys %{$self->{features}} ) {
           $self->_recordpos($key,$#{$self->{reqobjs}});
        }
}

sub dependencies {
        my $self=shift;
        return @{$self->{recobjs}}
}

sub store {
        my $self=shift;
        my $location=shift;

        my $fh=FileHandle->new();
        $self->verbose("opening $location for output");
        $fh->open(">".$location) or die "Unable to open $location for output".
                                $!."\n";
        print $fh "name:".$self->name().":_sys\n";
        print $fh "version:".$self->version().":_sys\n";
        print $fh "url:".$self->url().":_sys\n";
        foreach $f ( $self->features()) {
          foreach $val ( $self->getfeature($f) ) {
           print $fh $f.":".$val.":".$self->type($f)."\n";
          }
        }
        undef $fh;
}

sub restore {
        my $self=shift;
        my $location=shift;

        my $fh=FileHandle->new();
        $fh->open("<".$location) or die "Unable to open $location for output".
                                $!."\n";
        my ($tool,$type,$variable,$value);
        while ( <$fh> ) {
          chomp;
          next if /^#/;
          next if /^\s*$/;
          ($variable, $value, $type)=split /:/;
          next if ( $variable=~/\&/ );
          $product=~tr[A-Z][a-z];
          if ( $type eq "_sys" ) {
             if ( $self->can($variable)) {
               $self->$variable($value);
             }
          }
          else {
            $self->addfeature($variable,$value);
            if ( $type ne "" ) {
               $self->type($variable,$type);
            }
          }
        }
        undef $fh;
}

sub _recordpos {
        my $self=shift;
        my $name=shift;
        my $recref=shift;

        push @{$self->{requireposition}{$name}{$#{$self->{features}{$name}}}}
                ,$recref;
}

# return array of objects that correspond to the required position
sub _testpos {
        my $self=shift;
        my $name=shift;
        my $ref=shift;

        my @rv=();
        if ( exists $self->{requireposition}{$name}{$ref} ) {
           foreach $recref ( @{$self->{requireposition}{$name}{$ref}} ) {
             push @rv, $self->{reqobjs}[$recref];
           }
        }
        return @rv;
}


Revision:	1.1.2.10
Committed:	Wed Jun 21 16:38:40 2000 UTC (24 years, 10 months ago) by williamc
Content type:	text/plain
Branch:	V0_9branch
CVS Tags:	V0_13_3, V0_13_2, V0_13_1
Changes since 1.1.2.9:	+2 -1 lines
Log Message:	reset normal vars in runtime rather than adding
#	User	Rev	Content
1	williamc	1.1.2.1	#
2			# Tool.pm - Store basic tool properties
3			#
4			# Originally Written by Christopher Williams
5			#
6			# Description
7			# -----------
8			# Stores basic tool features
9			#
10			# Interface
11			# ---------
12			# new() : A new FeatureTool object
13			# name() : get/set the tools name
14			# version() : get set the tool version
15			# url() : get set the tool url
16			# features() : return a list of features defined (ordered in relation to
17			# their first definition)
18	williamc	1.1.2.3	# listtype(type) : return a list of all features of the specified type
19	williamc	1.1.2.1	# addfeature(name,@value) : add value(s) to the named feature
20			# setfeature(name,@value) : set value(s) for the named feature
21			# getfeature(name) : return a list of elements belonging to the named feature
22	williamc	1.1.2.2	# (with embedded dependencies)
23			# type(name[,type]) : get/set the type associated with a feature
24	williamc	1.1.2.1	# addrequirement() : add a requirement at the current parse position
25			# dependencies() : return a list of dependency objects
26	williamc	1.1.2.3	# store(location) : Save object to given file
27	williamc	1.1.2.2	# restore(location) : Restore object from specified file
28	williamc	1.1.2.5	# reset() : Clean out all the features
29	williamc	1.1.2.7	# equals(toolobj) : return 1 if the tools correspond in url version etc.
30	williamc	1.1.2.9	# runtime(hashref) : set the runtime environment into the specified hash
31	williamc	1.1.2.1
32			package BuildSystem::Tool;
33	williamc	1.1.2.6	use Utilities::Verbose;
34	williamc	1.1.2.1	require 5.004;
35	williamc	1.1.2.6	@ISA=qw(Utilities::Verbose);
36	williamc	1.1.2.1
37			sub new {
38			my $class=shift;
39			my $self={};
40			bless $self, $class;
41			return $self;
42			}
43
44			sub name {
45			my $self=shift;
46
47			@_?$self->{name}=shift
48			:$self->{name};
49			}
50
51			sub version {
52			my $self=shift;
53
54			@_?$self->{version}=shift
55			:$self->{version};
56			}
57
58			sub url {
59			my $self=shift;
60
61			@_?$self->{url}=shift
62			:$self->{url};
63	williamc	1.1.2.7	}
64
65			sub equals {
66			my $self=shift;
67			my $tool=shift;
68
69			my $rv=0;
70			if ( ($tool->url() eq $self->url() ) &&
71			($tool->name() eq $self->name() ) &&
72			($tool->version() eq $self->version()) ) {
73			$rv=1;
74			}
75			return $rv;
76	williamc	1.1.2.1	}
77
78	williamc	1.1.2.3	sub listtype {
79			my $self=shift;
80			my $type=shift;
81
82			my @list=();
83			foreach $v ( $self->features() ) {
84			if ( $self->type($v) eq $type ) {
85			push @list, $v;
86			}
87			}
88			return @list;
89			}
90
91	williamc	1.1.2.2	sub type {
92			my $self=shift;
93			my $name=shift;
94
95			if ( @_ ) {
96			$self->{featuretypes}{$name}=shift;
97			}
98			return ((defined $self->{featuretypes}{$name})?
99			$self->{featuretypes}{$name}:"");
100			}
101	williamc	1.1.2.1
102			sub addfeature {
103			my $self=shift;
104			my $name=shift;
105			my @value=@_;
106
107			$self->_newfeature($name,@value);
108			push @{$self->{features}{$name}}, @value;
109			}
110
111			sub setfeature {
112			my $self=shift;
113			my $name=shift;
114			my @value=@_;
115
116			$self->_newfeature($name,@value);
117			@{$self->{features}{$name}}=@value;
118			}
119	williamc	1.1.2.9
120			# ---- runtime routines -----------
121			sub runtime {
122			my $self=shift;
123			my $hashref=shift;
124
125			my ($val,$f);
126			# -- deal with path types
127			foreach $f ( $self->listtype("runtime_path")) {
128			foreach $val ( $self->getfeature($f) ) {
129			$self->_addpath($f,$val,$hashref);
130			}
131			}
132
133			# -- regular vars
134			foreach $f ( $self->listtype("runtime")) {
135			foreach $val ( $self->getfeature($f) ) {
136	williamc	1.1.2.10	#$self->_addvar($f,$val," ",$hashref);
137			$$hashref{$f}=$val;
138	williamc	1.1.2.9	}
139			}
140
141			}
142
143			sub _addpath {
144			my $self=shift;
145			my $name=shift;
146			my $val=shift;
147			my $hashref=shift;
148
149			my $n;
150			my @env;
151			@env=split /:/, $$hashref{$name};
152			foreach $n ( (split /:/, $val ) ){
153			if ( ! grep /^\Q$n\E$/, @env ) { # dont add duplicates
154			$self->_addvar($name,$n,":",$hashref);
155			}
156			}
157			}
158
159			sub _addvar {
160			my $self=shift;
161			my $name=shift;
162			my $val=shift;
163			my $sep=shift;
164			my $hashref=shift;
165
166			if ( $val ne "" ) {
167			if ( defined $$hashref{$name} ) {
168			$$hashref{$name}=$$hashref{$name}.$sep.$val;
169			}
170			else {
171			$$hashref{$name}=$val;
172			}
173			}
174			}
175
176			# --- end runtime routines
177	williamc	1.1.2.1
178	williamc	1.1.2.5	sub reset {
179			my $self=shift;
180			undef $self->{features};
181			undef $self->{'features_ordered'};
182			undef $self->{reqobjs};
183			undef $self->{requireposition};
184			}
185	williamc	1.1.2.1
186			sub _newfeature {
187			my $self=shift;
188			my $name=shift;
189			my @value=@_;
190
191			# if it dosnt exist , make sure we first mark all the current reqs
192			# get inserted beforehand
193			if ( ! exists $self->{features}{$name} ) {
194			# add feature name to our ordered list
195			push @{$self->{'features_ordered'}},$name;
196			for ( $i=0; $i<=$#{$self->{reqobjs}}; $i++ ) {
197			$self->_recordpos( $name, $i);
198			}
199			}
200			}
201
202			sub features {
203			my $self=shift;
204
205			# return (keys %{$self->{features}});
206			return @{$self->{'features_ordered'}};
207			}
208
209			sub getfeature {
210			my $self=shift;
211			my $name=shift;
212
213			my @rv=();
214			my @rep;
215			# make sure we insert requirements at the right place
216			for ( my $i=-1; $i<=$#{$self->{features}{$name}}; $i++ ) {
217			if ( $i>=0 ) {
218			push @rv, $self->{features}{$name}[$i];
219			}
220			my @rep=$self->_testpos($name, $i);
221			my $repobj;
222			foreach $repobj ( @rep ) {
223			push @rv, $repobj->getfeature($name);
224			}
225			}
226			return @rv;
227			}
228
229			sub clearfeature {
230			my $self=shift;
231			my $name=shift;
232
233			undef @{$self->{features}{$name}};
234			}
235
236			sub addrequirement {
237			my $self=shift;
238			my $reqobj=shift;
239
240			push @{$self->{reqobjs}}, $reqobj;
241			foreach $key ( keys %{$self->{features}} ) {
242			$self->_recordpos($key,$#{$self->{reqobjs}});
243			}
244			}
245
246			sub dependencies {
247			my $self=shift;
248			return @{$self->{recobjs}}
249			}
250
251	williamc	1.1.2.3	sub store {
252	williamc	1.1.2.2	my $self=shift;
253			my $location=shift;
254
255			my $fh=FileHandle->new();
256	williamc	1.1.2.6	$self->verbose("opening $location for output");
257	williamc	1.1.2.2	$fh->open(">".$location) or die "Unable to open $location for output".
258			$!."\n";
259	williamc	1.1.2.3	print $fh "name:".$self->name().":_sys\n";
260			print $fh "version:".$self->version().":_sys\n";
261	williamc	1.1.2.4	print $fh "url:".$self->url().":_sys\n";
262	williamc	1.1.2.2	foreach $f ( $self->features()) {
263			foreach $val ( $self->getfeature($f) ) {
264	williamc	1.1.2.3	print $fh $f.":".$val.":".$self->type($f)."\n";
265	williamc	1.1.2.2	}
266			}
267			undef $fh;
268			}
269
270			sub restore {
271			my $self=shift;
272			my $location=shift;
273
274			my $fh=FileHandle->new();
275			$fh->open("<".$location) or die "Unable to open $location for output".
276			$!."\n";
277			my ($tool,$type,$variable,$value);
278			while ( <$fh> ) {
279			chomp;
280			next if /^#/;
281			next if /^\s*$/;
282	williamc	1.1.2.3	($variable, $value, $type)=split /:/;
283	williamc	1.1.2.2	next if ( $variable=~/\&/ );
284			$product=~tr[A-Z][a-z];
285			if ( $type eq "_sys" ) {
286	williamc	1.1.2.3	if ( $self->can($variable)) {
287	williamc	1.1.2.2	$self->$variable($value);
288			}
289			}
290			else {
291			$self->addfeature($variable,$value);
292	williamc	1.1.2.8	if ( $type ne "" ) {
293			$self->type($variable,$type);
294			}
295	williamc	1.1.2.2	}
296			}
297			undef $fh;
298			}
299
300	williamc	1.1.2.1	sub _recordpos {
301			my $self=shift;
302			my $name=shift;
303			my $recref=shift;
304
305			push @{$self->{requireposition}{$name}{$#{$self->{features}{$name}}}}
306			,$recref;
307			}
308
309			# return array of objects that correspond to the required position
310			sub _testpos {
311			my $self=shift;
312			my $name=shift;
313			my $ref=shift;
314
315			my @rv=();
316			if ( exists $self->{requireposition}{$name}{$ref} ) {
317			foreach $recref ( @{$self->{requireposition}{$name}{$ref}} ) {
318			push @rv, $self->{reqobjs}[$recref];
319			}
320			}
321			return @rv;
322			}
323	williamc	1.1.2.2
324