You are viewing a plain text version of this content. The canonical link for it is here.
Posted to rivet-dev@tcl.apache.org by da...@apache.org on 2003/08/11 23:01:27 UTC
cvs commit: tcl-rivet/src/buildscripts cmdline.tcl fileutil.tcl typedCmdline.tcl buildscripts.tcl
davidw 2003/08/11 14:01:27
Modified: src make.tcl
src/buildscripts buildscripts.tcl
Added: src/buildscripts cmdline.tcl fileutil.tcl typedCmdline.tcl
Log:
* src/make.tcl: Added fileutils Tcl package to buildscripts, in order
to utilize the 'install' command.
Revision Changes Path
1.46 +9 -10 tcl-rivet/src/make.tcl
Index: make.tcl
===================================================================
RCS file: /home/cvs/tcl-rivet/src/make.tcl,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -r1.45 -r1.46
--- make.tcl 5 Aug 2003 17:00:13 -0000 1.45
+++ make.tcl 11 Aug 2003 21:01:27 -0000 1.46
@@ -46,7 +46,7 @@
set INCLUDEDIR [exec $APXS -q INCLUDEDIR]
set LIBEXECDIR [exec $APXS -q LIBEXECDIR]
-set PREFIX [lindex $auto_path end]
+set PREFIX $TCL_PACKAGE_PATH
set INC "-I$INCLUDEDIR -I$TCL_PREFIX/include"
@@ -228,10 +228,10 @@
depends $MOD_SHLIB $RIVETLIB_SHLIB $PARSER_SHLIB
tcl file delete -force [file join $LIBEXECDIR rivet]
tcl file delete -force [file join $PREFIX rivet]
- tcl file copy -force $MOD_SHLIB $LIBEXECDIR
- tcl file copy -force [file join .. rivet] $PREFIX
- tcl file copy -force $RIVETLIB_SHLIB [file join $PREFIX rivet packages rivet]
- tcl file copy -force $PARSER_SHLIB [file join $PREFIX rivet packages rivet]
+ tcl fileutil::install -m o+r $MOD_SHLIB $LIBEXECDIR
+ tcl fileutil::install -m o+r [file join .. rivet] $PREFIX
+ tcl fileutil::install -m o+r $RIVETLIB_SHLIB [file join $PREFIX rivet packages rivet]
+ tcl fileutil::install -m o+r $PARSER_SHLIB [file join $PREFIX rivet packages rivet]
}
# Install everything when creating a deb. We need to find a better
@@ -242,10 +242,9 @@
AddNode debinstall {
depends $MOD_SHLIB $RIVETLIB_SHLIB $PARSER_SHLIB
tcl {file delete -force [file join $DEBPREFIX/$LIBEXECDIR rivet]}
- tcl {file copy -force $MOD_SHLIB "$DEBPREFIX/$LIBEXECDIR"}
- tcl {file copy -force [file join .. rivet] "$DEBPREFIX/$PREFIX"}
- tcl {file copy -force $RIVETLIB_SHLIB "$DEBPREFIX/[file join $PREFIX rivet packages rivet]"}
- tcl {file copy -force $PARSER_SHLIB "$DEBPREFIX/[file join $PREFIX rivet packages rivet]"}
+ tcl {fileutil::install -m o+r $MOD_SHLIB "$DEBPREFIX/$LIBEXECDIR"}
+ tcl {fileutil::install -m o+r [file join .. rivet] "$DEBPREFIX/$PREFIX"} tcl {fileutil::install -m o+r $RIVETLIB_SHLIB "$DEBPREFIX/[file join $PREFIX rivet packages rivet]"}
+ tcl {fileutil::install -m o+r $PARSER_SHLIB "$DEBPREFIX/[file join $PREFIX rivet packages rivet]"}
}
foreach doc $HTML_DOCS {
1.2 +2 -0 tcl-rivet/src/buildscripts/buildscripts.tcl
Index: buildscripts.tcl
===================================================================
RCS file: /home/cvs/tcl-rivet/src/buildscripts/buildscripts.tcl,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- buildscripts.tcl 23 May 2003 16:41:44 -0000 1.1
+++ buildscripts.tcl 11 Aug 2003 21:01:27 -0000 1.2
@@ -4,6 +4,8 @@
package require aardvark
foreach script {
+ cmdline.tcl
+ fileutil.tcl
helpers.tcl
parsetclConfig.tcl
findapxs.tcl
1.1 tcl-rivet/src/buildscripts/cmdline.tcl
Index: cmdline.tcl
===================================================================
# cmdline.tcl --
#
# This package provides a utility for parsing command line
# arguments that are processed by our various applications.
# It also includes a utility routine to determine the app
# name for use in command line errors.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdline.tcl,v 1.1 2003/08/11 21:01:27 davidw Exp $
package require Tcl 8.2
package provide cmdline 1.2.1
namespace eval ::cmdline {
namespace export getArgv0 getopt getKnownOpt getfiles getoptions \
getKnownOptions usage
}
# Load the typed versions of these functions
source [file join [file dirname [info script]] typedCmdline.tcl]
# ::cmdline::getopt --
#
# The cmdline::getopt works in a fashion like the standard
# C based getopt function. Given an option string and a
# pointer to an array or args this command will process the
# first argument and return info on how to procede.
#
# Arguments:
# argvVar Name of the argv list that you
# want to process. If options are found the
# arg list is modified and the processed arguments
# are removed from the start of the list.
# optstring A list of command options that the application
# will accept. If the option ends in ".arg" the
# getopt routine will use the next argument as
# an argument to the option. Otherwise the option
# is a boolean that is set to 1 if present.
# optVar The variable pointed to by optVar
# contains the option that was found (without the
# leading '-' and without the .arg extension).
# valVar Upon success, the variable pointed to by valVar
# contains the value for the specified option.
# This value comes from the command line for .arg
# options, otherwise the value is 1.
# If getopt fails, the valVar is filled with an
# error message.
#
# Results:
# The getopt function returns 1 if an option was found, 0 if no more
# options were found, and -1 if an error occurred.
proc ::cmdline::getopt {argvVar optstring optVar valVar} {
upvar 1 $argvVar argsList
upvar 1 $optVar option
upvar 1 $valVar value
set result [getKnownOpt argsList $optstring option value]
if {$result < 0} {
# Collapse unknown-option error into any-other-error result.
set result -1
}
return $result
}
# ::cmdline::getKnownOpt --
#
# The cmdline::getKnownOpt works in a fashion like the standard
# C based getopt function. Given an option string and a
# pointer to an array or args this command will process the
# first argument and return info on how to procede.
#
# Arguments:
# argvVar Name of the argv list that you
# want to process. If options are found the
# arg list is modified and the processed arguments
# are removed from the start of the list. Note that
# unknown options and the args that follow them are
# left in this list.
# optstring A list of command options that the application
# will accept. If the option ends in ".arg" the
# getopt routine will use the next argument as
# an argument to the option. Otherwise the option
# is a boolean that is set to 1 if present.
# optVar The variable pointed to by optVar
# contains the option that was found (without the
# leading '-' and without the .arg extension).
# valVar Upon success, the variable pointed to by valVar
# contains the value for the specified option.
# This value comes from the command line for .arg
# options, otherwise the value is 1.
# If getopt fails, the valVar is filled with an
# error message.
#
# Results:
# The getKnownOpt function returns 1 if an option was found,
# 0 if no more options were found, -1 if an unknown option was
# encountered, and -2 if any other error occurred.
proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} {
upvar 1 $argvVar argsList
upvar 1 $optVar option
upvar 1 $valVar value
# default settings for a normal return
set value ""
set option ""
set result 0
# check if we're past the end of the args list
if {[llength $argsList] != 0} {
# if we got -- or an option that doesn't begin with -, return (skipping
# the --). otherwise process the option arg.
switch -glob -- [set arg [lindex $argsList 0]] {
"--" {
set argsList [lrange $argsList 1 end]
}
"-*" {
set option [string range $arg 1 end]
if {[lsearch -exact $optstring $option] != -1} {
# Booleans are set to 1 when present
set value 1
set result 1
set argsList [lrange $argsList 1 end]
} elseif {[lsearch -exact $optstring "$option.arg"] != -1} {
set result 1
set argsList [lrange $argsList 1 end]
if {[llength $argsList] != 0} {
set value [lindex $argsList 0]
set argsList [lrange $argsList 1 end]
} else {
set value "Option \"$option\" requires an argument"
set result -2
}
} else {
# Unknown option.
set value "Illegal option \"$option\""
set result -1
}
}
default {
# Skip ahead
}
}
}
return $result
}
# ::cmdline::getoptions --
#
# Process a set of command line options, filling in defaults
# for those not specified. This also generates an error message
# that lists the allowed flags if an incorrect flag is specified.
#
# Arguments:
# arglistVar The name of the argument list, typically argv.
# We remove all known options and their args from it.
# optlist A list-of-lists where each element specifies an option
# in the form:
# (where flag takes no argument)
# flag comment
#
# (or where flag takes an argument)
# flag default comment
#
# If flag ends in ".arg" then the value is taken from the
# command line. Otherwise it is a boolean and appears in
# the result if present on the command line. If flag ends
# in ".secret", it will not be displayed in the usage.
# usage Text to include in the usage display. Defaults to
# "options:"
#
# Results
# Name value pairs suitable for using with array set.
proc ::cmdline::getoptions {arglistVar optlist {usage options:}} {
upvar 1 $arglistVar argv
set opts [GetOptionDefaults $optlist result]
set argc [llength $argv]
while {[set err [getopt argv $opts opt arg]]} {
if {$err < 0} {
set result(?) ""
break
}
set result($opt) $arg
}
if {[info exist result(?)] || [info exists result(help)]} {
error [usage $optlist $usage]
}
return [array get result]
}
# ::cmdline::getKnownOptions --
#
# Process a set of command line options, filling in defaults
# for those not specified. This ignores unknown flags, but generates
# an error message that lists the correct usage if a known option
# is used incorrectly.
#
# Arguments:
# arglistVar The name of the argument list, typically argv. This
# We remove all known options and their args from it.
# optlist A list-of-lists where each element specifies an option
# in the form:
# flag default comment
# If flag ends in ".arg" then the value is taken from the
# command line. Otherwise it is a boolean and appears in
# the result if present on the command line. If flag ends
# in ".secret", it will not be displayed in the usage.
# usage Text to include in the usage display. Defaults to
# "options:"
#
# Results
# Name value pairs suitable for using with array set.
proc ::cmdline::getKnownOptions {arglistVar optlist {usage options:}} {
upvar 1 $arglistVar argv
set opts [GetOptionDefaults $optlist result]
# As we encounter them, keep the unknown options and their
# arguments in this list. Before we return from this procedure,
# we'll prepend these args to the argList so that the application
# doesn't lose them.
set unknownOptions [list]
set argc [llength $argv]
while {[set err [getKnownOpt argv $opts opt arg]]} {
if {$err == -1} {
# Unknown option.
# Skip over any non-option items that follow it.
# For now, add them to the list of unknownOptions.
lappend unknownOptions [lindex $argv 0]
set argv [lrange $argv 1 end]
while {([llength $argv] != 0) \
&& ![string match "-*" [lindex $argv 0]]} {
lappend unknownOptions [lindex $argv 0]
set argv [lrange $argv 1 end]
}
} elseif {$err == -2} {
set result(?) ""
break
} else {
set result($opt) $arg
}
}
# Before returning, prepend the any unknown args back onto the
# argList so that the application doesn't lose them.
set argv [concat $unknownOptions $argv]
if {[info exist result(?)] || [info exists result(help)]} {
error [usage $optlist $usage]
}
return [array get result]
}
# ::cmdline::GetOptionDefaults --
#
# This internal procdure processes the option list (that was passed to
# the getopt or getKnownOpt procedure). The defaultArray gets an index
# for each option in the option list, the value of which is the option's
# default value.
#
# Arguments:
# optlist A list-of-lists where each element specifies an option
# in the form:
# flag default comment
# If flag ends in ".arg" then the value is taken from the
# command line. Otherwise it is a boolean and appears in
# the result if present on the command line. If flag ends
# in ".secret", it will not be displayed in the usage.
# defaultArrayVar The name of the array in which to put argument defaults.
#
# Results
# Name value pairs suitable for using with array set.
proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} {
upvar 1 $defaultArrayVar result
set opts {? help}
foreach opt $optlist {
set name [lindex $opt 0]
if {[regsub -- .secret$ $name {} name] == 1} {
# Need to hide this from the usage display and getopt
}
lappend opts $name
if {[regsub -- .arg$ $name {} name] == 1} {
# Set defaults for those that take values.
set default [lindex $opt 1]
set result($name) $default
} else {
# The default for booleans is false
set result($name) 0
}
}
return $opts
}
# ::cmdline::usage --
#
# Generate an error message that lists the allowed flags.
#
# Arguments:
# optlist As for cmdline::getoptions
# usage Text to include in the usage display. Defaults to
# "options:"
#
# Results
# A formatted usage message
proc ::cmdline::usage {optlist {usage {options:}}} {
set str "[getArgv0] $usage\n"
foreach opt [concat $optlist \
{{help "Print this message"} {? "Print this message"}}] {
set name [lindex $opt 0]
if {[regsub -- .secret$ $name {} name] == 1} {
# Hidden option
continue
}
if {[regsub -- .arg$ $name {} name] == 1} {
set default [lindex $opt 1]
set comment [lindex $opt 2]
append str [format " %-20s %s <%s>\n" "-$name value" \
$comment $default]
} else {
set comment [lindex $opt 1]
append str [format " %-20s %s\n" "-$name" $comment]
}
}
return $str
}
# ::cmdline::getfiles --
#
# Given a list of file arguments from the command line, compute
# the set of valid files. On windows, file globbing is performed
# on each argument. On Unix, only file existence is tested. If
# a file argument produces no valid files, a warning is optionally
# generated.
#
# This code also uses the full path for each file. If not
# given it prepends [pwd] to the filename. This ensures that
# these files will never comflict with files in our zip file.
#
# Arguments:
# patterns The file patterns specified by the user.
# quiet If this flag is set, no warnings will be generated.
#
# Results:
# Returns the list of files that match the input patterns.
proc ::cmdline::getfiles {patterns quiet} {
set result {}
if {$::tcl_platform(platform) == "windows"} {
foreach pattern $patterns {
set pat [string map {{\\} {\\\\}} $pattern]
set files [glob -nocomplain -- $pat]
if {$files == {}} {
if {! $quiet} {
puts stdout "warning: no files match \"$pattern\""
}
} else {
foreach file $files {
lappend result $file
}
}
}
} else {
set result $patterns
}
set files {}
foreach file $result {
# Make file an absolute path so that we will never conflict
# with files that might be contained in our zip file.
set fullPath [file join [pwd] $file]
if {[file isfile $fullPath]} {
lappend files $fullPath
} elseif {! $quiet} {
puts stdout "warning: no files match \"$file\""
}
}
return $files
}
# ::cmdline::getArgv0 --
#
# This command returns the "sanitized" version of argv0. It will strip
# off the leading path and remove the ".bin" extensions that our apps
# use because they must be wrapped by a shell script.
#
# Arguments:
# None.
#
# Results:
# The application name that can be used in error messages.
proc ::cmdline::getArgv0 {} {
global argv0
set name [file tail $argv0]
return [file rootname $name]
}
1.1 tcl-rivet/src/buildscripts/fileutil.tcl
Index: fileutil.tcl
===================================================================
# fileutil.tcl --
#
# Tcl implementations of standard UNIX utilities.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2002 by Phil Ehrens <ph...@slug.org> (fileType)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fileutil.tcl,v 1.1 2003/08/11 21:01:27 davidw Exp $
package require Tcl 8.2
package require cmdline
package provide fileutil 1.5.1
namespace eval ::fileutil {
namespace export grep find findByPattern cat foreachLine
}
# ::fileutil::grep --
#
# Implementation of grep. Adapted from the Tcler's Wiki.
#
# Arguments:
# pattern pattern to search for.
# files list of files to search; if NULL, uses stdin.
#
# Results:
# results list of matches
proc ::fileutil::grep {pattern {files {}}} {
set result [list]
if {[llength $files] == 0} {
# read from stdin
set lnum 0
while {[gets stdin line] >= 0} {
incr lnum
if {[regexp -- $pattern $line]} {
lappend result "${lnum}:${line}"
}
}
} else {
foreach filename $files {
set file [open $filename r]
set lnum 0
while {[gets $file line] >= 0} {
incr lnum
if {[regexp -- $pattern $line]} {
lappend result "${filename}:${lnum}:${line}"
}
}
close $file
}
}
return $result
}
# ::fileutil::find ==
#
# Two different implementations of this command, one for unix with its
# softlinks, the other for the Win* platform. The trouble with
# softlink is that they can generate circles in the directory and/or
# file structure, leading a simple recursion into infinity. So we
# record device/inode information for each file and directory we touch
# to be able to skip it should we happen to visit it again.
# Note about the general implementation: The tcl interpreter sets a
# tcl stack limit of 1000 levels to prevent infinite recursions from
# running out of bounds. As this command is implemented recursively it
# will fail for very deeply nested directory structures.
if {[string compare unix $tcl_platform(platform)]} {
# Not a unix platform => Original implementation
# Note: This may still fail for directories mounted via SAMBA,
# i.e. coming from a unix server.
# ::fileutil::find --
#
# Implementation of find. Adapted from the Tcler's Wiki.
#
# Arguments:
# basedir directory to start searching from; default is .
# filtercmd command to use to evaluate interest in each file.
# If NULL, all files are interesting.
#
# Results:
# files a list of interesting files.
proc ::fileutil::find {{basedir .} {filtercmd {}}} {
set oldwd [pwd]
cd $basedir
set cwd [pwd]
set filenames [glob -nocomplain * .*]
set files {}
set filt [string length $filtercmd]
# If we don't remove . and .. from the file list, we'll get stuck in
# an infinite loop in an infinite loop in an infinite loop in an inf...
foreach special [list "." ".."] {
set index [lsearch -exact $filenames $special]
set filenames [lreplace $filenames $index $index]
}
foreach filename $filenames {
# Use uplevel to eval the command, not eval, so that variable
# substitutions occur in the right context.
if {!$filt || [uplevel $filtercmd [list $filename]]} {
lappend files [file join $cwd $filename]
}
if {[file isdirectory $filename]} {
set files [concat $files [find $filename $filtercmd]]
}
}
cd $oldwd
return $files
}
} else {
# Unix, record dev/inode to detect and break circles
# ::fileutil::find --
#
# Implementation of find. Adapted from the Tcler's Wiki.
#
# Arguments:
# basedir directory to start searching from; default is .
# filtercmd command to use to evaluate interest in each file.
# If NULL, all files are interesting.
#
# Results:
# files a list of interesting files.
proc ::fileutil::find {{basedir .} {filtercmd {}} {nodeVar {}}} {
if {$nodeVar == {}} {
# Main call, setup the device/inode structure
array set inodes {}
} else {
# Recursive call, import the device/inode record from the caller.
upvar $nodeVar inodes
}
# Instead of getting a directory, we have received one file
# name. Do not do directory operations.
if { [file isfile $basedir] } {
set cwd "" ; # This variable is needed below.
set fileisbasedir 1
set filenames $basedir
} elseif { [file isdirectory $basedir] } {
set fileisbasedir 0
set oldwd [pwd]
cd $basedir
set cwd [pwd]
set filenames [glob -nocomplain * .*]
} else {
error "$basedir does not exist"
}
set files {}
set filt [string length $filtercmd]
# If we don't remove . and .. from the file list, we'll get stuck in
# an infinite loop in an infinite loop in an infinite loop in an inf...
foreach special [list "." ".."] {
set index [lsearch -exact $filenames $special]
set filenames [lreplace $filenames $index $index]
}
foreach filename $filenames {
# Stat each file/directory get exact information about its identity
# (device, inode). Non-'stat'able files are either junk (link to
# non-existing target) or not readable, i.e. inaccessible. In both
# cases it makes sense to ignore them.
if {[catch {file stat [set full [file join $cwd $filename]] stat}]} {
continue
}
# SF [ 647974 ] find has problems recursing a metakit fs ...
#
# The following code is a HACK / workaround. We assume that virtual
# FS's do not suport links, and therefore there is no need for
# keeping track of device/inode information. A good thing as the
# the virtual FS's usually give us bad data for these anyway, as
# illustrated by the bug referenced above.
if {[string equal native [lindex [file system $full] 0]]} {
# No skip over previously recorded files/directories and
# record the new files/directories.
set key "$stat(dev),$stat(ino)"
if {[info exists inodes($key)]} {
continue
}
set inodes($key) 1
}
# Use uplevel to eval the command, not eval, so that variable
# substitutions occur in the right context.
if {!$filt || [uplevel $filtercmd [list $filename]]} {
lappend files $full
}
if {[file isdirectory $filename]} {
set files [concat $files [find $filename $filtercmd inodes]]
}
}
if { ! $fileisbasedir } {
cd $oldwd
}
return $files
}
# end if
}
# ::fileutil::findByPattern --
#
# Specialization of find. Finds files based on their names,
# which have to match the specified patterns. Options are used
# to specify which type of patterns (regexp-, glob-style) is
# used.
#
# Arguments:
# basedir Directory to start searching from.
# args Options (-glob, -regexp, --) followed by a
# list of patterns to search for.
#
# Results:
# files a list of interesting files.
proc ::fileutil::findByPattern {basedir args} {
set pos 0
set cmd ::fileutil::FindGlob
foreach a $args {
incr pos
switch -glob -- $a {
-- {break}
-regexp {set cmd ::fileutil::FindRegexp}
-glob {set cmd ::fileutil::FindGlob}
-* {return -code error "Unknown option $a"}
default {incr pos -1 ; break}
}
}
set args [lrange $args $pos end]
if {[llength $args] != 1} {
set pname [lindex [info level 0] 0]
return -code error \
"wrong#args for \"$pname\", should be\
\"$pname basedir ?-regexp|-glob? ?--? patterns\""
}
set patterns [lindex $args 0]
return [find $basedir [list $cmd $patterns]]
}
# ::fileutil::FindRegexp --
#
# Internal helper. Filter command used by 'findByPattern'
# to match files based on regular expressions.
#
# Arguments:
# patterns List of regular expressions to match against.
# filename Name of the file to match against the patterns.
# Results:
# interesting A boolean flag. Set to true if the file
# matches at least one of the patterns.
proc ::fileutil::FindRegexp {patterns filename} {
foreach p $patterns {
if {[regexp -- $p $filename]} {
return 1
}
}
return 0
}
# ::fileutil::FindGlob --
#
# Internal helper. Filter command used by 'findByPattern'
# to match files based on glob expressions.
#
# Arguments:
# patterns List of glob expressions to match against.
# filename Name of the file to match against the patterns.
# Results:
# interesting A boolean flag. Set to true if the file
# matches at least one of the patterns.
proc ::fileutil::FindGlob {patterns filename} {
foreach p $patterns {
if {[string match $p $filename]} {
return 1
}
}
return 0
}
# ::fileutil::stripPwd --
#
# If the specified path references is a path in [pwd] (or [pwd] itself) it
# is made relative to [pwd]. Otherwise it is left unchanged.
# In the case of [pwd] itself the result is the string '.'.
#
# Arguments:
# path path to modify
#
# Results:
# path The (possibly) modified path.
proc ::fileutil::stripPwd {path} {
# [file split] is used to generate a canonical form for both
# paths, for easy comparison, and also one which is easy to modify
# using list commands.
set pwd [pwd]
if {[string equal $pwd $path]} {
return "."
}
set pwd [file split $pwd]
set npath [file split $path]
if {[string match ${pwd}* $npath]} {
set path [eval file join [lrange $npath [llength $pwd] end]]
}
return $path
}
# ::fileutil::stripN --
#
# Removes N elements from the beginning of the path.
#
# Arguments:
# path path to modify
# n number of elements to strip
#
# Results:
# path The modified path
proc ::fileutil::stripN {path n} {
set path [file split $path]
if {$n >= [llength $path]} {
return {}
} else {
return [eval file join [lrange $path $n end]]
}
}
# ::fileutil::cat --
#
# Tcl implementation of the UNIX "cat" command. Returns the contents
# of the specified file.
#
# Arguments:
# filename name of the file to read.
#
# Results:
# data data read from the file.
proc ::fileutil::cat {filename} {
# Don't bother catching errors, just let them propagate up
set fd [open $filename r]
# Use the [file size] command to get the size, which preallocates memory,
# rather than trying to grow it as the read progresses.
set size [file size $filename]
if {$size} {
set data [read $fd $size]
} else {
# if the file has zero bytes it is either empty, or something
# where [file size] reports 0 but the file actually has data (like
# the files in the /proc filesystem on Linux)
set data [read $fd]
}
close $fd
return $data
}
# ::fileutil::foreachLine --
#
# Executes a script for every line in a file.
#
# Arguments:
# var name of the variable to contain the lines
# filename name of the file to read.
# cmd The script to execute.
#
# Results:
# None.
proc ::fileutil::foreachLine {var filename cmd} {
upvar 1 $var line
set fp [open $filename r]
# -future- Use try/eval from tcllib/control
catch {
set code 0
set result {}
while {[gets $fp line] >= 0} {
set code [catch {uplevel 1 $cmd} result]
if {($code != 0) && ($code != 4)} {break}
}
}
close $fp
if {($code == 0) || ($code == 3) || ($code == 4)} {
return $result
}
if {$code == 1} {
global errorCode errorInfo
return \
-code $code \
-errorcode $errorCode \
-errorinfo $errorInfo \
$result
}
return -code $code $result
}
# ::fileutil::touch --
#
# Tcl implementation of the UNIX "touch" command.
#
# touch [-a] [-m] [-c] [-r ref_file] [-t time] filename ...
#
# Arguments:
# -a change the access time only, unless -m also specified
# -m change the modification time only, unless -a also specified
# -c silently prevent creating a file if it did not previously exist
# -r ref_file use the ref_file's time instead of the current time
# -t time use the specified time instead of the current time
# ("time" is an integer clock value, like [clock seconds])
# filename ... the files to modify
#
# Results
# None.
#
# Errors:
# Both of "-r" and "-t" cannot be specified.
if {[package vsatisfies [package provide Tcl] 8.3]} {
namespace eval ::fileutil { namespace export touch }
proc ::fileutil::touch {args} {
# Don't bother catching errors, just let them propagate up
set options {
{a "set the atime only"}
{m "set the mtime only"}
{c "do not create non-existant files"}
{r.arg "" "use time from ref_file"}
{t.arg -1 "use specified time"}
}
set usage ": [lindex [info level 0] 0]\
\[options] filename ...\noptions:"
array set params [::cmdline::getoptions args $options $usage]
# process -a and -m options
set set_atime [set set_mtime "true"]
if { $params(a) && ! $params(m)} {set set_mtime "false"}
if {! $params(a) && $params(m)} {set set_atime "false"}
# process -r and -t
set has_t [expr {$params(t) != -1}]
set has_r [expr {[string length $params(r)] > 0}]
if {$has_t && $has_r} {
return -code error "Cannot specify both -r and -t"
} elseif {$has_t} {
set atime [set mtime $params(t)]
} elseif {$has_r} {
file stat $params(r) stat
set atime $stat(atime)
set mtime $stat(mtime)
} else {
set atime [set mtime [clock seconds]]
}
# do it
foreach filename $args {
if {! [file exists $filename]} {
if {$params(c)} {continue}
close [open $filename w]
}
if {$set_atime} {file atime $filename $atime}
if {$set_mtime} {file mtime $filename $mtime}
}
return
}
}
# ::fileutil::fileType --
#
# Do some simple heuristics to determine file type.
#
#
# Arguments:
# filename Name of the file to test.
#
# Results
# type Type of the file. May be a list if multiple tests
# are positive (eg, a file could be both a directory
# and a link). In general, the list proceeds from most
# general (eg, binary) to most specific (eg, gif), so
# the full type for a GIF file would be
# "binary graphic gif"
#
# At present, the following types can be detected:
#
# directory
# empty
# binary
# text
# script <interpreter>
# executable elf
# binary graphic [gif, jpeg, png, tiff]
# ps, eps, pdf
# html
# xml <doctype>
# message pgp
# bzip, gzip
# gravity_wave_data_frame
# link
#
proc ::fileutil::fileType {filename} {
;## existence test
if { ! [ file exists $filename ] } {
set err "file not found: '$filename'"
return -code error $err
}
;## directory test
if { [ file isdirectory $filename ] } {
set type directory
if { ! [ catch {file readlink $filename} ] } {
lappend type link
}
return $type
}
;## empty file test
if { ! [ file size $filename ] } {
set type empty
if { ! [ catch {file readlink $filename} ] } {
lappend type link
}
return $type
}
set bin_rx {[\x00-\x08\x0b\x0e-\x1f]}
if { [ catch {
set fid [ open $filename r ]
fconfigure $fid -translation binary
fconfigure $fid -buffersize 1024
fconfigure $fid -buffering full
set test [ read $fid 1024 ]
::close $fid
} err ] } {
catch { ::close $fid }
return -code error "::fileutil::fileType: $err"
}
if { [ regexp $bin_rx $test ] } {
set type binary
set binary 1
} else {
set type text
set binary 0
}
if { [ regexp {^\#\!(\S+)} $test -> terp ] } {
lappend type script $terp
} elseif { $binary && [ regexp {^[\x7F]ELF} $test ] } {
lappend type executable elf
} elseif { $binary && [string match "BZh91AY\&SY*" $test] } {
lappend type compressed bzip
} elseif { $binary && [string match "\x1f\x8b*" $test] } {
lappend type compressed gzip
} elseif { $binary && [string match "GIF*" $test] } {
lappend type graphic gif
} elseif { $binary && [string match "\x89PNG*" $test] } {
lappend type graphic png
} elseif { $binary && [string match "\xFF\xD8\xFF\xE0\x00\x10JFIF*" $test] } {
lappend type graphic jpeg
} elseif { $binary && [string match "MM\x00\**" $test] } {
lappend type graphic tiff
} elseif { $binary && [string match "\%PDF\-*" $test] } {
lappend type pdf
} elseif { ! $binary && [string match -nocase "*\<html\>*" $test] } {
lappend type html
} elseif { [string match "\%\!PS\-*" $test] } {
lappend type ps
if { [string match "* EPSF\-*" $test] } {
lappend type eps
}
} elseif { [string match -nocase "*\<\?xml*" $test] } {
lappend type xml
if { [ regexp -nocase {\<\!DOCTYPE\s+(\S+)} $test -> doctype ] } {
lappend type $doctype
}
} elseif { [string match {*BEGIN PGP MESSAGE*} $test] } {
lappend type message pgp
} elseif { $binary && [string match {IGWD*} $test] } {
lappend type gravity_wave_data_frame
}
;## lastly, is it a link?
if { ! [ catch {file readlink $filename} ] } {
lappend type link
}
return $type
}
# ::fileutil::tempfile --
#
# generate a temporary file name suitable for writing to
# the file name will be unique, writable and will be in the
# appropriate system specific temp directory
# Code taken from http://mini.net/tcl/772 attributed to
# Igor Volobouev and anon.
#
# Arguments:
# prefix - a prefix for the filename, p
# Results:
# returns a file name
#
proc ::fileutil::tempfile {{prefix {}}} {
global tcl_platform
switch $tcl_platform(platform) {
unix {
set tmpdir /tmp; # or even $::env(TMPDIR), at times.
} macintosh {
set tmpdir $env(TRASH_FOLDER) ;# a better place?
} default {
set tmpdir [pwd]
catch {set tmpdir $env(TMP)}
catch {set tmpdir $env(TEMP)}
}
}
set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
set nrand_chars 10
set maxtries 10
set access [list RDWR CREAT EXCL TRUNC]
set permission 0600
set channel ""
set checked_dir_writable 0
set mypid [pid]
for {set i 0} {$i < $maxtries} {incr i} {
set newname $prefix
for {set j 0} {$j < $nrand_chars} {incr j} {
append newname [string index $chars \
[expr {([clock clicks] ^ $mypid) % 62}]]
}
set newname [file join $tmpdir $newname]
if {[file exists $newname]} {
after 1
} else {
if {[catch {open $newname $access $permission} channel]} {
if {!$checked_dir_writable} {
set dirname [file dirname $newname]
if {![file writable $dirname]} {
error "Directory $dirname is not writable"
}
set checked_dir_writable 1
}
} else {
# Success
close $channel
return $newname
}
}
}
if {[string compare $channel ""]} {
return -code error "Failed to open a temporary file: $channel"
} else {
return -code error "Failed to find an unused temporary file name"
}
}
# ::fileutil::install --
#
# Tcl version of the 'install' command, which copies files from
# one places to another and also optionally sets some attributes
# such as group, owner, and permissions.
#
# Arguments:
# -m Change the file permissions to the specified
# value. Valid arguments are those accepted by
# file attributes -permissions
#
# Results:
# None.
# TODO - add options for group/owner manipulation.
proc ::fileutil::install {args} {
set options {
{m.arg "" "Set permission mode"}
}
set usage ": [lindex [info level 0] 0]\
\[options] source destination \noptions:"
array set params [::cmdline::getoptions args $options $usage]
# Args should now just be the source and destination.
if { [llength $args] < 2 } {
error $usage
}
set src [lindex $args 0]
set dst [lindex $args 1]
file copy -force $src $dst
if { $params(m) != "" } {
if { $::tcl_platform(platform) != "unix" } {
error "-m not supported on $::tcl_platform(platform)"
}
set targets [::fileutil::find [file join $dst [file tail $src]]]
foreach fl $targets {
file attributes $fl -permissions $params(m)
}
}
}
1.1 tcl-rivet/src/buildscripts/typedCmdline.tcl
Index: typedCmdline.tcl
===================================================================
# typedCmdline.tcl --
#
# This package provides a utility for parsing typed command
# line arguments that may be processed by various applications.
#
# Copyright (c) 2000 by Ross Palmer Mohn.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: typedCmdline.tcl,v 1.1 2003/08/11 21:01:27 davidw Exp $
namespace eval ::cmdline {
namespace export typedGetopt typedGetoptions typedUsage
# variable cmdline::charclasses --
#
# Create regexp list of allowable character classes
# from "string is" error message.
#
# Results:
# String of character class names separated by "|" characters.
variable charclasses
catch {string is . .} charclasses
regexp -- {must be (.+)$} $charclasses dummy charclasses
regsub -all -- {, (or )?} $charclasses {|} charclasses
}
# ::cmdline::typedGetopt --
#
# The cmdline::typedGetopt works in a fashion like the standard
# C based getopt function. Given an option string and a
# pointer to a list of args this command will process the
# first argument and return info on how to procede. In addition,
# you may specify a type for the argument to each option.
#
# Arguments:
# argvVar Name of the argv list that you want to process.
# If options are found, the arg list is modified
# and the processed arguments are removed from the
# start of the list.
#
# optstring A list of command options that the application
# will accept. If the option ends in ".xxx", where
# xxx is any valid character class to the tcl
# command "string is", then typedGetopt routine will
# use the next argument as a typed argument to the
# option. The argument must match the specified
# character classes (e.g. integer, double, boolean,
# xdigit, etc.). Alternatively, you may specify
# ".arg" for an untyped argument.
#
# optVar Upon success, the variable pointed to by optVar
# contains the option that was found (without the
# leading '-' and without the .xxx extension). If
# typedGetopt fails the variable is set to the empty
# string. SOMETIMES! Different for each -value!
#
# argVar Upon success, the variable pointed to by argVar
# contains the argument for the specified option.
# If typedGetopt fails, the variable is filled with
# an error message.
#
# Argument type syntax:
# Option that takes no argument.
# foo
#
# Option that takes a typeless argument.
# foo.arg
#
# Option that takes a typed argument. Allowable types are all
# valid character classes to the tcl command "string is".
# Currently must be one of alnum, alpha, ascii, control,
# boolean, digit, double, false, graph, integer, lower, print,
# punct, space, true, upper, wordchar, or xdigit.
# foo.double
#
# Option that takes an argument from a list.
# foo.(bar|blat)
#
# Argument quantifier syntax:
# Option that takes an optional argument.
# foo.arg?
#
# Option that takes a list of arguments terminated by "--".
# foo.arg+
#
# Option that takes an optional list of arguments terminated by "--".
# foo.arg*
#
# Argument quantifiers work on all argument types, so, for
# example, the following is a valid option specification.
# foo.(bar|blat|blah)?
#
# Argument syntax miscellany:
# Options may be specified on the command line using a unique,
# shortened version of the option name. Given that program foo
# has an option list of {bar.alpha blah.arg blat.double},
# "foo -b fob" returns an error, but "foo -ba fob"
# successfully returns {bar fob}
#
# Results:
# The typedGetopt function returns one of the following:
# 1 a valid option was found
# 0 no more options found to process
# -1 invalid option
# -2 missing argument to a valid option
# -3 argument to a valid option does not match type
#
# Known Bugs:
# When using options which include special glob characters,
# you must use the exact option. Abbreviating it can cause
# an error in the "cmdline::prefixSearch" procedure.
proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} {
variable charclasses
upvar $argvVar argsList
upvar $optVar retvar
upvar $argVar optarg
# default settings for a normal return
set optarg ""
set retvar ""
set retval 0
# check if we're past the end of the args list
if {[llength $argsList] != 0} {
# if we got -- or an option that doesn't begin with -, return (skipping
# the --). otherwise process the option arg.
switch -glob -- [set arg [lindex $argsList 0]] {
"--" {
set argsList [lrange $argsList 1 end]
}
"-*" {
# Create list of options without their argument extentions
set optstr ""
foreach str $optstring {
lappend optstr [file rootname $str]
}
set _opt [string range $arg 1 end]
set i [prefixSearch $optstr [file rootname $_opt]]
if {$i != -1} {
set opt [lindex $optstring $i]
set quantifier "none"
if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} {
set opt [string range $opt 0 end-1]
}
if {[string first . $opt] == -1} {
set retval 1
set retvar $opt
set argsList [lrange $argsList 1 end]
} elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass]
|| [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
if {[string equal arg $charclass]} {
set type arg
} elseif {[regexp -- "^($charclasses)\$" $charclass]} {
set type class
} else {
set type oneof
}
set argsList [lrange $argsList 1 end]
set opt [file rootname $opt]
while {1} {
if {[llength $argsList] == 0
|| [string equal "--" [lindex $argsList 0]]} {
if {[string equal "--" [lindex $argsList 0]]} {
set argsList [lrange $argsList 1 end]
}
set oneof ""
if {$type == "arg"} {
set charclass an
} elseif {$type == "oneof"} {
set oneof ", one of $charclass"
set charclass an
}
if {$quantifier == "?"} {
set retval 1
set retvar $opt
set optarg ""
} elseif {$quantifier == "+"} {
set retvar $opt
if {[llength $optarg] < 1} {
set retval -2
set optarg "Option requires at least one $charclass argument$oneof -- $opt"
} else {
set retval 1
}
} elseif {$quantifier == "*"} {
set retval 1
set retvar $opt
} else {
set optarg "Option requires $charclass argument$oneof -- $opt"
set retvar $opt
set retval -2
}
set quantifier ""
} elseif {($type == "arg")
|| (($type == "oneof")
&& [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1)
|| (($type == "class")
&& [string is $charclass [lindex $argsList 0]])} {
set retval 1
set retvar $opt
lappend optarg [lindex $argsList 0]
set argsList [lrange $argsList 1 end]
} else {
set oneof ""
if {$type == "arg"} {
set charclass an
} elseif {$type == "oneof"} {
set oneof ", one of $charclass"
set charclass an
}
set optarg "Option requires $charclass argument$oneof -- $opt"
set retvar $opt
set retval -3
if {$quantifier == "?"} {
set retval 1
set optarg ""
}
set quantifier ""
}
if {![regexp -- {[+*]} $quantifier]} {
break;
}
}
} else {
error "Illegal option type specification:\
must be one of $charclasses"
}
} else {
set optarg "Illegal option -- $_opt"
set retvar $_opt
set retval -1
}
}
default {
# Skip ahead
}
}
}
return $retval
}
# ::cmdline::typedGetoptions --
#
# Process a set of command line options, filling in defaults
# for those not specified. This also generates an error message
# that lists the allowed options if an incorrect option is
# specified.
#
# Arguments:
# arglistVar The name of the argument list, typically argv
# optlist A list-of-lists where each element specifies an option
# in the form:
#
# option default comment
#
# Options formatting is as described for the optstring
# argument of typedGetopt. Default is for optionally
# specifying a default value. Comment is for optionally
# specifying a comment for the usage display. The
# options "-help" and "-?" are automatically included
# in optlist.
#
# Argument syntax miscellany:
# Options formatting and syntax is as described in typedGetopt.
# There are two additional suffixes that may be applied when
# passing options to typedGetoptions.
#
# You may add ".multi" as a suffix to any option. For options
# that take an argument, this means that the option may be used
# more than once on the command line and that each additional
# argument will be appended to a list, which is then returned
# to the application.
# foo.double.multi
#
# If a non-argument option is specified as ".multi", it is
# toggled on and off for each time it is used on the command
# line.
# foo.multi
#
# If an option specification does not contain the ".multi"
# suffix, it is not an error to use an option more than once.
# In this case, the behavior for options with arguments is that
# the last argument is the one that will be returned. For
# options that do not take arguments, using them more than once
# has no additional effect.
#
# Options may also be hidden from the usage display by
# appending the suffix ".secret" to any option specification.
# Please note that the ".secret" suffix must be the last suffix,
# after any argument type specification and ".multi" suffix.
# foo.xdigit.multi.secret
#
# Results
# Name value pairs suitable for using with array set.
proc ::cmdline::typedGetoptions {arglistVar optlist {usage options:}} {
variable charclasses
upvar 1 $arglistVar argv
set opts {? help}
foreach opt $optlist {
set name [lindex $opt 0]
if {[regsub -- {\.secret$} $name {} name] == 1} {
# Remove this extension before passing to typedGetopt.
}
if {[regsub -- {\.multi$} $name {} name] == 1} {
# Remove this extension before passing to typedGetopt.
regsub -- {\..*$} $name {} temp
set multi($temp) 1
}
lappend opts $name
if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} {
# Set defaults for those that take values.
# Booleans are set just by being present, or not
set dflt [lindex $opt 1]
if {$dflt != {}} {
set defaults($name) $dflt
}
}
}
set argc [llength $argv]
while {[set err [typedGetopt argv $opts opt arg]]} {
if {$err == 1} {
if {[info exists result($opt)]
&& [info exists multi($opt)]} {
# Toggle boolean options or append new arguments
if {$arg == ""} {
unset result($opt)
} else {
set result($opt) "$result($opt) $arg"
}
} else {
set result($opt) "$arg"
}
} elseif {($err == -1) || ($err == -3)} {
error [typedUsage $optlist $usage]
} elseif {$err == -2 && ![info exists defaults($opt)]} {
error [typedUsage $optlist $usage]
}
}
if {[info exists result(?)] || [info exists result(help)]} {
error [typedUsage $optlist $usage]
}
foreach {opt dflt} [array get defaults] {
if {![info exists result($opt)]} {
set result($opt) $dflt
}
}
return [array get result]
}
# ::cmdline::typedUsage --
#
# Generate an error message that lists the allowed flags,
# type of argument taken (if any), default value (if any),
# and an optional description.
#
# Arguments:
# optlist As for cmdline::typedGetoptions
#
# Results
# A formatted usage message
proc ::cmdline::typedUsage {optlist {usage {options:}}} {
variable charclasses
set str "[getArgv0] $usage\n"
foreach opt [concat $optlist \
{{help "Print this message"} {? "Print this message"}}] {
set name [lindex $opt 0]
if {[regsub -- {\.secret$} $name {} name] == 1} {
# Hidden option
} else {
if {[regsub -- {\.multi$} $name {} name] == 1} {
# Display something about multiple options
}
if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass]
|| [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
regsub -- "\\..+\$" $name {} name
set comment [lindex $opt 2]
set default "<[lindex $opt 1]>"
if {$default == "<>"} {
set default ""
}
append str [format " %-20s %s %s\n" "-$name $charclass" \
$comment $default]
} else {
set comment [lindex $opt 1]
append str [format " %-20s %s\n" "-$name" $comment]
}
}
}
return $str
}
# ::cmdline::prefixSearch --
#
# Search a Tcl list for a pattern; searches first for an exact match,
# and if that fails, for a unique prefix that matches the pattern
# (ie, first "lsearch -exact", then "lsearch -glob $pattern*"
#
# Arguments:
# list list of words
# pattern word to search for
#
# Results:
# Index of found word is returned. If no exact match or
# unique short version is found then -1 is returned.
proc ::cmdline::prefixSearch {list pattern} {
# Check for an exact match
if {[set pos [::lsearch -exact $list $pattern]] > -1} {
return $pos
}
# Check for a unique short version
set slist [lsort $list]
if {[set pos [::lsearch -glob $slist $pattern*]] > -1} {
# What if there is nothting for the check variable?
set check [lindex $slist [expr {$pos + 1}]]
if {[string first $pattern $check] != 0} {
return [::lsearch -exact $list [lindex $slist $pos]]
}
}
return -1
}
---------------------------------------------------------------------
To unsubscribe, e-mail: rivet-cvs-unsubscribe@tcl.apache.org
For additional commands, e-mail: rivet-cvs-help@tcl.apache.org