tclu.tcl

genesis 2000 v9.1软件下载

# Description :	
#   Returns 1 if the tail of the name starts with a dot
#
# Input	:	PATH - path to be checked
# Output :	None
# Return Value:	1 - if path is hidden
#		0 - otherwise
#*******************************************************
#
proc tclu_is_path_hidden { PATH } {
   set TAIL [file tail $PATH]
   if [string match .* $TAIL ] {
      return 1
   }
   return 0
}

#*******************************************************
#
# Name :	tclu_mkdir
#
# Description :	
#   Creates a directory under certain checks and precautions:
#   - Path must contain only legal characters:
#       letters, digits, dot, underscore, colon, slash, dash, backslash
#   - If the path exists and is a directory, a check is made that it is
#     writable (Error is popped up if not)
#   - An error is popped up and returned if the path is to an existing file
#   - If the directory does not exists, a confirmation message is popped up
# Input	:	PATH - path to be checked
# Output :	None
# Return Value:	1 - if path is a file
#		0 - otherwise
#*******************************************************
#
proc tclu_mkdir { PATH {QUIET 0} } {
  global TCLU_G
  if {$TCLU_G(OS) == "nt"} {
     set LEGAL {^[a-zA-Z]:[\\a-z A-Z0-9._:/\-]+$}
#    Ignores regular paths & UNC paths
  } else {
     set LEGAL {^[\\a-zA-Z0-9._:/\-]+$}
  }
  set PATH [string trim $PATH]
#
# Check path characters legality
#
  if {! [regexp $LEGAL $PATH]} {
     tku_popup_message error ok \
	"Path contains illegal characters\
	 \n\nName  = $PATH\n"
     return 1
  }
  set EXISTS [tclu_file_exists $PATH]
  set IS_DIR [tclu_is_path_dir $PATH]
#
#  If path is an exiting directory, check its permissions
#     
  if { $EXISTS && $IS_DIR } {
     set WRITABLE [file writable $PATH]
     if { ! $WRITABLE } {
       tku_popup_message error ok \
  	  "Directory is not writable\
	   \n\nName  = $PATH\n"
        return 1
     }
     return 0
  }
#
#  If path is an existing file, it is an error
#  
  if { $EXISTS && ! $IS_DIR } {
     tku_popup_message error ok \
	"Path is an existing file\
	 \n\nName  = $PATH\n"
     return 1
  }
#
#  Confirm creation of a directory and handle any creation errors  
#  
  if { ! $EXISTS } {
    if {$QUIET == 0} {
      set CHOICE \
	  [tku_popup_message question yesno \
	       "No such directory\
       \n\nName=$PATH\n\nCreate ?\n"]
    }
    if {$QUIET != 0 || $CHOICE == "yes"} {
       set STATUS [catch {file mkdir $PATH} ERROR]
       if { $STATUS } {
         tku_popup_message error ok \
	   "Directory creation failure\
	    \n\nName  = $PATH\
	    \n\nError = $ERROR\n"
	 return 1
       }
    } else {
       return 1 
    }
  }  
  return 0 
}

#*******************************************************
#
# Name :	tclu_get_dir_for_file
#
# Description :	
#   For a dicrectory - returns self
#   For a file, returns the parent directory
#
# Input	:	PATH - path to be checked
# Output :	None
# Return Value:	PATH or result
#*******************************************************
#
proc tclu_get_dir_for_file {PATH} {
  if { [tclu_is_path_dir $PATH] } {
     return $PATH 
  } else {
     return [file dirname $PATH] 
  }
}

#*******************************************************
#
# Name :	tclu_get_bak_name
#
# Description :	
#   Returns a path which extends the input path with a suffix
#   of yyyymmdd and a serial number (If exists already)
#
# Input	:	PATH - path to be appended
# Output :	None
# Return Value:	New path
#*******************************************************
#
proc tclu_get_bak_name {PATH} {
   set DATE [clock format [clock seconds] -format "%Y%b%d"]   
   set NEW_PATH_ORG ${PATH}.${DATE}
   set NEW_PATH $NEW_PATH_ORG
   set COUNTER 0
   while { [tclu_file_exists $NEW_PATH] } {
      incr COUNTER
      set NEW_PATH ${NEW_PATH_ORG}.$COUNTER
   }
   return $NEW_PATH
}

#*******************************************************
#
# Name :	tclu_get_tmp_dir
#
# Description :	
#   Returns a path for temporary files
#
# Input	:	None
# Output :	None
# Return Value:	Path of temporary directory
#*******************************************************
#
proc tclu_get_tmp_dir {} {
   global TCLU_G
   global env

   if {$TCLU_G(OS) == "nt"} {
      return [tclu_path_back_to_fore $env(TEMP)]
   } else {
      return "/usr/tmp"
   }
}

#*******************************************************
#
# Name :	tclu_str_cmp_nc
#
# Description :	
#   Compare 2 strings (case insensitive)
#
# Input	:	S1, S2 - 2 strings
# Output :	None
# Return Value:	-1 for smaller, 0 for equal, 1 for larger
#*******************************************************
#
proc tclu_str_cmp_nc {S1 S2} {

   set S1_LC [string tolower $S1]
   set S2_LC [string tolower $S2]
   return [string compare $S1_LC $S2_LC]
}

#*******************************************************
#
# Name :	tclu_get_tmp_name
#
# Description :	
#   Returns a path  for a temporary file
#
# Input	:	PREFIX - A prefix for the file
# Output :	None
# Return Value:	New path
#*******************************************************
#
proc tclu_get_tmp_name {PREFIX} {
   return [format "%s/%s.%s" [tclu_get_tmp_dir] $PREFIX [pid]]
}

#*******************************************************
#
# Name :	tclu_copy_txt_file
#
# Description :	
#   Copies a text file, replacing lf to crlf if needed
#
# Input	:	IPATH - Input path
#               OPATH - Output path
# Output :	None
# Return Value:	None
#*******************************************************
#
proc tclu_copy_txt_file {IPATH OPATH } {

    if { [catch {open $IPATH RDONLY} IFP] } {
       tku_popup_message error ok $IFP
       return 1
    }
    if { [catch {open $OPATH { WRONLY CREAT }} OFP] } {
       close $IFP
       tku_popup_message error ok $OFP
       return 1
    }
    while {! [eof $IFP]} {
       gets $IFP LINE
       puts $OFP $LINE
    }
   
    close $IFP
    close $OFP
}

#*******************************************************
#
# Name :	tclu_del_tmp_files
#
# Description :	
#   Deletes all temp files of a process
#
# Input	:	PREFIX - A prefix for the file
# Output :	None
# Return Value:	New path
#*******************************************************
#
proc tclu_del_tmp_files {{PREFIX *}} {
   global TCLU_G
   global env

   if {$TCLU_G(OS) == "nt"} {
      set PATH [file join $env(TEMP) $PREFIX.[pid]]
   } else {
      set PATH [file join usr tmp $PREFIX.[pid]]
   }
   catch {file delete $PATH}
}

#*******************************************************
#
# Name :	tclu_check_files
#
# Description :	
#   Receives a root path and a list of relative paths and checks
#   against several lists of statis. A window is popped and shows all
#   results, marking in red the discrepancies. The user, in Custom mode
#   has the choice to overlook and continue.
#     
#
# Input	:	MODE       - Standard or Custom
#               ROOT_PATH  - Path of the root directory
#               PATH_LIST  - A list of relative paths, types and write/req
# Output :	
# Return Value:	New path
#*******************************************************
#
proc tclu_check_files {MODE ROOT_PATH PATH_LIST } { 
     
   set WLOGS \
     [tku_popup_log_open "Frontline Pro-Installer : Required Files Status" \
                     "-height 30"]
   set WLOG [lindex $WLOGS 0]
   set WT   [lindex $WLOGS 1]
   
   tku_popup_log $WT underline \
       "\nPath                                                      Exists  Type Rd Wr"
   tku_popup_log $WT normal "\n\n"
   set COUNT 0   
   foreach {PATH REQ_TYPE REQ_WRITABLE} $PATH_LIST {
      set FULL_PATH [file join $ROOT_PATH $PATH]
      set ASC_EXISTS    "No"
      set ASC_TYPE      "??"
      set ASC_READABLE  "??"
      set ASC_WRITABLE  "??"
      set STYLE "error"
      
      set EXISTS [tclu_file_exists $FULL_PATH]
      if { $EXISTS } {
         set ASC_EXISTS    "Yes"
	 set STYLE "normal"
	 if [tclu_is_path_file $FULL_PATH] {	    
	    set TYPE file 
	    set ASC_TYPE "File"
 	    set READABLE  [file readable $FULL_PATH]
	    if { $READABLE } {
	       set ASC_READABLE "Ok"   
	    } else {
	       set ASC_READABLE "No"
	    }
	 }
	 if [tclu_is_path_dir $FULL_PATH] {	    
	    set TYPE dir
	    set ASC_TYPE "Dir"
 	    set READABLE [expr \
	       [file readable $FULL_PATH] && [file executable $FULL_PATH] ]
	    if { $READABLE } {
	       set ASC_READABLE "Ok"   
	    } else {
	       set ASC_READABLE "No"
	    }
	 }	 
	 if { $TYPE != $REQ_TYPE } {
	    set STYLE "error"
	 }
	 if { ! $READABLE } {
	    set STYLE "error"
	 }
	 set WRITABLE [file writable $FULL_PATH]
	 if { $WRITABLE } {
	    set ASC_WRITABLE "Ok"   
	 } else {
	    set ASC_WRITABLE "No"
	 }
	    
	 if { ( $REQ_WRITABLE == "w" ) && ( ! $WRITABLE ) } {
	    set STYLE "error"
	 }	 
      }
      tku_popup_log $WT $STYLE \
	 [format "%-58s%-8s%-5s%-3s%-3s\n" \
              $FULL_PATH $ASC_EXISTS $ASC_TYPE $ASC_READABLE $ASC_WRITABLE] 
      incr COUNT
      if { [expr $COUNT % 5 ] == 0 } {
         tku_popup_log $WT normal "\n"
      }
	 
   }
   tku_popup_log_show $WLOG      
     
   return ok  
}

#*******************************************************
#
# Name :	tclu_is_root
#
# Description :	
#   Returns 1 if the caller has root privileges
#
# Input	:	None
# Output :	None
# Return Value:	1 for root, 0 for other
#*******************************************************
#
proc tclu_is_root {} {
   global TCLU_G
   global env
    
   if { $TCLU_G(IS_ROOT) == 1 } {
      return 1
   }
   if {$TCLU_G(OS) == "nt"} {
      if { [tclu_get_user] == "Administrator" } {
         return 1
      }
   } else {
      if { [tclu_get_user] == "root" } {
         return 1 
      }
   }
   return 0
}

#*******************************************************
proc tclu_set_root {IS_ROOT} {
   global TCLU_G
   set TCLU_G(IS_ROOT) $IS_ROOT
}
   

#*******************************************************
#
# Name :	tclu_file_exists
#
# Description :	
#   Returns 1 if input file exists.
#   Created because of Sun-Os Tcl problem - file exists
#   returns 1 when input name is ""
#
# Input	:	PATH
# Output :	
# Return Value:	1 for existing files, 0 for other
#*******************************************************
#
proc tclu_file_exists {PATH} {
  if {[string compare $PATH ""] == 0} {
    return 0
  }
  return [file exists $PATH]
}

#*******************************************************
#
# Name :	tclu_path_back_to_fore
#
# Description :	
# Convert all backslashes in path to forward slashes
#   Returns converted path
#
# Input	:	PATH
# Output :	none
# Return Value:	Path with foreward slashes
#*******************************************************
#
proc tclu_path_back_to_fore { PATH } {
  regsub -all "\\\\" $PATH "/" NEW_PATH
  return $NEW_PATH
}
#*******************************************************
#
# Name :	tclu_quote_backslashes
#
# Description :	
# Convert all backslashes in path to two backslashes for quoting 
# purposes
#
# Input	:	PATH
# Output :	none
# Return Value:	Path with double backslashes
#*******************************************************
#
proc tclu_quote_backslashes { PATH } {
  regsub -all "\\\\" $PATH "\\\\\\\\" NEW_PATH
  return $NEW_PATH
}

################ HOSTID UTITLITIES #######################

#*******************************************************
#
# Name :	tclu_get_hostid
#
# Description :	
#   Returns the 6 digits host id of the system, according to the given 
#   operating system.
#
# Input	:	OS - Operating system : aix, hp10, nt, solaris, linux
# Output :	None
# Return Value:	6 digit hostid
#*******************************************************
#
proc tclu_get_hostid {OS} {
   global TCLU_G

   switch -- $OS {
     aix {
       if { [catch {exec /bin/entstat ent0 | grep Hardware} HOSTLINE]  } {
	 # if 'ent0' did not work, we try tok0
	 if { [catch {exec /bin/tokstat tok0 | grep Hardware} HOSTLINE]  } {
	   tku_popup_message error ok \
	     "/bin/tokstat tok0 | grep Hardware :\n$HOSTLINE"
	   return ""
	 }
       }