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

package Scram::ScramFunctions;
use URL::URLcache;
use Utilities::Verbose;
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};
        return $self;
}

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);
        if ( defined $req ) {
          $req->download($self->areatoolbox($area));
        }  

        return $area;
}

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

        # -- initialise 
        $self->_allprojectinitsearcher();

        # -- create a new toolbox object
        my $toolbox=$self->areatoolbox($area);
        $toolbox->searcher($self->_projsearcher());

        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
            my $reqs=$self->arearequirements($area);
            $self->verbose("Setup ToolBox from Requirements doc ($reqs)");
            $reqs->setup($toolbox);
        }
}

sub satellite {
        my $self=shift;
        my $name=shift;
        my $version=shift;
        my $installarea=shift;

        my $areaname=undef;
        if ( @_ ) {
          $areaname=shift;
        }

        # -- look up scram database for location
        my $relarea=$self->_lookupareaindb($name,$version);
        if ( ! defined $relarea ) {
          $self->error("Unable to Find Project $name $version");
        }

        # -- fix for old broken areas
        if ( (! defined $relarea->version()) || ($relarea->version() eq "") ) {
           $relarea->version($version);
        }

        # -- create satellite
        my $area=$relarea->satellite($installarea,$areaname);
        $area->archname($self->arch());

        # -- copy setup info - deprecated by toolbox copy method
        #$relarea->copysetup($area->location());

        # -- copy toolbox
        my $rtb=$self->areatoolbox($relarea);
        my $tb=$self->areatoolbox($area);
        $rtb->copytools($tb);

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

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

        return $area;
}

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

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

sub addareatoDB {
        my $self=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($tagname,$version,$area);
}

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 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->{toolboxes}{$name}->verbosity($self->verbosity());
        }
        return $self->{toolboxes}{$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{TOOL_HOME}."/".$file;

        if ( ! -f $file ) {
          $self->error("Unable to find $class in ".$ENV{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]);
          }
        }
}

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.7
Committed:	Wed Sep 13 15:46:18 2000 UTC (24 years, 8 months ago) by williamc
Content type:	text/plain
Branch:	MAIN
Changes since 1.6:	+10 -0 lines
Log Message:	Add webget function
#	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.7	# webget(area,url) : get the url into the cache of the specified area
23	williamc	1.2
24			package Scram::ScramFunctions;
25			use URL::URLcache;
26			use Utilities::Verbose;
27			require 5.004;
28
29			@ISA=qw(Utilities::Verbose);
30
31			sub new {
32			my $class=shift;
33			$self={};
34			bless $self, $class;
35			# -- default settings
36	williamc	1.5	$self->{cachedir}=$ENV{HOME}."/.scramrc/globalcache";
37	williamc	1.2	$self->{scramprojectsdbdir}=$ENV{SCRAM_LOOKUPDB};
38			return $self;
39			}
40
41			sub project {
42			my $self=shift;
43			my $url=shift;
44			my $installarea=shift;
45
46			my $areaname="";
47			if ( @_ ) {
48			$areaname=shift;
49			}
50			require Configuration::BootStrapProject;
51			my $bs=Configuration::BootStrapProject->
52			new($self->globalcache(),$installarea);
53			$self->verbose("BootStrapping $url");
54			my $area=$bs->boot($url,$areaname);
55			if ( ! defined $area ) {
56			$self->error("Unable to create project area");
57			}
58			$area->archname($self->arch());
59
60			# -- download all tool description files
61			my $req=$self->arearequirements($area);
62			if ( defined $req ) {
63			$req->download($self->areatoolbox($area));
64			}
65
66			return $area;
67			}
68
69			sub setuptoolsinarea {
70			my $self=shift;
71			my $area=shift;
72
73			# -- initialise
74			$self->_allprojectinitsearcher();
75
76			# -- create a new toolbox object
77			my $toolbox=$self->areatoolbox($area);
78			$toolbox->searcher($self->_projsearcher());
79
80			if ( @_ ) {
81			# -- specific tool specified
82			if ( my $rv=$toolbox->toolsetup(@_) ) {
83			if ( $rv eq 1 ) {
84			print "Unknown tool $toolname @ARGV\n";
85			exit 1;
86			}
87			}
88			}
89			else {
90			# -- setup all tools specified in the requirements doc
91			my $reqs=$self->arearequirements($area);
92			$self->verbose("Setup ToolBox from Requirements doc ($reqs)");
93			$reqs->setup($toolbox);
94			}
95			}
96
97			sub satellite {
98			my $self=shift;
99			my $name=shift;
100			my $version=shift;
101			my $installarea=shift;
102
103	williamc	1.4	my $areaname=undef;
104	williamc	1.2	if ( @_ ) {
105			$areaname=shift;
106			}
107
108			# -- look up scram database for location
109			my $relarea=$self->_lookupareaindb($name,$version);
110			if ( ! defined $relarea ) {
111			$self->error("Unable to Find Project $name $version");
112	williamc	1.4	}
113
114			# -- fix for old broken areas
115			if ( (! defined $relarea->version()) \|\| ($relarea->version() eq "") ) {
116			$relarea->version($version);
117	williamc	1.2	}
118
119			# -- create satellite
120			my $area=$relarea->satellite($installarea,$areaname);
121			$area->archname($self->arch());
122
123			# -- copy setup info - deprecated by toolbox copy method
124			#$relarea->copysetup($area->location());
125
126			# -- copy toolbox
127			my $rtb=$self->areatoolbox($relarea);
128			my $tb=$self->areatoolbox($area);
129			$rtb->copytools($tb);
130
131			# -- copy configuration directory
132			if ( ! -d $area->location()."/".$area->configurationdir() ) {
133			use Utilities::AddDir;
134			AddDir::copydir($relarea->location()."/".$relarea->configurationdir(),
135			$area->location()."/".$area->configurationdir() );
136			}
137
138			# -- copy RequirementsDoc
139			if ( ! -f $area->requirementsdoc() ) {
140	williamc	1.3	use File::Copy;
141	williamc	1.2	copy( $relarea->requirementsdoc() , $area->requirementsdoc());
142			}
143
144			return $area;
145	williamc	1.7	}
146
147			sub webget {
148			my $self=shift;
149			my $area=shift;
150			my $url=shift;
151
152			my $handler=URL::URLhandler->new($area->cache());
153			return ($handler->get($url));
154	williamc	1.2	}
155
156			sub addareatoDB {
157			my $self=shift;
158			my $area=shift;
159			my $tagname=shift;
160			my $version=shift;
161
162			# -- create defaults if necessary
163			if ( (! defined $version) \|\| ( $version eq "") ) {
164			$version=$area->version();
165			}
166			if ( (! defined $tagname) \|\| ( $tagname eq "") ) {
167			$tagname=$area->name();
168			}
169
170			# -- Add to the DB
171			$self->scramprojectdb()->addarea($tagname,$version,$area);
172			}
173
174			sub globalcache {
175			my $self=shift;
176			if ( @_ ) {
177			$self->{cachedir}=shift;
178			}
179			if ( ! defined $self->{globalcache} ) {
180			$self->{globalcache}=URL::URLcache->new($self->{cachedir});
181			}
182			return $self->{globalcache};
183			}
184
185
186			sub scramprojectdb {
187			my $self=shift;
188			if ( @_ ) {
189			$self->{scramprojectsdbdir}=shift;
190			}
191			if ( ! defined $self->{scramprojectsdb} ) {
192			require Scram::ScramProjectDB;
193			$self->{scramprojectsdb}=Scram::ScramProjectDB->new(
194			$self->{scramprojectsdbdir} );
195			$self->{scramprojectsdb}->verbosity($self->verbosity());
196			}
197			return $self->{scramprojectsdb};
198			}
199
200			sub areatoolbox {
201			my $self=shift;
202			my $area=shift;
203
204			my $name=$area->location();
205			if ( ! defined $self->{toolboxes}{$name} ) {
206			# -- create a new toolbox object
207			require BuildSystem::ToolBox;
208			$self->{toolboxes}{$name}=BuildSystem::ToolBox->new($area);
209			$self->{toolboxes}{$name}->verbosity($self->verbosity());
210			}
211			return $self->{toolboxes}{$name};
212			}
213
214			sub arearequirements {
215			my $self=shift;
216			my $area=shift;
217
218			my $name=$area->location();
219			if ( ! defined $self->{requirements}{$name} ) {
220			# -- create a new toolbox object
221			require BuildSystem::Requirements;
222			my $doc=$area->requirementsdoc();
223			my $cache=$area->cache();
224			my $db=$area->objectstore();
225			require ActiveDoc::ActiveStore;
226			my $astore=ActiveDoc::ActiveStore->new($db,$cache);
227			$self->{requirements}{$name}=
228			BuildSystem::Requirements->new($astore,"file:".$doc,
229			$ENV{SCRAM_ARCH});
230			$self->{requirements}{$name}->verbosity($self->verbosity());
231			$self->verbose("Requirements Doc (".$self->{requirements}{$name}.
232			") for area :\n $name\n initiated from $doc");
233			}
234			else {
235			$self->verbose("Requirements Doc (".$self->{requirements}{$name}.")");
236			}
237			return $self->{requirements}{$name};
238			}
239
240			sub arch {
241			my $self=shift;
242
243			@_?$self->{arch}=shift
244			:$self->{arch};
245	williamc	1.6	}
246
247			sub scramobjectinterface {
248			my $self=shift;
249			my $class=shift;
250
251			my $file;
252			($file=$class."\.pm")=~s/::/\//g;
253			$file=$ENV{TOOL_HOME}."/".$file;
254
255			if ( ! -f $file ) {
256			$self->error("Unable to find $class in ".$ENV{TOOL_HOME});
257			}
258			print "--------------------- $class ------------------\n";
259			my $fh=FileHandle->new();
260			$fh->open("<$file");
261			while ( <$fh> ) {
262			if ( $_=~/#\s*Interface/g ) {
263			$intregion=1;
264			next;
265			}
266			if ( $intregion ) { # if we are in the interface documentation
267			if ( ( $_!~/^#/ ) \|\| ( $_=~/^#\s?-{40}/ ) ) { #moving out of Int doc
268			$intregion=0;
269			next;
270			}
271			print $_;
272			if ( $_=~/^#\s(.)\((.)\)?:(.)/ ) {
273			$interface=$1;
274			$args=$2;
275			$rest=$3;
276			next if ($interface eq "");
277			push @interfaces,$interface;
278			$interfaceargs{$interface}=$args;
279			}
280			}
281			}
282			print "\n";
283			undef $fh;
284	williamc	1.2	}
285
286			# -------------- Support Routines ------------------------------
287
288
289			sub _allprojectinitsearcher {
290			if ( ! defined $self->{projsearcher} ) {
291			my $search=_projsearcher();
292			foreach $proj ( $self->scramprojectdb()->list() ) {
293			$search->addproject($$proj[0],$$proj[1]);
294			}
295			}
296			}
297
298			sub _projsearcher {
299			if ( ! defined $self->{projsearcher} ) {
300			require Scram::ProjectSearcher;
301			$self->{projsearcher}=Scram::ProjectSearcher->new(
302			$self->scramprojectdb());
303			}
304			return $self->{projsearcher};
305			}
306
307
308			sub _lookupareaindb {
309			my $self=shift;
310
311			my $area=undef;
312			# -- Look up the area in the databse
313			my @areas=$self->scramprojectdb()->getarea(@_);
314			if ( $#areas > 0 ) { #ambigous
315			# could ask user - for now just error
316			$self->error("Ambigous request - please be more specific");
317			}
318			elsif ( $#areas != 0 ) { #not found
319			$self->error("The project requested has not been found");
320			}
321			else {
322			$area=$areas[0];
323			}
324			return $area;
325			}