install.tcl

genesis 2000 v9.1软件下载

    set PATH_TITLE [file join $PATH_NAME ${NAME}.ttl]
  
    set TITLE "<No Title>"
    if {! [catch {open $PATH_TITLE r} TFP]} {
      gets $TFP TITLE
      close $TFP
    }
    puts $FP [format "%-15s --> %s" $NAME $TITLE] 
    if [catch { glob [file join $PATH_NAME *]} VERSIONS_LIST ] {
       set VERSIONS_LIST ""     
    }
    foreach PATH_VERSION $VERSIONS_LIST {
      set NAME_VERSION [file tail $PATH_VERSION]
      if { [tclu_str_cmp_nc $NAME_VERSION ${NAME}.ttl] == 0 } continue
      if [catch { glob [file join $PATH_VERSION *]} OSS_LIST ] {
         set OSS_LIST ""     
      }
      if {$OSS_LIST != ""} {
         puts -nonewline $FP [format "    Version %s   for operating systems: " \
		$NAME_VERSION]
	 foreach NAME_OS $OSS_LIST {
	    set NAME_OS [file tail $NAME_OS]
	    puts -nonewline $FP "$NAME_OS"
	    puts -nonewline $FP " "
	 } 
      } else {
            puts $FP \
	       [format "()error     Version %s   No operating system available" \
	 	       $NAME_VERSION]		
      }
      puts $FP " "
    }
    if {$VERSIONS_LIST == ""} {
       puts $FP "()error No versions available"
    }
    puts $FP "()underline                                                      "
  }
  close $FP
	 tku_popup_file $TMP_PATH start "-width 100"
  file delete $TMP_PATH
   
}

##################################################################
proc vpi.cb_name_dat {W} {
  global VPIG 
  
  set STATUS [tclu_get_dat_lst_file $VPIG(DAT_DEVICE) DAT_LIST]
  if { $STATUS != "ok" } {
    puts "while extracting products list from DAT, status is $STATUS"
    tku_popup_message warning ok "Error extracting DAT's products list"
    return
  }
  
  catch {unset NAME}
  set I 0
  foreach {PROD VER OS TITLE} $DAT_LIST {
    if { $I > 0 } {
      set PREV_IND [incr I -1]
      set PREV $NAMES($PREV_IND)
      if { [string compare $PROD $PREV] != 0 } {
	set NAMES($I) $PROD
      }
    } else {
      set NAMES($I) $PROD
    }
    incr I    

  }
  vpi.popup_list NAMES 0
  return  
}


##################################################################
proc vpi.list_contents_ftp_cb {} {
  global VPIG 

  set SOURCE [vpi.get_ftp_source_dir]
  if { $SOURCE == "" } return
   
  set TYPE $VPIG(PRODUCTS_OR_BEANS) 

  set LST_PATH "$SOURCE/.$TYPE.lst"
  set DEST_PATH [tclu_get_tmp_name "frontline_install_list"]
  
  set STATUS [vpi.ftp_command DUMMY get $LST_PATH 0 $DEST_PATH]
  if {$STATUS != 0} {
     return
  }
  
  tku_popup_file $DEST_PATH start "-width 100"
  tclu_del_tmp_files  
}
 

##################################################################
proc vpi.show_f_name {W} {
   global VPIG 

   set WF1 $W.f_name
   frame $WF1 -bg $VPIG(C_BG)
   button $WF1.b_name -text "安装程序:"  \
          -bg [c_yellow] -font [cbr14]      \
          -highlightbackground [c_dblue] \
          -command [list vpi.cb_name $W]
   entry  $WF1.e_name  -bg [c_yellow] -font [cbr14] \
         -textvariable VPIG(NAME)
   pack $WF1.b_name $WF1.e_name -side left 

   set WF2 $W.f_version
   frame $WF2 -bg $VPIG(C_BG)
   button $WF2.b_version -text "安装版本:" \
          -bg [c_yellow] -font [cbr14]     \
          -highlightbackground [c_dblue] \
          -command [list vpi.cb_name_version $W]
   entry  $WF2.e_version  -bg [c_yellow] -font [cbr14]  \
         -textvariable VPIG(NAME_VERSION)
   pack $WF2.b_version $WF2.e_version -side left 

   set WF3 $W.f_os
   frame $WF3 -bg $VPIG(C_BG)
   button $WF3.b_os -text "操作系统:"  \
          -bg [c_yellow] -font [cbr14] \
          -highlightbackground [c_dblue] \
          -command [list vpi.cb_name_os $W]
   entry  $WF3.e_os  -bg [c_yellow] -font [cbr14] \
         -textvariable VPIG(NAME_OS)
   pack $WF3.b_os $WF3.e_os -side left 
   
   pack  $WF1 $WF2 $WF3 -fill x
}

##################################################################
proc vpi.cb_name {W} {
  global VPIG 
  
  switch -- $VPIG(SOURCE) {
    CDROM { vpi.cb_name_cdrom_disk $W }
    FTP   { vpi.cb_name_ftp $W }
    DAT   { vpi.cb_name_dat $W }
    DISK  { vpi.cb_name_cdrom_disk $W }
    default { bgerror "Switch error install.tcl (1)"}
  }
}

#................................................................#
proc vpi.cb_name_cdrom_disk {W} {
  global VPIG 
  
  set PATH [vpi.get_dir]
  if { ! [tclu_is_path_dir $PATH] } {
     tku_popup_message warning ok [format "Illegal directory : \n%s" $PATH]
     return
  }
  if [catch { glob [file join $PATH *]} NAME_LIST ] {
      set NAME_LIST ""     
  }
  catch {unset NAMES}
  set I 0
  foreach NAME_PATH $NAME_LIST {
    set NAME [file tail $NAME_PATH]
    set PATH_TITLE [file join $NAME_PATH ${NAME}.ttl]
    
    set TITLE "<No Title>"
    if {! [catch {open $PATH_TITLE r} FP]} {
      gets $FP TITLE
      close $FP
    }
    set NAMES($I) [format "%-15s --> %s" $NAME $TITLE]
    incr I
  }
  vpi.popup_list NAMES 0
}

proc vpi.cb_name_ftp {W} {
  global VPIG
  set STATUS 0
  
  set SOURCE [vpi.get_ftp_source_dir]
  if { $SOURCE == "" } return
  set TYPE $VPIG(PRODUCTS_OR_BEANS) 

  set SOURCE_DIR "$SOURCE/$TYPE"
  set STATUS [vpi.ftp_command FILES_LIST list $SOURCE_DIR]
  if {$STATUS != 0} {
     return
  }
  catch {unset NAMES}
  set IND 0
  foreach FILE $FILES_LIST {
    set SIZE [string length $FILE]    
    if {$SIZE > 20} {
      set COUNT [scan $FILE "%s%s%s%s%s%s%s%s%s" SEC HLINK OWNER GGOUP \
    	         SIZE MONTH DATE TIME NAME]
      if { $COUNT < 9 } continue 
      if [tclu_is_path_dot $NAME] continue
      if [tclu_is_path_hidden $NAME] continue
      
      set TITLE "<No Title>"
      set SOURCE_TITLE "$SOURCE_DIR/$NAME/$NAME.ttl"
      set DEST_TITLE [tclu_get_tmp_name tmp_ttl]
      set STATUS [vpi.ftp_command DUMMY get $SOURCE_TITLE 0 $DEST_TITLE]
      if {$STATUS != 0} {
         return
      }
      if {! [catch {open $DEST_TITLE r} FP]} {
        gets $FP TITLE
        close $FP
	file delete $DEST_TITLE
      }
      set NAMES($IND) [format "%-15s --> %s" $NAME $TITLE]
      incr IND
    }
  }
  vpi.popup_list NAMES 0
}

proc vpi.list_contents_dat_cb {} {
  global VPIG 

  set STATUS [tclu_get_dat_lst_file $VPIG(DAT_DEVICE) DAT_LIST]
  if { $STATUS != "ok" } {
    puts "while extracting products list from DAT, status is $STATUS"
    tku_popup_message warning ok "Error extracting DAT's products list"
    return
  }

  set TMP_PATH [tclu_get_tmp_name "vpi_list"]
  if {[catch {open $TMP_PATH w} FP]} {
     tku_popup_message error ok [format "Cannot open file\n%s" $TMP_PATH]
     return
  }

  puts $FP [format "()title List of %s available on DAT" $VPIG(PRODUCTS_OR_BEANS)]
	    

  foreach {PROD VER OS TITLE} $DAT_LIST {
    
    puts $FP " "
    puts $FP [format "%-15s --> %s" $PROD $TITLE] 
    puts -nonewline $FP [format "    Version %s   for operating system: " $VER]
    puts $FP "$OS "
    puts $FP "()underline                                                      "    
      
  }
  
  close $FP
	 tku_popup_file $TMP_PATH start "-width 100"
  file delete $TMP_PATH
   
  return 
}

##################################################################
proc vpi.cb_name_version {W} {
  global VPIG 
  
  switch -- $VPIG(SOURCE) {
    CDROM { vpi.cb_name_version_cdrom_disk $W }
    FTP   { vpi.cb_name_version_ftp $W }
    DAT   { vpi.cb_name_version_dat $W }
    DISK  { vpi.cb_name_version_cdrom_disk $W }
    default { bgerror "Switch error install.tcl (2)"}
  }
}

#................................................................#
proc vpi.cb_name_version_cdrom_disk {W} {
  global VPIG 

  if { [string length [string trim $VPIG(NAME)]] == 0 } {
     tku_popup_message warning ok "请选择安装程序！"
     return
  }	
     
  set PATH [file join [vpi.get_dir] $VPIG(NAME)]
  if { ! [tclu_is_path_dir $PATH] } {
     tku_popup_message warning ok [format "Illegal directory : \n%s" $PATH]
     return
  }
  if [catch { glob [file join $PATH *]} VERSIONS_LIST ] {
      set VERSIONS_LIST ""     
  }
  catch {unset VERSIONS}
  set J 0
  foreach NAME_VERSION $VERSIONS_LIST {
    set NAME_VERSION [file tail $NAME_VERSION]
    if {! [tclu_str_cmp_nc $NAME_VERSION $VPIG(NAME).ttl] } continue 
    set VERSIONS($J) $NAME_VERSION
    incr J
  }
  vpi.popup_list VERSIONS 1
}

#................................................................#
proc vpi.cb_name_version_ftp {W} {
  global VPIG
  
  set SOURCE [vpi.get_ftp_source_dir]
  if { $SOURCE == "" } return
  set TYPE   $VPIG(PRODUCTS_OR_BEANS) 
  set NAME   $VPIG(NAME)
  
  if { [string length [string trim $VPIG(NAME)]] == 0 } {
     tku_popup_message warning ok "Name is not defined"
     return
  }	
  
  set SOURCE_DIR "$SOURCE/$TYPE/$NAME"
  set STATUS [vpi.ftp_command VER_LIST list $SOURCE_DIR]
  if {$STATUS != 0} {
     return
  }
  catch {unset VERSIONS}
  set IND 0
  foreach VER $VER_LIST {
    set SIZE [string length $VER]    
    if {$SIZE > 20} {
      set COUNT [scan $VER "%s%s%s%s%s%s%s%s%s" SEC HLINK OWNER GGOUP \
	  SIZE MONTH DATE TIME NAME_VERSION]
      if { $COUNT < 9 } { continue } 
      if [tclu_is_path_dot $NAME_VERSION] continue
      if {! [tclu_str_cmp_nc $NAME_VERSION $VPIG(NAME).ttl] } continue 
      set VERSIONS($IND) $NAME_VERSION
      incr IND
    }
  }
  vpi.popup_list VERSIONS 1
}

#................................................................#
proc vpi.cb_name_version_dat {W} {
  global VPIG 
  
  set STATUS [tclu_get_dat_lst_file $VPIG(DAT_DEVICE) DAT_LIST]
  if { $STATUS != "ok" } {
    puts "while extracting products list from DAT, status is $STATUS"
    tku_popup_message warning ok "Error extracting DAT's products list"
    return
  }
  
  catch {unset NAME}
  set I 0
  foreach {PROD VER OS TITLE} $DAT_LIST {
    if { [string compare $PROD $VPIG(NAME)] != 0} continue
    if { $I > 0 } {
      set PREV_IND [incr I -1]
      set PREV $NAMES($PREV_IND)
      if { [string compare $VER $PREV] != 0 } {
	set NAMES($I) $VER
      }
    } else {
      set NAMES($I) $VER
    }
    incr I    
  }
  vpi.popup_list NAMES 1
  return 
}

##################################################################
proc vpi.cb_name_os {W} {
  global VPIG 
  
  switch -- $VPIG(SOURCE) {
    CDROM { vpi.cb_name_os_cdrom_disk $W }
    FTP   { vpi.cb_name_os_ftp $W }
    DAT   { vpi.cb_name_os_dat $W }
    DISK  { vpi.cb_name_os_cdrom_disk $W }
    default { bgerror "Switch error install.tcl (3)"}
  }
}

#................................................................#
proc vpi.cb_name_os_cdrom_disk {W} {
  global VPIG 
  
  if { [string length [string trim $VPIG(NAME)]] == 0 } {
     tku_popup_message warning ok "请选择安装程序！"
     return
  }	
     
  if { [string length [string trim $VPIG(NAME_VERSION)]] == 0 } {
     tku_popup_message warning ok "请选择安装版本！"
     return
  }	
     
  set PATH \
    [file join [vpi.get_dir] $VPIG(NAME) $VPIG(NAME_VERSION)]
  if { ! [tclu_is_path_dir $PATH] } {
     tku_popup_message warning ok [format "Illegal directory : \n%s" $PATH]
     return
  }
  if [catch { glob [file join $PATH *]} OSS_LIST ] {
      set OSS_LIST ""     
  }
  catch {unset OSS}
  set J 0
  foreach NAME_OS $OSS_LIST {
    set NAME_OS [file tail $NAME_OS]
    set OSS($J) $NAME_OS
    incr J
  }
  vpi.popup_list OSS 2
}

#................................................................#
proc vpi.cb_name_os_ftp {W} {
  global VPIG
  
  set SOURCE [vpi.get_ftp_source_dir]
  if { $SOURCE == "" } return
  set TYPE   $VPIG(PRODUCTS_OR_BEANS) 
  set NAME   $VPIG(NAME)
  set VER    $VPIG(NAME_VERSION)
  
  set SOURCE_DIR "$SOURCE/$TYPE/$NAME/$VER"
  set STATUS [vpi.ftp_command OS_LIST list $SOURCE_DIR]
  if {$STATUS != 0} {
     return
  }
  catch {unset OSS}
  set IND 0
  foreach OS $OS_LIST {
    set SIZE [string length $OS]    
    if {$SIZE > 20} {
      set COUNT [scan $OS "%s%s%s%s%s%s%s%s%s" SEC HLINK OWNER GGOUP \
	         SIZE MONTH DATE TIME NAME_OS]
      if { $COUNT < 9 } continue 
      if [tclu_is_path_dot $NAME_OS] continue
      set OSS($IND) $NAME_OS
      incr IND
    }
  }
  vpi.popup_list OSS 2
}

proc vpi.cb_name_os_dat {W} {
  global VPIG 
  
  set STATUS [tclu_get_dat_lst_file $VPIG(DAT_DEVICE) DAT_LIST]
  if { $STATUS != "ok" } {
    puts "while extracting products list from DAT, status is $STATUS"
    tku_popup_message warning ok "Error extracting DAT's products list"
    return
  }
  
  catch {unset NAME}
  set I 0
  foreach {PROD VER OS TITLE} $DAT_LIST {
    if { [string compare $PROD $VPIG(NAME)] != 0} continue
    if { [string compare $VER $VPIG(NAME_VERSION)] != 0} continue
    set NAMES($I) $OS
    incr I    
  }
  vpi.popup_list NAMES 2
  return 
  
}

#
# The next 3 procedures are called by the trace mechanism. Due
# to some unexplained behaviour on Solaris, we use 'catch' to avoid
# any unpleasantries
##################################################################
proc vpi.name_change_cb { NAME1 NAME2 OP } {
  global VPIG 
  catch { set VPIG(NAME_VERSION) ""  }
  catch { set VPIG(NAME_OS) ""  }
  catch { vpi.unload }
}

##################################################################
proc vpi.name_version_change_cb { NAME1 NAME2 OP } {
  global VPIG 
  catch { set VPIG(NAME_OS) ""  }
  catch { vpi.unload }
}

##################################################################
proc vpi.name_os_change_cb { NAME1 NAME2 OP } {
  global VPIG 
  catch { vpi.unload }
}

proc vpi.unload { } {
  global VPIG 
   if { $VPIG(INSTALL_STATE) == 1 } {
     vpi.install_cb  $VPIG(WMAIN).f_action.f_buttons.install
   }
}
##################################################################
proc vpi.show_f_action {W} {
  global VPIG 
  
 set CHILDREN [list [winfo children $W]]
 foreach CHILD $CHILDREN {
   if { [string length $CHILD] > 0 } {
     destroy $CHILD
   }
 }