aftcllib.tcl

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

  set new_list ""

  foreach list "$args" {
    foreach elem $list {
      if { [ lsearch -exact $new_list $elem ] < 0 } {
	lappend new_list $elem
      }
    }
  }

  return $new_list
}

#
# Replace any occurrence of the 2nd argument in the 1st argument
# with the 3rd argument
#
proc GStr_replSubstring { string to_repl replacement } {
  set new ""
  set repllen [ string length $to_repl ]

  while { $string != "" } {
    set idx [ string first $to_repl $string ]
    if { $idx >= 0 } {
      append new [ string range $string 0 [ expr $idx - 1 ] ]
      append new $replacement
      set string [ string range $string [ expr $idx + $repllen ] end ]
    } else {
      append new $string
      break
    }
  }

  return $new
}

#
# replace backslash sequences of type \n or \t
# with the appropriate ASCII-characters and return
# the result
#
proc GStr_replBackslSeq { string } {
  set new ""

  while { [ set idx [ string first "\\" $string ] ] >= 0 } {
    append new [ string range $string 0 [ expr $idx - 1 ] ]
    set c [ string index $string [ expr $idx + 1 ] ]
    set string [ string range $string [ expr $idx + 2 ] end ]
    if { [ string first $c "tn" ] >= 0 } {
      switch $c {
	"t" {
	  append new "\t"
	}
	"n" {
	  append new "\n"
	}
	"r" {
	  append new "\r"
	}
	"a" {
	  append new "\a"
	}
	"b" {
	  append new "\b"
	}
      }
    } else {
      append new $c
    }
  }

  append new $string

  return $new
}

#
# Remove any garbage from a given path (e.g. //// -> / )
# and return the result
#
proc GFile_cleanPath { path } {
  set newpath ""

  while { $path != $newpath } {
    set newpath $path
    set path [ GStr_replSubstring $path "/./" "/" ]
    while { [ string first "//" $path ] >= 0 } {
      set path [ GStr_replSubstring $path "//" "/" ]
    }
    if { [ string range $path 0 1 ] == "./" } {
      set path [ string range $path 2 end ]
    }
    set l [ string length $path ]
    incr l -1
    if { [ string range $path $l $l ] == "/"  && $l > 0 } {
      set path [ string range $path 0 [ expr $l - 1 ] ]
      incr l -1
    }
    if { [ string range $path [ expr $l -1 ] $l ] == "/." } {
      if { $path == "/." } {
	set path "/"
      } else {
	set path [ string range $path 0 [ expr $l - 1 ] ]
      }
    }
    if { [ string range $path 0 3 ] == "/../" } {
      set path [ string range $path 3 end ]
    }
  }

  return $path
}

#
# Scans the file named in 1st arg and tells, if the
# line matching the regular expression in the 2nd
# argument is not commented out. Then 1 is returned,
# otherwise 0
#
proc GFile_lineActive { filename pattern { commentstr "#" } } {
  set failure [ GFile_readFile $filename lines num_lines list ]
  if { $failure } {
    return -1
  }

  set comlen [ string length $commentstr ]
  set comlast [ expr $comlen - 1 ]

  foreach line $lines {
    if { [ regexp $pattern $line ] } {
      if { [ string range [ string trim $line ] 0 $comlast ] == $commentstr } {
	return 0
      } else {
	return 1
      }
    }
  }

  return -1
}

proc GFile_commentLines { mode filename commentstr args } {
  set failure [ GFile_readFile $filename lines num_lines list ]
  if { $failure } {
    return 1
  }
  set mode [ GStr_replSubstring [ string tolower $mode ] "_" "" ]
  if { [ string range $mode 0 1 ] == "un" } {
    set newmode "de"
    append newmode [ string range $mode 2 end ]
    set mode $newmode
  }
  set comlen [ string length $commentstr ]
  set comlast [ expr $comlen - 1 ]
  set range 0
  set have_first 0
  set have_last 0
  set new_lines ""

  if { $mode == "commentrange" || $mode == "decommentrange" } {
    set first [ lindex $args 0 ]
    set last [ lindex $args 1 ]
    set range 1
  } else {
    set patterns [ lindex $args 0 ]
  }

  foreach line $lines {
    set valid_line 0

    if { $range } {
      if { $have_first } {
	set valid_line 1
	if { $have_last } {
	  set valid_line 0
	} else {
	  if { [ regexp $last $line ] } {
	    set have_last 1
	  }
	}
      } else {
	if { [ regexp $first $line ] } {
	  set valid_line 1
	  set have_first 1
	}
      }
    } else {
      foreach pat $patterns {
	if { [ regexp $pat $line ] } {
	  set valid_line 1
	  break
	}
      }
    }

    if { $valid_line } {
      set comidx [ string first $commentstr $line ]
      if { [ string range [ string trim $line ] 0 $comlast ] == $commentstr } {
	if { $mode == "decommentrange" || $mode == "decommentpatterns" } {
	  set head [ string range $line 0 [ expr $comidx - 1 ] ]
	  set tail [ string range $line [ expr $comidx + $comlen ] end ]
	  set line "$head$tail"
	}
      } else {
        if { $mode == "commentrange" || $mode == "commentpatterns" } {
	  set line "$commentstr$line"
      	}
      }
    }

    lappend new_lines $line
  }

  set failure [ GFile_writeFile $filename new_lines $num_lines list ]
  if { $failure } {
    return 1
  }

  return 0
}

proc GFile_replaceLines { filename patlist substlist } {
  set failed [ GFile_readFile $filename lines num_lines list ]
  if { $failed } {
    return $failed
  }

  set new_list [ GList_replaceElements $lines $patlist $substlist ]

  set failed [ GFile_writeFile $filename new_list [ llength $new_list ] list ]
  if { $failed } {
    return $failed
  }

  return 0
}

proc GList_replaceElements { lines patlist substlist { up_to 0 } } {
  if { $up_to == 1 || [ string tolower $up_to ] == "true" } {
    set up_to 1
  } else {
    set up_to 0
  }
  set first_pat [ lindex $patlist 0 ]
  set last_pat [ lindex $patlist 1 ]
  set have_first 0
  set have_last 0

  set new_list ""

  foreach line $lines {
    if { $have_first } {
      if { $have_last } {
	lappend new_list $line
      } else {
	if { [ regexp $last_pat $line ] } {
	  set have_last 1
	  if { $up_to } {
	    lappend new_list $line
	  }
	}
      }
    } else {
      if { [ regexp $first_pat $line ] } {
	set have_first 1
	foreach subst $substlist {
	  lappend new_list $subst
	}
	if { $last_pat == "" } {
	  set have_last 1
	}
      } else {
	lappend new_list $line
      }
    }
  }

  if { ! $have_first } {
    foreach subst $substlist {
      lappend new_list $subst
    }
  }

  return $new_list
}

proc GList_stanzas { mode lines stanzaname args } {
  set mode [ string tolower $mode ]
  set first_pat ""
  set l [ list {^[ } "\t" {]*\[[ } "\t" {]*} $stanzaname {[ } "\t" {]*\][ } "\t" {]*$} ]
  foreach p $l {
    append first_pat $p
  }
  set last_pat ""
  set l [ list {^[ } "\t" {]*\[[^]]*\][ } "\t" {]*$} ]
  foreach p $l {
    append last_pat $p
  }

  set first_line -1
  set last_line -1
  set stanza ""

  set i 0
  foreach line $lines {
    if { $first_line >= 0 } {
      if { $last_line < 0 } {
	if { [ regexp $last_pat $line ] } {
	  set last_line $i
	} else {
	  if { [ string trim $line ] != "" } {
	    lappend stanza $line
	  }
	}
      }
    } else {
      if { [ regexp $first_pat $line ] } {
	set first_line $i
      }
    }
    incr i
  }
}

#
# Find the file in the path named as 2nd argument. The
# path should be supplied as TCL-list (not colon-separated)
#
proc GFile_findFileInPathVar { file pathl } {
  upvar $pathl pathlist
  global	GVar_foundPathFiles

  if { ! [ info exists pathlist ] } {
    return $file
  }

  if { [ info exists GVar_foundPathFiles($file<$pathl) ] } {
    return $GVar_foundPathFiles($file<$pathl)
  }

  foreach path $pathlist {
    if { [ file readable $path/$file ] } {
      set GVar_foundPathFiles($file<$pathl) $path/$file
      return $path/$file
    }
  }

  return $file
}

#
# Returns the full path to the program given as argument,
# if it were tried to be started with the current PATH
# setting
#
proc GFile_findProgram { program } {
  global	env

  set program [ file tail $program ]

  set path "$env(PATH):/usr/local/bin:/usr/local/gnu:/usr/local/gnu/bin:/usr/local/bin/gnu:/opt/bin:/opt/gnu/bin:/opt/bin/gnu:/usr/bin:/bin:/usr/local/bin/X11:/opt/bin/X11:/opt/X11/bin:/usr/local/X11/bin:/usr/X11R5/bin:/usr/X11X6/bin:/usr/bsd:/usr/ucb:/usr/ccs/bin:/usr/sbin:/usr/etc:/sbin"

  set n [ GFmCv_lineToFieldsVar $path dirs : ]
  set found 0
  for { set i 0 } { $i < $n } { incr i } {
    if { [ file executable "$dirs($i)/$program" ] } {
      set found 1
      break
    }
  }

  if { $found } {
    return "$dirs($i)/$program"
  } else {
    return ""
  }
}

proc GFile_editAssignment { filename varname val mode } {
    set failed [ GFile_readFile $filename lines num_lines ]
    if { $failed } {
	GIO_errorMessage "Cannot read file $filename."
    } else {
	set found 0
	for { set actlineno 0 } { $actlineno < $num_lines } { incr actlineno } {
	  set line [ string trim $lines($actlineno) ]
	  if { [ regexp -indices "^ *$varname *= *" $line indices ] } {
	    set f [ expr [ lindex $indices 1 ] + 1 ]
	    set line [ string range $line $f end ]
	    set rest ""
	    set found 1
	    break
	  }
	}
	if { ! $found } {
	  GIO_errorMessage "Cannot find line, where $varname is set."
	} else {
	  if { [ string index $line 0 ] == "\"" } {
	    set line [ string range $line 1 end ]
	  }
	  set l [ string first "\"" $line ]
	  if { $l >= 0 } {
	    set rest [ string range $line [ expr $l + 1 ] end ]
	    set line [ string range $line 0 [ expr $l - 1 ] ]
	  }
	  if { $mode == "getval" } {
	    return $line
	  }
	  set i [ lsearch -exact $line $val ]
	  set found [ expr $i >= 0 ? 1 : 0 ]
	  if { $mode == "get" } {
	    return $found
	  }
	  set do_write 0
	  if { $found && $mode == "clear" } {
	    set line [ lreplace $line $i $i ]
	    set lines($actlineno) "$varname=\"$line\"$rest"
	    set do_write 1
	  }
	  if { ! $found && $mode == "set" } {
	    lappend line "$val"
	    set lines($actlineno) "$varname=\"$line\"$rest"
	    set do_write 1
	  }
	  if { $mode == "setval" } {
	    set lines($actlineno) "$varname=\"$val\"$rest"
	    set do_write 1
	  }
	  if { $do_write } {
	    set failed [ GFile_writeFile $filename lines $num_lines ]
	    if { $failed } {
		GIO_errorMessage "Unable to write file $lpd_startup_filename."
	    }
	  }
	}
    }
}

#
# host resolution stuff
set failed [ catch { exec ypwhich } ]
if { $failed } {
  set yp 0
} else {
  set yp 1
}

set failed [ catch { set Conf_nisDomain [ exec domainname ] } ]
if $failed {
  set Conf_nisDomain ""
}
set GCon_qualifiedNameRE {[^.]+[.][^.]+}
if { ! [ regexp $GCon_qualifiedNameRE $Conf_nisDomain ] } {
  set Conf_nisDomain ""
}

proc GHost_getHosts { } {
  global	Conf_hostsFilename yp

  if { $yp } {
    set hostsfile "| ypcat hosts"
  } else {
    set hostsfile $Conf_hostsFilename
  }
  set hosts ""
  set failed [ GFile_readFile $hostsfile hlines num_hlines ]
  if { ! $failed } {
    GArr_separateLinesComm hlines c #
    GArr_cutField hlines $num_hlines 1
    set hosts [ GTyCv_arrayToString hlines $num_hlines ]
    set idx [ lsearch -exact $hosts "localhost" ]
    if { $idx >= 0 } {
      set hosts [ lreplace $hosts $idx $idx ]
    }
  }

  return $hosts
}

proc GHost_reduceHostlistLocal { li } {
  upvar $li list
  global	Conf_nisDomain GCon_qualifiedNameRE

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

  while 1 {
    set idx [ lsearch -glob $list *.$Conf_nisDomain ]
    if { $idx < 0 } {
      break
    }

    set host [ lindex $list $idx ]
    set dot [ string first . $host ]
    set host [ string range $host 0 [ expr $dot - 1 ] ]
    set hidx [ lsearch -exact $list $host ]
    if { $hidx >= 0 } {
      set list [ lreplace $list $idx $idx ]
    } else {
      set list [ lreplace $list $idx $idx $host ]
    }
  }
}

proc GHost_expandHostlistLocal { li } {
  upvar $li list
  global	Conf_nisDomain GCon_qualifiedNameRE