aftcllib.tcl

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

  if { $Conf_nisDomain == "" } {
    return
  }

  GHost_reduceHostlistLocal list

  foreach elem $list {
    if { ! [ regexp $GCon_qualifiedNameRE $elem ] } {
      lappend list "${elem}.$Conf_nisDomain"
    }
  }
}

#
# Check, if the application with the given name (must be
# the name of the current app) is already running. If yes
# and the flag exit is set (default), the program exits.
# otherwise a dialog is showed telling the user about the
# already running app
#
proc GProc_isAppRunning { name { exit 1 } } {
  set n 0

  set list [ winfo interps ]
  set l [ llength $list ]

  for { set i 0 } { $i < $l } { incr i } {
    if { $name == [ lindex [ lindex $list $i ] 0 ] } {
      incr n
      if { $n >= 2 } {
	if { $exit } {
	  frame .w
	  option add *l.wrapLength 3i widgetDefault
	  label .w.l -justify left -text "The application $name is already running. Before starting a second one of this type, please close the running one first."
	  catch { .w.l configure -font -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-* }
	  button .w.b -text "Ok" -command "exit 1"
	  pack .w.l .w.b -side top
	  GGUI_packAndCenter .w
	  tkwait window .
	  exit 1
	} else {
	  GGUI_warningDialog "The application $name is already running."
	  return
	}
      }
    }
  }
}

#
# source-s the named file. The global variable Conf_libraryPath
# can be set up (TCL-list) as search path for this file
#
proc GFile_loadTclSource { filename } {
  global	GVar_sourcedFiles Conf_libraryPath

  set newfilename [ GFile_findFileInPathVar $filename Conf_libraryPath ]
  if { $newfilename == $filename } {
    set newfilename [ GFile_findFileInPathVar "$filename.tcl" Conf_libraryPath ]
  }

  if { ! [ info exists GVar_sourcedFiles($newfilename) ] } {
    if { ! [ file readable $newfilename ] } {
      return 1
    }

    uplevel #0 source $newfilename
    set GVar_sourcedFiles($newfilename) 1
  }

  return 0
}

#
# If the given file is a symlink, return the path
# with the basename resolved i.e. the symlink been read
#
proc GFile_resolveLink { path } {
  set errfl [ catch { set link [ file readlink $path ] } ]

  if { $errfl } {
    return $path
  }

  set link [ GFile_cleanPath $link ]

  if { [ string range $link 0 0 ] == "/" } {
    return $link
  }

  set d [ file dirname $path ]

  return [ GFile_cleanPath "$d/$link" ]
}

#
# Resolve all occurring symlinks in the given path and
# return a path completely free of symlinks and cleaned
# from any other garbage
#
proc GFile_resolvePath { path } {
  if { $path == "/" || $path == "." } {
    return $path
  }

  set link [ GFile_resolveLink $path ]
  if { $link != $path } {
    set link [ GFile_resolvePath $link ]
    if { $link == "" } {
      return ""
    }
  }

  set p [ GFile_resolvePath [ file dirname $link ] ]
  set t [ file tail $link ]

  if { ! [ file exists "$p/$t" ] } {
    return ""
  }

  return [ GFile_cleanPath "$p/$t" ]
}

#
# Resolve all occurring symlinks in the given path and
# return a path completely free of symlinks and cleaned
# from any other garbage. Furthermore remove upward
# references (e.g. /usr/bin/../lib -> /usr/lib)
#
proc GFile_resolvePath__ { path } {
  set path [ GFile_resolvePath $path ]

  set prefix ""
  while { [ string range $path 0 2 ] == "../" } {
    append prefix "../"
    set path [ string range $path 3 end ]
  }

  set newpath ""
  while { $newpath != $path } {
    set newpath $path

    regsub {[^/]+/[.][.]/} $path "" path
  }

  set newpath ""
  while { $newpath != $path } {
    set newpath $path
    regsub {[^/]+/[.][.]$} $path "" path
    if { $path == "" } {
      set path "."
    }
  }

  append prefix [ GFile_cleanPath $path ]

  return $prefix
}

proc GGUI_getActPos { } {
  global	GVar_actMenuPath GVar_actXPos GVar_actYPos
  global	GVar_parentFrame GVar_menuItems

  if { [ info exists GVar_actMenuPath ] } {
    set achild [ lindex $GVar_menuItems($GVar_actMenuPath) 0 ]
    set failed [ catch { set geom [ wm geometry $GVar_parentFrame($achild) ] } ]
    if { ! $failed } {
      scan $geom "%dx%d%d%d" w h x y
      return "$x $y"
    }
  }
  if { [ info exists GVar_actXPos ] && [ info exists GVar_actYPos ] } {
    return "$GVar_actXPos $GVar_actYPos"
  }

  return ""
}

proc GGUI_insertInMenuTree { name } {
  global	GVar_parentMenus GVar_menuItems

      if { [ string index $name 0 ] == "/" } {
	set names $name
      } else {
	set names ""

	set lname $name
	set rest [ file tail $name ]
	while 1 {
	  if { [ info exists GVar_parentMenus($lname) ] } {
	    foreach m $GVar_parentMenus($lname) {
	      if { $m == "/" } {
		set m ""
	      }
	      if { [ lsearch -exact $names "$m/$rest" ] < 0 } {
		lappend names "$m/$rest"
	      }
	    }
	    break
	  }

	  set idx [ string last / $lname ]
	  if { $idx < 0 } {
	    puts stderr "Warning: Menu item $name not yet known, ignored."
	    set names ""
	    break
	  }

	  set lname [ string range $lname 0 [ expr $idx - 1 ] ]
	  set resthead [ file tail $lname ]
	  set rest "$resthead/$rest"
	}
      }
      foreach name $names {
	while { $name != "/" && $name != "" } {
	  set parent [ file dirname $name ]

	  if { ! [ info exists GVar_menuItems($parent) ] } {
	    set GVar_menuItems($parent) $name
	  } else {
	    if { [ lsearch -exact $GVar_menuItems($parent) $name ] < 0 } {
	      lappend GVar_menuItems($parent) $name
	    } else {
	      break
	    }
	  }

	  if { ! [ info exists GVar_parentMenus($name) ] } {
	    set GVar_parentMenus($name) $parent
	  } else {
	    if { [ lsearch -exact $GVar_parentMenus($name) $parent ] < 0 } {
	      lappend GVar_parentMenus($name) $parent
	    }
	  }
	  set lname [ string range $name 1 end ]
	  while { $lname != "" } {
	    if { ! [ info exists GVar_parentMenus($lname) ] } {
	      set GVar_parentMenus($lname) $parent
	    } else {
	      if { [ lsearch -exact $GVar_parentMenus($lname) $parent ] < 0 } {
		lappend GVar_parentMenus($lname) $parent
	      }
	    }
	    set idx [ string first / $lname ]
	    if { $idx >= 0 } {
	      set lname [ string range $lname [ expr $idx + 1 ] end ]
	    } else { 
	      break
	      set lname ""
	    }
	  }
	  set name $parent
	}
      }

  return $names
}

proc GGUI_insertExistingItemsRecursive { menu itempath } {
  global	GVar_menuItemLabel GVar_menuItemProc
  global	GVar_menuItemFilename GVar_menuItemCondition
  global	GVar_menuLabel GVar_menuTitle GVar_menuItems

  GGUI_insertInMenuTree "$menu"
  foreach vars "GVar_menuItemLabel GVar_menuItemProc GVar_menuItemFilename GVar_menuItemCondition GVar_menuLabel GVar_menuTitle" {
    if { [ info exists "${vars}($itempath)" ] } {
      set "${vars}($menu)" [ set "${vars}($itempath)" ]
    }
  }

  if { [ info exists GVar_menuItems($itempath) ] } {
    foreach menuitem $GVar_menuItems($itempath) {
      set itemname [ file tail $menuitem ]
      GGUI_insertExistingItemsRecursive "$menu/$itemname" "$itempath/$itemname"
    }
  }
}

proc GGUI_readMenuConfiguration { filename { option "" } } {
  global	GVar_parentMenus GVar_menuItems GVar_sourcedFiles
  global	GVar_menuItemLabel GVar_menuItemProc
  global	GVar_menuItemFilename GVar_menuItemCondition
  global	GVar_subframeExists GVar_menuLabel GVar_menuTitle

  set menuitemcmd "menuitem"
  set menuhookcmd "menuhook"
  set itemlabelcmd "itemlabel"
  set itemproccmd "itemproc"
  set conditioncmd "condition"
  set menulabelcmd "menulabel"
  set menutitlecmd "menutitle"
  set validcmds "$menuitemcmd $itemlabelcmd $itemproccmd $conditioncmd $menulabelcmd $menutitlecmd $menuhookcmd"

  set menu_conf [ GFile_readFilesAsListRecursive $filename ]

  if { [ string tolower [ string range $option 0 3 ] ] != "keep" } {
    foreach var { GVar_parentMenus GVar_menuItems GVar_menuItemProc
		GVar_menuItemCondition GVar_menuItemFilename
		GVar_sourcedFiles GVar_menuItemLabel
		GVar_subframeExists } {
      catch { unset $var }
    }
  }

  foreach line $menu_conf {
    set cmd [ string tolower [ lindex $line 0 ] ]

    if { [ lsearch -exact $validcmds $cmd ] >= 0 } {
      set names [ GGUI_insertInMenuTree [ lindex $line 1 ] ]
    }

    switch $cmd \
      "" { } \
      $menuitemcmd { } \
      $itemlabelcmd {
	set itemlabeltype [ string tolower [ lindex $line 2 ] ]
	set label [ lindex $line 3 ]
	foreach name $names {
	  switch $itemlabeltype {
	    "var" {
	      set GVar_menuItemLabel($name) {$}
	    }
	    "string" {
	      set GVar_menuItemLabel($name) {"}
	      set label [ GStr_replBackslSeq $label ]
	    }
	  }
	  append GVar_menuItemLabel($name) $label
	}
      } \
      $itemproccmd {
	set proc [ lindex $line 2 ]
	set file [ lindex $line 3 ]

	foreach name $names {
	  set GVar_menuItemFilename($name) $file
	  set GVar_menuItemProc($name) $proc
	}
      } \
      $conditioncmd {
	set condtype [ string tolower [ lindex $line 2 ] ]
	set condition [ lindex $line 3 ]
	foreach name $names {
	  switch $condtype {
	    "var" {
	      set GVar_menuItemCondition($name) {$}
	    }
	    "expr" {
	      set GVar_menuItemCondition($name) {@}
	    }
	    "file" {
	      set GVar_menuItemCondition($name) {/}
	    }
	  }
	  append GVar_menuItemCondition($name) [ string trim $condition ]
	}
      } \
      $menulabelcmd {
	set menulabeltype [ string tolower [ lindex $line 2 ] ]
	set label [ lindex $line 3 ]
	foreach name $names {
	  switch $menulabeltype {
	    "var" {
	      set GVar_menuLabel($name) {$}
	    }
	    "string" {
	      set GVar_menuLabel($name) {"}
	      set label [ GStr_replBackslSeq $label ]
	    }
	  }
	  append GVar_menuLabel($name) $label
	}
      } \
      $menutitlecmd {
	set menutitletype [ string tolower [ lindex $line 2 ] ]
	set title [ lindex $line 3 ]
	foreach name $names {
	  switch $menutitletype {
	    "var" {
	      set GVar_menuTitle($name) {$}
	    }
	    "string" {
	      set GVar_menuTitle($name) {"}
	      set title [ GStr_replBackslSeq $title ]
	    }
	  }
	  append GVar_menuTitle($name) $title
	}
      } \
      $menuhookcmd {
	set insert_points [ GGUI_insertInMenuTree [ lindex $line 2 ] ]
	foreach name $names {
	  foreach insert_point $insert_points {
	    GGUI_insertExistingItemsRecursive $insert_point $name
	  }
	}
      } \
      default {
	if { [ string index [ string trim $line ] 0 ] != "#" } {
	  puts stderr "Warning: illegal configuration line:\n\"$line\""
	}
      }
    \
  }

  set GVar_parentMenus(/) _
}

proc GGUI_selectionProc { { menu "/" } } {
  global	GVar_parentMenus GVar_menuItems GVar_sourcedFiles
  global	GVar_actMenuPath GVar_menuItemLabel GVar_actWidget
  global	GVar_menuItemProc GVar_menuItemFilename
  global	GVar_menuItemCondition GVar_actMenuPath
  global	GVar_parentFrame Conf_menuXDist Conf_libraryPath
  global	Conf_menuYDist GVar_actXPos GVar_actYPos GVar_subframeExists
  global	GVar_menuTreeDialogShowed GVar_menuLabel GVar_menuTitle

  set top_widget .app

  if { [ info exists GVar_menuItemProc($menu) ] } {
    set proc [ string trim $GVar_menuItemProc($menu) ]
    if { $proc != "" } {
      set can_execute 1
      set program [ lindex $proc 0 ]

      if { [ info proc $program ] == "" && [ info commands $program ] == "" } {
	set filename $GVar_menuItemFilename($menu)
	if { [ GFile_loadTclSource $filename ] } {
	  GIO_errorMessage "Cannot read file \"$filename\" for executing procedure \"$proc\"."
	  set can_execute 0
	}
	if { [ info proc $program ] == "" } {
	  GIO_errorMessage "Cannot find procedure \"$program\" in file \"$filename\"."
	  set can_execute 0
	}
      }

      if { $can_execute } {
	eval $proc
      }
    }
  }


  if { ! [ info exists GVar_menuItems($menu) ] } {
    return
  }

  set parentmenu [ file dirname $menu ]
  if { $menu == "/" } {
    set parentmenu _
  }

  if { [ llength $GVar_parentMenus($menu) ] > 1 } {
    set idx [ lsearch -exact $GVar_parentMenus($menu) $parentmenu ]
    if { $idx < 0 } {
      GIO_errorMessage "Internal error: $parentmenu not in array for $menu."
    } else {
      set GVar_parentMenus($menu) [ linsert [ lreplace $GVar_parentMenus($menu) $idx $idx ] 0 $parentmenu ]
    }
  } else {
    if { $parentmenu != $GVar_parentMenus($menu) } {
      GIO_errorMessage "Internal error: $parentmenu not in array for $menu."
    }
    set parentmenu $GVar_parentMenus($menu)
  }

  set parentmenu [ lindex $GVar_parentMenus($menu) 0 ]
  if { [ info exists GVar_subframeExists($parentmenu) ] } {
    bell
    if { ! [ info exists GVar_menuTreeDialogShowed ] } {
      set GVar_menuTreeDialogShowed 1
      GGUI_genericDialog .info "Information" "For keeping your screen clearly arranged and the system configuration files consistent you are not allowed to open more than one subtree at the same time. Nonetheless you can close a total subtree by pressing Cancel in any dialog. (This message won't be popped up again until exit)" "" 0 Ok
    }
    return
  }

  set GVar_subframeExists($parentmenu) 1

  set widget [ GStr_replSubstring $menu / . ]
  if { $widget == "." } {
    set widget $top_widget
  } else {
    set widget "$top_widget$widget"
  }

  set GVar_actMenuPath $menu
  set GVar_actWidget $widget

  catch { destroy $widget }

  if { $widget == "$top_widget" } {
    frame $widget
    set actparentframe [ winfo parent $widget ]
  } else {
    toplevel $widget
    set actparentframe $widget

    set getpos_failed [ catch { set geometry [ wm geometry $GVar_parentFrame($menu) ] } ]
    if { ! $getpos_failed } {
      scan $geometry "%dx%d%d%d" w h GVar_actXPos GVar_actYPos

      incr GVar_actXPos $Conf_menuXDist
      incr GVar_actYPos $Conf_menuYDist
    }
  }