tku.tcl

genesis 2000 v9.1软件下载

   catch {pack forget $W_STOP_FRAME}
   catch {grab release $W_STOP_FRAME}
   if { [string length  $TKU_G(PROG_FILE)] > 0} {
     if [tclu_file_exists $TKU_G(PROG_FILE)] {
        file delete -force $TKU_G(PROG_FILE)
     }
   }
   if { [tclu_file_exists $TKU_G(LOCAL_STOP_FILE)] } {
      catch {file delete -force $TKU_G(LOCAL_STOP_FILE)}
   }
   
   if {$END_CONDITION == "cancel"} {
      tclu_log_message "Command canceled by user" "error"
      set COMMAND_DONE cancel
   } else {
      if { $COMMAND_DONE == "ok" } {
         tclu_log_message "Command ended normally" ""
         set COMMAND_DONE ok
      }
   }
   . configure -cursor left_ptr
   set TKU_G(COMMAND_DONE) $COMMAND_DONE
}

################ Override tk_getOpenFile #########################
#*******************************************************
#
# Name :	tku_override_tk_getOpenFile
#
# Description :	
#   The Tk standard tk_getOpenFile does not allow to select a directory;
#   only a file. This command changes this behaviour by making the 'Open'
#   button closing the window and returning the current selected directory.
#
# Input	:	None
# Output :	None
# Return Value:	None
#
#*******************************************************
#
proc tku_override_tk_getOpenFile {} {
 global TKU_G
 global tk_library
 source [file join $tk_library tkfbox.tcl]
 rename tkFDialog_OkCmd tkFDialog_OkCmd.org

 proc tkFDialog_OkCmd.new w {
#   upvar #0 $w data

    # set text [tkIconList_Get $data(icons)]
    set data_icons [lindex [uplevel #0 array get [winfo name $w] icons] 1]
    set text [tkIconList_Get $data_icons]

    # tkFDialog_Done $w [tkFDialog_JoinFile $data(selectPath) $text]
    set data_selectpath [lindex [uplevel #0 array get [winfo name $w] selectPath] 1]
    tkFDialog_Done $w [tkFDialog_JoinFile  $data_selectpath $text]
 }
 proc tk_getOpenFile.new {{ARG1 ""} {ARG2 ""} \
                          {ARG3 ""} {ARG4 ""} \
                          {ARG5 ""} {ARG6 ""} \
                          {ARG7 ""} {ARG8 ""} \
                          {ARG9 ""} {ARG10 ""} \
                          {ARG11 ""} {ARG12 ""} } {
     set COMMAND  "tkFDialog $ARG1 $ARG2 $ARG3 $ARG4  $ARG5  $ARG6 \
                   $ARG7 $ARG8 $ARG9 $ARG10 $ARG11 $ARG12"
     return [eval $COMMAND]
 }
 
 rename tkFDialog_OkCmd.new tkFDialog_OkCmd
 if { $TKU_G(OS) == "nt" } {
     if [catch {rename tk_getOpenFile tk_getOpenFile.org} ERROR] {
        puts "1. $ERROR"
     }
     if [catch {rename tk_getOpenFile.new tk_getOpenFile} ERROR] {
        puts "2. $ERROR"
     }
 }
 return
}

proc tku_restore_tk_getOpenFile {} {
 global TKU_G
 global tk_library
 rename tkFDialog_OkCmd tkFDialog_OkCmd.new
 rename tkFDialog_OkCmd.org tkFDialog_OkCmd
 
 return
}


################ POPUP FILE #########################
#*******************************************************
#
# Name :	tku_popup_file
#
# Description :	
#   Opens a window showing a file in it. If the file is longer than
#   SIZE_LIMIT, only SIZE_LIMIT bytes are displayed (rounded to a full
#   line). Tags are supported inside the file:
#    normal (default) - font: cbr14  color: black
#    error            - font: cbr14  color: red
#    underline        - font: cbr14  color: black  underline
#    title            - font: cbr18  color: black  underline
#   tags should appear as ()tag in the beginning of the line.
#
# Input	:	PATH - Path of file to display
#               POSITION - start for showing line 1 on top
#                          end for showing last line on bottom
#               ATTRIBUTES - Allows additional attribute (e.g. -height 40)
# Output :	None
# Return Value:	None
#
#*******************************************************
#
proc tku_popup_file {PATH {POSITION start} {ATTRIBUTES ""}} {
   global TKU_G
   set WF .popup_file
   append WF _ $TKU_G(WCOUNTER)
   set WFT $WF.text
   set WFB $WF.button
   set SIZE_LIMIT 100000

   if { ! [tclu_is_path_file $PATH] } {
      tku_popup_message warning ok [format "Missing file:\n%s" $PATH]
      return
   }
   set WLOGS [tku_popup_log_open $PATH $ATTRIBUTES]
   set W  [lindex $WLOGS 0]
   set WT [lindex $WLOGS 1]
          
   set NORMAL_STRING ""
   set FP [open $PATH]
   set SIZE [file size $PATH]
   if {$SIZE > $SIZE_LIMIT} {
      seek $FP -$SIZE_LIMIT end
      gets $FP LINE
      set LINE_SIZE [string length $LINE]
      tku_popup_log $WT error \
	 [format "File %s is too long.\
	        \n%d initial bites were not displayed\n" \
	         $PATH [expr $SIZE - $SIZE_LIMIT + $LINE_SIZE]]
   }      
   set LINE_NUM 0
   while {![eof $FP]} {
      gets $FP LINE
      incr LINE_NUM
      if {[string range $LINE 0 1] == "()"} {
         tku_popup_log $WT normal "$NORMAL_STRING"
	 set NORMAL_STRING ""
	 set I1 [string wordend $LINE 2]
	 tku_popup_log $WT [string range $LINE 2 [expr $I1-1]] \
	                   "[string range $LINE [expr $I1+1] end]\n"
      } else {   
         append NORMAL_STRING $LINE "\n"
      }
   }
   tku_popup_log $WT normal "$NORMAL_STRING"
   close $FP
      
   if {$POSITION == "end"} {
      $WT yview moveto 1
   }
   tku_popup_log_show $W
}

################ POPUP LOG #########################
#*******************************************************
#
# Name :	tku_popup_log_open
#
# Description :	
#   Opens a window to which lines can be added in sequence using the 
#   procedure tku_popup_log. The window is only displayed upon call to 
#   tku_popup_log_show. 
#
# Input	:	NAME - Title of window
#               ATTRIBUTES - Allows additional attribute (e.g. -height 40)
# Output :	None
# Return Value:		A list of 2 widgets - 
#                W     - Widget of window
#                WTEXT - Widget of text portion
#*******************************************************
#
proc tku_popup_log_open {NAME {ATTRIBUTES ""}} {
   global TKU_G
   set WF .popup_log
   append WF _ $TKU_G(WCOUNTER)
   incr TKU_G(WCOUNTER)

   set WFT $WF.text
   set WFB $WF.button
      
   toplevel $WF
   wm title $WF "$NAME"
   frame $WFT -bg [c_lblue]
            
   text $WFT.text -yscrollcommand "$WFT.scroll set" -setgrid 1 \
        -font [cbr14] -bg [c_yellow] 
   
   set CONF_CMD [list $WFT.text configure]
   foreach WORD $ATTRIBUTES {
      lappend CONF_CMD $WORD
   }
   eval $CONF_CMD
   
   scrollbar $WFT.scroll -command "$WFT.text yview" -bg [c_yellow]
   pack $WFT.scroll -side right -fill y 
   pack $WFT.text -expand 1 -fill both

   $WFT.text tag configure error  -foreground [c_red]
   $WFT.text tag configure normal -foreground [c_black]
   $WFT.text tag configure title \
      -foreground [c_black] -underline 1 -font [cbr18]
   $WFT.text tag configure underline \
      -foreground [c_black] -underline 1 -font [cbr14]
      
   frame $WFB -bg [c_dblue]
   button $WFB.b1 -text "Close" -font [tbr14] -bg [c_aqua] \
          -highlightbackground [c_yellow] \
          -command [list destroy $WF]
   button $WFB.b2 -text "Copy" -font [tbr14] -bg [c_aqua] \
          -highlightbackground [c_yellow] \
          -command [list tku.popup_log_copy $WF $WFT.text]
   pack $WFB.b1 $WFB.b2 -side left -expand 1
   pack $WFT -fill both  -expand 1  
   pack $WFB -side bottom -fill both -expand 1
      
   return "$WF $WFT.text" 
}

proc tku_popup_log {W  TAG MESSAGE} {
   $W insert end $MESSAGE $TAG
}

proc tku_popup_log_show {W} {
   $W.text.text configure -state disabled
   wm transient $W .
   tku_center_on_window . $W
   wm deiconify $W 
}
#.....................................................................
proc tku.popup_log_copy { WF WFT } {
   global TKU_G
   
   if { [string length $TKU_G(COPY_DIR)] == 0 } {
     set TKU_G(COPY_DIR) [tclu_get_tmp_dir]
   }
  tku_cursor_watch       
  tku_restore_tk_getOpenFile 
  set DEST_PATH \
     [tk_getSaveFile -initialdir  $TKU_G(COPY_DIR)]
  tku_override_tk_getOpenFile 
  tku_cursor_normal      
  if { [string length $DEST_PATH] > 0 } { 
       set TKU_G(COPY_DIR) [file dirname $DEST_PATH]
       if [ file exists $DEST_PATH ] {
	  if [ tclu_is_path_dir $DEST_PATH ] {
	     tku_popup_message error ok \
	       "The destination must be a file and\
	      \nnot a directory."
	      return 
	  }
       }
       set MESSAGE "Copy window data to $DEST_PATH ? "
       set CHOICE [tku_popup_message question okcancel $MESSAGE]
       if { $CHOICE != "ok" } {
          return
       }
       if {[catch {open $DEST_PATH w} OFP]} {
         tku_popup_message error ok $OFP
         return 1
       }
       foreach { KEY VALUE INDEX } [ $WFT dump -text 1.0 end ] {
         puts -nonewline $OFP $VALUE
       }
       close $OFP
  }
}

#*******************************************************
#
# Name :	tku_is_root
#
# Description :	
#   Shows a popup alerting that the user is not a superuser (root)
#
# Input	:	MODE - error - if not root - cannot continue
#                      warning - if not root - give a choice
# Output :	None 
# Return Value:	1 if user is root
#               0 otherwise
#*******************************************************
#
proc tku_is_root { MODE } {
   global TKU_G
   
   set IS_ROOT [tclu_is_root]
   
   if { $TKU_G(OS) == "nt" } {
     if { ! $IS_ROOT} {
	set CHOICE [tku_popup_message warning yesno \
                "Administrator privileges are required for \
	       \nperforming this operation.\
	       \nDo you wish to continue ?"]
	if { $CHOICE == "yes" } {
	       tclu_set_root 1
	       return 1
	} else {
	       return 0
	}       
     } else {
       return 1 
     }
   } else {
     if { ! $IS_ROOT} {
       switch -- $MODE {
	 "error" {	 
           tku_popup_message error ok \
             "You do not have superuser privileges\
            \nwhich are required for this operation.\
            \nPlease contact your administrator."
           return 0
	 }
	 "warning" {
	    set CHOICE [tku_popup_message warning yesno \
                "You do not have superuser privileges\
               \nwhich are required for this operation.\
	       \nYou may encounter errors.\
	       \nDo you wish to continue ?"]
	    if { $CHOICE == "yes" } {
	       return 1
	    } else {
	       return 0
	    }
	 }
         default { bgerror "Switch error tku.tcl (2)" }
      }
     } else {
       return 1 
     }
   }
}

#*******************************************************
#
# Name :	tku_prompt_size
#
# Description :	
#   Shows a popup alerting about the size required for the 
#   coming installation
#
# Input	:	SIZE - The required size
# Output :	None 
# Return Value:	1 if user approved
#               0 otherwise
#*******************************************************
#
proc tku_prompt_size { SIZE } {
   if { $SIZE == 0 } {
     return 1
   }
   set APP_SIZE [ expr $SIZE / 1024 ] 
   set CHOICE [tku_popup_message question yesno \
                "The installation you are about to perform\
               \nrequires approximately $APP_SIZE Kbytes.\
	       \nDo you wish to continue ?"]
   if { $CHOICE == "yes" } {
     return 1
   } else {
     return 0
   }
}

################ POPUP MESSAGE #########################
#*******************************************************
#
# Name :	tku_popup_message
#
# Description :	
#   Shows a dialog popup with a message and action buttons.
#   IS better than the Tk default one since it changes colors 
#   depending on type and also does not clip the message 
#   arbitrarily.
#
# Input	:	ICON - error, warning question info
#               TYPE - ok, okcancel retrycancel yesno yesnocancel