ViewVC Help

View File | Revision Log | Show Annotations | Root Listing

root/cvsroot/COMP/SCRAM/src/Scram/ScramFunctions.pm

Comparing COMP/SCRAM/src/Scram/ScramFunctions.pm (file contents):
Revision 1.9 by williamc, Fri Oct 20 11:31:43 2000 UTC vs.
Revision 1.24 by sashby, Wed Feb 2 18:57:02 2005 UTC

#	Line 19 | Line 19
19		# setuptoolsinarea($area[,$toolname[,$toolversion[,toolfile]) : setup
20		# arch()                : get/set the architecture string
21		# scramobjectinterface(Class)  : print out the interface of a scram class
22	<	# webget(area,url)      : get the url into the cache of the specified area
22	>	# webget(area,url)      : get the url into the cache of the specified area
23		# getversion()          : return the current scram version
24		# spawnversion(version,@args) : spawn the scram version with the given args
25	+	# classverbose(classstring,setting) : Set the class verbosity level
26	+	# toolruntime(ConfigArea): Get a runtime object withthe settings from
27	+	#                          the specified toolbox
28
29		package Scram::ScramFunctions;
30		use URL::URLcache;
28	–	use URL::URLhandler;
31		use Utilities::Verbose;
32	+	use Utilities::IndexedFileStore;
33	+
34		require 5.004;
35
36		@ISA=qw(Utilities::Verbose);
37
38	<	sub new {
38	>	sub new
39	>	{
40	>	my $class=shift;
41	>	$self={};
42	>	bless $self, $class;
43	>	# -- default settings
44	>	$self->{cachedir}=$ENV{HOME}."/.scramrc/globalcache";
45	>	$self->{scramprojectsdbdir}=$ENV{SCRAM_LOOKUPDB};
46	>	($self->{scram_top})=( $ENV{SCRAM_HOME}=~/(.*)\//) ;
47	>
48	>	return $self;
49	>	}
50	>
51	>	sub classverbose {
52	>	my $self=shift;
53		my $class=shift;
54	<	$self={};
37	<	bless $self, $class;
38	<	# -- default settings
39	<	$self->{cachedir}=$ENV{HOME}."/.scramrc/globalcache";
40	<	$self->{scramprojectsdbdir}=$ENV{SCRAM_LOOKUPDB};
41	<	($self->{scram_top})=( $ENV{SCRAM_HOME}=~/(.*)\//) ;
54	>	my $val=shift;
55
56	<	return $self;
56	>	$ENV{"VERBOSE_".$class}=$val;
57		}
58
59		sub project {
#	Line 64 | Line 77 | sub project {
77
78		# -- download all tool description files
79		my $req=$self->arearequirements($area);
80	+	$area->toolboxversion($req->{configversion});
81	+
82		if ( defined $req ) {
83		$req->download($self->areatoolbox($area));
84		}
#	Line 71 | Line 86 | sub project {
86		return $area;
87		}
88
89	<	sub setuptoolsinarea {
90	<	my $self=shift;
91	<	my $area=shift;
92	<
93	<	# -- initialise
94	<	$self->_allprojectinitsearcher();
95	<
96	<	# -- create a new toolbox object
97	<	my $toolbox=$self->areatoolbox($area);
98	<	$toolbox->searcher($self->_projsearcher());
89	>	sub setuptoolsinarea
90	>	{
91	>	my $self=shift;
92	>	my $area=shift;
93	>
94	>	# -- initialise
95	>	print "Initialising setup procedure......","\n";
96	>	$self->_allprojectinitsearcher();
97	>
98	>	# -- create a new toolbox object
99	>	my $toolbox=$self->areatoolbox($area);
100	>	$toolbox->searcher($self->_allprojectinitsearcher());
101	>
102	>	if ( @_ )
103	>	{
104	>	# -- specific tool specified
105	>	if ( my $rv=$toolbox->toolsetup(@_) )
106	>	{
107	>	if ( $rv eq 1 )
108	>	{
109	>	print "Unknown tool $toolname @ARGV\n";
110	>	exit 1;
111	>	}
112	>	}
113	>	}
114	>	else
115	>	{
116	>	# -- setup all tools specified in the requirements doc
117	>	print "Going to set up all tools....","\n\n";
118	>	my $reqs=$self->arearequirements($area);
119	>	$self->verbose("Setup ToolBox from Requirements doc ($reqs)");
120	>	# reqs is a BuildSystem::Requirements object:
121	>	$reqs->setup($toolbox);
122	>	}
123	>	}
124	>
125	>	sub updatetoolsinarea
126	>	{
127	>	my $self=shift;
128	>	my $area=shift;
129	>
130	>
131	>	my $toolbox=$self->areatoolbox($area);
132	>
133	>	print "Going to refresh the setup of tools....","\n\n";
134	>	my $currenttag = $area->toolboxversion();
135	>
136	>	# Get rid of the current cache:
137	>	my $cachename = $area->cache()->location();
138	>	system("mv","$cachename","$cachename".".$currenttag");
139	>	# Create a new one:
140	>	$area->_newcache();
141	>	my $reqs=$self->arearequirements($area);
142	>	$reqs->download();
143	>	$reqs->setup($toolbox);
144	>	print "Previous configuration tag : ",$currenttag,"\n";
145	>	$area->toolboxversion($reqs->{configversion});
146	>	print "Current configuration tag  : ",$area->toolboxversion(),"\n\n";
147	>	$area->save();
148	>	}
149	>
150	>	sub satellite
151	>	{
152	>	#
153	>	# Modified to suit new structure
154	>	#
155	>	my $self=shift;
156	>	my $name=shift;
157	>	my $version=shift;
158	>	my $installarea=shift; # Where to install (-dir option in project cmd);
159	>	my $areaname=undef;    # Name of the area (comes from -name option in project cmd);
160	>
161	>	use Utilities::AddDir;
162	>
163	>	if ( @_ )
164	>	{
165	>	$areaname=shift;
166	>	}
167	>
168	>	# Get location from SCRAMDB:
169	>	my $relarea=$self->_lookupareaindb($name,$version);
170	>
171	>	if ( ! defined $relarea )
172	>	{
173	>	$self->error("Unable to Find Project $name $version");
174	>	}
175	>
176	>	# Create a satellite area:
177	>	my $area=$relarea->satellite($installarea,$areaname);
178	>	$area->archname($self->arch());
179	>
180	>	# Copy the admin dir (and with it, the ToolCache):
181	>	$relarea->copywithskip($area->location(),'ProjectCache.db');
182	>
183	>	# Also, we need to copy .SCRAM/cache from the release area. This eliminates the need
184	>	# to download tools again from CVS:
185	>	$relarea->copyurlcache($area->location());
186	>
187	>	# Copy configuration directory contents:
188	>	if ( ! -d $area->location()."/".$area->configurationdir() )
189	>	{
190	>	AddDir::copydir($relarea->location()."/".$relarea->configurationdir(),
191	>	$area->location()."/".$area->configurationdir() );
192	>	}
193	>
194	>	# Make sourcecode dir:
195	>	if ( ! -d $area->location()."/".$area->sourcedir() )
196	>	{
197	>	AddDir::adddir($area->location()."/".$area->sourcedir());
198	>	}
199	>
200	>	# Copy RequirementsDoc:
201	>	if ( ! -f $area->requirementsdoc() )
202	>	{
203	>	use File::Copy;
204	>	copy( $relarea->requirementsdoc() , $area->requirementsdoc());
205	>	}
206
207	<	if ( @_ ) {
208	<	# -- specific tool specified
87	<	if ( my $rv=$toolbox->toolsetup(@_) ) {
88	<	if ( $rv eq 1 ) {
89	<	print "Unknown tool $toolname @ARGV\n";
90	<	exit 1;
91	<	}
92	<	}
93	<	}
94	<	else {
95	<	# -- setup all tools specified in the requirements doc
96	<	my $reqs=$self->arearequirements($area);
97	<	$self->verbose("Setup ToolBox from Requirements doc ($reqs)");
98	<	$reqs->setup($toolbox);
99	<	}
100	<	}
207	>	return $area;
208	>	}
209
210	<	sub satellite {
210	>	sub toolruntime {
211		my $self=shift;
212	<	my $name=shift;
213	<	my $version=shift;
214	<	my $installarea=shift;
107	<
108	<	my $areaname=undef;
109	<	if ( @_ ) {
110	<	$areaname=shift;
111	<	}
112	<
113	<	# -- look up scram database for location
114	<	my $relarea=$self->_lookupareaindb($name,$version);
115	<	if ( ! defined $relarea ) {
116	<	$self->error("Unable to Find Project $name $version");
117	<	}
118	<
119	<	# -- fix for old broken areas
120	<	if ( (! defined $relarea->version()) || ($relarea->version() eq "") ) {
121	<	$relarea->version($version);
122	<	}
123	<
124	<	# -- create satellite
125	<	my $area=$relarea->satellite($installarea,$areaname);
126	<	$area->archname($self->arch());
127	<
128	<	# -- copy setup info - deprecated by toolbox copy method
129	<	#$relarea->copysetup($area->location());
212	>	my $area=shift;
213	>	my $ld_lib_path="";
214	>	my $bin_path="";
215
216	<	# -- copy toolbox
217	<	my $rtb=$self->areatoolbox($relarea);
218	<	my $tb=$self->areatoolbox($area);
219	<	$rtb->copytools($tb);
220	<
221	<	# -- copy configuration directory
222	<	if ( ! -d $area->location()."/".$area->configurationdir() ) {
223	<	use Utilities::AddDir;
224	<	AddDir::copydir($relarea->location()."/".$relarea->configurationdir(),
225	<	$area->location()."/".$area->configurationdir() );
226	<	}
227	<
228	<	# -- copy RequirementsDoc
229	<	if ( ! -f $area->requirementsdoc() ) {
230	<	use File::Copy;
231	<	copy( $relarea->requirementsdoc() , $area->requirementsdoc());
216	>	my $name=$area->location();
217	>
218	>	if ( ! defined $self->{toolruntime}{$name} )
219	>	{
220	>	require Runtime;
221	>	my $toolbox=$self->areatoolbox($area);
222	>	$self->{toolruntime}{$name}=Runtime->new();
223	>
224	>	# Test for SCRAM_ARCH/lib order:
225	>	if ( -d $area->location()."/".$self->arch())
226	>	{
227	>	$ld_lib_path = $area->location()."/".$self->arch()."/lib"
228	>	unless ( ! -d $area->location()."/".$self->arch()."/lib");
229	>	$bin_path = $area->location()."/".$self->arch()."/bin"
230	>	unless ( ! -d $area->location()."/".$self->arch()."/bin");
231	>	}
232	>	# Other way around:
233	>	elsif ( -d  $area->location()."/lib/".$self->arch())
234	>	{
235	>	$ld_lib_path = $area->location()."/lib/".$self->arch()
236	>	unless ( ! -d $area->location()."/lib/".$self->arch());
237	>	$bin_path = $area->location()."/bin/".$self->arch()
238	>	unless ( ! -d $area->location()."/bin/".$self->arch());
239	>	}
240	>	else
241	>	# Assume no arch so just use lib and bin:
242	>	{
243	>	$ld_lib_path = $area->location()."/lib";
244	>	$bin_path = $area->location()."/bin";
245	>	}
246	>
247	>	# -- Now set the scram area specific runtimes accordingly:
248	>	$self->{toolruntime}{$name}->addvar("LD_LIBRARY_PATH",$ld_lib_path,"path");
249	>	$self->{toolruntime}{$name}->addvar("PATH",$bin_path,"path");
250	>
251	>	# Check for a linked area:
252	>	if ( defined $area->linkarea() )
253	>	{
254	>	my $relarea=$area->linkarea();
255	>	# Now do the checks for the release area:
256	>	if ( -d $relarea->location()."/".$self->arch())
257	>	{
258	>	$ld_lib_path = $relarea->location()."/".$self->arch()."/lib"
259	>	unless ( ! -d $relarea->location()."/".$self->arch()."/lib");
260	>	$bin_path = $relarea->location()."/".$self->arch()."/bin"
261	>	unless ( ! -d $relarea->location()."/".$self->arch()."/bin");
262	>	}
263	>	# Other way around:
264	>	elsif ( -d  $relarea->location()."/lib/".$self->arch())
265	>	{
266	>	$ld_lib_path = $relarea->location()."/lib/".$self->arch()
267	>	unless ( ! -d $relarea->location()."/lib/".$self->arch());
268	>	$bin_path = $relarea->location()."/bin/".$self->arch()
269	>	unless ( ! -d $relarea->location()."/bin/".$self->arch());
270	>	}
271	>	else
272	>	# Assume no arch so just use lib and bin:
273	>	{
274	>	$ld_lib_path = $relarea->location()."/lib";
275	>	$bin_path = $relarea->location()."/bin";
276	>	}
277	>	# Add the release paths:
278	>	$self->{toolruntime}{$name}->addvar("LD_LIBRARY_PATH",$ld_lib_path,"path");
279	>	$self->{toolruntime}{$name}->addvar("PATH",$bin_path,"path");
280	>	}
281	>
282	>	# -- get the runtime environment from all the tools
283	>	my $tool;
284	>	foreach $toolname ( $toolbox->tools() )
285	>	{
286	>	$tool=$toolbox->gettool($toolname);
287	>	if ( defined $tool )
288	>	{
289	>	# -- get runtime paths
290	>	foreach $f ( $tool->listtype("runtime_path"))
291	>	{
292	>	foreach $val ( $tool->getfeature($f) )
293	>	{
294	>	$self->{toolruntime}{$name}->addvar($f,$val,"path");
295	>	}
296	>	}
297	>	# -- get runtime vars
298	>	foreach $f ( $tool->listtype("runtime"))
299	>	{
300	>	foreach $val ( $tool->getfeature($f) )
301	>	{
302	>	$self->{toolruntime}{$name}->addvar($f,$val);
303	>	}
304	>	}
305	>	}
306	>	}
307	>
308	>	# -- Get the project level environment
309	>	my $runtimefile=$area->location()."/".$area->configurationdir()."/Runtime";
310	>
311	>	if ( -f $runtimefile )
312	>	{
313	>	$self->{toolruntime}{$name}->file($runtimefile);
314	>	}
315	>	}
316	>	return $self->{toolruntime}{$name};
317		}
318
149	–	return $area;
150	–	}
151	–
319		sub webget {
320	<	my $self=shift;
321	<	my $area=shift;
322	<	my $url=shift;
323	<
324	<	my $handler=URL::URLhandler->new($area->cache());
325	<	return ($handler->get($url));
320	>	my $self=shift;
321	>	my $area=shift;
322	>	my $url=shift;
323	>
324	>	require URL::URLhandler;
325	>	my $handler=URL::URLhandler->new($area->cache());
326	>	return ($handler->download($url));
327		}
328
329		sub addareatoDB {
330		my $self=shift;
331	+	my $flag=shift;
332		my $area=shift;
333		my $tagname=shift;
334		my $version=shift;
#	Line 171 | Line 340 | sub addareatoDB {
340		if ( (! defined $tagname)  || ( $tagname eq "") ) {
341		$tagname=$area->name();
342		}
174	–
343		# -- Add to the DB
344	<	$self->scramprojectdb()->addarea($tagname,$version,$area);
344	>	$self->scramprojectdb()->addarea($flag,$tagname,$version,$area);
345		}
346
179	–	sub spawnversion {
180	–	my $self=shift;
181	–	my $version=shift;
347
348	<	my $rv=0;
349	<	my $thisversion=$self->getversion();
350	<	if ( defined $version ) {
351	<	if ( $version ne $thisversion ) {
352	<	# first try to use the correct version
353	<	if ( -d $self->{scram_top}."/".$version ) {
354	<	$ENV{SCRAM_HOME}=$self->{scram_top}."/".$version;
355	<	$ENV{TOOL_HOME}="$ENV{SCRAM_HOME}/src";
356	<	$self->verbose("Spawning SCRAM version $version");
357	<	my $rv=system("scram", @_)/256;
358	<	exit $rv;
359	<	}
360	<	else { # if not then simply warn
361	<	print "******* Warning : scram version inconsistent ********\n";
362	<	print "This version: $thisversion; Required version: $version\n";
363	<	print "*****************************************************\n";
364	<	print "\n";
365	<	}
366	<	}
367	<	}
368	<	else {
369	<	$self->error("Undefined value for version requested");
370	<	$rv=1;
371	<	}
372	<	return $rv;
373	<	}
348	>	sub removeareafromDB
349	>	{
350	>	###############################################################
351	>	# removearefromDB()                                           #
352	>	###############################################################
353	>	# modified : Thu Jun 14 10:46:22 2001 / SFA                   #
354	>	# params   : projectname, projectversion                      #
355	>	#          :                                                  #
356	>	#          :                                                  #
357	>	#          :                                                  #
358	>	# function : Remove project <projectname> from DB file.       #
359	>	#          :                                                  #
360	>	#          :                                                  #
361	>	###############################################################
362	>	my $self=shift;
363	>	my $flag=shift;
364	>	my $projname=shift;
365	>	my $version=shift;
366	>
367	>	# -- Remove from the DB:
368	>	$self->scramprojectdb()->removearea($flag,$projname,$version);
369	>	}
370	>
371	>
372	>	sub spawnversion
373	>	{
374	>	###############################################################
375	>	# spawnversion                                                #
376	>	###############################################################
377	>	# modified : Fri Aug 10 15:42:08 2001 / SFA                   #
378	>	# params   :                                                  #
379	>	#          :                                                  #
380	>	#          :                                                  #
381	>	#          :                                                  #
382	>	# function : Check for version of scram to run, and run it.   #
383	>	#          :                                                  #
384	>	#          :                                                  #
385	>	###############################################################
386	>
387	>	my $self=shift;
388	>	my $version=shift;
389	>	my $rv=0;
390	>
391	>	my $thisversion=$self->getversion();
392	>
393	>	if ( defined $version )
394	>	{
395	>	if ( $version ne $thisversion )
396	>	{
397	>	# first try to use the correct version
398	>	if ( -d $self->{scram_top}."/".$version )
399	>	{
400	>	$ENV{SCRAM_HOME}=$self->{scram_top}."/".$version;
401	>	$ENV{SCRAM_TOOL_HOME}="$ENV{SCRAM_HOME}/src";
402	>	$self->verbose("Spawning SCRAM version $version");
403	>	my $rv=system($ENV{SCRAM_HOME}."/src/main/scram.pl", @_)/256;
404	>	exit $rv;
405	>	}
406	>	else
407	>	{
408	>	# if not then simply warn. Send output to STDERR:
409	>	if ( -t STDERR )
410	>	{
411	>	print STDERR "******* Warning : scram version inconsistent ********\n";
412	>	print STDERR "This version: $thisversion; Required version: $version\n";
413	>	print STDERR "*****************************************************\n";
414	>	print STDERR "\n";
415	>	}
416	>	}
417	>	}
418	>	}
419	>	else
420	>	{
421	>	$self->error("Undefined value for version requested");
422	>	$rv=1;
423	>	}
424	>	return $rv;
425	>	}
426
427		sub globalcache {
428		my $self=shift;
#	Line 263 | Line 480 | sub areatoolbox {
480		return $self->{toolboxes}{$name};
481		}
482
483	+	sub areatoolmanager
484	+	{
485	+	my $self=shift;
486	+	my $area=shift;
487	+
488	+	my $name=$area->location();
489	+
490	+	if ( ! defined $self->{toolmanagers}{$name} )
491	+	{
492	+	use BuildSystem::ToolManager;
493	+	$self->{toolmanagers}{$name}=ToolManager->new($area,$self->arch());
494	+	}
495	+
496	+	return $self->{toolmanagers}{$name};
497	+	}
498	+
499		sub arearequirements {
500		my $self=shift;
501		my $area=shift;
#	Line 297 | Line 530 | sub arch {
530		}
531
532		sub scramobjectinterface {
533	<	my $self=shift;
534	<	my $class=shift;
533	>	my $self=shift;
534	>	my $class=shift;
535
536	<	my $file;
537	<	($file=$class."\.pm")=~s/::/\//g;
538	<	$file=$ENV{TOOL_HOME}."/".$file;
536	>	my $file;
537	>	($file=$class."\.pm")=~s/::/\//g;
538	>	$file=$ENV{SCRAM_TOOL_HOME}."/".$file;
539
540	<	if ( ! -f $file ) {
541	<	$self->error("Unable to find $class in ".$ENV{TOOL_HOME});
542	<	}
543	<	print "--------------------- $class ------------------\n";
544	<	my $fh=FileHandle->new();
540	>	if ( ! -f $file ) {
541	>	$self->error("Unable to find $class in ".$ENV{SCRAM_TOOL_HOME});
542	>	}
543	>	print "--------------------- $class ------------------\n";
544	>	my $fh=FileHandle->new();
545		$fh->open("<$file");
546		while ( <$fh> ) {
547		if ( $_=~/#\s*Interface/g ) {
#	Line 332 | Line 565 | sub scramobjectinterface {
565		}
566		}
567		print "\n";
568	<	undef $fh;
568	>	undef $fh;
569		}
570
571		# -------------- Support Routines ------------------------------
#	Line 345 | Line 578 | sub _allprojectinitsearcher {
578		$search->addproject($$proj[0],$$proj[1]);
579		}
580		}
581	+	return $self->{projsearcher};
582		}
583
584		sub _projsearcher {

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines