src/Scram/ScramFunctions.pm

#
# ScramFunctions.pm
#
# Written by Christopher Williams
#
# Description
#
# Interface
# ---------
# new()         : A new ScramCommands object
# project(urlstring,dir[,areaname]): Create a project from the given url file
#                                       return the area
# satellite(name,version,installdirectory[,areaname]): create a satellite 
#                                       project from the specified name version
# addareatoDB(ConfigArea[,name[,version]]) : add area to the db 
# globalcache([cachedirectory])) : return the global cache object/set at dir.
# scramprojectdb()              : return the scram project DB object
# areatoolbox(ConfigArea) : return the toolbox of the specified area
# setuptoolsinarea($area[,$toolname[,$toolversion[,toolfile]) : setup
# arch()                : get/set the architecture string
# scramobjectinterface(Class)  : print out the interface of a scram class
# webget(area,url)      : get the url into the cache of the specified area
# getversion()          : return the current scram version
# spawnversion(version,@args) : spawn the scram version with the given args
# classverbose(classstring,setting) : Set the class verbosity level
# toolruntime(ConfigArea): Get a runtime object withthe settings from 
#                          the specified toolbox

package Scram::ScramFunctions;
use URL::URLcache;
use Utilities::Verbose;
use Utilities::IndexedFileStore;

require 5.004;

@ISA=qw(Utilities::Verbose);

sub new
   {
   my $class=shift;
   $self={};
   bless $self, $class;
   # -- default settings
   $self->{cachedir}=$ENV{HOME}."/.scramrc/globalcache";
   $self->{scramprojectsdbdir}=$ENV{SCRAM_LOOKUPDB};
   ($self->{scram_top})=( $ENV{SCRAM_HOME}=~/(.*)\//) ;
   
   return $self;
   }

sub classverbose {
        my $self=shift;
        my $class=shift;
        my $val=shift;

        $ENV{"VERBOSE_".$class}=$val;
}

sub project {
        my $self=shift;
        my $url=shift;
        my $installarea=shift;

        my $areaname="";
        if ( @_ ) {
          $areaname=shift;
        }
        require Configuration::BootStrapProject;
        my $bs=Configuration::BootStrapProject->
                        new($self->globalcache(),$installarea);
        $self->verbose("BootStrapping $url");
        my $area=$bs->boot($url,$areaname);
        if ( ! defined $area ) {
                $self->error("Unable to create project area");
        }
        $area->archname($self->arch());

        # -- download all tool description files
        my $req=$self->arearequirements($area);
        $area->toolboxversion($req->{configversion});

        if ( defined $req ) {
          $req->download($self->areatoolbox($area));
        }  

        return $area;
}

sub setuptoolsinarea
   {
   my $self=shift;
   my $area=shift;
   
   # -- initialise
   print "Initialising setup procedure......","\n";
   $self->_allprojectinitsearcher();
   
   # -- create a new toolbox object
   my $toolbox=$self->areatoolbox($area);
   $toolbox->searcher($self->_allprojectinitsearcher());
   
   if ( @_ )
      {
      # -- specific tool specified
      if ( my $rv=$toolbox->toolsetup(@_) )
         {
         if ( $rv eq 1 )
            {
            print "Unknown tool $toolname @ARGV\n";
            exit 1;
            }
         }
      }
   else
      {
      # -- setup all tools specified in the requirements doc
      print "Going to set up all tools....","\n\n";
      my $reqs=$self->arearequirements($area);     
      $self->verbose("Setup ToolBox from Requirements doc ($reqs)");
      # reqs is a BuildSystem::Requirements object:
      $reqs->setup($toolbox);
      }
   }

sub updatetoolsinarea
   {
   my $self=shift;
   my $area=shift;

   
   my $toolbox=$self->areatoolbox($area);

   print "Going to refresh the setup of tools....","\n\n";
   my $currenttag = $area->toolboxversion();
   
   # Get rid of the current cache:
   my $cachename = $area->cache()->location();
   system("mv","$cachename","$cachename".".$currenttag");
   # Create a new one:
   $area->_newcache();
   my $reqs=$self->arearequirements($area);
   $reqs->download();
   $reqs->setup($toolbox);
   print "Previous configuration tag : ",$currenttag,"\n";
   $area->toolboxversion($reqs->{configversion});
   print "Current configuration tag  : ",$area->toolboxversion(),"\n\n";
   $area->save();
   }

sub satellite
   {
   #
   # Modified to suit new structure
   #
   my $self=shift;
   my $name=shift;
   my $version=shift;
   my $installarea=shift;   
   my $areaname=undef;
   
   if ( @_ )
      {
      $areaname=shift;
      }
   
   # Get location from SCRAMDB:
   my $relarea=$self->_lookupareaindb($name,$version);

   if ( ! defined $relarea )
      {
      $self->error("Unable to Find Project $name $version");
      }
   
   # Create a satellite area:
   my $area=$relarea->satellite($installarea,$areaname);
   $area->archname($self->arch());

   # Copy the admin dir (and with it, the ToolCache):
   $relarea->copysetup($area->location());

   # Copy configuration directory contents:
   if ( ! -d $area->location()."/".$area->configurationdir() )
      {
      use Utilities::AddDir;
      AddDir::copydir($relarea->location()."/".$relarea->configurationdir(),
                      $area->location()."/".$area->configurationdir() );
      }

   # Make sourcecode dir:
   if ( ! -d $area->location()."/".$area->sourcedir() )
      {
      use Utilities::AddDir;
      AddDir::adddir($area->location()."/".$area->sourcedir());
      }

   # Copy RequirementsDoc:
   if ( ! -f $area->requirementsdoc() )
      {
      use File::Copy;
      copy( $relarea->requirementsdoc() , $area->requirementsdoc());
      }

   return $area;
   }

sub toolruntime {
        my $self=shift;
        my $area=shift;
        my $ld_lib_path="";
        my $bin_path="";

        my $name=$area->location();
        
        if ( ! defined $self->{toolruntime}{$name} )
           {
           require Runtime;
           my $toolbox=$self->areatoolbox($area);
           $self->{toolruntime}{$name}=Runtime->new();
           
           # Test for SCRAM_ARCH/lib order:
           if ( -d $area->location()."/".$self->arch())
              {
              $ld_lib_path = $area->location()."/".$self->arch()."/lib"
                 unless ( ! -d $area->location()."/".$self->arch()."/lib");
              $bin_path = $area->location()."/".$self->arch()."/bin"
                 unless ( ! -d $area->location()."/".$self->arch()."/bin");
              }
           # Other way around:
           elsif ( -d  $area->location()."/lib/".$self->arch())
              {
              $ld_lib_path = $area->location()."/lib/".$self->arch()
                 unless ( ! -d $area->location()."/lib/".$self->arch());
              $bin_path = $area->location()."/bin/".$self->arch()
                 unless ( ! -d $area->location()."/bin/".$self->arch());
              }
           else
              # Assume no arch so just use lib and bin:
              {
              $ld_lib_path = $area->location()."/lib";
              $bin_path = $area->location()."/bin";
              }
           
           # -- Now set the scram area specific runtimes accordingly:
           $self->{toolruntime}{$name}->addvar("LD_LIBRARY_PATH",$ld_lib_path,"path");
           $self->{toolruntime}{$name}->addvar("PATH",$bin_path,"path");
           
           # Check for a linked area:
           if ( defined $area->linkarea() )
              {
              my $relarea=$area->linkarea();
              # Now do the checks for the release area:
              if ( -d $relarea->location()."/".$self->arch())
                 {
                 $ld_lib_path = $relarea->location()."/".$self->arch()."/lib"
                    unless ( ! -d $relarea->location()."/".$self->arch()."/lib");
                 $bin_path = $relarea->location()."/".$self->arch()."/bin"
                    unless ( ! -d $relarea->location()."/".$self->arch()."/bin");
                 }
              # Other way around:
              elsif ( -d  $relarea->location()."/lib/".$self->arch())
                 {
                 $ld_lib_path = $relarea->location()."/lib/".$self->arch()
                    unless ( ! -d $relarea->location()."/lib/".$self->arch());
                 $bin_path = $relarea->location()."/bin/".$self->arch()
                    unless ( ! -d $relarea->location()."/bin/".$self->arch());
                 }
              else
                 # Assume no arch so just use lib and bin:
                 {
                 $ld_lib_path = $relarea->location()."/lib";
                 $bin_path = $relarea->location()."/bin";
                 }
              # Add the release paths:
              $self->{toolruntime}{$name}->addvar("LD_LIBRARY_PATH",$ld_lib_path,"path");
              $self->{toolruntime}{$name}->addvar("PATH",$bin_path,"path");
              }

           # -- get the runtime environment from all the tools
           my $tool;
           foreach $toolname ( $toolbox->tools() )
              {
              $tool=$toolbox->gettool($toolname);
              if ( defined $tool )
                 {
                 # -- get runtime paths
                 foreach $f ( $tool->listtype("runtime_path"))
                    {
                    foreach $val ( $tool->getfeature($f) )
                       {
                       $self->{toolruntime}{$name}->addvar($f,$val,"path");
                       }
                    }
                 # -- get runtime vars
                 foreach $f ( $tool->listtype("runtime"))
                    {
                    foreach $val ( $tool->getfeature($f) )
                       {
                       $self->{toolruntime}{$name}->addvar($f,$val);
                       }
                    }
                 }
              }

           # -- Get the project level environment
           my $runtimefile=$area->location()."/".$area->configurationdir()."/Runtime";

           if ( -f $runtimefile )
              {
              $self->{toolruntime}{$name}->file($runtimefile);
              }
           }
        return $self->{toolruntime}{$name};
        }

sub webget {
        my $self=shift;
        my $area=shift;
        my $url=shift;

        require URL::URLhandler;
        my $handler=URL::URLhandler->new($area->cache());
        return ($handler->download($url));
}

sub addareatoDB {
        my $self=shift;
        my $flag=shift;
        my $area=shift;
        my $tagname=shift;
        my $version=shift;

        # -- create defaults if necessary
        if ( (! defined $version)  || ( $version eq "") ) {
           $version=$area->version();
        }
        if ( (! defined $tagname)  || ( $tagname eq "") ) {
           $tagname=$area->name();
        }

        # -- Add to the DB
        $self->scramprojectdb()->addarea($flag,$tagname,$version,$area);
}


sub removeareafromDB
   {
   ###############################################################
   # removearefromDB()                                           #
   ###############################################################
   # modified : Thu Jun 14 10:46:22 2001 / SFA                   #
   # params   : projectname, projectversion                      #
   #          :                                                  #
   #          :                                                  #
   #          :                                                  #
   # function : Remove project <projectname> from DB file.       #
   #          :                                                  #
   #          :                                                  #
   ###############################################################
   my $self=shift;
   my $flag=shift;
   my $projname=shift;
   my $version=shift;
   
   # -- Remove from the DB:
   $self->scramprojectdb()->removearea($flag,$projname,$version);
   }


sub spawnversion
   {
   ###############################################################
   # spawnversion                                                #
   ###############################################################
   # modified : Fri Aug 10 15:42:08 2001 / SFA                   #
   # params   :                                                  #
   #          :                                                  #
   #          :                                                  #
   #          :                                                  #
   # function : Check for version of scram to run, and run it.   #
   #          :                                                  #
   #          :                                                  #
   ###############################################################

   my $self=shift;
   my $version=shift;
   my $rv=0;
   
   my $thisversion=$self->getversion();

   if ( defined $version )
      {
      if ( $version ne $thisversion )
         {
         # first try to use the correct version
         if ( -d $self->{scram_top}."/".$version )
            {
            $ENV{SCRAM_HOME}=$self->{scram_top}."/".$version;
            $ENV{SCRAM_TOOL_HOME}="$ENV{SCRAM_HOME}/src";
            $self->verbose("Spawning SCRAM version $version");
            my $rv=system("scram", @_)/256;
            exit $rv;
            }
         else
            {
            # if not then simply warn. Send output to STDERR:
            if ( -t STDERR )
               {
               print STDERR "******* Warning : scram version inconsistent ********\n";
               print STDERR "This version: $thisversion; Required version: $version\n";
               print STDERR "*****************************************************\n";
               print STDERR "\n";
               }    
            }
         }
      }
   else
      {
      $self->error("Undefined value for version requested");
      $rv=1;
      }
   return $rv;
   }

sub globalcache {
        my $self=shift;
        if ( @_ ) {
          $self->{cachedir}=shift;
        }
        if ( ! defined $self->{globalcache} ) {
          $self->{globalcache}=URL::URLcache->new($self->{cachedir});
        }
        return $self->{globalcache};
}


sub scramprojectdb {
        my $self=shift;
        if ( @_ ) {
          $self->{scramprojectsdbdir}=shift;
        }
        if ( ! defined $self->{scramprojectsdb} ) {
          require Scram::ScramProjectDB;
          $self->{scramprojectsdb}=Scram::ScramProjectDB->new(
                           $self->{scramprojectsdbdir} );
          $self->{scramprojectsdb}->verbosity($self->verbosity());
        }
        return $self->{scramprojectsdb};
}

sub getversion {
        my $self=shift;
        
        my $thisversion;
        ($thisversion=$ENV{SCRAM_HOME})=~s/(.*)\///;
        my $scram_top=$1;
        my $scram_version=$thisversion;
        # deal with links
        my $version=readlink $ENV{SCRAM_HOME};
        if ( defined $version)  {
          $scram_version=$version;
        }
        return $scram_version;
}
 
sub areatoolbox {
        my $self=shift;
        my $area=shift;

        my $name=$area->location();
        if ( ! defined $self->{toolboxes}{$name} ) {
          # -- create a new toolbox object
          require BuildSystem::ToolBox;
          $self->{toolboxes}{$name}=BuildSystem::ToolBox->new($area,
                                                        $self->arch());
          $self->{toolboxes}{$name}->verbosity($self->verbosity());
        }
        return $self->{toolboxes}{$name};
}

sub areatoolmanager
   {
   my $self=shift;
   my $area=shift;
   
   my $name=$area->location();
   print "Am I called at all, ever???","\n";
   if ( ! defined $self->{toolmanagers}{$name} )
      {
      use BuildSystem::ToolManager;
      $self->{toolmanagers}{$name}=ToolManager->new($area,$self->arch());
      }
   return $self->{toolmanagers}{$name};
   }


sub arearequirements {
        my $self=shift;
        my $area=shift;

        my $name=$area->location();
        if ( ! defined $self->{requirements}{$name} ) {
          # -- create a new toolbox object
          require BuildSystem::Requirements;
          my $doc=$area->requirementsdoc();
          my $cache=$area->cache();
          my $db=$area->objectstore();
          require ActiveDoc::ActiveStore;
          my $astore=ActiveDoc::ActiveStore->new($db,$cache);
          $self->{requirements}{$name}=
                BuildSystem::Requirements->new($astore,"file:".$doc, 
                        $ENV{SCRAM_ARCH});
          $self->{requirements}{$name}->verbosity($self->verbosity());
          $self->verbose("Requirements Doc (".$self->{requirements}{$name}.
                                  ") for area :\n $name\n initiated from $doc");
        }
        else {
          $self->verbose("Requirements Doc (".$self->{requirements}{$name}.")");
        }
        return $self->{requirements}{$name};
}

sub arch {
        my $self=shift;

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

sub scramobjectinterface {
        my $self=shift;
        my $class=shift;

        my $file;
        ($file=$class."\.pm")=~s/::/\//g;
        $file=$ENV{SCRAM_TOOL_HOME}."/".$file;

        if ( ! -f $file ) {
          $self->error("Unable to find $class in ".$ENV{SCRAM_TOOL_HOME});
        }
        print "--------------------- $class ------------------\n";
        my $fh=FileHandle->new();
        $fh->open("<$file");
        while ( <$fh> ) {
           if ( $_=~/#\s*Interface/g ) {
                $intregion=1;
                next;
           }
           if ( $intregion ) { # if we are in the interface documentation
            if ( ( $_!~/^#/ ) || ( $_=~/^#\s?-{40}/ ) ) { #moving out of Int doc
                $intregion=0;
                next;
            }
            print $_;
            if ( $_=~/^#\s*(.*)\((.*)\)?:(.*)/ ) {
             $interface=$1;
             $args=$2;
             $rest=$3;
             next if ($interface eq "");
             push @interfaces,$interface;
             $interfaceargs{$interface}=$args;
            }
           }
        }
        print "\n";
        undef $fh;
}

# -------------- Support Routines ------------------------------


sub _allprojectinitsearcher {
        if ( ! defined $self->{projsearcher} ) {
          my $search=_projsearcher();
          foreach $proj ( $self->scramprojectdb()->list() ) {
           $search->addproject($$proj[0],$$proj[1]);
          }
        }
        return $self->{projsearcher};
}

sub _projsearcher {
        if ( ! defined $self->{projsearcher} ) {
          require Scram::ProjectSearcher;
          $self->{projsearcher}=Scram::ProjectSearcher->new(
                        $self->scramprojectdb());
        }
        return $self->{projsearcher};
}


sub _lookupareaindb {
        my $self=shift;

        my $area=undef;
        # -- Look up the area in the databse
        my @areas=$self->scramprojectdb()->getarea(@_);
        if ( $#areas > 0 ) { #ambigous
                # could ask user - for now just error
          $self->error("Ambigous request - please be more specific");
        }
        elsif ( $#areas != 0 ) { #not found
          $self->error("The project requested has not been found");
        }
        else {
          $area=$areas[0];
        }
        return $area;
}
Revision:	1.21.4.1
Committed:	Fri Feb 27 15:34:56 2004 UTC (21 years, 2 months ago) by sashby
Content type:	text/plain
Branch:	SCRAM_V1_BRANCH
CVS Tags:	SCRAM_V1, SCRAMV1_IMPORT
Changes since 1.21:	+203 -91 lines
Log Message:	First import of new SCRAM packages into CMS cvs repos.
#	User	Rev	Content
1	williamc	1.2	#
2			# ScramFunctions.pm
3			#
4			# Written by Christopher Williams
5			#
6			# Description
7			#
8			# Interface
9			# ---------
10			# new() : A new ScramCommands object
11			# project(urlstring,dir[,areaname]): Create a project from the given url file
12			# return the area
13			# satellite(name,version,installdirectory[,areaname]): create a satellite
14			# project from the specified name version
15			# addareatoDB(ConfigArea[,name[,version]]) : add area to the db
16			# globalcache([cachedirectory])) : return the global cache object/set at dir.
17			# scramprojectdb() : return the scram project DB object
18			# areatoolbox(ConfigArea) : return the toolbox of the specified area
19			# setuptoolsinarea($area[,$toolname[,$toolversion[,toolfile]) : setup
20			# arch() : get/set the architecture string
21	williamc	1.6	# scramobjectinterface(Class) : print out the interface of a scram class
22	williamc	1.10	# webget(area,url) : get the url into the cache of the specified area
23	williamc	1.8	# getversion() : return the current scram version
24			# spawnversion(version,@args) : spawn the scram version with the given args
25	williamc	1.10	# classverbose(classstring,setting) : Set the class verbosity level
26			# toolruntime(ConfigArea): Get a runtime object withthe settings from
27			# the specified toolbox
28	williamc	1.2
29			package Scram::ScramFunctions;
30			use URL::URLcache;
31			use Utilities::Verbose;
32	sashby	1.21.4.1	use Utilities::IndexedFileStore;
33
34	williamc	1.2	require 5.004;
35
36			@ISA=qw(Utilities::Verbose);
37
38	sashby	1.11	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	williamc	1.2
51	williamc	1.10	sub classverbose {
52			my $self=shift;
53			my $class=shift;
54			my $val=shift;
55
56			$ENV{"VERBOSE_".$class}=$val;
57			}
58
59	williamc	1.2	sub project {
60			my $self=shift;
61			my $url=shift;
62			my $installarea=shift;
63
64			my $areaname="";
65			if ( @_ ) {
66			$areaname=shift;
67			}
68			require Configuration::BootStrapProject;
69			my $bs=Configuration::BootStrapProject->
70			new($self->globalcache(),$installarea);
71			$self->verbose("BootStrapping $url");
72			my $area=$bs->boot($url,$areaname);
73			if ( ! defined $area ) {
74			$self->error("Unable to create project area");
75			}
76			$area->archname($self->arch());
77
78			# -- download all tool description files
79			my $req=$self->arearequirements($area);
80	sashby	1.21.4.1	$area->toolboxversion($req->{configversion});
81
82	williamc	1.2	if ( defined $req ) {
83			$req->download($self->areatoolbox($area));
84			}
85
86			return $area;
87			}
88
89	sashby	1.18	sub setuptoolsinarea
90			{
91			my $self=shift;
92			my $area=shift;
93	sashby	1.19
94	sashby	1.18	# -- 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	williamc	1.2
125	sashby	1.21.4.1	sub updatetoolsinarea
126			{
127			my $self=shift;
128			my $area=shift;
129	williamc	1.2
130	sashby	1.21.4.1
131			my $toolbox=$self->areatoolbox($area);
132	williamc	1.2
133	sashby	1.21.4.1	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	williamc	1.4
150	sashby	1.21.4.1	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;
159			my $areaname=undef;
160
161			if ( @_ )
162			{
163			$areaname=shift;
164			}
165
166			# Get location from SCRAMDB:
167			my $relarea=$self->_lookupareaindb($name,$version);
168	williamc	1.2
169	sashby	1.21.4.1	if ( ! defined $relarea )
170			{
171			$self->error("Unable to Find Project $name $version");
172			}
173
174			# Create a satellite area:
175			my $area=$relarea->satellite($installarea,$areaname);
176			$area->archname($self->arch());
177	williamc	1.2
178	sashby	1.21.4.1	# Copy the admin dir (and with it, the ToolCache):
179			$relarea->copysetup($area->location());
180	williamc	1.2
181	sashby	1.21.4.1	# Copy configuration directory contents:
182			if ( ! -d $area->location()."/".$area->configurationdir() )
183			{
184			use Utilities::AddDir;
185			AddDir::copydir($relarea->location()."/".$relarea->configurationdir(),
186			$area->location()."/".$area->configurationdir() );
187			}
188
189			# Make sourcecode dir:
190			if ( ! -d $area->location()."/".$area->sourcedir() )
191			{
192			use Utilities::AddDir;
193			AddDir::adddir($area->location()."/".$area->sourcedir());
194			}
195
196			# Copy RequirementsDoc:
197			if ( ! -f $area->requirementsdoc() )
198			{
199			use File::Copy;
200			copy( $relarea->requirementsdoc() , $area->requirementsdoc());
201			}
202
203			return $area;
204			}
205	williamc	1.7
206	williamc	1.10	sub toolruntime {
207	williamc	1.7	my $self=shift;
208			my $area=shift;
209	sashby	1.21.4.1	my $ld_lib_path="";
210			my $bin_path="";
211	williamc	1.7
212	williamc	1.10	my $name=$area->location();
213	sashby	1.21.4.1
214			if ( ! defined $self->{toolruntime}{$name} )
215			{
216			require Runtime;
217			my $toolbox=$self->areatoolbox($area);
218			$self->{toolruntime}{$name}=Runtime->new();
219
220			# Test for SCRAM_ARCH/lib order:
221			if ( -d $area->location()."/".$self->arch())
222			{
223			$ld_lib_path = $area->location()."/".$self->arch()."/lib"
224			unless ( ! -d $area->location()."/".$self->arch()."/lib");
225			$bin_path = $area->location()."/".$self->arch()."/bin"
226			unless ( ! -d $area->location()."/".$self->arch()."/bin");
227			}
228			# Other way around:
229			elsif ( -d $area->location()."/lib/".$self->arch())
230			{
231			$ld_lib_path = $area->location()."/lib/".$self->arch()
232			unless ( ! -d $area->location()."/lib/".$self->arch());
233			$bin_path = $area->location()."/bin/".$self->arch()
234			unless ( ! -d $area->location()."/bin/".$self->arch());
235			}
236			else
237			# Assume no arch so just use lib and bin:
238			{
239			$ld_lib_path = $area->location()."/lib";
240			$bin_path = $area->location()."/bin";
241			}
242
243			# -- Now set the scram area specific runtimes accordingly:
244			$self->{toolruntime}{$name}->addvar("LD_LIBRARY_PATH",$ld_lib_path,"path");
245			$self->{toolruntime}{$name}->addvar("PATH",$bin_path,"path");
246
247			# Check for a linked area:
248			if ( defined $area->linkarea() )
249			{
250			my $relarea=$area->linkarea();
251			# Now do the checks for the release area:
252			if ( -d $relarea->location()."/".$self->arch())
253			{
254			$ld_lib_path = $relarea->location()."/".$self->arch()."/lib"
255			unless ( ! -d $relarea->location()."/".$self->arch()."/lib");
256			$bin_path = $relarea->location()."/".$self->arch()."/bin"
257			unless ( ! -d $relarea->location()."/".$self->arch()."/bin");
258			}
259			# Other way around:
260			elsif ( -d $relarea->location()."/lib/".$self->arch())
261			{
262			$ld_lib_path = $relarea->location()."/lib/".$self->arch()
263			unless ( ! -d $relarea->location()."/lib/".$self->arch());
264			$bin_path = $relarea->location()."/bin/".$self->arch()
265			unless ( ! -d $relarea->location()."/bin/".$self->arch());
266			}
267			else
268			# Assume no arch so just use lib and bin:
269			{
270			$ld_lib_path = $relarea->location()."/lib";
271			$bin_path = $relarea->location()."/bin";
272			}
273			# Add the release paths:
274			$self->{toolruntime}{$name}->addvar("LD_LIBRARY_PATH",$ld_lib_path,"path");
275			$self->{toolruntime}{$name}->addvar("PATH",$bin_path,"path");
276			}
277
278			# -- get the runtime environment from all the tools
279			my $tool;
280			foreach $toolname ( $toolbox->tools() )
281			{
282			$tool=$toolbox->gettool($toolname);
283			if ( defined $tool )
284			{
285			# -- get runtime paths
286			foreach $f ( $tool->listtype("runtime_path"))
287			{
288			foreach $val ( $tool->getfeature($f) )
289			{
290			$self->{toolruntime}{$name}->addvar($f,$val,"path");
291			}
292			}
293			# -- get runtime vars
294			foreach $f ( $tool->listtype("runtime"))
295			{
296			foreach $val ( $tool->getfeature($f) )
297			{
298			$self->{toolruntime}{$name}->addvar($f,$val);
299			}
300			}
301			}
302			}
303
304			# -- Get the project level environment
305			my $runtimefile=$area->location()."/".$area->configurationdir()."/Runtime";
306
307			if ( -f $runtimefile )
308			{
309			$self->{toolruntime}{$name}->file($runtimefile);
310			}
311			}
312	williamc	1.10	return $self->{toolruntime}{$name};
313	sashby	1.21.4.1	}
314	williamc	1.10
315			sub webget {
316			my $self=shift;
317			my $area=shift;
318			my $url=shift;
319
320			require URL::URLhandler;
321			my $handler=URL::URLhandler->new($area->cache());
322			return ($handler->download($url));
323	williamc	1.2	}
324
325			sub addareatoDB {
326			my $self=shift;
327	sashby	1.21.4.1	my $flag=shift;
328	williamc	1.2	my $area=shift;
329			my $tagname=shift;
330			my $version=shift;
331
332			# -- create defaults if necessary
333			if ( (! defined $version) \|\| ( $version eq "") ) {
334			$version=$area->version();
335			}
336			if ( (! defined $tagname) \|\| ( $tagname eq "") ) {
337			$tagname=$area->name();
338			}
339
340			# -- Add to the DB
341	sashby	1.21.4.1	$self->scramprojectdb()->addarea($flag,$tagname,$version,$area);
342	williamc	1.2	}
343
344	sashby	1.13
345			sub removeareafromDB
346			{
347			###############################################################
348			# removearefromDB() #
349			###############################################################
350			# modified : Thu Jun 14 10:46:22 2001 / SFA #
351			# params : projectname, projectversion #
352			# : #
353			# : #
354			# : #
355			# function : Remove project <projectname> from DB file. #
356			# : #
357			# : #
358			###############################################################
359			my $self=shift;
360	sashby	1.21.4.1	my $flag=shift;
361	sashby	1.13	my $projname=shift;
362			my $version=shift;
363
364			# -- Remove from the DB:
365	sashby	1.21.4.1	$self->scramprojectdb()->removearea($flag,$projname,$version);
366	sashby	1.13	}
367
368
369	sashby	1.12	sub spawnversion
370			{
371	sashby	1.15	###############################################################
372			# spawnversion #
373			###############################################################
374			# modified : Fri Aug 10 15:42:08 2001 / SFA #
375			# params : #
376			# : #
377			# : #
378			# : #
379			# function : Check for version of scram to run, and run it. #
380			# : #
381			# : #
382			###############################################################
383
384	sashby	1.12	my $self=shift;
385			my $version=shift;
386			my $rv=0;
387
388			my $thisversion=$self->getversion();
389	williamc	1.8
390	sashby	1.12	if ( defined $version )
391			{
392			if ( $version ne $thisversion )
393			{
394			# first try to use the correct version
395			if ( -d $self->{scram_top}."/".$version )
396			{
397			$ENV{SCRAM_HOME}=$self->{scram_top}."/".$version;
398	sashby	1.21.4.1	$ENV{SCRAM_TOOL_HOME}="$ENV{SCRAM_HOME}/src";
399	sashby	1.12	$self->verbose("Spawning SCRAM version $version");
400			my $rv=system("scram", @_)/256;
401			exit $rv;
402			}
403			else
404	sashby	1.21	{
405			# if not then simply warn. Send output to STDERR:
406			if ( -t STDERR )
407			{
408			print STDERR "***** Warning : scram version inconsistent ******\n";
409			print STDERR "This version: $thisversion; Required version: $version\n";
410			print STDERR "*****************************************************\n";
411			print STDERR "\n";
412			}
413	sashby	1.12	}
414			}
415			}
416			else
417			{
418			$self->error("Undefined value for version requested");
419			$rv=1;
420			}
421			return $rv;
422			}
423	williamc	1.8
424	williamc	1.2	sub globalcache {
425			my $self=shift;
426			if ( @_ ) {
427			$self->{cachedir}=shift;
428			}
429			if ( ! defined $self->{globalcache} ) {
430			$self->{globalcache}=URL::URLcache->new($self->{cachedir});
431			}
432			return $self->{globalcache};
433			}
434
435
436			sub scramprojectdb {
437			my $self=shift;
438			if ( @_ ) {
439			$self->{scramprojectsdbdir}=shift;
440			}
441			if ( ! defined $self->{scramprojectsdb} ) {
442			require Scram::ScramProjectDB;
443			$self->{scramprojectsdb}=Scram::ScramProjectDB->new(
444			$self->{scramprojectsdbdir} );
445			$self->{scramprojectsdb}->verbosity($self->verbosity());
446			}
447			return $self->{scramprojectsdb};
448			}
449	williamc	1.8
450			sub getversion {
451			my $self=shift;
452
453			my $thisversion;
454			($thisversion=$ENV{SCRAM_HOME})=~s/(.*)\///;
455			my $scram_top=$1;
456			my $scram_version=$thisversion;
457			# deal with links
458			my $version=readlink $ENV{SCRAM_HOME};
459			if ( defined $version) {
460			$scram_version=$version;
461			}
462			return $scram_version;
463			}
464	williamc	1.2
465			sub areatoolbox {
466			my $self=shift;
467			my $area=shift;
468
469			my $name=$area->location();
470			if ( ! defined $self->{toolboxes}{$name} ) {
471			# -- create a new toolbox object
472			require BuildSystem::ToolBox;
473	williamc	1.8	$self->{toolboxes}{$name}=BuildSystem::ToolBox->new($area,
474			$self->arch());
475	williamc	1.2	$self->{toolboxes}{$name}->verbosity($self->verbosity());
476			}
477			return $self->{toolboxes}{$name};
478			}
479
480	sashby	1.21.4.1	sub areatoolmanager
481			{
482			my $self=shift;
483			my $area=shift;
484
485			my $name=$area->location();
486			print "Am I called at all, ever???","\n";
487			if ( ! defined $self->{toolmanagers}{$name} )
488			{
489			use BuildSystem::ToolManager;
490			$self->{toolmanagers}{$name}=ToolManager->new($area,$self->arch());
491			}
492			return $self->{toolmanagers}{$name};
493			}
494
495
496	williamc	1.2	sub arearequirements {
497			my $self=shift;
498			my $area=shift;
499
500			my $name=$area->location();
501			if ( ! defined $self->{requirements}{$name} ) {
502			# -- create a new toolbox object
503			require BuildSystem::Requirements;
504			my $doc=$area->requirementsdoc();
505			my $cache=$area->cache();
506			my $db=$area->objectstore();
507			require ActiveDoc::ActiveStore;
508			my $astore=ActiveDoc::ActiveStore->new($db,$cache);
509			$self->{requirements}{$name}=
510			BuildSystem::Requirements->new($astore,"file:".$doc,
511			$ENV{SCRAM_ARCH});
512			$self->{requirements}{$name}->verbosity($self->verbosity());
513			$self->verbose("Requirements Doc (".$self->{requirements}{$name}.
514			") for area :\n $name\n initiated from $doc");
515			}
516			else {
517			$self->verbose("Requirements Doc (".$self->{requirements}{$name}.")");
518			}
519			return $self->{requirements}{$name};
520			}
521
522			sub arch {
523			my $self=shift;
524
525			@_?$self->{arch}=shift
526			:$self->{arch};
527	williamc	1.6	}
528
529			sub scramobjectinterface {
530	williamc	1.10	my $self=shift;
531			my $class=shift;
532	williamc	1.6
533	williamc	1.10	my $file;
534			($file=$class."\.pm")=~s/::/\//g;
535	sashby	1.21.4.1	$file=$ENV{SCRAM_TOOL_HOME}."/".$file;
536	williamc	1.6
537	williamc	1.10	if ( ! -f $file ) {
538	sashby	1.21.4.1	$self->error("Unable to find $class in ".$ENV{SCRAM_TOOL_HOME});
539	williamc	1.10	}
540			print "--------------------- $class ------------------\n";
541			my $fh=FileHandle->new();
542	williamc	1.6	$fh->open("<$file");
543			while ( <$fh> ) {
544			if ( $_=~/#\s*Interface/g ) {
545			$intregion=1;
546			next;
547			}
548			if ( $intregion ) { # if we are in the interface documentation
549			if ( ( $_!~/^#/ ) \|\| ( $_=~/^#\s?-{40}/ ) ) { #moving out of Int doc
550			$intregion=0;
551			next;
552			}
553			print $_;
554			if ( $_=~/^#\s(.)\((.)\)?:(.)/ ) {
555			$interface=$1;
556			$args=$2;
557			$rest=$3;
558			next if ($interface eq "");
559			push @interfaces,$interface;
560			$interfaceargs{$interface}=$args;
561			}
562			}
563			}
564			print "\n";
565	williamc	1.10	undef $fh;
566	williamc	1.2	}
567
568			# -------------- Support Routines ------------------------------
569
570
571			sub _allprojectinitsearcher {
572			if ( ! defined $self->{projsearcher} ) {
573			my $search=_projsearcher();
574			foreach $proj ( $self->scramprojectdb()->list() ) {
575			$search->addproject($$proj[0],$$proj[1]);
576			}
577			}
578	williamc	1.10	return $self->{projsearcher};
579	williamc	1.2	}
580
581			sub _projsearcher {
582			if ( ! defined $self->{projsearcher} ) {
583			require Scram::ProjectSearcher;
584			$self->{projsearcher}=Scram::ProjectSearcher->new(
585			$self->scramprojectdb());
586			}
587			return $self->{projsearcher};
588			}
589
590
591			sub _lookupareaindb {
592			my $self=shift;
593
594			my $area=undef;
595			# -- Look up the area in the databse
596			my @areas=$self->scramprojectdb()->getarea(@_);
597			if ( $#areas > 0 ) { #ambigous
598			# could ask user - for now just error
599			$self->error("Ambigous request - please be more specific");
600			}
601			elsif ( $#areas != 0 ) { #not found
602			$self->error("The project requested has not been found");
603			}
604			else {
605			$area=$areas[0];
606			}
607			return $area;
608			}