#! /usr/bin/perl -w
##**************************************************************
##
## Copyright (C) 1990-2007, Condor Team, Computer Sciences Department,
## University of Wisconsin-Madison, WI.
## 
## Licensed under the Apache License, Version 2.0 (the "License"); you
## may not use this file except in compliance with the License.  You may
## obtain a copy of the License at
## 
##    http://www.apache.org/licenses/LICENSE-2.0
## 
## Unless required by applicable law or agreed to in writing, software
## distributed under the License is distributed on an "AS IS" BASIS,
## WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
## See the License for the specific language governing permissions and
## limitations under the License.
##
##**************************************************************


##*****************************************************************
## Extracts an installation from a tar ball, a gzip, or a gzip'ed
## tar ball.  The installation package can be located on a mounted
## filesystem, a FTP site, or a HTTP site.  This program can copy
## auxillary files from similar locations but will not extract 
## extract them from a tar ball.
##
## Author: Joe Meehean
## Date: 6/21/03
##*****************************************************************

#***
# Uses
#***
use strict;
use FindBin;
use lib ($FindBin::Bin, "$FindBin::Bin/lib", "$FindBin::Bin/../lib");
use Execute;
use Cwd;
use File::Basename;
use Getopt::Long;
use File::Copy;
use File::Spec;

#***
# Constant Static Variables
#***
my $USAGE = 
    "Usage: install_release [-f] [-help] <binary_tar>\n".
    "[-basedir base_dir] [-log log_file_name]\n".
    "[-wget] [-globuslocation globus_location]\n".
    "[-o other_file1 other_file2 ...] \n";

#  error tags for output
my $FAILURE_TEXT = 'FAILED: ';
my $WARNING_TEXT = 'WARNING: ';
my $SEE_LOG = "\nSee the log file for further details";

#  commands
my $TAR_CMD = 'tar';
my $GUNZIP_CMD = 'gunzip';
my $WGET_CMD = 'wget';
my $GURL_CMD = 'globus-url-copy';

#  log entry headers
my $INSTALL_ENTRY_HDR = 101;
my $WARNING_ENTRY_HDR = 201;
my $ERROR_ENTRY_HDR = 301;
my $REMOVE_ENTRY_HDR = 501;

#  suffixes for installation packages
my @TAR_SFXS = ('.tar');
my @GZIP_SFXS = ('.gz', '-gz', '.z', '-z', '_z', '.Z');
my @GZIP_TAR_SFXS = ('.tgz', '.taz', '.tar.gz', '.tar.Z');

#  installation package types
my $TAR_TYPE = 1;
my $GZIP_TYPE = 2;
my $GZIP_TAR_TYPE = 3;

#  Acceptable network protocols for fetching a file with wget
my %WGET_PROTOCOLS = ( 'http'=>1,
		       'ftp'=>1,
		       );

# Acceptable network protocols for fetching a file with globus-url-copy
my %GURL_PROTOCOLS = ( 'http'=>1,
		       'ftp'=>1,
		       'gsiftp'=>1,
		       );

my $GURL_FILE_PROTOCOL_HEADER = 'file://';

# Environment variables
my $LD_LIBRARY_PATH = 'LD_LIBRARY_PATH';

#***
# Non-Constant Static Variables
#***
# Defaults to current working directory
my $base_dir= '.';
my $force = 0;
my $help = 0;
my $other_files_flag = 0;
my @other_files = ();
my $install_log = 'install.log';
my $globus_location = '/opt/globus';
my $wget_flag = 0;
my $iwd = 0;

#  Command options
my @tar_args = ('-xvf');
my @wget_args = ();
my @gunzip_args = ('-f');
my @gurl_args = ();

#***
# Main Function
#***

GetOptions('basedir=s'=>\$base_dir,
	   'log=s'=>\$install_log,
	   'f'=>\$force,
	   'wget'=>\$wget_flag,
	   'globuslocation=s'=>\$globus_location,
	   'o' =>\$other_files_flag,
	   'help' =>\$help,
	   );

#Process command-line arguments
my $incorrectUseOfO = $other_files_flag && (@ARGV < 1);
die $USAGE if( @ARGV < 1 || $help || $incorrectUseOfO);
my $binary_tar = shift @ARGV;
@other_files = @ARGV;

#See if the user doesn't want to install overtop of another installation
if( !$force ){
    unshift @tar_args, '-k';
}

# Store the initial working directory
$iwd = cwd;

#Setup globus-url-copy, if neccessary
&SetupGurl() if( !$wget_flag );

#Move to install directory
chdir $base_dir or die "Cannot chdir to $base_dir: $!";

#Create an install log
open INSTALL_LOG_FD, "> $install_log"
    or die "Cannot open $install_log: $!";

# Install the installation package
my $local_package = &InstallFile($binary_tar);

# Install from the installation package
&InstallFromPackage($local_package);

# Install the other files
if( $other_files_flag ){
    &InstallOtherFiles(@other_files);
}

# close the log file
close INSTALL_LOG_FD;

#DONE

#*********************************************************************
# Copies the other files specified to the install directory
#*********************************************************************
sub InstallOtherFiles(){
    my (@install_files) = @_;  #Name the parameters
    
    # Install each of the files
    foreach my $file(@install_files){
	&InstallFile($file);
    }
}

#*********************************************************************
# Installs a file from the given path name.
# Returns the base file name.
#*********************************************************************
sub InstallFile(){
    #Name the parameters
    my ($file_path) = @_;  
   
    # Create an install path for the file
    my $file_name = basename $file_path;
    my $file_install_path = File::Spec->rel2abs( $file_name );
    # Ensure we aren't reinstalling the file over itself
    if( $file_install_path eq $file_path ){
	#already done
	return $file_install_path;
    }
    
    # Ensure the file doesn't already exist (if no-force)
    if(-e $file_install_path && !$force ){
	WarnUser("File already exists, skipping installation of $file_install_path");
	#skip the install
	return $file_install_path;
    }

    # Create a local copy of the file
    &FetchFile($file_path);
    
    # Log the installation
    &LogInstall($file_install_path);

    return $file_install_path;
}


#*********************************************************************
# Fetches the given file from either a remote location or a mounted 
# file system using a either globus-url-copy or wget and Perl's copy.
# Returns the base file name of the given file
#*********************************************************************
sub FetchFile(){
    my($file_location) = @_;  #Name the parametersGURL_FILE_PROTOCOL_HEADER
    
    my $file_name;
    # See if the user prefers wget and copy
    if( $wget_flag ){
	$file_name = &FetchFileWGetCp($file_location);
    } else{
	$file_name = &FetchFileGurl($file_location);
    }
}

#*********************************************************************
# Fetches the given file from either a remote location or a mounted
# file system using globus-url-copy.
# Supports HTTP, FTP, and GSIFTP.
# Returns the base file name of the given file.
#*********************************************************************
sub FetchFileGurl(){
    my($src_path) = @_;  #Name the parameters
    
    # get the local file name
    my $file = basename $src_path;

    # See if the src file
    # a. Has a protocol header?
    # b. That the protocol header is valid?
    # -
    # match a protocol name followed by a colon and two forward slashes
    # Ex: http://files.we.may/want
    # $1 = protocol name
    if( $src_path =~ m{^(\w+)://} ){
	if( !exists $GURL_PROTOCOLS{$1} ){
	    &DieWithError( "This program does not currently support". 
			   " the given protocol: $1");
	}
    }

    # Assume file system if there is no protocol header
    else{
	# Ensure the file location is an absolute path (from iwd)
	if( !File::Spec->file_name_is_absolute($src_path) ){
	    $src_path = File::Spec->catpath(0, $iwd, $src_path);
	}
	# Append the file protocol header to the location
	$src_path = $GURL_FILE_PROTOCOL_HEADER.$src_path;
    }
    
    # Create the destination string
    # Convert to absolute path
    my $dest_path = File::Spec->rel2abs($file);
    # Append file protocol header
    $dest_path = $GURL_FILE_PROTOCOL_HEADER.$dest_path;

    #fetch the file with globus-url-copy
    my $returnHashRef = ExecuteAndCapture($GURL_CMD, 
					  @gurl_args, 
					  $src_path,
					  $dest_path);
    
    #determine if the gurl failed
    if( $returnHashRef->{EXIT_VALUE} ){
	&LogError(@{$returnHashRef->{ERRORS}});
	&DieWithError("globus-url-copy failed");
    }
    
    return $file;
}

#*********************************************************************
# Fetches the given file from either a remote location using a 
# network protocol OR from a mounted file system using wget and Perl
# copy. 
# Currently only supports HTTP and FTP.
# Returns the base file name of the given file
#*********************************************************************
sub FetchFileWGetCp(){
    my ($file_location) = @_;  #Name the parameters

    # get the local file name
    my $file = basename $file_location;

    # Network protocol
    # match a protocol name followed by a colon and two forward slashes
    # Ex: http://files.we.may/want
    # $1 = protocol name
    if( $file_location =~ m{^(\w+)://} ){

	# See if we can use wget to get the file
	if( exists $WGET_PROTOCOLS{$1} ){
	    &FetchWithWGet($file_location);	    
	} 
	
	# Currently can only handle transfers wget supports
	else{
	    &DieWithError( "This program does not currently support". 
		" the given protocol: $1");
	}

    } 
    
    #Otherwise assume the file is in a mounted file system
    else{
	# Convert the path to be absolute (from the iwd)
	if( !File::Spec->file_name_is_absolute($file_location) ){
	    $file_location = File::Spec->catpath(0, $iwd, $file_location);
	}
	# Copy the file to the working dir
	copy($file_location, $file)
	    or &DieWithError("Failed to copy $file_location to $base_dir: $!");
    }

    return $file
}

#*********************************************************************
# Fetches the given file url with wget
#*********************************************************************
sub FetchWithWGet(){
    my ($file_url) = @_;  #Name the parameters

    #download the file with wget
    my $returnHashRef = ExecuteAndCapture($WGET_CMD, 
					  @wget_args, 
					  $file_url);
    
    #determine if the wget failed
    if( $returnHashRef->{EXIT_VALUE} ){
	&LogError(@{$returnHashRef->{ERRORS}});
	&DieWithError("wget failed");
    }
    
}

#*********************************************************************
# Installs files from a locally stored package.
# Currently installs from either gzip, tar, or gzip'ed tars.
#*********************************************************************
sub InstallFromPackage(){
    my ($install_package) = @_;  #Name the parameters
    
    # Determine the type of the package
    my ($name,$path,$suffix, $type) = &PackageNameAndType($install_package);
    
    # Install from the correct package type
    if ( $type == $TAR_TYPE ){

	&InstallFromTar($install_package);

    } elsif( $type == $GZIP_TYPE ){

	&InstallFromGzip($install_package);

    } elsif( $type == $GZIP_TAR_TYPE ){

	# Gunzip the package
	my $tarfile = &InstallFromGzip($install_package);
	# Perform the remaining extraction
	&InstallFromTar($tarfile);

    } else{
	&DieWithError("Could not extract $install_package".
		      " because could not recognize type");
    }
}

#*********************************************************************
# Installs from a gzip'ed file
# Returns the name of the extracted file
#*********************************************************************
sub InstallFromGzip(){
    my($gzip_file) = @_;  #Name the parameters

     # Determine the new name of the about to be gunzip'ed file
    my $extracted_file;
    my ($name,$path,$suffix, $type) = &PackageNameAndType($gzip_file);
    if( $type == $GZIP_TAR_TYPE ){
	$extracted_file = $path.$name.$TAR_SFXS[0];
    }  else{
	$extracted_file = $path.$name;
    }

    # Check to see whether the new file exits
    # and whether we want force overwrite it
    if( -e $extracted_file && !$force ){
	# An error has occured
	# We should not extract overtop of this file
	&DieWithError("Gunzip'ing $gzip_file would overwrite the $extracted_file.".
		      "  If this is what the user wants specify '-f'.\n");
    }

    # Unzip 
    my $returnHashRef = ExecuteAndCapture($GUNZIP_CMD, @gunzip_args, $gzip_file);

    #Determine if the install failed
    if( $returnHashRef->{EXIT_VALUE} ){
	#Log the errors from the gunzip install
	&LogError(@{$returnHashRef->{ERRORS}});
	&DieWithError("Gunzip'ing $gzip_file failed\n");
    }

   
    # Log the replacement of the gzip file with the unzipped file
    &LogRemove($gzip_file);
    &LogInstall($extracted_file);
    
    # Return extracted file name
    return $extracted_file;
}

#*********************************************************************
# Installs from a tar'ed file
#*********************************************************************
sub InstallFromTar(){
    my($tar_file) = @_;  #Name the parameters

    # Extract
    my $returnHashRef = ExecuteAndCapture($TAR_CMD, @tar_args, $tar_file);

    # Convert the logged installs from tar into absolute paths
    my @abPathInstalls = ();
    foreach my $relPath(@{$returnHashRef->{OUTPUT}}){
	my $absPath = File::Spec->rel2abs($relPath);
	push @abPathInstalls, $absPath;
    }

    #Log the untar install
    &LogInstall(@abPathInstalls);

    #Log the errors from the untar install
    &LogError(@{$returnHashRef->{ERRORS}});

    #Determine if the install failed
    if( $returnHashRef->{EXIT_VALUE} ){
	&DieWithError("Untarring the binaries failed\n");
    }
}

#*********************************************************************
# Adds the globus location to the list of paths to check for 
# dynamically linked libraries.
#*********************************************************************
sub SetupGurl(){
    # Look up the current ld path list
    my $ld_paths = $ENV{$LD_LIBRARY_PATH};

    # Ensure the globus location is an absolute path (from iwd)
    if( !File::Spec->file_name_is_absolute($globus_location) ){
	$globus_location = File::Spec->catpath(0, $iwd, $globus_location);
    }
    
    # Create globus libraries path
    my $globus_lib_path = File::Spec->catpath(0, $globus_location, 'lib');

    # Add globus location to the path list
    if( $ld_paths ){
	# colon-separated
	$ld_paths = $ld_paths.':'.$globus_lib_path;
    } else{
	$ld_paths = $globus_lib_path;
    }

    # Reset the environment variable
    $ENV{$LD_LIBRARY_PATH} = $ld_paths;
}

#*********************************************************************
# Writes the given message as an error to the install log
# then dies with the same message
#*********************************************************************
sub DieWithError(){
    #Name the parameter
    my ($message) = @_;

    # print the message to the log
    &LogError($message);
    # close the log
    close INSTALL_LOG_FD;
    
    # append the failure tag and die with the message
    die $FAILURE_TEXT.$message.$SEE_LOG."\n";
}

#*********************************************************************
# Writes the given warning to the log and to the screen.
#*********************************************************************
sub WarnUser(){
    #Name the parameter
    my ($message) = @_; 

    # print the message to the log
    &LogWarning($message);
        
    # warn with the message
    warn $WARNING_TEXT.$message.$SEE_LOG."\n";;
}

#*********************************************************************
# Writes an install entry to the given log.  Can take a list of 
# entries that will be written on their own lines.
#*********************************************************************
sub LogInstall(){
    my @install_entries = @_;

    foreach my $entry(@install_entries){
	print INSTALL_LOG_FD $INSTALL_ENTRY_HDR, "\t", $entry, "\n";
    }
}

#*********************************************************************
# Writes an error entry to the given log. Can take a list of
# entries that will be written on their own lines.
#*********************************************************************
sub LogError(){
    my @error_entries = @_;

    foreach my $entry(@error_entries){
	print INSTALL_LOG_FD $ERROR_ENTRY_HDR, "\t", $entry, "\n";
    }

}

#*********************************************************************
# Writes an warning entry to the given log. Can take a list of
# entries that will be written on their own lines.
#*********************************************************************
sub LogWarning(){
    my @warn_entries = @_;

    foreach my $entry(@warn_entries){
	print INSTALL_LOG_FD $WARNING_ENTRY_HDR, "\t", $entry, "\n";
    }
}

#*********************************************************************
# Writes an removal entry to the given log. Can take a list of
# entries that will be written on their own lines.
#*********************************************************************
sub LogRemove(){
    my @remove_entries = @_;

    foreach my $entry(@remove_entries){
	print INSTALL_LOG_FD $REMOVE_ENTRY_HDR, "\t", $entry, "\n";
    }
}

#*********************************************************************
# Returns the path, name, suffix, and type of the given package name.
#*********************************************************************
sub PackageNameAndType(){

    my($package_name) = @_;  #name the parameters

    # make the suffix lists into regular expressions
    # order of suffix checking matters
    # because gzip-tar suffixes can be concatentations 
    # of gzip and tar suffixes
    my @sfx_re_list = ();
    my @temp_sfx_list = (@GZIP_TAR_SFXS, @TAR_SFXS, @GZIP_SFXS);
    foreach ( @temp_sfx_list ){
	my $re = quotemeta $_;
	push @sfx_re_list, $re;
    }
    
    # parse the file name
    my($name,$path,$suffix) = fileparse($package_name, @sfx_re_list);

    # determine from which list the suffix came
    my $type = 0;
    if( &MemberStr($suffix, @TAR_SFXS) ){
	$type = $TAR_TYPE;
    } elsif( &MemberStr($suffix, @GZIP_SFXS) ){
	$type = $GZIP_TYPE;
    } elsif( &MemberStr($suffix, @GZIP_TAR_SFXS) ){
	$type = $GZIP_TAR_TYPE;
    } else{
	&DieWithError("Cannot determine the type of the package");
    }
    
    
    return ($name, $path, $suffix, $type);
}

#*********************************************************************
# Returns true if the given string is a member of the given list
#*********************************************************************
sub MemberStr(){
    my($item, @list) = @_;  #Name the parameters

    foreach my $next(@list){

	if( $item eq $next ){
	    # Yes
	    return 1;
	}
    }

    # No
    return 0;
}


