tclu.tcl

genesis 2000 v9.1软件下载

#---------------------------------------------------
#
#  Module : tclu.tcl
#  Author : MK
#  Date   : 20 Aug 1997
#
#  Description :
#
#  This module provides general utilities needed by the Frontline Pro-Installer
#  module and the various installation plug-ins.
#  All the public procedures are called tclu_<name>
#  All the private procedures are called tclu.<name> - should never be called
#
#  List of public procedures in this module:
#
#  tclu_set_tools_dir - 
#  tclu_set_os        -   Initialization routines
#  tclu_set_commands  -
#  tclu_get_genesis_epath - Specific for Enterprise/Genesis
#  tclu_get_genesis_path  - Specific for Enterprise/Genesis
#  tclu_get_home    - 	Get the HOME environment variable 
#  tclu_get_user    -   Get the current user
#  tclu_break_line  -	Breaks a line at convenient places
#  tclu_is_path_dir -   Checks if a path is or links to a directory
#  tclu_is_path_file -	Checks if a path is or links to a file
#  tclu_is_path_executable - Checks if a path is executable
#  tclu_is_path_dot -   Checks if a path is . or ..
#  tclu_mkdir -		Creates a directory with certain precautions
#  tclu_get_dir_for_file - Returns the directory of a file
#  tclu_get_bak_name -  Create a date/time tagged backup name
#  tclu_get_tmp_dir  -  Get the directory for temp files
#  tclu_get_tmp_name -  Create a temporary file names
#  tclu_copy_txt_file - Copies a text file (replacing lf to crlf if needed)
#  tclu_del_tmp_files - Deletes all the process temp files
#  tclu_check_files   - Checks a list of files against a table
#  tclu_is_root       - Checks if current user is root
#  tclu_file_exists   - Check if a file exists (Needed for SunOS)
#  tclu_path_back_to_fore - Converts back slashes to forward slashes
#  tclu_str_cmp_nc    - Compare 2 strings (case insensitive)
#  tclu_get_hostid -	Gets the host id of the workstation
#  tclu_get_dongle -    Gets the id of the dongle
#  tclu_get_gz_size -   calculates the size of a gzipped file
#  tclu_log_set_path -  Sets the path of the log file
#  tclu_log_get_path -  Gets the path of the log file
#  tclu_log_newline -   
#  tclu_log_message -	Procedures supporting writing of a log file
#  tclu_log_file -
#  tclu_create_lst_file - Creates a .lst file for a directory
#  tclu_check_lst_file  - Verifies a .lst file against a directory
#  tclu_check_sum_file - Checks a .sum file against the file
#  tclu_get_checksum -   Creates a md5sum
#  tclu_get_dat_lst_file 
#  tclu_update_file -     |
#  tclu_find_str_in_file -|--- Find/Update text files
#  tclu_put_after         |
#  tclu_put_at_eof        |
#  tclu_set_system_env  - Sets a systemwide environment variable (NT only)
#  tclu_null_file       - path of null file (/dev/null or nul)
#---------------------------------------------------
#
#  Change History 
#  --------------
#  970820 - First Version
#  970906 - Documentation
#

global TCLU_G
set    TCLU_G(IS_ROOT) 0

#*******************************************************
#
# Name :	tclu_set_tools_dir
#
# Description :	
#   Sets the locations of the tools directory 
#
# Input	:	TOOLS_DIR - location of the tools
# Output :	None
# Return Value:	None
#
#*******************************************************
#
proc tclu_set_tools_dir {TOOLS_DIR} {
  global TCLU_G
  
  set TCLU_G(TOOLS) $TOOLS_DIR
}

#*******************************************************
#
# Name :	tclu_set_os
#
# Description :	
#   Sets the operating system
#
# Input	:	OS - name of operating system
# Output :	None
# Return Value:	None
#
#*******************************************************
#
proc tclu_set_os {OS} {
  global TCLU_G
  
  set TCLU_G(OS) $OS
}

#*******************************************************
#
# Name :	tclu_set_commands
#
# Description :	
#   Sets the locations of the some useful commands
#
# Input	:	CAT   - Path to cat command
#               CHMOD - Path to chmod command
#               CP    - Path to cp command
#               DD    - Path to dd command
#               TAR   - Path to tar command
#               WHOAMI - Path to whoami command
# Output :	None
# Return Value:	HOME environment variable
#
#*******************************************************
#
proc tclu_set_commands {CAT CHMOD CP DD TAR WHOAMI} {
  global TCLU_G
  
  set TCLU_G(CAT)    $CAT
  set TCLU_G(CHMOD)  $CHMOD
  set TCLU_G(CP)     $CP
  set TCLU_G(DD)     $DD
  set TCLU_G(TAR)    $TAR
  set TCLU_G(WHOAMI) $WHOAMI
}


#*******************************************************
#
# Name :	tclu_get_home
#
# Description :	
#   Returns the value of the HOME environment variable
#
# Input	:	None
# Output :	None
# Return Value:	HOME environment variable
#
#*******************************************************
#
proc tclu_get_home {} {
   global env
   global TCLU_G

   if [info exists env(HOME)] {
      return $env(HOME)
   } else {
      if [info exists env(USERPROFILE)] {
         return "$env(USERPROFILE)"
      } else {
         if [info exists env(windir)] {
            return "[string index $env(windir) 0]:/"
         } else {
            return "/"
         }
      }
   }
}

#*******************************************************
#
# Name :	tclu_get_user
#
# Description :	
#   Returns the current user of the system
#
# Input	:	None
# Output :	None
# Return Value:	User name
#
#*******************************************************
#
proc tclu_get_user {}  {
   global TCLU_G
   global env
    
   if {$TCLU_G(OS) == "nt"} {
      return $env(USERNAME)
   } else {
      return [exec $TCLU_G(WHOAMI)]
   }
}

#*******************************************************
#
# Name :	tclu_get_genesis_epath
#
# Description :	
#   Returns the value of the genesis executable directory
#
# Input	:	None
# Output :	None
# Return Value:	HOME environment variable
#
#*******************************************************
#
proc tclu_get_genesis_epath {} {
   global env
   
   set GENESIS_DIR [tclu_get_genesis_path]
   if [info exists env(GENESIS_EDIR)] {
      set EDIR $env(GENESIS_EDIR)
      if [tclu_is_abs_path $EDIR] {
         return $EDIR
      }
   } else {
     if [info exists env(GENESIS_VER)] {
         set EDIR e$env(GENESIS_VER)
     } else {
	 # Should not happen
	 set EDIR e   
     }
   }
   return [file join $GENESIS_DIR $EDIR]   
}

#*******************************************************
#
# Name :	tclu_get_genesis_path
#
# Description :	
#   Returns the value of the genesis home directory
#
# Input	:	None
# Output :	None
# Return Value:	GENESIS_DIR environment variable or /genesis
#
#*******************************************************
#
proc tclu_get_genesis_path {} {
   global env
   global TCLU_G
   
   if [info exists env(GENESIS_DIR)] {
      return $env(GENESIS_DIR)
   } else {
      if {$TCLU_G(OS) == "nt"} {
         return "$env(HOMEDRIVE)/genesis"
      } else {
         return "/genesis"
      }
   }
}

#*******************************************************
#
# Name :	tclu_is_abs_path
#
# Description :	
#   Returns 1 if the path is absolute (Starts with / on UNIX or
#   with a X: on NT.
#
# Input	:	None
# Output :	None
# Return Value:	1 for absolute, 0 for relative
#
#*******************************************************
#
proc tclu_is_abs_path { PATH } {
   global TCLU_G
   
   set ABS 0
   if {$TCLU_G(OS) == "nt"} {
      if { [string length $PATH] >=3 } {
         if { [string index $PATH 1] == ":" } {
	    set ABS 1
	 }
      }
   } else {
      if { [string length $PATH] >=1 } {
         if { [string index $PATH 0] == "/" } {
	    set ABS 1
	 }
      }      
   }
   return $ABS
}

################ STRING UTITLITIES #######################
#*******************************************************
#
# Name :	tclu_break_line
#
# Description :	
#   Breaks a long string to lines according to MAXLINE.
#   Break occurs only on blank character.
#   If there is no blank to meet the criteria, string will 
#   be broken after MAXLINE characters.
#
# Input	:	S - The string to break
#               MAXLINE - The maximal characters in a line
# Output :	None
# Return Value:	New string
#
#*******************************************************
#
proc tclu_break_line {S MAXLINE} {
  set S1 $S
  set SNEW ""
  while {1} {
     set LEN [string length $S1]
     if { $LEN > $MAXLINE } {
        set BREAK_INDEX [expr $MAXLINE-1]
	while {$BREAK_INDEX > 0} {
	   set CHAR [string range $S1 $BREAK_INDEX $BREAK_INDEX]
	   if {[string compare $CHAR " "] == 0} {
	     incr BREAK_INDEX 
	     break 
	   }
	   incr BREAK_INDEX -1
	}
	if {$BREAK_INDEX == 0} {
	   set BREAK_INDEX $MAXLINE
	}
	append SNEW [string range $S1 0 [expr $BREAK_INDEX-1]] "\n"
	set S1 [string range $S1 $BREAK_INDEX end]
     } else {
	append SNEW $S1
	break 
     }
  }
  return "$SNEW"
}

################ FILE UTITLITIES #######################

#*******************************************************
#
# Name :	tclu_is_path_dir
#
# Description :	
#   Returns 1 if the file is a directory. It is better than
#   'file isdirectory' built-in since it also handles the case where the 
#   path is a link to a directory
#
# Input	:	PATH - path to be checked
# Output :	None
# Return Value:	1 - if path is a directory
#		0 - otherwise
#*******************************************************
#
proc tclu_is_path_dir { PATH } {
  set TYPE ""

  if [tclu_file_exists $PATH] {
    set TYPE [file type $PATH]
  }
  if { $TYPE == "link" } {
    set TYPE [file type [tclu.transfer_link $PATH]]
  }
  if { $TYPE == "directory" } {
    return 1
  } else {
    return 0
  }
}

#*******************************************************
#
# Name :	tclu_is_path_file
#
# Description :	
#   Returns 1 if the file is a file. It is better than
#   'file isfile' built-in since it also handles the case where the 
#   path is a link to a file
#
# Input	:	PATH - path to be checked
# Output :	None
# Return Value:	1 - if path is a file
#		0 - otherwise
#*******************************************************
#
proc tclu_is_path_file { PATH } {
   set TYPE ""
  if { [string compare $PATH ""] == 0 } {
    return 0
  }
  
  if [tclu_file_exists $PATH] {
      set TYPE [file type $PATH]
   }
   if { $TYPE == "link" } {
      set TYPE [file type [tclu.transfer_link $PATH]]
   }
   if { $TYPE == "file" } {
      return 1
   } else {
      return 0
   }
}

#...............................................................
proc tclu.transfer_link { PATH } {
   global TCLU_G
      
   set TYPE [file type $PATH]   
   if { $TYPE != "link" } {
      return $PATH
   }
   
   set LINK [file readlink $PATH]
   
   if { $TCLU_G(OS) == "nt" } {
      return $LINK 
   }
   if { [string index $LINK 0] == "/" } {
     # Absolute path #
      return $LINK       
   } else {
     # Relative path #
     set DIR [file dirname $PATH]
     set FINAL [file join $DIR $LINK]
   }
   return $FINAL
}

#*******************************************************
#
# Name :	tclu_is_path_executable
#
# Description :	
#   Returns 1 if the file is a file. It is better than
#   'file executable' built-in since it also handles the case where the 
#   path omits final ".exe" for Windows NT
#
# Input	:	PATH - path to be checked
# Output :	None
# Return Value:	1 - if path is executable
#		0 - otherwise
#*******************************************************
#
proc tclu_is_path_executable { PATH } {
  global TCLU_G
  
  if { $TCLU_G(OS) == "nt" } {
     if { [regexp -nocase "\\.exe$" $PATH] } {
        return [file executable $PATH]
     } else {
        return [file executable "$PATH.exe"]
     }
   } else {
      return [file executable $PATH]
   }
}

#*******************************************************
#
# Name :	tclu_is_path_dot
#
# Description :	
#   Returns 1 if the tail of the name is . or ..
#
# Input	:	PATH - path to be checked
# Output :	None
# Return Value:	1 - if path is a dot(dot) file
#		0 - otherwise
#*******************************************************
#
proc tclu_is_path_dot { PATH } {
   set TAIL [file tail $PATH]
   if {$TAIL == "." || $TAIL == ".."} {
      return 1
   }
   return 0
}

#*******************************************************
#
# Name :	tclu_is_path_hidden
#