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

package BuildSystem::Tool;
require 5.004;

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 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;
}


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();
        $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);
          }
        }
        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.4
Committed:	Wed Apr 19 09:16:47 2000 UTC (25 years ago) by williamc
Content type:	text/plain
Branch:	V0_9branch
Changes since 1.1.2.3:	+1 -0 lines
Log Message:	Store url info
#	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.1
29			package BuildSystem::Tool;
30			require 5.004;
31
32			sub new {
33			my $class=shift;
34			my $self={};
35			bless $self, $class;
36			return $self;
37			}
38
39			sub name {
40			my $self=shift;
41
42			@_?$self->{name}=shift
43			:$self->{name};
44			}
45
46			sub version {
47			my $self=shift;
48
49			@_?$self->{version}=shift
50			:$self->{version};
51			}
52
53			sub url {
54			my $self=shift;
55
56			@_?$self->{url}=shift
57			:$self->{url};
58			}
59
60	williamc	1.1.2.3	sub listtype {
61			my $self=shift;
62			my $type=shift;
63
64			my @list=();
65			foreach $v ( $self->features() ) {
66			if ( $self->type($v) eq $type ) {
67			push @list, $v;
68			}
69			}
70			return @list;
71			}
72
73	williamc	1.1.2.2	sub type {
74			my $self=shift;
75			my $name=shift;
76
77			if ( @_ ) {
78			$self->{featuretypes}{$name}=shift;
79			}
80			return ((defined $self->{featuretypes}{$name})?
81			$self->{featuretypes}{$name}:"");
82			}
83	williamc	1.1.2.1
84			sub addfeature {
85			my $self=shift;
86			my $name=shift;
87			my @value=@_;
88
89			$self->_newfeature($name,@value);
90			push @{$self->{features}{$name}}, @value;
91			}
92
93			sub setfeature {
94			my $self=shift;
95			my $name=shift;
96			my @value=@_;
97
98			$self->_newfeature($name,@value);
99			@{$self->{features}{$name}}=@value;
100			}
101
102
103			sub _newfeature {
104			my $self=shift;
105			my $name=shift;
106			my @value=@_;
107
108			# if it dosnt exist , make sure we first mark all the current reqs
109			# get inserted beforehand
110			if ( ! exists $self->{features}{$name} ) {
111			# add feature name to our ordered list
112			push @{$self->{'features_ordered'}},$name;
113			for ( $i=0; $i<=$#{$self->{reqobjs}}; $i++ ) {
114			$self->_recordpos( $name, $i);
115			}
116			}
117			}
118
119			sub features {
120			my $self=shift;
121
122			# return (keys %{$self->{features}});
123			return @{$self->{'features_ordered'}};
124			}
125
126			sub getfeature {
127			my $self=shift;
128			my $name=shift;
129
130			my @rv=();
131			my @rep;
132			# make sure we insert requirements at the right place
133			for ( my $i=-1; $i<=$#{$self->{features}{$name}}; $i++ ) {
134			if ( $i>=0 ) {
135			push @rv, $self->{features}{$name}[$i];
136			}
137			my @rep=$self->_testpos($name, $i);
138			my $repobj;
139			foreach $repobj ( @rep ) {
140			push @rv, $repobj->getfeature($name);
141			}
142			}
143			return @rv;
144			}
145
146			sub clearfeature {
147			my $self=shift;
148			my $name=shift;
149
150			undef @{$self->{features}{$name}};
151			}
152
153			sub addrequirement {
154			my $self=shift;
155			my $reqobj=shift;
156
157			push @{$self->{reqobjs}}, $reqobj;
158			foreach $key ( keys %{$self->{features}} ) {
159			$self->_recordpos($key,$#{$self->{reqobjs}});
160			}
161			}
162
163			sub dependencies {
164			my $self=shift;
165			return @{$self->{recobjs}}
166			}
167
168	williamc	1.1.2.3	sub store {
169	williamc	1.1.2.2	my $self=shift;
170			my $location=shift;
171
172			my $fh=FileHandle->new();
173			$fh->open(">".$location) or die "Unable to open $location for output".
174			$!."\n";
175	williamc	1.1.2.3	print $fh "name:".$self->name().":_sys\n";
176			print $fh "version:".$self->version().":_sys\n";
177	williamc	1.1.2.4	print $fh "url:".$self->url().":_sys\n";
178	williamc	1.1.2.2	foreach $f ( $self->features()) {
179			foreach $val ( $self->getfeature($f) ) {
180	williamc	1.1.2.3	print $fh $f.":".$val.":".$self->type($f)."\n";
181	williamc	1.1.2.2	}
182			}
183			undef $fh;
184			}
185
186			sub restore {
187			my $self=shift;
188			my $location=shift;
189
190			my $fh=FileHandle->new();
191			$fh->open("<".$location) or die "Unable to open $location for output".
192			$!."\n";
193			my ($tool,$type,$variable,$value);
194			while ( <$fh> ) {
195			chomp;
196			next if /^#/;
197			next if /^\s*$/;
198	williamc	1.1.2.3	($variable, $value, $type)=split /:/;
199	williamc	1.1.2.2	next if ( $variable=~/\&/ );
200			$product=~tr[A-Z][a-z];
201			if ( $type eq "_sys" ) {
202	williamc	1.1.2.3	if ( $self->can($variable)) {
203	williamc	1.1.2.2	$self->$variable($value);
204			}
205			}
206			else {
207			$self->addfeature($variable,$value);
208			}
209			}
210			undef $fh;
211			}
212
213	williamc	1.1.2.1	sub _recordpos {
214			my $self=shift;
215			my $name=shift;
216			my $recref=shift;
217
218			push @{$self->{requireposition}{$name}{$#{$self->{features}{$name}}}}
219			,$recref;
220			}
221
222			# return array of objects that correspond to the required position
223			sub _testpos {
224			my $self=shift;
225			my $name=shift;
226			my $ref=shift;
227
228			my @rv=();
229			if ( exists $self->{requireposition}{$name}{$ref} ) {
230			foreach $recref ( @{$self->{requireposition}{$name}{$ref}} ) {
231			push @rv, $self->{reqobjs}[$recref];
232			}
233			}
234			return @rv;
235			}
236	williamc	1.1.2.2
237