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 |
+ |
# listtype(type) : return a list of all features of the specified type |
19 |
+ |
# 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 |
+ |
# (with embedded dependencies) |
23 |
+ |
# type(name[,type]) : get/set the type associated with a feature |
24 |
+ |
# addrequirement() : add a requirement at the current parse position |
25 |
+ |
# dependencies() : return a list of dependency objects |
26 |
+ |
# store(location) : Save object to given file |
27 |
+ |
# restore(location) : Restore object from specified file |
28 |
+ |
# reset() : Clean out all the features |
29 |
+ |
# equals(toolobj) : return 1 if the tools correspond in url version etc. |
30 |
+ |
|
31 |
+ |
package BuildSystem::Tool; |
32 |
+ |
use Utilities::Verbose; |
33 |
+ |
require 5.004; |
34 |
+ |
@ISA=qw(Utilities::Verbose); |
35 |
+ |
|
36 |
+ |
sub new { |
37 |
+ |
my $class=shift; |
38 |
+ |
my $self={}; |
39 |
+ |
bless $self, $class; |
40 |
+ |
return $self; |
41 |
+ |
} |
42 |
+ |
|
43 |
+ |
sub name { |
44 |
+ |
my $self=shift; |
45 |
+ |
|
46 |
+ |
@_?$self->{name}=shift |
47 |
+ |
:$self->{name}; |
48 |
+ |
} |
49 |
+ |
|
50 |
+ |
sub version { |
51 |
+ |
my $self=shift; |
52 |
+ |
|
53 |
+ |
@_?$self->{version}=shift |
54 |
+ |
:$self->{version}; |
55 |
+ |
} |
56 |
+ |
|
57 |
+ |
sub url { |
58 |
+ |
my $self=shift; |
59 |
+ |
|
60 |
+ |
@_?$self->{url}=shift |
61 |
+ |
:$self->{url}; |
62 |
+ |
} |
63 |
+ |
|
64 |
+ |
sub equals { |
65 |
+ |
my $self=shift; |
66 |
+ |
my $tool=shift; |
67 |
+ |
|
68 |
+ |
my $rv=0; |
69 |
+ |
if ( |
70 |
+ |
# TODO - temp for backwards comp mode($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 |
+ |
} |
77 |
+ |
|
78 |
+ |
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 |
+ |
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 |
+ |
|
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 |
+ |
|
120 |
+ |
sub reset { |
121 |
+ |
my $self=shift; |
122 |
+ |
undef $self->{features}; |
123 |
+ |
undef $self->{'features_ordered'}; |
124 |
+ |
undef $self->{reqobjs}; |
125 |
+ |
undef $self->{requireposition}; |
126 |
+ |
} |
127 |
+ |
|
128 |
+ |
sub _newfeature { |
129 |
+ |
my $self=shift; |
130 |
+ |
my $name=shift; |
131 |
+ |
my @value=@_; |
132 |
+ |
|
133 |
+ |
# if it dosnt exist , make sure we first mark all the current reqs |
134 |
+ |
# get inserted beforehand |
135 |
+ |
if ( ! exists $self->{features}{$name} ) { |
136 |
+ |
# add feature name to our ordered list |
137 |
+ |
push @{$self->{'features_ordered'}},$name; |
138 |
+ |
for ( $i=0; $i<=$#{$self->{reqobjs}}; $i++ ) { |
139 |
+ |
$self->_recordpos( $name, $i); |
140 |
+ |
} |
141 |
+ |
} |
142 |
+ |
} |
143 |
+ |
|
144 |
+ |
sub features { |
145 |
+ |
my $self=shift; |
146 |
+ |
|
147 |
+ |
# return (keys %{$self->{features}}); |
148 |
+ |
return @{$self->{'features_ordered'}}; |
149 |
+ |
} |
150 |
+ |
|
151 |
+ |
sub getfeature { |
152 |
+ |
my $self=shift; |
153 |
+ |
my $name=shift; |
154 |
+ |
|
155 |
+ |
my @rv=(); |
156 |
+ |
my @rep; |
157 |
+ |
# make sure we insert requirements at the right place |
158 |
+ |
for ( my $i=-1; $i<=$#{$self->{features}{$name}}; $i++ ) { |
159 |
+ |
if ( $i>=0 ) { |
160 |
+ |
push @rv, $self->{features}{$name}[$i]; |
161 |
+ |
} |
162 |
+ |
my @rep=$self->_testpos($name, $i); |
163 |
+ |
my $repobj; |
164 |
+ |
foreach $repobj ( @rep ) { |
165 |
+ |
push @rv, $repobj->getfeature($name); |
166 |
+ |
} |
167 |
+ |
} |
168 |
+ |
return @rv; |
169 |
+ |
} |
170 |
+ |
|
171 |
+ |
sub clearfeature { |
172 |
+ |
my $self=shift; |
173 |
+ |
my $name=shift; |
174 |
+ |
|
175 |
+ |
undef @{$self->{features}{$name}}; |
176 |
+ |
} |
177 |
+ |
|
178 |
+ |
sub addrequirement { |
179 |
+ |
my $self=shift; |
180 |
+ |
my $reqobj=shift; |
181 |
+ |
|
182 |
+ |
push @{$self->{reqobjs}}, $reqobj; |
183 |
+ |
foreach $key ( keys %{$self->{features}} ) { |
184 |
+ |
$self->_recordpos($key,$#{$self->{reqobjs}}); |
185 |
+ |
} |
186 |
+ |
} |
187 |
+ |
|
188 |
+ |
sub dependencies { |
189 |
+ |
my $self=shift; |
190 |
+ |
return @{$self->{recobjs}} |
191 |
+ |
} |
192 |
+ |
|
193 |
+ |
sub store { |
194 |
+ |
my $self=shift; |
195 |
+ |
my $location=shift; |
196 |
+ |
|
197 |
+ |
my $fh=FileHandle->new(); |
198 |
+ |
$self->verbose("opening $location for output"); |
199 |
+ |
$fh->open(">".$location) or die "Unable to open $location for output". |
200 |
+ |
$!."\n"; |
201 |
+ |
print $fh "name:".$self->name().":_sys\n"; |
202 |
+ |
print $fh "version:".$self->version().":_sys\n"; |
203 |
+ |
print $fh "url:".$self->url().":_sys\n"; |
204 |
+ |
foreach $f ( $self->features()) { |
205 |
+ |
foreach $val ( $self->getfeature($f) ) { |
206 |
+ |
print $fh $f.":".$val.":".$self->type($f)."\n"; |
207 |
+ |
} |
208 |
+ |
} |
209 |
+ |
undef $fh; |
210 |
+ |
} |
211 |
+ |
|
212 |
+ |
sub restore { |
213 |
+ |
my $self=shift; |
214 |
+ |
my $location=shift; |
215 |
+ |
|
216 |
+ |
my $fh=FileHandle->new(); |
217 |
+ |
$fh->open("<".$location) or die "Unable to open $location for output". |
218 |
+ |
$!."\n"; |
219 |
+ |
my ($tool,$type,$variable,$value); |
220 |
+ |
my @fields; |
221 |
+ |
while ( <$fh> ) { |
222 |
+ |
chomp; |
223 |
+ |
next if /^#/; |
224 |
+ |
next if /^\s*$/; |
225 |
+ |
@fields=split /:/; |
226 |
+ |
if ( $_!~/:$/ ) { |
227 |
+ |
$type=pop @fields; |
228 |
+ |
} |
229 |
+ |
else { $type="" }; |
230 |
+ |
$variable=shift @fields; |
231 |
+ |
$value=join ":",@fields; |
232 |
+ |
#($variable, $value, $type)=split /:/; |
233 |
+ |
next if ( $variable=~/\&/ ); |
234 |
+ |
$product=~tr[A-Z][a-z]; |
235 |
+ |
if ( $type eq "_sys" ) { |
236 |
+ |
if ( $self->can($variable)) { |
237 |
+ |
$self->$variable($value); |
238 |
+ |
} |
239 |
+ |
} |
240 |
+ |
else { |
241 |
+ |
$self->addfeature($variable,$value); |
242 |
+ |
if ( $type ne "" ) { |
243 |
+ |
$self->type($variable,$type); |
244 |
+ |
} |
245 |
+ |
} |
246 |
+ |
} |
247 |
+ |
undef $fh; |
248 |
+ |
} |
249 |
+ |
|
250 |
+ |
sub _recordpos { |
251 |
+ |
my $self=shift; |
252 |
+ |
my $name=shift; |
253 |
+ |
my $recref=shift; |
254 |
+ |
|
255 |
+ |
push @{$self->{requireposition}{$name}{$#{$self->{features}{$name}}}} |
256 |
+ |
,$recref; |
257 |
+ |
} |
258 |
+ |
|
259 |
+ |
# return array of objects that correspond to the required position |
260 |
+ |
sub _testpos { |
261 |
+ |
my $self=shift; |
262 |
+ |
my $name=shift; |
263 |
+ |
my $ref=shift; |
264 |
+ |
|
265 |
+ |
my @rv=(); |
266 |
+ |
if ( exists $self->{requireposition}{$name}{$ref} ) { |
267 |
+ |
foreach $recref ( @{$self->{requireposition}{$name}{$ref}} ) { |
268 |
+ |
push @rv, $self->{reqobjs}[$recref]; |
269 |
+ |
} |
270 |
+ |
} |
271 |
+ |
return @rv; |
272 |
+ |
} |
273 |
+ |
|
274 |
+ |
|