aftcllib.tcl

一套客户/服务器模式的备份系统代码,跨平台,支持linux,AIX, IRIX, FreeBSD, Digital Unix (OSF1), Solaris and HP-UX.

  if { [ info exists GVar_menuLabel($menu) ] } {
    set type [ string index $GVar_menuLabel($menu) 0 ]
    set body [ string range $GVar_menuLabel($menu) 1 end ]
    switch $type {
      {$} {
	global $body
	if { [ info exists $body ] } {
	  set text [ set $body ]
	} else {
	  set text ""
	}
      }
      {"} {
	set text $body
      }
    }
    label "$widget.__GVar_menuLabel__" -text $text
    pack "$widget.__GVar_menuLabel__" -in $widget -side top
  }

  set childwidget $widget.__dummy__

  foreach child $GVar_menuItems($menu) {
    set amenuitem $child
    set GVar_parentFrame($child) $actparentframe

    if { [ info exists GVar_menuItemCondition($child) ] } {
      set type [ string index $GVar_menuItemCondition($child) 0 ]
      set body [ string range $GVar_menuItemCondition($child) 1 end ]
      switch $type {
	{$} {
	  global $body
	  set ok 0
	  if { [ info exists $body ] } {
	    set val [ set $body ]
	    if { $val == "1" || [ string tolower $val ] == "true" } {
	      set ok 1
	    }
	  }
	  if { ! $ok } {
	    continue
	  }
	}
	"/" {
	  if { ! [ file exists $body ] } {
	    continue
	  }
	}
	"@" {
	  if { ! [ eval $body ] } {
	    continue
	  }
	}
      }
    }

    set childhead [ file dirname $child ]
    if { $childhead == "/" } {
      set childhead ""
    }
    set childtail [ file tail $child ]
    set childwidget [ GStr_replSubstring "$childhead/__${childtail}__" / . ]
    set childwidget "$top_widget$childwidget"

    frame $childwidget
    button $childwidget.button -text "" -command "GGUI_selectionProc $child"
    if { [ info exists GVar_menuItemLabel($child) ] } {
      set body [ string range $GVar_menuItemLabel($child) 1 end ]
      switch [ string index $GVar_menuItemLabel($child) 0 ] {
	{"} {
	  set label $body
	}
	{$} {
	  global $body
	  set label [ set $body ]
	}
      }
    } else {
      set label [ file tail $child ]
    }
    label $childwidget.label -text $label

    pack $childwidget.button $childwidget.label -side left
    pack $childwidget -in $widget -side top -anchor w
  }

  if { [ info exists GVar_menuTitle($menu) ] } {
    set type [ string index $GVar_menuTitle($menu) 0 ]
    set body [ string range $GVar_menuTitle($menu) 1 end ]

    switch $type {
      {$} {
	global $body
	if { [ info exists $body ] } {
	  set title [ set $body ]
	} else {
	  set title ""
	}
      }
      {"} {
	set title $body
      }
    }
  } else {
    if { [ info exists GVar_menuItemLabel($menu) ] } {
      set body [ string range $GVar_menuItemLabel($menu) 1 end ]
      switch [ string index $GVar_menuItemLabel($menu) 0 ] {
	{"} {
	  set title $body
	}
	{$} {
	  global $body
	  set title [ set $body ]
	}
      }
    } else {
      set title [ file tail $menu ]
    }
  }

  if { $widget == "$top_widget" } {
    frame "${childwidget}_can_"
    button "${childwidget}_can_.cancel" -text "Exit" -command "exit 0"

    pack "${childwidget}_can_.cancel"
    pack "${childwidget}_can_" -in $widget -side top

    pack $widget
    catch { wm geometry [ winfo parent $widget ] "+$GVar_actXPos+$GVar_actYPos" }
    catch { wm title [ winfo parent $widget ] $title }
  } else {
    frame "${childwidget}_can_"
    button "${childwidget}_can_.cancel" -text "Cancel" -command "GGUI_destroyFrametree $widget $menu"

    pack "${childwidget}_can_.cancel"
    pack "${childwidget}_can_" -in $widget -side top

    if { ! $getpos_failed } {
      catch { wm geometry $GVar_parentFrame($amenuitem) "+$GVar_actXPos+$GVar_actYPos" }
    }
    wm protocol $GVar_parentFrame($amenuitem) WM_DELETE_WINDOW "GGUI_destroyFrametree $widget $menu"
    catch { wm title $GVar_parentFrame($amenuitem) $title }
  }
}

proc GGUI_destroyFrametree { widget menu } {
  global	GVar_subframeExists GVar_parentMenus
  global	GVar_parentFrame GVar_actMenuPath GVar_actWidget

  destroy $widget

  set parentmenu [ lindex $GVar_parentMenus($menu) 0 ]
  foreach frame [ array names GVar_subframeExists ] {
    if { [ string length $parentmenu ] <= [ string length $frame ] } {
      catch { unset GVar_subframeExists($frame) }
    }
  }

  set GVar_actWidget $GVar_parentFrame($menu)
  set GVar_actMenuPath [ lindex $GVar_parentMenus($menu) 0 ]
}

proc GGUI_redisplayActMenu { } {
  global	GVar_actMenuPath GVar_subframeExists GVar_parentMenus

  set parentmenu [ lindex $GVar_parentMenus($GVar_actMenuPath) 0 ]
  catch { unset GVar_subframeExists($parentmenu) }

  GGUI_selectionProc $GVar_actMenuPath
}

proc GGUI_destroyActFrameTree { } {
  global	GVar_actMenuPath GVar_actWidget

  GGUI_destroyFrametree $GVar_actWidget $GVar_actMenuPath
}

proc GGUI_placeToplevel { w { change_actpos 0 } } {
  global	Conf_menuXDist Conf_menuYDist GVar_actXPos GVar_actYPos

  set pos [ GGUI_getActPos ]

  if { $pos == "" } {
    set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
            - [winfo vrootx $w]]
    set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
            - [winfo vrooty $w]]
  } else {
    set x [ lindex $pos 0 ]
    set y [ lindex $pos 1 ]
    if { [ info exists Conf_menuXDist ] } {
      incr x $Conf_menuXDist
    }
    if { [ info exists Conf_menuYDist ] } {
      incr y $Conf_menuYDist
    }
  }

  if { $change_actpos == "1" || [ string tolower $change_actpos] == "true" } {
    set GVar_actXPos $x
    set GVar_actYPos $y
  }

  wm geom $w "+$x+$y"
}

#
# pack a toplevel window and put it into the center of the screen
#
proc GGUI_packAndCenter { win } {
  pack $win
  set w [ winfo parent $win ]
  wm withdraw $w
  update idletasks

  set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 ]
  set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 ]
  wm geom $w +$x+$y
  wm deiconify .
}

proc GGUI_getPosAndDestroy { widget } {
  global GVar_actXPos GVar_actYPos

  set fault [ catch { set parent [ winfo parent $widget ] } ]
  if { $fault } {
    return
  }
  if { $parent == "" } {
    set parent "."
  }
  set fault [ catch { set winfo [ winfo geometry $parent ] } ]

  if { $fault } {
    return
  }

  scan $winfo "%dx%d%d%d" w h GVar_actXPos GVar_actYPos
  catch { destroy $widget }
}

proc GGUI_packAndPlace { widget } {
  global GVar_actXPos GVar_actYPos

  pack $widget

  set fault [ catch { set widget [ winfo parent $widget ] } ]
  if { $fault } {
    return
  }
  if { $widget == "" } {
    set widget "."
  }

  wm geometry $widget "+$GVar_actXPos+$GVar_actYPos"
}

#
# Pop up an error dialog prompting the user with the message in msg
#
proc GGUI_errorDialog { msg } {
  GGUI_genericDialog .error "Error" "Error:\n\n$msg" "" 0 Ok
}

#
# Pop up a warning dialog prompting the user with the message in msg
#
proc GGUI_warningDialog { msg } {
  GGUI_genericDialog .warning "Warning" "Warning:\n\n$msg" "" 0 Ok
}

#
# Pop up a toplevel dialog and call a procedure to build it's
# subwidgets. The procedure to call is the second argument. That
# procedure gets the parent widget and a tkPriv array element name
# as next to last and last argument. The tkPriv array element
# must be set, when the dialog should disappear. The second
# argument to may be combined of several words. The second word etc.
# is passed to the subwidgets_proc as first arguments.
#
proc GGUI_basicDialog { title subwidgets_proc } {
  global	tkPriv

  set w .dialog[clock seconds]
  catch { destroy $w }

  set tkw tkprivvar[clock seconds]
  set tkPriv($tkw) 0

  toplevel $w -class Dialog
  wm title $w $title
  wm protocol $w WM_DELETE_WINDOW "destroy $w ; set tkPriv($tkw) -1"
  wm iconname $w $title

  frame $w.f

  set ret [ eval $subwidgets_proc $w.f $tkw ]

  pack $w.f -fill both -expand 1

  tkwait variable tkPriv($tkw)

  destroy $w

  return $ret
}

#
# Pop up an information dialog prompting the user with the text
#
proc GGUI_infoDialog { text { title "Information" } } {
  global	Conf_menuXDist Conf_menuYDist
  global	GVar_actXPos GVar_actYPos

  set w .info[clock seconds]
  catch { destroy $w }

  toplevel $w -class Dialog
  wm title $w $title
  wm protocol $w WM_DELETE_WINDOW "destroy $w"
  wm iconname $w $title
#  wm transient $w [ winfo toplevel [ winfo parent $w ] ]
  frame $w.
  option add *l.wrapLength 4i widgetDefault
  label $w.l -justify left -text "$text"
  catch { $w.l configure -font -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-* }
#  button $w.b -text "Ok" -command "destroy $w"
  pack $w.l -side top
  GGUI_placeToplevel $w True

  set exists 1
  foreach var "Conf_menuXDist Conf_menuYDist GVar_actXPos GVar_actYPos" {
    if { ! [ info exists $var ] } {
      set exists 0
    }
  }

  update idletasks
}

#
# Internal routine for sorting
proc SDIC_compareListElements { arg1 arg2 } {
  if { [ lindex $arg1 0 ] > [ lindex $arg2 0 ] } {
    return 1
  }
  if { [ lindex $arg1 0 ] < [ lindex $arg2 0 ] } {
    return -1
  }
  return 0
}

#
# Internal callback
proc SDIC_selectAll { } {
  .seldialog.list.listbox selection set 0 end
  .seldialog.sel.all configure -text "Deselect all" -command SDIC_deselectAll
}

#
# Internal callback
proc SDIC_deselectAll { } {
  .seldialog.list.listbox selection clear 0 end
  .seldialog.sel.all configure -text "Select all" -command SDIC_selectAll
}

#
# Display a dialog to make the user select one or more items
# from the list passed in the 1st arg. The list must contain
# elements each being a combination of the item text to display
# and the value to be returned, e.g.:
# GGUI_selectionDialog { { one 1 } { two 2 } { three 3 } }
# It is that complicated, cause the displayed list will be sorted
# and so indices can be returned or whatever ...
# an empty string is returned, if nothing has been selected
#
proc GGUI_selectionDialog { list { title "Selection" } } {
  global tkPriv GVar_sdicSelectionEntry GVar_sdicSelectionList

  set sdic_num_selection_items [ llength $list ]
  set sorted_list [ lsort -command SDIC_compareListElements $list ]
  set GVar_sdicSelectionList $sorted_list
  set tkPriv(sel_marker) -2

  set w .seldialog

  catch { destroy $w }
  toplevel $w -class Dialog
  wm title $w $title
  wm protocol $w WM_DELETE_WINDOW "set tkPriv(sel_marker) -3"
  wm iconname $w $title
#  wm transient $w [ winfo toplevel [ winfo parent $w ] ]
  frame .seldialog.list
  frame .seldialog.sel
  frame .seldialog.cmds
  set scrollb 0
  set height $sdic_num_selection_items
  if { $height > 20 } {
    set height 20
    set scrollb 1
  }
  if { $scrollb } {
    listbox .seldialog.list.listbox -height $height -selectmode multiple -yscrollcommand ".seldialog.list.scrollbar set"
    scrollbar .seldialog.list.scrollbar -command ".seldialog.list.listbox yview"
  } else {
    listbox .seldialog.list.listbox -height $height -selectmode multiple
  }
  button .seldialog.sel.all -text "Select all" -command SDIC_selectAll
  button .seldialog.cmds.cancel -text Cancel -command "set tkPriv(sel_marker) -1"
  button .seldialog.cmds.done -text Done -command "set tkPriv(sel_marker) 0"

  if { $scrollb } {
    pack .seldialog.list.listbox .seldialog.list.scrollbar -side left -fill both
    pack .seldialog.list.listbox -expand 1
  } else {
    pack .seldialog.list.listbox -fill both
    pack .seldialog.list.listbox -expand 1
  }
  foreach elem $sorted_list {
    .seldialog.list.listbox insert end [ lindex $elem 0 ]
  }
  pack .seldialog.sel.all -expand 1
  pack .seldialog.cmds.done .seldialog.cmds.cancel -side left -expand 1
  pack .seldialog.list .seldialog.sel .seldialog.cmds -side top -fill both

  wm withdraw $w
  GGUI_placeToplevel $w True
  update idletasks
  wm deiconify $w 
  set old_focus [focus]
  set old_grab [ grab current $w]
  if {$old_grab != ""} {
        set grab_status [grab status $old_grab]
  }
  grab $w
  tkwait variable tkPriv(sel_marker)

  if {$old_grab != ""} {
    if {$grabStatus == "global"} {
      grab -global $old_grab
    } else {
      grab $old_grab
    }
  }

  set sel $tkPriv(sel_marker)
  set selection ""
  if { $sel >= 0 } {
    set sels [ .seldialog.list.listbox curselection ]
    if { $sels != "" } {
      foreach i "$sels" {
	lappend selection [ lindex [ lindex $sorted_list $i ] 1 ]
      }
    }
  } else {
    set selection -1
  }

  destroy $w

  return $selection
}

#
# internal callback
proc CDIC_isItemInList { item list } {
  set l [ llength $list ]

  for { set i 0 } { $i < $l } { incr i } {
    if { [ lindex [ lindex $list $i ] 0 ] == $item } {
      return $i
    }
  }

  return -1
}

#
# internal callback
proc CDIC_showInsPos { list elem widget } {
  global Conf_listHeight

  set l [ llength $list ]
  set p [ expr ($l + 1) / 2 ]
  set d [ expr ($p + 1) / 2 ]

  while { $d > 0 } {
    if { [ lindex $list $p ] > $elem } {
	set p [ expr $p - $d ]
	if { $p < 0 } {
	  set p 0
	}
    } else {
	set p [ expr $p + $d ]
	if { $p >= $l } {
	  set p [ expr $l - 1]
	}
    }

    if { $d <= 1 } {
	break
    }
    set d [ expr ($d + 1) / 2 ]
  }

  set p [ expr $p - ($Conf_listHeight / 2) ]
  if { $p < 0 } {
    set p 0