[ViewVC] Annotation of: cvsroot/COMP/SCRAM/src/scram

#!/usr/local/bin/perl5 -w 
#
# User Interface
#

# Make sure were running the right version
#versioncheck();

$bold  = "\033[1m";
$normal = "\033[0m";
@allowed_commands=qw(area project tool options install list arch version setup runtime db devtest doctest);

use Scram::SCRAM2;
setupscram();

$found=_processcmds("_mainoptions",\@allowed_commands,\@ARGV);

if ( ! ( $found=~/true/ ) ) {
        helpheader('Recognised Commands');
        foreach $command ( @allowed_commands ) {
        print "      $bold scram ".$command.$normal."\n";       
        }
        print "\n";
        print "Help on individual commands available through\n\n";
        print "$bold       scram".$normal." command$bold help $normal\n\n";
        print "Main options can be seen with\n";
        print "$bold       scram options help$normal\n\n";
}

sub options {
        help_options();
}

# --------- main command processing routines

sub _mainoptions {
        my $option=shift;
        my $cmds=shift;

        if ( $option eq "-f" ) {
           # force update of urls
           shift @$cmds;
           $scram->setoption("url_update", 1);
        }
        elsif ( $option eq "-update" ) {
           # force update of urls
           shift @$cmds;
           $scram->setoption("url_update", shift @ARGV);
        }
        elsif ( $option eq "-arch" ) {
           # pretend to be a different architecture
           shift @$cmds;
           my $arch=$scram->arch();
           $arch->arch(shift @$cmds);
        }
        elsif ( $option eq "-verbose" ) {
           shift @$cmds;
           $scram->setoption("verbose_".$$cmds[0],1);
           print "Verbose turned on for $$cmds[0]\n";
           shift @$cmds;
        }
        else {
          $scram->error("Unknown Option $option");
        }
}

sub _processcmds {
        my $optionhandler=shift;
        my $allowed_commands=shift;
        my $cmds=shift;
        my @subs=@_;

        my $found='false';
        # make a string from the subcommand levels
        my $substring="";
        if ( @subs ) {
           $substring= join '_', @subs;
           $substring=$substring."_";
        }

        # Process options
        while ( ${$cmds}[0]=~/^-/) {
           &{$optionhandler}( ${$cmds}[0],$cmds);
        }

        my $inputcmd=shift @{$cmds};
        if ( $inputcmd ne "" ) {
         foreach $command ( @{$allowed_commands} ) {
           if ( $command=~/^$inputcmd/i) {
                # Deal with a help request
                if ( ( defined $$cmds[0]) && $$cmds[0]=~/help/i ) {
                   &helpheader($command,@subs);
                   &{"help_".$substring.$command}; exit;
                }
                else {
        #print "calling $substring".$command."(@{$cmds})\n";
                   &{$substring.$command}(@{$cmds}); $found='true';
                   last;
                }
           }
         }
        }
        return $found;
}

sub help_options {
        helpheader('Main SCRAM options');
        print "$bold -arch ".$normal."architecture \n";
        print "\tPretend to be the specified architecture\n\n";
        print "$bold -f $normal \n";
        print "\tForced update of urls instead of using"
                ." the cached\n\tversions\n\n";
        print "$bold -re $normal\n";
        print "\tRequest Exit - Scram will ask the user to enter RETURN\n".
              "\tat the end of the process rather than exiting directly\n";
        print "\tUseful for use where scram is run as a forked process\n\n";    
        print "$bold -update ".$normal."string \n";
        print "\tAs -f but only update the url that matches the \n";
        print "\tgiven string\n\n";
        print "$bold -verbose ".$normal."object \n";
        print "\tTurn on the verbose mode for the specified object.\n"; 
        print "\tThe special object \"all\" will turn on verbosity for\n";
        print "\tall objects that support verbosity\n\n";       
}

sub versioncheck {
        my $version;
        my $thisversion;

        $thisversion=getversion();

        if ( ! localtop_find() ) {
        LoadEnvFile();
        my $versionfile=$ENV{LOCALTOP}."/$ENV{projconfigdir}/scram_version";
        if ( -f $versionfile ) {
          open (VERSION, "<".$versionfile) ;
            $version=<VERSION>;
            chomp $version;
            if ( $version ne $thisversion ) {
              # first try to use the correct version
              if ( -d $scram_top."/".$version ) {
                $ENV{SCRAM_HOME}=$scram_top."/".$version;
                system("scram", @ARGV);
                exit;
              } 
              else { # if not then simply warn
                print "******* Warning : scram version inconsistent ********\n";
                print "This version: $thisversion; Required version: $version";
                print "*****************************************************\n";
                print "\n";
              }
            }
        }
        }
}

sub doctest {
        $scram->doctest(@ARGV);
}

sub help_build {
        &build;
}
sub build {
        # is this a based or free release?
        FullEnvInit();
        use BuildSetup;
        $ENV{MAKETARGETS}=join ' ',@ARGV;
        BuildSetup($ENV{THISDIR},@ARGV);
}

sub project {
        # process options
        while ( $ARGV[0]=~"^-" ) {
         if ( $ARGV[0]=~/-n/ ) {
           shift @ARGV;
           $self->setoptions("ConfigArea_name",shift @ARGV);
         }
         elsif ( $ARGV[0]=~/-d/ ) {  #installation area directory 
          shift @ARGV;
          $self->setoptions("ConfigArea_location",shift @ARGV);
         }
         else {
          print "scram: unknown option $ARGV[0] to project command\n";
          exit;
         }
        } 

        # -- work out if we have a url or not
        if ( $ARGV[0]=~/.*:.*/ ) {
          $scram->project(@ARGV);
        }
        else {
          $scram->basedarea(@ARGV);
        }
        print "\nInstallation Procedure Complete. \n".
                        "Installation Located at:\n".cwd()."\n";
}

sub runtime {
        my $shell;
        FullEnvInit();

        # process options
        while ( $ARGV[0]=~"^-" ) {
         if ( $ARGV[0]=~/-sh/ ) {
           shift @ARGV;
           $shell="sh";
           next;
         }
         if ( $ARGV[0]=~/-csh/ ) {  #installation area directory 
          shift @ARGV;
          $shell="csh";
          next;
         }
         print "Unknown Option $ARGV[0]\n";
         exit 1;
        } 
        print "Not yet implemented\n";
}

# Support rt for runtime

sub printoutenv {
        my $shell=shift;
        my $variable=shift;
        my $value=shift;

        if ( $shell eq "csh" ) {
          print "setenv $variable \"$value\";\n";
        }
        elsif ( $shell eq "sh" ) {
          print "$variable=\"$value\";\n";
          print "export $variable;\n";
        }
}

sub addpath {
        my $name=shift;
        my $val=shift;

        my $n;
        my @env;
        @env=split /:/, $EnvRuntime{$name};
        foreach $n ( (split /:/, $val ) ){
         if (  ! grep /^\Q$n\E$/, @env ) {
          addvar($name,$n,":");
         }
        }
}

sub addvar {
        my $name=shift;
        my $val=shift;
        my $sep=shift;

        if ( $val ne "" ) {
        if ( defined $EnvRuntime{$name} ) {
         $EnvRuntime{$name}=$EnvRuntime{$name}.$sep.$val;
        }
        else {  
         $EnvRuntime{$name}=$val;
        }
        }
}

sub FullEnvInit {
    environmentinit();
    localtop();
    LoadEnvFile();
}

sub environmentinit {
#       use Utilities::setarchitecture;
        my $name;
        my $value;

        $ENV{LatestBuildFile}=""; # stop recursive behaviour in make
#       setarchitecture::setarch();
        $ENV{INTwork}="tmp/$ENV{SCRAM_ARCH}";
        $ENV{INTlib}="lib/$ENV{SCRAM_ARCH}";
        $ENV{INTsrc}="src";
        $ENV{INTbin}="bin/$ENV{SCRAM_ARCH}";
        $ENV{INTlog}="logs";

        ($ENV{SCRAM_BASEDIR}=$ENV{SCRAM_HOME})=~s/(.*)\/.*/$1/;
        if ( ! ( exists $ENV{SCRAM_CONFIG} ) ){
                $ENV{SCRAM_CONFIG}="$ENV{SCRAM_HOME}/configuration";
        }
        if ( ! ( exists $ENV{TOOL_HOME} ) ){
                $ENV{TOOL_HOME}="$ENV{SCRAM_HOME}/src";
        }
        if ( ! ( exists $ENV{SCRAM_LOOKUPDB} ) ){
                if ( -d "$ENV{SCRAM_BASEDIR}/scramdb/" ) {
                  $ENV{SCRAM_LOOKUPDB}="$ENV{SCRAM_BASEDIR}/scramdb/project.lookup";
                }
                else {
                  $ENV{SCRAM_LOOKUPDB}="$ENV{SCRAM_CONFIG}/project.lookup";
                }
        }
        $ENV{SCRAM_AVAILDIRS}="";
        $ENV{SCRAM_AVAILFILES}="";
}

sub localtop_find {
        # find localtop
        use Cwd;
        my $thispath=cwd;
        my $rv=1;

        block: {
        do { 
          if ( -e "$thispath/.SCRAM" ) {
                $ENV{LOCALTOP}=$thispath;
                $ENV{SCRAM_WORKDIR}="$ENV{LOCALTOP}/.SCRAM";
                $rv=0;
                last block;
          }
        } while ( ( $thispath=~s/(.*)\/.*/$1/ )=~/./  ); 
        } #end block
        return $rv;
}

sub localtop {
        localtop_find();
        if ( ! (defined $ENV{LOCALTOP}) ) {
         print "Unable to locate the top of local release. Exiting\n";
         exit 1;
        }
        ($ENV{THISDIR}=cwd)=~s/^\Q$ENV{LOCALTOP}\L//;
        $ENV{THISDIR}=~s/^\///;
}

sub LoadEnvFile {
        open ( SCRAMENV, "<$ENV{SCRAM_WORKDIR}/Environment" ) || 
                die "Cant find Environment file $!\n";
        while ( <SCRAMENV> ) {
           chomp;
           next if /^#/;
           next if /^\s*$/ ;
           ($name, $value)=split /=/;
           eval "\$ENV{${name}}=\"$value\"";
        }
        close SCRAMENV;
}

sub env {
   print "Sorry - Not yet\n";
}

#
# Create a lookup tag in the site database
#
sub install  {
        my $tagname=shift @ARGV;
        my $version=shift @ARGV;
        $scram->install();
}

sub uninstall {
        $scram->uninstall(@ARGV);
}

sub help_install()  {

print <<ENDTEXT;
Associates a label with the current release in the SCRAM database.
This allows other users to refer to a centrally installed project by
this label rather than a remote url reference.

Usage:

        $bold   scram install $normal [project_tag [version_tag]]

porject_tag : override default label (the project name of the current release)
version_tag : the version tag of the current release. If version is not
          specified the base release version will be taken by default.

ENDTEXT
exit;
}


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

sub version {
        my $version=shift @ARGV;
        my $thisversion;
        my $scram_top;
        my $cvsobject;

        ($thisversion=$ENV{SCRAM_HOME})=~s/(.*)\///;
        $scram_top=$1;
        if ( $version eq "" ) {
          print "$thisversion";
          # deal with links
          $version=readlink $ENV{SCRAM_HOME};
          if ( defined $version)  {
                print " ---> $version";
          }
          print "\n";
        }
        else {
          if ( -d $scram_top."/".$version ) {
                print "Version $version exists\n";
          }
          else {
              print "Version $version not available locally\n";
              print "Attempting download from the SCRAM repository\n";
              # set up and configure the cvs module for SCRAM
              use Utilities::CVSmodule;
              $cvsobject=CVSmodule->new();
              $cvsobject->set_base(
                "cmscvs.cern.ch:/cvs_server/repositories/SCRAM");
              $cvsobject->set_auth("pserver");
              $cvsobject->set_user("anonymous");
              $cvsobject->set_passkey("AA_:yZZ3e");
              # Now check it out in the right place
              chdir $scram_top or die "Unable to change to $scram_top $!\n";
              $cvsobject->invokecvs( ( split / /, 
                        "co -d $version -r $version SCRAM" ));
                
              # Get rid of cvs object now weve finished
              $cvsobject=undef;
              print "\n";
          }
        }
}

sub list {
        print "Installed Projects\n";
        print "------------------\n";
        print "|Project Name  | Project Version |\n";
        print "----------------------------------\n";
#       listdb($filename);
        my @areas=$scram->listprojects();
        foreach $area ( @areas ) {
          print $area->name()."\t".$area->version()."\n";
          print "\t-->".$area->location()."\n";
        }
}

sub area {
        my $subcmd=shift @ARGV;

        switch : {
        if ( $subcmd eq 'link' ) {
          $scram->link(@ARGV);
          last switch;
        }
        elsif ( $subcmd eq 'unlink' ) {
          $scram->unlink();
          last switch;
        }
        elsif ( $subcmd eq 'install' ) {
          install();
        }
        elsif ( $subcmd eq 'uninstall' ) {
          uninstall();
        }
        }
}

sub db {
        my $subcmd=shift @ARGV;
        &environmentinit;

        switch : {
        if ( $subcmd eq 'link' ) {
          dblink($ENV{SCRAM_LOOKUPDB},@ARGV);
          last switch;
        }
        if ( $subcmd eq 'unlink' ) {
          dbunlink($ENV{SCRAM_LOOKUPDB},@ARGV);
          last switch;
        }
        if ( $subcmd eq 'showlinks' ) {
          dblinklist($ENV{SCRAM_LOOKUPDB});
          last switch;
        }
        } # end switch
        
}

sub dblinklist {
        my $filename=shift;
        open (LOCALLOOKUPDB, "<$filename")  or
                die "Unable to open local database $!"; 
        while (<LOCALLOOKUPDB>) {
          if ( $_=~/\!DB (.*)/) {
            print $1,"\n";
          }
        }
        close LOCALLOOKUPDB;
}

sub dblink {
        my $filename=shift;
        my $newdbfilename=shift;
        my $exists=0;

        if ( -e $filename ) {
         if ( -e $newdbfilename ) {
         # Check if its already there
          open (LOCALLOOKUPDB, "<$filename")  or
                die "Unable to open local database $!"; 
           while (<LOCALLOOKUPDB>) {
            if ( $_=~/\!DB $newdbfilename/ ) {
                $exists=1;
                last;
            }
           }
          close LOCALLOOKUPDB;
          # Add it
          if ( ! $exists ) {
            open (LOCALLOOKUPDB, ">>$filename")  or 
                die "Unable to open local database $!";
            print LOCALLOOKUPDB "\!DB $newdbfilename\n";
            close LOCALLOOKUPDB;
          }
         }
         else {
          print "Unknown file $newdbfilename\n";
          exit();
         }
        }
        else {
          print "Unknown file $filename $!\n";
          exit();
        }
        
}

sub dbunlink {
        my $filename=shift;
        my $dbfilename=shift;
        if ( -e $filename ) {
         # Check if its already there
         open (LOCALLOOKUPDB, "<$filename")  or
                die "Unable to open local database $!"; 
         open (DBOUTFILE, ">$filename.tmp") or
                die "Unable to open working file $!";
         while (<LOCALLOOKUPDB>) {
            if ( $_!~/\!DB $dbfilename/ ) {
                print DBOUTFILE $_;
            }
           }
         close LOCALLOOKUPDB;
         close DBOUTFILE;
         use File::Copy;
         rename "$filename.tmp", $filename;
        }
}

sub listdb {
        my $filename=shift;
        my $map;

        use FileHandle;
        my $fh=FileHandle->new();
        open ( $fh, "<$filename" );
        while ( $map=<$fh> ) {
          if ( $map=~/^\!DB (.*)/ ) { # Check for other DB files
                my $db=$1;
                if ( -f $db ) {
                  listdb($db);
                }
                next;
          }
          ( $name, $version, $type, $url ) = split ":", $map; 
          printf "%1s",$name;
          printf "%25s\n",$version;
          printf "--> %25s\n",$type.":".$url;
        }
        close $fh;
}

sub arch {
        print $scram->arch()->arch()."\n";
}

sub setupscram {
        $scram=Scram::SCRAM2->new();
}

# ------------ tool command --------------------------------------------
sub tool {
        my @allowed_cmds=qw(setup info list);
        _processcmds("_tooloptions", \@allowed_cmds, \@_, ("tool"));
}

sub tool_setup {
        my $tool=shift;

        print "Setting Up Tool $tool\n";
        $scram->setuptool($tool,@_);
}

sub tool_list {
        my ($area,@tools)=$scram->tools();
        print "Tool List for ".$area->name()." ".$area->version()."\n";
        print "Location : ".$area->location()."\n";
        print "+"x60;
        print "\n";
        
        foreach $t ( @tools ) {
           print $t->name();
           print " ";
           print $t->version();
           print "\n";
        }
}

sub tool_info {
        my $tool=shift;
        print "Info on Tool $tool\n";
}

sub _tooloptions {
        $scram->error("No Options defined for tool command");
}

sub help_tool_setup {
print <<ENDTEXT;
Description:
        Set up the configuration parameters for a given tool
Usage :
        scram tool setup tool_name [tool_version]

ENDTEXT
}

sub help_tool_info {
print <<ENDTEXT;
Description:
        Print out information on the specified tool in the current area 
        configuration.
Usage :
        scram tool info tool_name [tool_version]

ENDTEXT
}

sub help_tool_list {
print <<ENDTEXT;
Description:
        List of currently configured tools available in ther current scram
        area
Usage :
        scram tool list

ENDTEXT
}

# ----------- setup command ------------------------------------------
sub setup {
        my $toolname=shift @ARGV;

        if ( ! defined $toolname ) {
                # general area setup for new platform
          print "****** Not implemented *****\n";
        }
        else {
          $scram->setuptool($toolname);
        }

}

sub devtest {
        use Utilities::TestClass;
        my $class=shift @ARGV;

        $scram->devtest($class);
}

# ------------------- HELP routines ----------------------------------


sub help_db {
print <<ENDTEXT;
scram database administration command. 

Usage:

                 $bold scram db $normal subcommand

subcommands:
        link : 
                Make available an additional database for 
                project and list operations

                $bold scram db link $normal /a/directory/path/project.lookup

        unlink : 
                Remove a database from the link list. Note this does
                not remove the database, just the link to it in scram.

                $bold scram db unlink $normal /a/directory/path/project.lookup

        showlinks : 
                List the databases that are linked in

ENDTEXT
}

sub help_setup {

print <<ENDTEXT;
Allows installation/re-installation of a new tool/external package into an 
already existing development area. If not toolname is specified, 
the complete installation process is initiated.

Usage:

                 $bold scram setup $normal [toolname]

toolname : The name of the tool setup file required.
ENDTEXT
exit;
}

sub help_area {
print <<ENDTEXT;
Provides access to Scram development area management tools

Usage:

        $bold   scram area $normal [link|unlink|install|uninstall] options

Description of subcommnads:

${bold}scram area link ${normal}project_tag version_tag
   Attatch the scram area corresponding to the current working directory
   to the named project and version in the central installation 
   (see scram list)

${bold}scram area unlink $normal
   Break a link with the central installation

${bold}scram area install ${normal}[project_tag [version_tag]]
   Create an entry for the current area in the central installation database
   (admin permissions required)

${bold}scram area uninstall ${normal}[project_tag [version_tag]]
   Delete entry for the current area in the central installation database
   (admin permissions required)

ENDTEXT
exit;
}

sub help_list {
print <<ENDTEXT;
List the available projects and versions installed in the local SCRAM database
(see scram install help) 

Usage:

        $bold   scram list $normal

ENDTEXT
exit;
}

sub help_project {
print <<ENDTEXT;
Setup a new project development area. The new area will appear in the current 
working directory.
Usage:

        $bold scram project [-d install_area] [-n directory_name]$normal project_url [project_version]

Options:

project_url: The url of a scram bootstrap file.
             Currently supported types are:
                $bold Database label $normal
                        Labels can be assigned to bootstrap files for easy
                        access (See "scram install" command). If you
                        specify a label you must also specify a project_version.
                        e.g.

                           scram project SCRAM V1_0
                                
                           scram project ORCA ORCA_1_1_1

                        To see the list of installed projects use the
                        "scram list" command.

                $bold file: $normal A regular file on an accessable file system
                        e.g.

                           file:~/myprojects/projecta/config/BootStrapFile

project_version:
                 Only for use with a database label

-d install_area:
                 Indicate a project installation area into which the new
                 project area should appear. Default is the current working
                 directory.

-n directory_name:
                 Specify the name of the SCRAM development area you wish to 
                 create.
        
ENDTEXT
}

sub help_version {
print <<ENDTEXT;
With now $bold[version] $normal argument given, this command will simply
print to standard output the current version number.

Providing a version argument will cause that version to be downloaded and 
installed, if not already locally available. 
[Coming soon: When available locally, your current development area will
then be associated with the specified scram version rather than the default]


Usage:
                $bold scram version [version]$normal

ENDTEXT
}

sub help_arch {
print <<ENDTEXT;
Print out the architecture flag for the current machine.

Usage:
        $bold   scram arch $normal
ENDTEXT
}

sub help_tool {
print <<ENDTEXT;
Manage the tools in the scram area that define the areas environment.
ENDTEXT
}

sub help_runtime {
print <<ENDTEXT;
Echo to Standard Output the Runtime Environment for the current development area
Output available in csh or sh flavours

Usage:
        $bold   scram runtime [-csh|-sh] $normal

Examples:

Setup the current environment to include the project Runtime Environment
in a csh environment

       $bold  eval `scram runtime -csh` $normal

Setup the current environment to include the project Runtime Environment in a
sh environment

       $bold  eval `scram runtime -sh` $normal


ENDTEXT
}

sub helpheader {
        my $label=shift;
        my @sub=@_;

        my $substring;
        if ( @sub ) {
          $substring=join ' - ', @sub;
        }
        else {
          $substring="";
        }
print <<ENDTEXT;
*************************************************************************
SCRAM HELP ---------$bold scram $substring $label $normal
*************************************************************************
ENDTEXT
}
Revision:	1.29
Committed:	Tue Feb 22 16:13:00 2000 UTC (25 years, 2 months ago) by williamc
Branch:	MAIN
Changes since 1.28:	+276 -171 lines
Log Message:	Generalise command processing - multi level commands and aut help calling