src/BuildSystem/ToolDoc.pm

#
# ToolDoc.pm
#
# Originally Written by Christopher Williams
#
# Description
# -----------
# SimpleDoc interface to initialise Tool objects
#
# Interface
# ---------
# new()         : A new ToolDoc object
# tool(toolobj) : set the tool object for the class
# toolsearcher(searcher) : set the searcher for finding reference tools
# setup(file,$name,$version) : setup a tool object from the specified file
#                               return 0 for OK 1 for cancel
# interactive([0|1]) : set the interactive node 0=off 1=on

package BuildSystem::ToolDoc;
require 5.004;
use ActiveDoc::SimpleDoc;
use Utilities::Verbose;
@ISA=qw(Utilities::Verbose);

sub new {
        my $class=shift;
        $self={};
        bless $self, $class;
        $self->{cache}=shift;
        $self->{mydoctype}="BuildSystem::ToolDoc";
        $self->{mydocversion}="1.0";
        $self->init();
        return $self;
}

sub init {
        my $self=shift;
        $self->{switch}=ActiveDoc::SimpleDoc->new();
        $self->{switch}->newparse("setupinit");
        $self->{switch}->addtag("setupinit","Tool",\&Tool_Start, $self, 
                                                "", $self,
                                                \&Tool_End, $self);
        $self->{switch}->addtag("setupinit", "Architecture",
                                        \&Arch_Start,$self,
                                        "", $self,
                                        \&Arch_End,$self);
        $self->{switch}->addtag("setupinit","Environment",
                                        \&Environment_init, $self,
                                        "", $self,
                                        "", $self);
        $self->{switch}->newparse("setup");
        $self->{switch}->addtag("setup","Tool",\&Tool_Start, $self,     
                                                "", $self,
                                                \&Tool_End, $self);
        $self->{switch}->addtag("setup","Lib",\&Lib, $self,     
                                                "", $self,
                                                "", $self);
        $self->{switch}->addtag("setup","External",\&External_Start, $self,     
                                                "", $self,
                                                "", $self);
        $self->{switch}->addtag("setup","Client",\&Client_start, $self, 
                                                "", $self,
                                                \&Client_end, $self);
        $self->{switch}->addtag("setup","Environment",
                                                \&Environment_Start, $self,     
                                                \&Env_text, $self,
                                                \&Environment_End, $self);
        $self->{switch}->grouptag("Tool","setup");
        $self->{switch}->addtag("setup","Architecture",
                                        \&Arch_Start,$self,
                                        "", $self,
                                        \&Arch_End,$self);
        $self->{Arch}=1;
        push @{$self->{ARCHBLOCK}}, $self->{Arch};

}

sub interactive {
        my $self=shift;
        
        @_?$self->{interactive}=shift
          :((defined $self->{interactive})?$self->{interactive}:0);
}

sub tool {
        my $self=shift;
        $self->{tool}=shift;
}

sub toolsearcher {
        my $self=shift;
        if ( @_ ) {
          my $searcher=shift;
          if ( ! defined $searcher ) {
             $self->error("Undefined Value passed as a Searcher".
                " in ToolDoc::toolsearcher");
          }
          $self->{toolboxsearcher}=$searcher;
        }
        return $self->{toolboxsearcher};
}

sub setup {
        my $self=shift;
        my $file=shift;
        my $name=shift;
        my $version=shift;

        $self->{ToolEnv}{'SCRAMtoolname'}=$name;
        $self->{ToolEnv}{'SCRAMtoolversion'}=$version;
        $self->{ToolEnv}{'SCRAM_ARCH'}=$ENV{'SCRAM_ARCH'};

        $name=~tr[A-Z][a-z];
        $self->{tool}->name($name);
        $self->{tool}->version($version);
        $self->{switch}->filetoparse($file);
        $self->{toolfound}=1;
        # -- check the type of document - can we parse it?
        my($doctype,$docversion)=$self->{switch}->doctype();
        if ( ($doctype ne $self->{mydoctype}) || 
                ($self->{mydocversion} ne $docversion) ) {
          $self->error("Unable to Parse Document of type $doctype $docversion".
                "\n(Only ".$self->{mydoctype}." ". $self->{mydocversion}.")");
        }
        delete $self->{envcount};
        $self->{switch}->parse("setupinit");
        $self->{switch}->parse("setup");
        return $self->{toolfound};
}

sub featuretext {
        my $self=shift;
        my $feature=shift;

        if ( @_ ) {
          $self->{featuretext}{$feature}=shift;
        }
        else {
          return ($self->{featuretext}{$feature});
        }
}

sub _checkdefault {
        my $self=shift;
        my $hashref=shift;

        if ( defined $$hashref{'default'} ) { #check default
          my $default;
          foreach $default ( split /:/, $$hashref{'default'} ) {
            $default=~s/\"//;
            if ($self->_testlocation($default,
               [ $self->{tool}->getfeature($$hashref{'type'})] )) { return 1; }
          }
        }
        return 0;
}

sub _testlocation {
        my $self=shift;
        my $default=shift;
        my $testfiles=shift;

        my $OK='false';
        my $file;

        chomp $default;
        $default=$self->_expandvars($default);
        $self->verbose("Testing location");
        print "Trying $default .... ";
        if ( -f $default ) {
                $OK="true";
                $self->verbose("File OK");
        }
        else {
          my $dh=DirHandle->new();
          opendir $dh, $default or do { print "No $!\n"; return 0; };
         ($#{$testfiles}==-1) ? $OK='false' : $OK='true';
          print "\n";
          my @files=readdir $dh;
          undef $dh;
          foreach $file ( @$testfiles ) {
                print "   Checking for $file .... ";
                # now check that the required files are actually there
                if ( ( $number = grep /\Q$file\L/, @files) == 0 ) {
                   $OK='false';
                   print "not found\n";
                   last;
                }
                print "found\n";
          }
        }
        if ( $OK eq 'true' ) {
                print "Directory Check Complete\n";
                return 1
        }
        return 0
}

sub _expandvars {
        my $self=shift;
        my $string=shift;

        return "" , if ( ! defined $string );
        $string=~s{
                \$\((\w+)\)
        }{
          if (defined $self->{ToolEnv}{$1}) {
                $self->_expandvars($self->{ToolEnv}{$1});
          } else {
                "\$$1";
          }
        }egx;
        $string=~s{
                \$(\w+)
        }{
          if (defined $self->{ToolEnv}{$1}) {
                $self->_expandvars($self->{ToolEnv}{$1});
          } else {
                "\$$1";
          }
        }egx;
        return $string;
}

sub _askusermenu {
        my $self=shift;
        my $querystring=shift;
        my @items=@_;

        my $path=-1;
        my $n;
        while ( ($path!~/^\d+$/) || ($path > ($#items+1)) || ($path < 1) ) {
         for (my $i=0; $i<=$#items; $i++ ) {
          $n=$i+1;
          print $n.") ".$items[$i]."\n";
         }
         print "\n".$querystring;
         $path=<STDIN>;
         chomp $path;
        }
        $path--;
        return $path;
}

sub _askuser {
        my $self=shift;
        my $querystring=shift;
        my $varname=shift;

        my $type=$self->{tool}->type($varname);
        my $path;
        my $oldpath;
        print $self->featuretext($self->{EnvContext});
        for  ( ;; ) {
         print "\n".$querystring." (RETURN to log as missing)\nset $varname = ";
         $path=<STDIN>;
         chomp $path;
         $oldpath=$path;
         if ( $path ne "" ) {
          ($path)=$self->_validateparam($type,$path);
           if ( ! defined $path ) {
            print "Error : ".$oldpath." is not valid.\n";
            next;
           }
         }
         return $path;
        } #end for

}

sub _validateparam {
        my $self=shift;
        my $type=shift;
        my @params=@_;

        my @newparams=();
        foreach $param ( @params ) {
         if ( defined $self->{'client'}) { # must be a location
          if ( $self->_testlocation($param ,
               [ $self->{tool}->getfeature($type)] )) {
            $self->verbose("$param passed validation");
            push @newparams,$param;
          }
          else {
            $self->verbose("$param failed validation");
          }
         }
         else {
           # --- no other tests to pass so it must be OK
           push @newparams,$param;
         }
        }
        return @newparams;
}

#
# Propgate through the searcher collecting matching tools
#
sub _searchtools {
        my $self=shift;
        my $tool=shift;
        my $searcher=shift;

        my @tools=();
        my $area;
        my $rtool;
        my $it=$searcher->newiterator();

        while ( ! $it->last()  ) {
             $area=$it->next();
             if ( defined $area ) {
              $self->verbose("Searching for ".$tool->name()." ".
                 $tool->version()." in ".$area->location());
              $rtool=$area->toolbox()->gettool($tool->name(),$tool->version());
              if ( defined $rtool ) {
               if ( $rtool->equals($tool) ) {
                $self->verbose("Found matching tool");
                push @tools,$rtool;
               }
               else {
                $self->verbose("Rejected tool ".$rtool->name()." "
                                                        .$rtool->version());
               }
              }
              else {
                $self->verbose("Tool Passed as Undefined");
              }
             }
             else {
                $self->verbose("Area passed is not defined");
             }
        }
        return @tools; 
}

# search toolboxes for a nice list
#
sub _toolparamcopy {
        my $self=shift;
        my $tool=shift;
        my $param=shift;

        my $rv=0;
        my @params=();
        $self->verbose("Check Other Projects for tool");
        my @validtools=();
        if ( defined $self->{toolboxsearcher} ) {
          @validtools=$self->_searchtools($tool,$self->{toolboxsearcher});
        }
        if ( $#validtools >=0 ) {
          if ( ! $self->interactive() ) {
           @params=$validtools[0]->getfeature($param);
           if ( $#params >=0 ) {
                $self->verbose("Extracting Feature $param from tool".
                        " (= @params )\n");
                $rv=1;
           }
          }
        }
        return ($rv,@params);
}

sub _getparamsets {
        my $self=shift;
        my $tool=shift;
        my $param=shift;

        my @paramlist=();
        my @params=();
        $self->verbose("Searching for parameter settings in other tools");
        my @validtools=();
        if ( defined $self->{toolboxsearcher} ) {
          @validtools=$self->_searchtools($tool,$self->{toolboxsearcher});
        }
        else {
          $self->verbose("No tool searcher available");
        }
        if ( $#validtools >=0 ) {
          foreach $t ( @validtools ) {
            @params=$t->getfeature($param);
            if ( $#params >=0 ) {
              push @paramlist, [ @params ];
              $self->verbose("Found @params");
            }
          }
        }
        return @paramlist;
}

# -- Tag Routines

sub Client_start {
        my $self=shift;
        my $name=shift;
        my $hashref=shift;

        if ( $self->{Arch} ) {
          $self->{'client'}=1;
        }
}

sub Client_end {
        my $self=shift;
        if ( $self->{Arch} ) {
        undef $self->{'client'};
        }
}
        
sub Tool_Start {
        my $self=shift;
        my $name=shift;
        my $hashref=shift;

        $self->{switch}->checktag($name, $hashref, 'name');
        $self->{switch}->checktag($name, $hashref, 'version');
        $self->{switch}->opengroup("Toolactive");

        # lower case the name
        $$hashref{'name'}=~tr[A-Z][a-z];
        # make sure we only pick up the tool requested
        if ( ( $self->{tool}->name() eq $$hashref{'name'} ) && 
                ($self->{tool}->version() eq $$hashref{'version'})) {
          $self->{switch}->
                allowgroup("Toolactive",$self->{switch}->currentparsename());
          $self->{ToolEnv}{'SCRAMtoolname'}=$$hashref{'name'};
          $self->{ToolEnv}{'SCRAMtoolversion'}=$$hashref{'version'};
          $self->{toolfound}=0;
        }
        else {
          $self->{switch}->disallowgroup("Toolactive",
                                $self->{switch}->currentparsename());
        }
}

sub Tool_End {
        my $self=shift;
        my $name=shift;
        my $hashref=shift;

        $self->{switch}->closegroup("Toolactive");
}

# -- collect number of variables of the same name - need to know how many
#    before main setup processing
sub Environment_init {
        my $self=shift;
        my $name=shift;
        my $hashref=shift;

        $self->{switch}->checktag($name, $hashref, 'name');
        if ( $self->{Arch} ) {
        if ( exists $self->{envcount}{$$hashref{'name'}} ) {
          $self->{envcount}{$$hashref{'name'}}++;
        }
        else {
          $self->{envcount}{$$hashref{'name'}}=0;
        }
        }
}

sub Environment_Start {
        my $self=shift;
        my $name=shift;
        my $hashref=shift;

        $self->{switch}->checktag($name, $hashref, 'name');
        if ( $self->{Arch} ) {
          my $val=undef;
          if ( defined $self->{EnvContext} ) {
            $self->parserror(" Attempted to open new <$name> context".
                        " without closing the previous one");
          }
          # -- keep a counter of the number of times we see this variable
          if ( exists $self->{EnvironmentCount}{$$hashref{'name'}} ) {
             $self->{EnvironmentCount}{$$hashref{'name'}}++;
          }
          else {
             $self->{EnvironmentCount}{$$hashref{'name'}}=0;
          }

          $self->{currentenvtext}="";
          $self->{EnvContext}=$$hashref{'name'};
          undef $self->{Envvalue};
          if ( exists $$hashref{'type'} ) {
            $$hashref{'type'}=~tr[A-Z][a-z];
            $self->{tool}->type($$hashref{'name'},$$hashref{'type'});
          }
          # check other installed copies of the tool
          # -- construct a menu of options
          my @menulist=();
          # -- a value is fixed - unless interactive switch is on
          if ( exists $$hashref{'value'}) {
            $val=$$hashref{'value'};
            if ( $self->interactive() ) {
              unshift @menulist,$$hashref{'value'};
            }
          }
          # -- add any default values to the selection
          if ( ! defined $val ) {
           if ( $self->_checkdefault($hashref) ) { 
             my $var=$self->_expandvars($$hashref{'default'});
             if ( !grep { $_ eq $var }  @menulist ) {
               unshift @menulist, $var;
             }
           }
           # -- check the environment
           if ( defined $ENV{$$hashref{'name'}} ) {
              if ( !grep { $_ eq $ENV{$$hashref{'name'}}} @menulist ) { 
                unshift @menulist, $ENV{$$hashref{'name'}};
              }
           }
           my @paramlist=$self->_getparamsets($self->{tool},
                                                        $$hashref{'name'});
           foreach $p ( @paramlist ) {
             # -- only add them if there are the same number of variables
             if ( $#{$p} == $self->{envcount}{$$hashref{'name'}} ) {
              if ( !grep {$_ eq $$p[$self->{EnvironmentCount}
                                {$$hashref{'name'}}] } @menulist) {
                push @menulist,$$p[$self->{EnvironmentCount}
                                                        {$$hashref{'name'}}];
              }
             }
             else {
                $self->verbose("Ignoring tool params - not the same number".
                 " defined (".$#{$p}." != ".
                         $self->{envcount}{$$hashref{'name'}}.")");
             }
           }
           if ( $#menulist >=0 ) {
            print "Validating Values for Variable : ".$$hashref{'name'}."\n";
            @menulist=$self->_validateparam($$hashref{'type'},@menulist);
           }
           # -- If theres only one option take it without asking
           if ( $#menulist == 0 && ( ! $self->interactive() )) {
                $val=$menulist[0];
           } 
           elsif ( $#menulist > 0 ) {
              my $in=$self->_askusermenu(
                "Multiple possibilities found for ".
                $$hashref{'name'}." ( occurance ".
                ($self->{EnvironmentCount}{$$hashref{'name'}}+1)." ) ".
                "\nPlease Choose: ",
                (@menulist,"Other"));
              if ( $in <=$#menulist ) {
                  $val=$menulist[$in];
              }
              else {
                  undef $val;
              }
           }    
          }
          $self->{Envvalue}=$val; # single val parameter
        }
}

sub Env_text {
        my $self=shift;
        my $name=shift;
        my $string=shift;

        if ( $self->{Arch} ) {
          $self->{currentenvtext}=$self->{currentenvtext}.$string;
        }
}

sub Environment_End {
        my $self=shift;
        my $name=shift;

        if ( $self->{Arch} ) {
          if ( ! defined $self->{EnvContext} ) {
            $self->{switch}->parseerror("</$name> without an opening context");
          }
          # - set the help text
          $self->featuretext($self->{EnvContext},$self->{currentenvtext});
          if ( ! defined $self->{Envvalue} ) {
            $self->{Envvalue}=$self->_askuser("Please Enter the Value Below:",
                        $self->{EnvContext});
          }
          $self->{Envvalue}=$self->_expandvars($self->{Envvalue});
          $self->{tool}->addfeature($self->{EnvContext}, $self->{Envvalue});
          $self->{ToolEnv}{$self->{EnvContext}}=$self->{Envvalue};
          undef $self->{EnvContext};
          undef $self->{Envvalue};
        }
}

sub Lib {
        my $self=shift;
        my $name=shift;
        my $hashref=shift;

        $self->{switch}->checktag($name, $hashref, 'name');
        if ( $self->{Arch} ) {
          $self->{tool}->addfeature("lib",$$hashref{'name'});
        }
}

sub External_Start {
        my $self=shift;
        my $name=shift;
        my $hashref=shift;

        $self->{switch}->checktag($name, $hashref,'ref');
        if ( $self->{Arch} ) {
          $self->{tool}->addfeature("_externals",$$hashref{'ref'});
        }
}

sub Arch_Start {
        my $self=shift;
        my $name=shift;
        my $hashref=shift;

        $self->{switch}->checktag($name, $hashref,'name');
        ( ($ENV{SCRAM_ARCH}=~/$$hashref{name}.*/) )? ($self->{Arch}=1)
                                                : ($self->{Arch}=0);
        push @{$self->{ARCHBLOCK}}, $self->{Arch};
}

sub Arch_End {
        my $self=shift;
        my $name=shift;

        pop @{$self->{ARCHBLOCK}};
        $self->{Arch}=$self->{ARCHBLOCK}[$#{$self->{ARCHBLOCK}}];
}
Revision:	1.1.2.14.2.1.2.3.2.3.4.4
Committed:	Wed Nov 8 11:18:39 2000 UTC (24 years, 6 months ago) by williamc
Content type:	text/plain
Branch:	V0_17branch
CVS Tags:	V0_17_1
Changes since 1.1.2.14.2.1.2.3.2.3.4.3:	+5 -4 lines
Log Message:	Use DIrHandle rather than FileHandle for dirs
#	User	Rev	Content
1	williamc	1.1.2.1	#
2			# ToolDoc.pm
3			#
4			# Originally Written by Christopher Williams
5			#
6			# Description
7			# -----------
8			# SimpleDoc interface to initialise Tool objects
9			#
10			# Interface
11			# ---------
12			# new() : A new ToolDoc object
13			# tool(toolobj) : set the tool object for the class
14	williamc	1.1.2.11	# toolsearcher(searcher) : set the searcher for finding reference tools
15	williamc	1.1.2.1	# setup(file,$name,$version) : setup a tool object from the specified file
16	williamc	1.1.2.3	# return 0 for OK 1 for cancel
17	williamc	1.1.2.1	# interactive([0\|1]) : set the interactive node 0=off 1=on
18
19			package BuildSystem::ToolDoc;
20			require 5.004;
21			use ActiveDoc::SimpleDoc;
22	williamc	1.1.2.11	use Utilities::Verbose;
23			@ISA=qw(Utilities::Verbose);
24	williamc	1.1.2.1
25			sub new {
26			my $class=shift;
27			$self={};
28			bless $self, $class;
29	williamc	1.1.2.14.2.1	$self->{cache}=shift;
30			$self->{mydoctype}="BuildSystem::ToolDoc";
31			$self->{mydocversion}="1.0";
32	williamc	1.1.2.1	$self->init();
33			return $self;
34			}
35
36			sub init {
37			my $self=shift;
38			$self->{switch}=ActiveDoc::SimpleDoc->new();
39	williamc	1.1.2.14.2.1.2.3.2.3.4.1	$self->{switch}->newparse("setupinit");
40	williamc	1.1.2.14.2.1.2.3.2.3.4.3	$self->{switch}->addtag("setupinit","Tool",\&Tool_Start, $self,
41			"", $self,
42			\&Tool_End, $self);
43	williamc	1.1.2.14.2.1.2.3.2.3.4.1	$self->{switch}->addtag("setupinit", "Architecture",
44			\&Arch_Start,$self,
45			"", $self,
46			\&Arch_End,$self);
47			$self->{switch}->addtag("setupinit","Environment",
48			\&Environment_init, $self,
49			"", $self,
50			"", $self);
51	williamc	1.1.2.1	$self->{switch}->newparse("setup");
52			$self->{switch}->addtag("setup","Tool",\&Tool_Start, $self,
53			"", $self,
54			\&Tool_End, $self);
55			$self->{switch}->addtag("setup","Lib",\&Lib, $self,
56			"", $self,
57			"", $self);
58			$self->{switch}->addtag("setup","External",\&External_Start, $self,
59			"", $self,
60			"", $self);
61			$self->{switch}->addtag("setup","Client",\&Client_start, $self,
62			"", $self,
63			\&Client_end, $self);
64			$self->{switch}->addtag("setup","Environment",
65			\&Environment_Start, $self,
66			\&Env_text, $self,
67			\&Environment_End, $self);
68			$self->{switch}->grouptag("Tool","setup");
69			$self->{switch}->addtag("setup","Architecture",
70			\&Arch_Start,$self,
71			"", $self,
72			\&Arch_End,$self);
73			$self->{Arch}=1;
74	williamc	1.1.2.6	push @{$self->{ARCHBLOCK}}, $self->{Arch};
75	williamc	1.1.2.1
76			}
77
78			sub interactive {
79			my $self=shift;
80
81			@_?$self->{interactive}=shift
82			:((defined $self->{interactive})?$self->{interactive}:0);
83			}
84
85			sub tool {
86			my $self=shift;
87			$self->{tool}=shift;
88			}
89
90	williamc	1.1.2.11	sub toolsearcher {
91			my $self=shift;
92			if ( @_ ) {
93	williamc	1.1.2.12	my $searcher=shift;
94			if ( ! defined $searcher ) {
95			$self->error("Undefined Value passed as a Searcher".
96			" in ToolDoc::toolsearcher");
97			}
98			$self->{toolboxsearcher}=$searcher;
99	williamc	1.1.2.11	}
100			return $self->{toolboxsearcher};
101			}
102
103	williamc	1.1.2.1	sub setup {
104			my $self=shift;
105			my $file=shift;
106			my $name=shift;
107			my $version=shift;
108
109			$self->{ToolEnv}{'SCRAMtoolname'}=$name;
110			$self->{ToolEnv}{'SCRAMtoolversion'}=$version;
111			$self->{ToolEnv}{'SCRAM_ARCH'}=$ENV{'SCRAM_ARCH'};
112
113			$name=~tr[A-Z][a-z];
114			$self->{tool}->name($name);
115			$self->{tool}->version($version);
116			$self->{switch}->filetoparse($file);
117	williamc	1.1.2.4	$self->{toolfound}=1;
118	williamc	1.1.2.14.2.1	# -- check the type of document - can we parse it?
119			my($doctype,$docversion)=$self->{switch}->doctype();
120			if ( ($doctype ne $self->{mydoctype}) \|\|
121			($self->{mydocversion} ne $docversion) ) {
122			$self->error("Unable to Parse Document of type $doctype $docversion".
123			"\n(Only ".$self->{mydoctype}." ". $self->{mydocversion}.")");
124			}
125	williamc	1.1.2.14.2.1.2.3.2.3.4.3	delete $self->{envcount};
126	williamc	1.1.2.14.2.1.2.3.2.3.4.2	$self->{switch}->parse("setupinit");
127	williamc	1.1.2.1	$self->{switch}->parse("setup");
128	williamc	1.1.2.4	return $self->{toolfound};
129	williamc	1.1.2.1	}
130
131			sub featuretext {
132			my $self=shift;
133			my $feature=shift;
134
135			if ( @_ ) {
136			$self->{featuretext}{$feature}=shift;
137			}
138			else {
139			return ($self->{featuretext}{$feature});
140			}
141			}
142
143			sub _checkdefault {
144			my $self=shift;
145			my $hashref=shift;
146
147			if ( defined $$hashref{'default'} ) { #check default
148			my $default;
149			foreach $default ( split /:/, $$hashref{'default'} ) {
150			$default=~s/\"//;
151			if ($self->_testlocation($default,
152			[ $self->{tool}->getfeature($$hashref{'type'})] )) { return 1; }
153			}
154			}
155			return 0;
156			}
157
158			sub _testlocation {
159			my $self=shift;
160			my $default=shift;
161			my $testfiles=shift;
162	williamc	1.1.2.14.2.1.2.3.2.2
163	williamc	1.1.2.1	my $OK='false';
164			my $file;
165
166			chomp $default;
167			$default=$self->_expandvars($default);
168	williamc	1.1.2.14.2.1.2.3.2.2	$self->verbose("Testing location");
169	williamc	1.1.2.1	print "Trying $default .... ";
170			if ( -f $default ) {
171			$OK="true";
172	williamc	1.1.2.14.2.1.2.3.2.3.4.4	$self->verbose("File OK");
173	williamc	1.1.2.1	}
174			else {
175	williamc	1.1.2.14.2.1.2.3.2.3.4.4	my $dh=DirHandle->new();
176			opendir $dh, $default or do { print "No $!\n"; return 0; };
177	williamc	1.1.2.1	($#{$testfiles}==-1) ? $OK='false' : $OK='true';
178			print "\n";
179	williamc	1.1.2.14.2.1.2.3.2.3.4.4	my @files=readdir $dh;
180			undef $dh;
181	williamc	1.1.2.1	foreach $file ( @$testfiles ) {
182			print " Checking for $file .... ";
183			# now check that the required files are actually there
184			if ( ( $number = grep /\Q$file\L/, @files) == 0 ) {
185			$OK='false';
186			print "not found\n";
187			last;
188			}
189			print "found\n";
190			}
191			}
192			if ( $OK eq 'true' ) {
193			print "Directory Check Complete\n";
194			return 1
195			}
196			return 0
197			}
198
199			sub _expandvars {
200			my $self=shift;
201			my $string=shift;
202
203			return "" , if ( ! defined $string );
204			$string=~s{
205			\$\((\w+)\)
206			}{
207			if (defined $self->{ToolEnv}{$1}) {
208			$self->_expandvars($self->{ToolEnv}{$1});
209			} else {
210			"\$$1";
211			}
212			}egx;
213			$string=~s{
214			\$(\w+)
215			}{
216			if (defined $self->{ToolEnv}{$1}) {
217			$self->_expandvars($self->{ToolEnv}{$1});
218			} else {
219			"\$$1";
220			}
221			}egx;
222			return $string;
223			}
224
225	williamc	1.1.2.14.2.1.2.2	sub _askusermenu {
226			my $self=shift;
227			my $querystring=shift;
228			my @items=@_;
229
230			my $path=-1;
231	williamc	1.1.2.14.2.1.2.3.2.1	my $n;
232			while ( ($path!~/^\d+$/) \|\| ($path > ($#items+1)) \|\| ($path < 1) ) {
233	williamc	1.1.2.14.2.1.2.2	for (my $i=0; $i<=$#items; $i++ ) {
234	williamc	1.1.2.14.2.1.2.3.2.1	$n=$i+1;
235			print $n.") ".$items[$i]."\n";
236	williamc	1.1.2.14.2.1.2.2	}
237			print "\n".$querystring;
238			$path=<STDIN>;
239			chomp $path;
240			}
241	williamc	1.1.2.14.2.1.2.3.2.1	$path--;
242	williamc	1.1.2.14.2.1.2.2	return $path;
243			}
244	williamc	1.1.2.1
245			sub _askuser {
246			my $self=shift;
247			my $querystring=shift;
248			my $varname=shift;
249
250	williamc	1.1.2.14.2.1.2.3.2.2	my $type=$self->{tool}->type($varname);
251			my $path;
252			my $oldpath;
253	williamc	1.1.2.1	print $self->featuretext($self->{EnvContext});
254			for ( ;; ) {
255			print "\n".$querystring." (RETURN to log as missing)\nset $varname = ";
256			$path=<STDIN>;
257			chomp $path;
258	williamc	1.1.2.14.2.1.2.3.2.2	$oldpath=$path;
259	williamc	1.1.2.1	if ( $path ne "" ) {
260	williamc	1.1.2.14.2.1.2.3.2.2	($path)=$self->_validateparam($type,$path);
261			if ( ! defined $path ) {
262			print "Error : ".$oldpath." is not valid.\n";
263			next;
264			}
265	williamc	1.1.2.1	}
266	williamc	1.1.2.14.2.1.2.3.2.2	return $path;
267	williamc	1.1.2.1	} #end for
268
269			}
270
271	williamc	1.1.2.14.2.1.2.3.2.2	sub _validateparam {
272			my $self=shift;
273			my $type=shift;
274			my @params=@_;
275
276			my @newparams=();
277			foreach $param ( @params ) {
278			if ( defined $self->{'client'}) { # must be a location
279			if ( $self->_testlocation($param ,
280			[ $self->{tool}->getfeature($type)] )) {
281			$self->verbose("$param passed validation");
282			push @newparams,$param;
283			}
284			else {
285			$self->verbose("$param failed validation");
286			}
287			}
288			else {
289			# --- no other tests to pass so it must be OK
290			push @newparams,$param;
291			}
292			}
293			return @newparams;
294			}
295
296	williamc	1.1.2.11	#
297			# Propgate through the searcher collecting matching tools
298			#
299			sub _searchtools {
300			my $self=shift;
301			my $tool=shift;
302	williamc	1.1.2.14.2.1.2.3.2.1	my $searcher=shift;
303	williamc	1.1.2.11
304			my @tools=();
305			my $area;
306			my $rtool;
307	williamc	1.1.2.14.2.1.2.3.2.1	my $it=$searcher->newiterator();
308
309			while ( ! $it->last() ) {
310	williamc	1.1.2.11	$area=$it->next();
311			if ( defined $area ) {
312			$self->verbose("Searching for ".$tool->name()." ".
313			$tool->version()." in ".$area->location());
314			$rtool=$area->toolbox()->gettool($tool->name(),$tool->version());
315	williamc	1.1.2.14.2.1.2.1	if ( defined $rtool ) {
316			if ( $rtool->equals($tool) ) {
317			$self->verbose("Found matching tool");
318	williamc	1.1.2.11	push @tools,$rtool;
319	williamc	1.1.2.14.2.1.2.1	}
320			else {
321			$self->verbose("Rejected tool ".$rtool->name()." "
322			.$rtool->version());
323			}
324	williamc	1.1.2.11	}
325	williamc	1.1.2.14.2.1.2.3.2.1	else {
326			$self->verbose("Tool Passed as Undefined");
327			}
328	williamc	1.1.2.11	}
329	williamc	1.1.2.14.2.1.2.1	else {
330			$self->verbose("Area passed is not defined");
331			}
332	williamc	1.1.2.11	}
333			return @tools;
334			}
335
336			# search toolboxes for a nice list
337			#
338			sub _toolparamcopy {
339			my $self=shift;
340			my $tool=shift;
341			my $param=shift;
342
343			my $rv=0;
344	williamc	1.1.2.13	my @params=();
345	williamc	1.1.2.11	$self->verbose("Check Other Projects for tool");
346	williamc	1.1.2.14.2.1.2.3.2.1	my @validtools=();
347			if ( defined $self->{toolboxsearcher} ) {
348			@validtools=$self->_searchtools($tool,$self->{toolboxsearcher});
349			}
350			if ( $#validtools >=0 ) {
351			if ( ! $self->interactive() ) {
352	williamc	1.1.2.13	@params=$validtools[0]->getfeature($param);
353	williamc	1.1.2.11	if ( $#params >=0 ) {
354			$self->verbose("Extracting Feature $param from tool".
355			" (= @params )\n");
356			$rv=1;
357			}
358			}
359			}
360	williamc	1.1.2.13	return ($rv,@params);
361	williamc	1.1.2.11	}
362
363	williamc	1.1.2.14.2.1.2.3.2.1	sub _getparamsets {
364			my $self=shift;
365			my $tool=shift;
366			my $param=shift;
367
368			my @paramlist=();
369			my @params=();
370			$self->verbose("Searching for parameter settings in other tools");
371			my @validtools=();
372			if ( defined $self->{toolboxsearcher} ) {
373			@validtools=$self->_searchtools($tool,$self->{toolboxsearcher});
374			}
375			else {
376			$self->verbose("No tool searcher available");
377			}
378			if ( $#validtools >=0 ) {
379			foreach $t ( @validtools ) {
380			@params=$t->getfeature($param);
381			if ( $#params >=0 ) {
382			push @paramlist, [ @params ];
383			$self->verbose("Found @params");
384			}
385			}
386			}
387			return @paramlist;
388			}
389
390	williamc	1.1.2.1	# -- Tag Routines
391
392			sub Client_start {
393			my $self=shift;
394			my $name=shift;
395			my $hashref=shift;
396
397			if ( $self->{Arch} ) {
398			$self->{'client'}=1;
399			}
400			}
401
402			sub Client_end {
403			my $self=shift;
404			if ( $self->{Arch} ) {
405			undef $self->{'client'};
406			}
407			}
408
409			sub Tool_Start {
410			my $self=shift;
411			my $name=shift;
412			my $hashref=shift;
413
414			$self->{switch}->checktag($name, $hashref, 'name');
415			$self->{switch}->checktag($name, $hashref, 'version');
416			$self->{switch}->opengroup("Toolactive");
417
418			# lower case the name
419			$$hashref{'name'}=~tr[A-Z][a-z];
420			# make sure we only pick up the tool requested
421			if ( ( $self->{tool}->name() eq $$hashref{'name'} ) &&
422			($self->{tool}->version() eq $$hashref{'version'})) {
423			$self->{switch}->
424			allowgroup("Toolactive",$self->{switch}->currentparsename());
425			$self->{ToolEnv}{'SCRAMtoolname'}=$$hashref{'name'};
426			$self->{ToolEnv}{'SCRAMtoolversion'}=$$hashref{'version'};
427	williamc	1.1.2.4	$self->{toolfound}=0;
428	williamc	1.1.2.1	}
429			else {
430			$self->{switch}->disallowgroup("Toolactive",
431			$self->{switch}->currentparsename());
432			}
433			}
434
435			sub Tool_End {
436			my $self=shift;
437			my $name=shift;
438			my $hashref=shift;
439
440			$self->{switch}->closegroup("Toolactive");
441			}
442
443	williamc	1.1.2.14.2.1.2.3.2.3.4.1	# -- collect number of variables of the same name - need to know how many
444			# before main setup processing
445			sub Environment_init {
446			my $self=shift;
447			my $name=shift;
448			my $hashref=shift;
449
450			$self->{switch}->checktag($name, $hashref, 'name');
451			if ( $self->{Arch} ) {
452	williamc	1.1.2.14.2.1.2.3.2.3.4.3	if ( exists $self->{envcount}{$$hashref{'name'}} ) {
453	williamc	1.1.2.14.2.1.2.3.2.3.4.1	$self->{envcount}{$$hashref{'name'}}++;
454			}
455			else {
456			$self->{envcount}{$$hashref{'name'}}=0;
457			}
458			}
459			}
460
461	williamc	1.1.2.1	sub Environment_Start {
462			my $self=shift;
463			my $name=shift;
464			my $hashref=shift;
465
466			$self->{switch}->checktag($name, $hashref, 'name');
467			if ( $self->{Arch} ) {
468	williamc	1.1.2.14.2.1.2.3.2.1	my $val=undef;
469	williamc	1.1.2.1	if ( defined $self->{EnvContext} ) {
470			$self->parserror(" Attempted to open new <$name> context".
471			" without closing the previous one");
472			}
473	williamc	1.1.2.14.2.1.2.3.2.1	# -- keep a counter of the number of times we see this variable
474			if ( exists $self->{EnvironmentCount}{$$hashref{'name'}} ) {
475			$self->{EnvironmentCount}{$$hashref{'name'}}++;
476			}
477			else {
478			$self->{EnvironmentCount}{$$hashref{'name'}}=0;
479			}
480
481	williamc	1.1.2.1	$self->{currentenvtext}="";
482			$self->{EnvContext}=$$hashref{'name'};
483			undef $self->{Envvalue};
484	williamc	1.1.2.10	if ( exists $$hashref{'type'} ) {
485			$$hashref{'type'}=~tr[A-Z][a-z];
486			$self->{tool}->type($$hashref{'name'},$$hashref{'type'});
487	williamc	1.1.2.1	}
488	williamc	1.1.2.14.2.1.2.3.2.1	# check other installed copies of the tool
489			# -- construct a menu of options
490			my @menulist=();
491			# -- a value is fixed - unless interactive switch is on
492	williamc	1.1.2.1	if ( exists $$hashref{'value'}) {
493	williamc	1.1.2.14.2.1.2.3.2.1	$val=$$hashref{'value'};
494			if ( $self->interactive() ) {
495			unshift @menulist,$$hashref{'value'};
496			}
497	williamc	1.1.2.1	}
498	williamc	1.1.2.14.2.1.2.3.2.1	# -- add any default values to the selection
499			if ( ! defined $val ) {
500			if ( $self->_checkdefault($hashref) ) {
501	williamc	1.1.2.14.2.1.2.3.2.3.4.2	my $var=$self->_expandvars($$hashref{'default'});
502			if ( !grep { $_ eq $var } @menulist ) {
503			unshift @menulist, $var;
504			}
505	williamc	1.1.2.11	}
506	williamc	1.1.2.14.2.1.2.3.2.1	# -- check the environment
507			if ( defined $ENV{$$hashref{'name'}} ) {
508			if ( !grep { $_ eq $ENV{$$hashref{'name'}}} @menulist ) {
509			unshift @menulist, $ENV{$$hashref{'name'}};
510			}
511			}
512			my @paramlist=$self->_getparamsets($self->{tool},
513			$$hashref{'name'});
514			foreach $p ( @paramlist ) {
515	williamc	1.1.2.14.2.1.2.3.2.3.4.1	# -- only add them if there are the same number of variables
516			if ( $#{$p} == $self->{envcount}{$$hashref{'name'}} ) {
517	williamc	1.1.2.14.2.1.2.3.2.1	if ( !grep {$_ eq $$p[$self->{EnvironmentCount}
518			{$$hashref{'name'}}] } @menulist) {
519			push @menulist,$$p[$self->{EnvironmentCount}
520			{$$hashref{'name'}}];
521			}
522	williamc	1.1.2.14.2.1.2.3.2.3.4.3	}
523			else {
524			$self->verbose("Ignoring tool params - not the same number".
525			" defined (".$#{$p}." != ".
526			$self->{envcount}{$$hashref{'name'}}.")");
527	williamc	1.1.2.14.2.1.2.3.2.1	}
528	williamc	1.1.2.5	}
529	williamc	1.1.2.14.2.1.2.3.2.3.4.2	if ( $#menulist >=0 ) {
530			print "Validating Values for Variable : ".$$hashref{'name'}."\n";
531			@menulist=$self->_validateparam($$hashref{'type'},@menulist);
532			}
533	williamc	1.1.2.14.2.1.2.3.2.1	# -- If theres only one option take it without asking
534			if ( $#menulist == 0 && ( ! $self->interactive() )) {
535			$val=$menulist[0];
536			}
537			elsif ( $#menulist > 0 ) {
538			my $in=$self->_askusermenu(
539			"Multiple possibilities found for ".
540			$$hashref{'name'}." ( occurance ".
541			($self->{EnvironmentCount}{$$hashref{'name'}}+1)." ) ".
542			"\nPlease Choose: ",
543			(@menulist,"Other"));
544			if ( $in <=$#menulist ) {
545			$val=$menulist[$in];
546			}
547	williamc	1.1.2.14.2.1.2.3.2.2	else {
548			undef $val;
549			}
550	williamc	1.1.2.14.2.1.2.3.2.1	}
551	williamc	1.1.2.1	}
552	williamc	1.1.2.14.2.1.2.3.2.1	$self->{Envvalue}=$val; # single val parameter
553	williamc	1.1.2.1	}
554			}
555
556			sub Env_text {
557			my $self=shift;
558			my $name=shift;
559			my $string=shift;
560
561			if ( $self->{Arch} ) {
562			$self->{currentenvtext}=$self->{currentenvtext}.$string;
563			}
564			}
565
566			sub Environment_End {
567			my $self=shift;
568			my $name=shift;
569
570			if ( $self->{Arch} ) {
571			if ( ! defined $self->{EnvContext} ) {
572	williamc	1.1.2.8	$self->{switch}->parseerror("</$name> without an opening context");
573	williamc	1.1.2.1	}
574			# - set the help text
575			$self->featuretext($self->{EnvContext},$self->{currentenvtext});
576			if ( ! defined $self->{Envvalue} ) {
577			$self->{Envvalue}=$self->_askuser("Please Enter the Value Below:",
578			$self->{EnvContext});
579			}
580			$self->{Envvalue}=$self->_expandvars($self->{Envvalue});
581			$self->{tool}->addfeature($self->{EnvContext}, $self->{Envvalue});
582			$self->{ToolEnv}{$self->{EnvContext}}=$self->{Envvalue};
583			undef $self->{EnvContext};
584			undef $self->{Envvalue};
585			}
586			}
587
588			sub Lib {
589			my $self=shift;
590			my $name=shift;
591			my $hashref=shift;
592
593			$self->{switch}->checktag($name, $hashref, 'name');
594			if ( $self->{Arch} ) {
595			$self->{tool}->addfeature("lib",$$hashref{'name'});
596			}
597			}
598
599			sub External_Start {
600			my $self=shift;
601			my $name=shift;
602			my $hashref=shift;
603
604			$self->{switch}->checktag($name, $hashref,'ref');
605			if ( $self->{Arch} ) {
606	williamc	1.1.2.2	$self->{tool}->addfeature("_externals",$$hashref{'ref'});
607	williamc	1.1.2.1	}
608			}
609
610			sub Arch_Start {
611			my $self=shift;
612			my $name=shift;
613			my $hashref=shift;
614
615	williamc	1.1.2.5	$self->{switch}->checktag($name, $hashref,'name');
616	williamc	1.1.2.1	( ($ENV{SCRAM_ARCH}=~/$$hashref{name}.*/) )? ($self->{Arch}=1)
617			: ($self->{Arch}=0);
618			push @{$self->{ARCHBLOCK}}, $self->{Arch};
619			}
620
621			sub Arch_End {
622			my $self=shift;
623			my $name=shift;
624
625			pop @{$self->{ARCHBLOCK}};
626			$self->{Arch}=$self->{ARCHBLOCK}[$#{$self->{ARCHBLOCK}}];
627			}