aftcllib.tcl

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

################### Start of $RCSfile: aftcllib.tcl,v $ ##################
#
# $Source: /home/alb/afbackup/afbackup-3.3.8.1/RCS/aftcllib.tcl,v $
# $Id: aftcllib.tcl,v 1.2 2004/07/08 20:34:42 alb Exp alb $
# $Date: 2004/07/08 20:34:42 $
# $Author: alb $
#
#
####### description ################################################
#
#
#
####################################################################

set GVar_errorProc GGUI_errorDialog

#
# Post error message to the user, either through
# an open GUI or to the command line
#
proc GIO_errorMessage { msg } {
  global	GVar_errorProc

  eval { $GVar_errorProc $msg }
}

#
# Post error message to stderr of command line
#
proc GIO_errorOutput { message } {
  puts stderr "Error: $message"
}

#
# read contents of a file with name filename (first arg)
# into variable named as 2nd arg. Depent on the mode (default: array)
# store into the variable as:
#
#  mode        explanation
#
#  array       array with indexes starting with 0
#  list        a TCL-list
#  string      as a string with newline characters between the lines
#  words       as string with space characters between lines
#
# number of read lines is stored in variable named in 3rd arg.
# returns != 0 on error
#
proc GFile_readFile { filename linesptr num_linesptr { mode "array" } } {
  upvar $linesptr lines
  upvar $num_linesptr num_lines

  set mode [ string tolower $mode ]

  set errfl [ catch { set fp [ open $filename r ] } ]

  if { $errfl } {
    return 1
  }

  catch { unset lines }
  switch $mode {
    "list" {
      set lines ""
    }
    "string" {
      set lines ""
    }
    "words" {
      set lines ""
    }
  }

  set num_lines 0
  set i 0
  switch $mode {
    "array" {
      while { [ gets $fp lines($i) ] >= 0 } {
	incr i
      }
    }
    "list" {
      while { [ gets $fp line ] >= 0 } {
	lappend lines $line
	incr i
      }
    }
    "string" {
      while { [ gets $fp line ] >= 0 } {
	incr i
	append lines "${line}\n"
      }
    }
    "words" {
      while { [ gets $fp line ] >= 0 } {
	incr i
	if { $lines != "" } {
	  append lines " "
	}
	append lines "${line}"
      }
    }
  }

  close $fp

  set num_lines $i

  return 0
}

#
# write contents of a variable named as 2nd arg into a file
# named in 1st arg. Number of lines is given in 3rd arg. Write
# dependent on the mode (default: array) as:
#
#  mode     explanation
#
#  array    each element of the array starting with index 0
#  list     each element of the list
#  string   simply write 2nd arg to file
#  words    one word in 2nd arg per line
#  
proc GFile_writeFile { filename linesptr num_lines { mode "array" } } {
  upvar $linesptr lines

  set mode [ string tolower $mode ]

  set openfile 1

  if { $filename == "-" || $filename == "--" } {
    set openfile 0
    if { $filename == "-" } {
      set fp stdout
    } else {
      set fp stderr
    }
  }

  if { $openfile } {
    set errfl [ catch { set fp [ open $filename w ] } ]

    if { $errfl } {
      return 1
    }
  }

  switch $mode {
    "array" {
      for { set i 0 } { $i < $num_lines } { incr i } {
	puts $fp $lines($i)
      }
    }
    "list" {
      foreach elem $lines {
	puts $fp $elem
      }
    }
    "string" {
      puts -nonewline $fp $lines
    }
    "words" {
      foreach elem $lines {
	puts $fp $elem
      }
    }
  }

  if { $openfile } {
    close $fp
  }

  return 0
}

#
# Read file named in 1st arg, put each line into another element
# of the resulting TCL-list. When discovered, the include_inst
# serves as include-directive. The file named thereafter will be
# used for further input. Recursions are allowed. The global
# variable Conf_includePath can be supplied as TCL-list. Returns
# lines as TCL-list
#
proc GFile_readFilesAsListRecursive { filename { include_inst "#include" } } {
  global	Conf_includePath env

  set include_inst_last [ expr [ string length $include_inst ] - 1 ]

  set list ""

  set filename [ GFile_findFileInPathVar $filename Conf_includePath ]
  set failed [ catch { set fp [ open $filename r ] } ]
  if { $failed } {
    puts stderr "Warning: cannot open file $filename."
    return ""
  }

  while { [ gets $fp line ] >= 0 } {
    if { [ string range $line 0 $include_inst_last ] == $include_inst } {
      foreach inc_file [ lrange $line 1 end ] {
	set inc_file [ GFile_findFileInPathVar $inc_file Conf_includePath ]
	set inclist [ GFile_readFilesAsListRecursive $inc_file $include_inst ]
	foreach elem $inclist {
	  lappend list $elem
	}
      }
    } else {
      lappend list $line
    }
  }

  close $fp

  return $list
}

#
# Split lines in the array, whose name is supplied as 1st arg, info fields.
# Field separator is space or optional 5th arg. 2nd arg tells the number of
# lines in array arg 1. 3rd arg is name of target two-dimensional array var.
# First index: line number, second index: field number, each index starts
# with 0. 4th arg supplies the number of fields, that should be in each line.
# If number does not fit, an error message is posted. If 6th arg is given,
# error is not posted and line is ignored, if the line matches the regular
# expression in the 6th arg
#
proc GFmCv_linesToFields { linesptr num_lines fieldsptr num_fields { separator " " } { ignore_pattern "" } } {
  upvar $linesptr lines
  upvar $fieldsptr fields

  set seplen [ string length $separator ]

  incr num_fields -1

  for { set i 0 } { $i < $num_lines } { incr i } {
    set actline $lines($i)

    set rest $actline

    for { set j 0 } { $j < $num_fields } { incr j } {
      set idx [ string first $separator $rest ]
      if { $idx < 0 } {
	set txt "Format error in the following line:\n$actline"
	if { $ignore_pattern == "" || ! [ regexp $ignore_pattern $actline ] } {
	  GIO_errorMessage $txt
	}
	set idx 0
      }

      set fields($i,$j) [ string range $rest 0 [ expr $idx - 1 ] ]

      set rest [ string range $rest [ expr $idx + $seplen ] end ]
    }

    set fields($i,$j) $rest
  }
}

proc GFmCv_lineToFieldsVar { line fieldsptr separator { keep_empty_fields 0 } } {
  upvar $fieldsptr fields

  set num 0
  set rest $line
  set idx [ string first $separator $line ]
  set seplen [ string length $separator ]
  if { [ string tolower $keep_empty_fields ] == "false" } {
    set keep_empty_fields 0
  }

  while { $idx >= 0 } {
    set fields($num) [ string range $rest 0 [ expr $idx - 1 ] ]

    if { [ string length [ string trim $fields($num) ] ] != 0 || $keep_empty_fields != 0 } {
      incr num
    }

    set rest [ string range $rest [ expr $idx + $seplen ] end ]
    set idx [ string first $separator $rest ]
  }

  set fields($num) $rest

  if { (($num != 0 || $line != "") && [ string length [ string trim $fields($num) ] ] != 0) || $keep_empty_fields != 0 } {
    incr num
  }

  return $num
}

#
# Convert array named in first arg into TCL-list
# 2nd arg tells number of elements in array, 1st index is 0
#
proc GTyCv_arrayToList { arr num } {
  upvar $arr array

  set list ""
  for { set i 0 } { $i < $num } { incr i } {
    lappend list $array($i)
  }

  return $list
}

#
# Convert TCL-list in first arg into array named in
# 2nd arg. 1st array index is 0
#
proc GTyCv_listToArray { list arr } {
  upvar $arr array

  catch { unset array }

  set i 0
  foreach elem $list {
    set array($i) $elem
    incr i
  }

  return $i
}

#
# Reduce array of lists to array of list elements, whose
# index is given in 3rd arg. Num gives number of elements
# in array starting with 0
#
proc GArr_cutField { arr num idx } {
  upvar $arr array

  for { set i 0 } { $i < $num } { incr i } {
    set array($i) [ lindex $array($i) $idx ]
  }
}

#
# concatenate list elements to a string separating
# the list elements with space characters
#
proc GTyCv_listToString { list } {
  set string ""

  foreach elem $list {
    if { [ string trim $elem ] != "" } {
      if { $string != "" } {
	append string " "
      }
      append string $elem
    }
  }

  return $string
}

#
# concatenate array elements to a string separating
# the elements with space characters. 1st arg names
# the array, 2nd arg gives number of elements in
# array starting with index 0
#
proc GTyCv_arrayToString { arr num } {
  upvar $arr array

  set string ""
  for { set i 0 } { $i < $num } { incr i } {
    if { [ string trim $array($i) ] != "" } {
      if { $string != "" } {
	append string " "
      }
      append string $array($i)
    }
  }

  return $string
}

proc GArr_separateLinesComm { lin com commentstring { leave_comstr 0 } } {
  upvar $lin lines
  upvar $com comments

  if { [ string tolower $leave_comstr ] == "true" } {
    set leave_comstr 1
  }

  if { $leave_comstr == "1" } {
    set comlen 0
  } else {
    set comlen [ string length $commentstring ]
  }

  for { set i 0 } { [ info exists lines($i) ] } { incr i } {
    set idx [ string first $commentstring $lines($i) ]
    if { $idx >= 0 } {
      set comments($i) [ string range $lines($i) [ expr $idx + $comlen ] end ]
      set lines($i) [ string range $lines($i) 0 [ expr $idx - 1 ] ]
    } else {
      set comments($i) ""
    }
  }
}

#
# Checks, if a file is empty or only contains comments.
# Comments must start with optional commentstr and reach
# until end of line
#
proc GFile_fileEmpty { filename { commentstr "" } } {
  set failed [ GFile_readFile $filename lines num_lines ]
  if { $failed } {
    return -1
  }

  if { $commentstr != "" } {
    GArr_separateLinesComm lines comms $commentstr
  }

  if { [ string trim [ GTyCv_arrayToString lines $num_lines ] ] == "" } {
    return 1
  }

  return 0
}

#
# chain together lines in the array named as 1st arg, if
# a trailing backslash character is found. The optional
# commentsign indicates, that a line with this character
# as the first non-blank is a comment and thus ignored
#
proc GFmCv_combBackslLines { linesptr { commentsign "" } } {
  upvar $linesptr lines

  for { set i 0 } { [ info exists lines($i) ] } { incr i } {
    set l [ expr [ string length $lines($i) ] - 1 ]
    set j [ expr $i + 1 ]
    if { [ string index $lines($i) $l ] == "\\" && [ info exists lines($j) ] && [ string index [ string trim $lines($i) ] 0 ] != $commentsign } {
      set lines($i) [ string range $lines($i) 0 [ expr $l - 1 ] ]
      set lines($i) "$lines($i)$lines($j)"
      set m $i
      set n $j
      for { incr m ; incr n } { [ info exists lines($n) ] } { incr m ; incr n } {
	set lines($m) $lines($n)
      }
      unset lines($m)
      incr i -1
    }
  }

  return $i
}

#
# matches a given pattern to existing filesystem entries
# and returns two lists of their basenames (without leading
# paths): One list of directory entries, one of other entries
#
proc GFile_matchPath { path } {
  set allentries "[ glob -nocomplain $path ]"
  set dirs ""
  set files ""
  foreach entry $allentries {
    set entryt [ file tail $entry ]
    if { [ file isdirectory $entry ] } {
      if { $entryt != ".." && $entryt != "." } {
	lappend dirs $entryt
      }
    } else {
      lappend files $entryt
    }
  }

  set e ""
  lappend e $files $dirs
  return $e
}

#
# read the given directory and return two lists of entries:
# One list with subdirectories and one with other entries.
#
proc GFile_readDir { path } {
  if { ! [ file isdirectory $path ] } {
    return ""
  }

  set allentries "[ glob $path/* $path/.* ]"
  set dirs ""
  set files ""
  foreach entry $allentries {
    if { [ file isdirectory $entry ] } {
      if { $entry != ".." && $entry != "." } {
	lappend dirs [ file tail $entry ]
      }
    } else {
      lappend files [ file tail $entry ]
    }
  }

  set e ""
  lappend e $files $dirs
  return $e
}

#
# Merge together n given TCL-lists removing duplicate
# entries
#
proc GList_mergeLists { args } {