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.1";
        $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}->grouptag("Tool","setupinit");

        $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}->addtag("setup","Makefile",
                                                \&Makefile_Start, $self,        
                                                \&Makefile_text, $self,
                                                \&Makefile_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;
        my $toolbox=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) && ($docversion ne "1.0")) ) {
          $self->error("Unable to Parse Document of type $doctype $docversion".
                "\n(Only ".$self->{mydoctype}." ". $self->{mydocversion}.")");
        }
        delete $self->{envcount};
        $self->verbose("Pre-Parse");
        $self->{switch}->parse("setupinit");
        $self->{toolmakefile}=$toolbox->toolmakefile($name,$version);
        $self->verbose("Setup Parse");
        $self->{switch}->parse("setup");
        undef $self->{toolmakefilefh};

        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;
   my $statusgood = $main::bold."OK".$main::normal;
   my $statusbad = $main::bold."Not found".$main::normal;
   
   chomp $default;
   $default=$self->_expandvars($default);
   $self->verbose("Testing location");
   
   if ( -f $default )
      {
      $OK="true";
      $self->verbose("File OK");
      }
   else
      {
      my $dh=DirHandle->new();
      
      opendir $dh, $default or do
         {
         printf ("\nTrying %-s ...... >> %s <<\n",$default,$main::bold.$!.$main::normal);
         return 0;
         };
      
      ($#{$testfiles}==-1) ? $OK='false' : $OK='true';
      
      my @files=readdir $dh;
      undef $dh;

      foreach $file ( @$testfiles )
         {
         # now check that the required files are actually there
         if ( ( $number = grep /\Q$file\L/, @files) == 0 )
            {
            $OK='false';
            $status = $statusbad;
            last;
            }
         $status = $statusgood;

         printf ("\t\tChecking for %-22s............ [%s]\n",$file,$status);
         }
      print "\n";
      }
   
   if ( $OK eq 'true' )
      {
      printf ("Existence check for %-30s ............ [%s]\n",$default.":",$statusgood);
      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
   {
   ###############################################################
   # _askuser()                                                  #
   ###############################################################
   # modified : Mon Nov 19 15:51:01 2001 / SFA                   #
   # params   :                                                  #
   #          :                                                  #
   #          :                                                  #
   #          :                                                  #
   # function : Looks for valid path to tool, either using a     #
   #          : default path, or by using the lookup table.      #
   #          :                                                  #
   #          :                                                  #
   ###############################################################
   my $self=shift;
   
   # First, check for interactive flag. If "on", call the original
   # version of this routine:
   if ( $self->{interactive} )
      {
      my $ipath=$self->_askuseri(@_);
      return $ipath;
      }

   my $querystring=shift;
   my $varname=shift;
   my $lookupdb = $main::lookupobject;
   my $type=$self->{tool}->type($varname);
   my $path;
   my $oldpath;
   my $defaultpath = $lookupdb->lhcxxPath();
   
   # Print the feature info:
   print $self->featuretext($self->{EnvContext});

   # Check if tool is listed in the lookupdb:
   if ($lookupdb->checkTool(${$self->{tool}}{name}))
      {
      $self->verbose(">> Tool ${$self->{tool}}{name} exists in DB...");
      # Check if $varname is a tag that's listed in our lookup table for this tool:      
      if ($lookupdb->lookupTag(${$self->{tool}}{name},$varname))
          {
          $self->verbose(">> Tag $varname is defined for tool ${$self->{tool}}{name}");
          # Get the value for this tag:
          $path = $lookupdb->lookupTag(${$self->{tool}}{name},$varname);
          }
      else
      # No known tag for this tool so try the default path:
          {
          $path = $defaultpath;
          }   
      }
   # If the defaultpath is valid then try that:
   elsif ( -d $defaultpath)
      {
      $path = $defaultpath;
      }
   # We'll have to ask the user:
   else
      {
      # Infinite loop while there isn't a valid path:
      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 the path is not defined, print
            # a message and repeat the prompt:
            if ( ! defined $path )
              {
              print "Error : ".$oldpath." is not valid.\n";
              next;
              }
            }
         return $path;
         }
      }
    return $path;
   }


sub _askuseri
   {
   ###############################################################
   # _askuseri()                                                 #
   ###############################################################
   # modified : Mon Nov 19 15:46:36 2001 / SFA                   #
   # params   :                                                  #
   #          :                                                  #
   #          :                                                  #
   #          :                                                  #
   # function : Interactive version of askuser routine. Called   #
   #          : when "-i" flag set in scramcli.                  #
   #          :                                                  #
   #          :                                                  #
   ###############################################################
   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;
      }
   }


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=();

        # Check for an override of the searcher. If the
        # variable SEARCHOVRD is set, we return an empty array:
        if ( $ENV{'SEARCHOVRD'} eq 'true' )
           {
           $self->verbose("Searching for tool settings from other projects OVERRIDDEN");
           # This bypasses the menu option presented to the user when there is more than one
           # choice for the tool location:
           return @paramlist;
           }
        # Otherwise we proceed as normal:
        $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");
}

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

        if ( $self->{Arch} ) {
         if ( ! defined $self->{toolmakefilefh} ) {
           $self->{toolmakefilefh}=FileHandle->new();
           $self->{toolmakefilefh}->open(">".$self->{toolmakefile}); 
         }
        }
}

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

        if ( $self->{Arch} ) {
          print {$self->{toolmakefilefh}} $string;
        }
}

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

        if ( $self->{Arch} ) {
          print {$self->{toolmakefilefh}} "\n"; 
        }
}

# -- 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);
            }
         print "\n";
         # -- 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'}." ( occurrance ".
                                       ($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};

      # Undefine in time for next pass:
      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.10
Committed:	Tue Feb 19 17:43:28 2002 UTC (23 years, 2 months ago) by sashby
Content type:	text/plain
Branch:	MAIN
CVS Tags:	V0_19_5, SFATEST, V0_19_4, V0_19_4_pre3, V0_19_4_pre2, V0_19_4_pre1, V0_19_3
Branch point for:	V0_19_4_B
Changes since 1.9:	+14 -2 lines
Log Message:	Fixed couple of things: FNAL site probs with setup, general auto setup probs.