#!/bin/sh
# Copyright (c) 2006-2011 WorkWare Systems http://www.workware.net.au/
# All rights reserved
# vim:se syntax=tcl:
# \
dir=`dirname "$0"`; exec "`$dir/autosetup-find-tclsh`" "$0" "$@"
# Note that the version has a trailing + on unreleased versions
set autosetup(version) 0.7.0+
# Can be set to 1 to debug early-init problems
set autosetup(debug) [expr {"--debug" in $argv}]
##################################################################
#
# Main flow of control, option handling
#
proc main {argv} {
global autosetup define
# There are 3 potential directories involved:
# 1. The directory containing autosetup (this script)
# 2. The directory containing auto.def
# 3. The current directory
# From this we need to determine:
# a. The path to this script (and related support files)
# b. The path to auto.def
# c. The build directory, where output files are created
# This is also complicated by the fact that autosetup may
# have been run via the configure wrapper ([getenv WRAPPER] is set)
# Here are the rules.
# a. This script is $::argv0
# => dir, prog, exe, libdir
# b. auto.def is in the directory containing the configure wrapper,
# otherwise it is in the current directory.
# => srcdir, autodef
# c. The build directory is the current directory
# => builddir, [pwd]
# 'misc' is needed before we can do anything, so set a temporary libdir
# in case this is the development version
set autosetup(libdir) [file dirname $::argv0]/lib
use misc
# (a)
set autosetup(dir) [realdir [file dirname [realpath $::argv0]]]
set autosetup(prog) [file join $autosetup(dir) [file tail $::argv0]]
set autosetup(exe) [getenv WRAPPER $autosetup(prog)]
if {$autosetup(installed)} {
set autosetup(libdir) $autosetup(dir)
} else {
set autosetup(libdir) [file join $autosetup(dir) lib]
}
autosetup_add_dep $autosetup(prog)
# (b)
if {[getenv WRAPPER ""] eq ""} {
# Invoked directly
set autosetup(srcdir) [pwd]
} else {
# Invoked via the configure wrapper
set autosetup(srcdir) [file-normalize [file dirname $autosetup(exe)]]
}
set autosetup(autodef) [relative-path $autosetup(srcdir)/auto.def]
# (c)
set autosetup(builddir) [pwd]
set autosetup(argv) $argv
set autosetup(cmdline) {}
# options is a list of known options
set autosetup(options) {}
# optset is a dictionary of option values set by the user based on getopt
set autosetup(optset) {}
# optdefault is a dictionary of default values
set autosetup(optdefault) {}
# options-defaults is a dictionary of overrides for default values for options
set autosetup(options-defaults) {}
set autosetup(optionhelp) {}
set autosetup(showhelp) 0
use util
# Parse options
use getopt
# At the is point we don't know what is a valid option
# We simply parse anything that looks like an option
set autosetup(getopt) [getopt argv]
#"=Core Options:"
options-add {
help:=all => "display help and options. Optional: module name, such as --help=system"
licence license => "display the autosetup license"
version => "display the version of autosetup"
ref:=text manual:=text
reference:=text => "display the autosetup command reference. 'text', 'wiki', 'asciidoc' or 'markdown'"
debug => "display debugging output as autosetup runs"
install:=. => "install autosetup to the current or given directory"
}
if {$autosetup(installed)} {
# hidden options so we can produce a nice error
options-add {
sysinstall:path
}
} else {
options-add {
sysinstall:path => "install standalone autosetup to the given directory (e.g.: /usr/local)"
}
}
options-add {
force init:=help => "create initial auto.def, etc. Use --init=help for known types"
# Undocumented options
option-checking=1
nopager
quiet
timing
conf:
}
if {[opt-bool version]} {
puts $autosetup(version)
exit 0
}
# autosetup --conf=alternate-auto.def
if {[opt-str conf o]} {
set autosetup(autodef) $o
}
# Debugging output (set this early)
incr autosetup(debug) [opt-bool debug]
incr autosetup(force) [opt-bool force]
incr autosetup(msg-quiet) [opt-bool quiet]
incr autosetup(msg-timing) [opt-bool timing]
# If the local module exists, source it now to allow for
# project-local customisations
if {[file exists $autosetup(libdir)/local.tcl]} {
use local
}
# Now any auto-load modules
autosetup_load_auto_modules
if {[opt-str help o]} {
incr autosetup(showhelp)
use help
autosetup_help $o
}
if {[opt-bool licence license]} {
use help
autosetup_show_license
exit 0
}
if {[opt-str {manual ref reference} o]} {
use help
autosetup_reference $o
}
# Allow combining --install and --init
set earlyexit 0
if {[opt-str install o]} {
use install
autosetup_install $o
incr earlyexit
}
if {[opt-str init o]} {
use init
autosetup_init $o
incr earlyexit
}
if {$earlyexit} {
exit 0
}
if {[opt-str sysinstall o]} {
use install
autosetup_install $o 1
exit 0
}
if {![file exists $autosetup(autodef)]} {
# Check for invalid option first
options {}
user-error "No auto.def found in \"$autosetup(srcdir)\" (use [file tail $::autosetup(exe)] --init to create one)"
}
# Parse extra arguments into autosetup(cmdline)
foreach arg $argv {
if {[regexp {([^=]*)=(.*)} $arg -> n v]} {
dict set autosetup(cmdline) $n $v
define $n $v
} else {
user-error "Unexpected parameter: $arg"
}
}
autosetup_add_dep $autosetup(autodef)
# Add $argv to CONFIGURE_OPTS, but ignore duplicates and quote if needed
set configure_opts {}
foreach arg $autosetup(argv) {
set quoted [quote-if-needed $arg]
# O(n^2), but n will be small
if {$quoted ni $configure_opts} {
lappend configure_opts $quoted
}
}
define CONFIGURE_OPTS [join $configure_opts]
define AUTOREMAKE [quote-if-needed $autosetup(exe)]
define-append AUTOREMAKE [get-define CONFIGURE_OPTS]
# Log how we were invoked
configlog "Invoked as: [getenv WRAPPER $::argv0] [quote-argv $autosetup(argv)]"
configlog "Tclsh: [info nameofexecutable]"
# Load auto.def as module "auto.def"
autosetup_load_module auto.def source $autosetup(autodef)
# Could warn here if options {} was not specified
show-notices
if {$autosetup(debug)} {
msg-result "Writing all defines to config.log"
configlog "================ defines ======================"
foreach n [lsort [array names define]] {
configlog "define $n $define($n)"
}
}
exit 0
}
# @opt-bool ?-nodefault? option ...
#
# Check each of the named, boolean options and if any have been explicitly enabled
# or disabled by the user, return 1 or 0 accordingly.
#
# If the option was specified more than once, the last value wins.
# e.g. With '--enable-foo --disable-foo', '[opt-bool foo]' will return 0
#
# If no value was specified by the user, returns the default value for the
# first option. If '-nodefault' is given, this behaviour changes and
# -1 is returned instead.
#
proc opt-bool {args} {
set nodefault 0
if {[lindex $args 0] eq "-nodefault"} {
set nodefault 1
set args [lrange $args 1 end]
}
option-check-names {*}$args
foreach opt $args {
if {[dict exists $::autosetup(optset) $opt]} {
return [dict get $::autosetup(optset) $opt]
}
}
if {$nodefault} {
return -1
}
# Default value is the default for the first option
return [dict get $::autosetup(optdefault) [lindex $args 0]]
}
# @opt-val optionlist ?default=""?
#
# Returns a list containing all the values given for the non-boolean options in '$optionlist'.
# There will be one entry in the list for each option given by the user, including if the
# same option was used multiple times.
#
# If no options were set, '$default' is returned (exactly, not as a list).
#
# Note: For most use cases, 'opt-str' should be preferred.
#
proc opt-val {names {default ""}} {
option-check-names {*}$names
foreach opt $names {
if {[dict exists $::autosetup(optset) $opt]} {
lappend result {*}[dict get $::autosetup(optset) $opt]
}
}
if {[info exists result]} {
return $result
}
return $default
}
# @opt-str optionlist varname ?default?
#
# Sets '$varname' in the callers scope to the value for one of the given options.
#
# For the list of options given in '$optionlist', if any value is set for any option,
# the option value is taken to be the *last* value of the last option (in the order given).
#
# If no option was given, and a default was specified with 'options-defaults',
# that value is used.
#
# If no 'options-defaults' value was given and '$default' was given, it is used.
#
# If none of the above provided a value, no value is set.
#
# The return value depends on whether '$default' was specified.
# If it was, the option value is returned.
# If it was not, 1 is returns if a value was set, or 0 if not.
#
# Typical usage is as follows:
#
## if {[opt-str {myopt altname} o]} {
## do something with $o
## }
#
# Or:
## define myname [opt-str {myopt altname} o "/usr/local"]
#
proc opt-str {names varname args} {
global autosetup
option-check-names {*}$names
upvar $varname value
if {[llength $args]} {
# A default was given, so always return the string value of the option
set default [lindex $args 0]
set retopt 1
} else {
# No default, so return 0 or 1 to indicate if a value was found
set retopt 0
}
foreach opt $names {
if {[dict exists $::autosetup(optset) $opt]} {
set result [lindex [dict get $::autosetup(optset) $opt] end]
}
}
if {![info exists result]} {
# No user-specified value. Has options-defaults been set?
foreach opt $names {
if {[dict exists $::autosetup(optdefault) $opt]} {
set result [dict get $autosetup(optdefault) $opt]
}
}
}
if {[info exists result]} {
set value $result
if {$retopt} {
return $value
}
return 1
}
if {$retopt} {
set value $default
return $value
}
return 0
}
proc option-check-names {args} {
foreach o $args {
if {$o ni $::autosetup(options)} {
autosetup-error "Request for undeclared option --$o"
}
}
}
# Parse the option definition in $opts and update
# ::autosetup(setoptions) and ::autosetup(optionhelp) appropriately
#
proc options-add {opts} {
global autosetup
# First weed out comment lines
set realopts {}
foreach line [split $opts \n] {
if {![string match "#*" [string trimleft $line]]} {
append realopts $line \n
}
}
set opts $realopts
for {set i 0} {$i < [llength $opts]} {incr i} {
set opt [lindex $opts $i]
if {[string match =* $opt]} {
# This is a special heading
lappend autosetup(optionhelp) [list $opt $autosetup(module)]
continue
}
unset -nocomplain defaultvalue equal value
#puts "i=$i, opt=$opt"
regexp {^([^:=]*)(:)?(=)?(.*)$} $opt -> name colon equal value
if {$name in $autosetup(options)} {
autosetup-error "Option $name already specified"
}
#puts "$opt => $name $colon $equal $value"
# Find the corresponding value in the user options
# and set the default if necessary
if {[string match "-*" $opt]} {
# This is a documentation-only option, like "-C <dir>"
set opthelp $opt
} elseif {$colon eq ""} {
# Boolean option
lappend autosetup(options) $name
# Check for override
if {[dict exists $autosetup(options-defaults) $name]} {
# A default was specified with options-defaults, so use it
set value [dict get $autosetup(options-defaults) $name]
}
if {$value eq "1"} {
set opthelp "--disable-$name"
} else {
set opthelp "--$name"
}
# Set the default
if {$value eq ""} {
set value 0
}
set defaultvalue $value
dict set autosetup(optdefault) $name $defaultvalue
if {[dict exists $autosetup(getopt) $name]} {
# The option was specified by the user. Look at the last value.
lassign [lindex [dict get $autosetup(getopt) $name] end] type setvalue
if {$type eq "str"} {
# Can we convert the value to a boolean?
if {$setvalue in {1 enabled yes}} {
set setvalue 1
} elseif {$setvalue in {0 disabled no}} {
set setvalue 0
} else {
user-error "Boolean option $name given as --$name=$setvalue"
}
}
dict set autosetup(optset) $name $setvalue
#puts "Found boolean option --$name=$setvalue"
}
} else {
# String option.
lappend autosetup(options) $name
if {$equal ne "="} {
# Was the option given as "name:value=default"?
# If so, set $value to the display name and $defaultvalue to the default
# (This is the preferred way to set a default value for a string option)
if {[regexp {^([^=]+)=(.*)$} $value -> value defaultvalue]} {
dict set autosetup(optdefault) $name $defaultvalue
}
}
# Maybe override the default value
if {[dict exists $autosetup(options-defaults) $name]} {
# A default was specified with options-defaults, so use it
set defaultvalue [dict get $autosetup(options-defaults) $name]
dict set autosetup(optdefault) $name $defaultvalue
} elseif {![info exists defaultvalue]} {
# No default value was given by value=default or options-defaults
# so use the value as the default when the plain option with no
# value is given (.e.g. just --opt instead of --opt=value)
set defaultvalue $value
}
if {$equal eq "="} {
# String option with optional value
set opthelp "--$name?=$value?"
} else {
# String option with required value
set opthelp "--$name=$value"
}
# Get the values specified by the user
if {[dict exists $autosetup(getopt) $name]} {
set listvalue {}
foreach pair [dict get $autosetup(getopt) $name] {
lassign $pair type setvalue
if {$type eq "bool" && $setvalue} {
if {$equal ne "="} {
user-error "Option --$name requires a value"
}
# If given as a boolean, use the default value
set setvalue $defaultvalue
}
lappend listvalue $setvalue
}
#puts "Found string option --$name=$listvalue"
dict set autosetup(optset) $name $listvalue
}
}
# Now create the help for this option if appropriate
if {[lindex $opts $i+1] eq "=>"} {
set desc [lindex $opts $i+2]
if {[info exists defaultvalue]} {
set desc [string map [list @default@ $defaultvalue] $desc]
}
# A multi-line description
lappend autosetup(optionhelp) [list $opthelp $autosetup(module) $desc]
incr i 2
}
}
}
# @module-options optionlist
#
# Deprecated. Simply use 'options' from within a module.
proc module-options {opts} {
options $opts
}
proc max {a b} {
expr {$a > $b ? $a : $b}
}
proc options-wrap-desc {text length firstprefix nextprefix initial} {
set len $initial
set space $firstprefix
foreach word [split $text] {
set word [string trim $word]
if {$word == ""} {
continue
}
if {$len && [string length $space$word] + $len >= $length} {
puts ""
set len 0
set space $nextprefix
}
incr len [string length $space$word]
puts -nonewline $space$word
set space " "
}
if {$len} {
puts ""
}
}
# Display options (from $autosetup(optionhelp)) for modules that match
# glob pattern $what
proc options-show {what} {
set local 0
# Determine the max option width
set max 0
foreach help $::autosetup(optionhelp) {
lassign $help opt module desc
if {![string match $what $module]} {
continue
}
if {[string match =* $opt] || [string match \n* $desc]} {
continue
}
set max [max $max [string length $opt]]
}
set indent [string repeat " " [expr {$max+4}]]
set cols [getenv COLUMNS 80]
catch {
lassign [exec stty size] rows cols
}
incr cols -1
# Now output
foreach help $::autosetup(optionhelp) {
lassign $help opt module desc
if {![string match $what $module]} {
continue
}
if {$local == 0 && $module eq "auto.def"} {
puts "Local Options:"
incr local
}
if {[string match =* $opt]} {
# Output a special heading line"
puts [string range $opt 1 end]
continue
}
puts -nonewline " [format %-${max}s $opt]"
if {[string match \n* $desc]} {
# Output a pre-formatted help description as-is
puts $desc
} else {
options-wrap-desc [string trim $desc] $cols " " $indent [expr {$max+2}]
}
}
}
# @options optionspec
#
# Specifies configuration-time options which may be selected by the user
# and checked with 'opt-str' and 'opt-bool'. '$optionspec' contains a series
# of options specifications separated by newlines, as follows:
#
# A boolean option is of the form:
#
## name[=0|1] => "Description of this boolean option"
#
# The default is 'name=0', meaning that the option is disabled by default.
# If 'name=1' is used to make the option enabled by default, the description should reflect
# that with text like "Disable support for ...".
#
# An argument option (one which takes a parameter) is of one of the following forms:
#
## name:value => "Description of this option"
## name:value=default => "Description of this option with a default value"
## name:=value => "Description of this option with an optional value"
#
# If the 'name:value' form is used, the value must be provided with the option (as '--name=myvalue').
# If the 'name:value=default' form is used, the option has the given default value even if not
# specified by the user.
# If the 'name:=value' form is used, the value is optional and the given value is used
# if it is not provided.
#
# The description may contain '@default@', in which case it will be replaced with the default
# value for the option (taking into account defaults specified with 'options-defaults'.
#
# Undocumented options are also supported by omitting the '=> description'.
# These options are not displayed with '--help' and can be useful for internal options or as aliases.
#
# For example, '--disable-lfs' is an alias for '--disable=largefile':
#
## lfs=1 largefile=1 => "Disable large file support"
#
proc options {optlist} {
global autosetup
options-add $optlist
if {$autosetup(showhelp)} {
# If --help, stop now to show help
return -code break
}
if {$autosetup(module) eq "auto.def"} {
# Check for invalid options
if {[opt-bool option-checking]} {
foreach o [dict keys $::autosetup(getopt)] {
if {$o ni $::autosetup(options)} {
user-error "Unknown option --$o"
}
}
}
}
}
# @options-defaults dictionary
#
# Specifies a dictionary of options and a new default value for each of those options.
# Use before any 'use' statements in 'auto.def' to change the defaults for
# subsequently included modules.
proc options-defaults {dict} {
foreach {n v} $dict {
dict set ::autosetup(options-defaults) $n $v
}
}
proc config_guess {} {
if {[file-isexec $::autosetup(dir)/autosetup-config.guess]} {
if {[catch {exec-with-stderr sh $::autosetup(dir)/autosetup-config.guess} alias]} {
user-error $alias
}
return $alias
} else {
configlog "No autosetup-config.guess, so using uname"
string tolower [exec uname -p]-unknown-[exec uname -s][exec uname -r]
}
}
proc config_sub {alias} {
if {[file-isexec $::autosetup(dir)/autosetup-config.sub]} {
if {[catch {exec-with-stderr sh $::autosetup(dir)/autosetup-config.sub $alias} alias]} {
user-error $alias
}
}
return $alias
}
# @define name ?value=1?
#
# Defines the named variable to the given value.
# These (name, value) pairs represent the results of the configuration check
# and are available to be subsequently checked, modified and substituted.
#
proc define {name {value 1}} {
set ::define($name) $value
#dputs "$name <= $value"
}
# @undefine name
#
# Undefine the named variable.
#
proc undefine {name} {
unset -nocomplain ::define($name)
#dputs "$name <= <undef>"
}
# @define-append name value ...
#
# Appends the given value(s) to the given "defined" variable.
# If the variable is not defined or empty, it is set to '$value'.
# Otherwise the value is appended, separated by a space.
# Any extra values are similarly appended.
# If any value is already contained in the variable (as a substring) it is omitted.
#
proc define-append {name args} {
if {[get-define $name ""] ne ""} {
# Avoid duplicates
foreach arg $args {
if {$arg eq ""} {
continue
}
set found 0
foreach str [split $::define($name) " "] {
if {$str eq $arg} {
incr found
}
}
if {!$found} {
append ::define($name) " " $arg
}
}
} else {
set ::define($name) [join $args]
}
#dputs "$name += [join $args] => $::define($name)"
}
# @get-define name ?default=0?
#
# Returns the current value of the "defined" variable, or '$default'
# if not set.
#
proc get-define {name {default 0}} {
if {[info exists ::define($name)]} {
#dputs "$name => $::define($name)"
return $::define($name)
}
#dputs "$name => $default"
return $default
}
# @is-defined name
#
# Returns 1 if the given variable is defined.
#
proc is-defined {name} {
info exists ::define($name)
}
# @is-define-set name
#
# Returns 1 if the given variable is defined and is set
# to a value other than "" or 0
#
proc is-define-set {name} {
if {[get-define $name] in {0 ""}} {
return 0
}
return 1
}
# @all-defines
#
# Returns a dictionary (name, value list) of all defined variables.
#
# This is suitable for use with 'dict', 'array set' or 'foreach'
# and allows for arbitrary processing of the defined variables.
#
proc all-defines {} {
array get ::define
}
# @get-env name default
#
# If '$name' was specified on the command line, return it.
# Otherwise if '$name' was set in the environment, return it.
# Otherwise return '$default'.
#
proc get-env {name default} {
if {[dict exists $::autosetup(cmdline) $name]} {
return [dict get $::autosetup(cmdline) $name]
}
getenv $name $default
}
# @env-is-set name
#
# Returns 1 if '$name' was specified on the command line or in the environment.
# Note that an empty environment variable is not considered to be set.
#
proc env-is-set {name} {
if {[dict exists $::autosetup(cmdline) $name]} {
return 1
}
if {[getenv $name ""] ne ""} {
return 1
}
return 0
}
# @readfile filename ?default=""?
#
# Return the contents of the file, without the trailing newline.
# If the file doesn't exist or can't be read, returns '$default'.
#
proc readfile {filename {default_value ""}} {
set result $default_value
catch {
set f [open $filename]
set result [read -nonewline $f]
close $f
}
return $result
}
# @writefile filename value
#
# Creates the given file containing '$value'.
# Does not add an extra newline.
#
proc writefile {filename value} {
set f [open $filename w]
puts -nonewline $f $value
close $f
}
proc quote-if-needed {str} {
if {[string match {*[\" ]*} $str]} {
return \"[string map [list \" \\" \\ \\\\] $str]\"
}
return $str
}
proc quote-argv {argv} {
set args {}
foreach arg $argv {
lappend args [quote-if-needed $arg]
}
join $args
}
# @list-non-empty list
#
# Returns a copy of the given list with empty elements removed
proc list-non-empty {list} {
set result {}
foreach p $list {
if {$p ne ""} {
lappend result $p
}
}
return $result
}
# @find-executable-path name
#
# Searches the path for an executable with the given name.
# Note that the name may include some parameters, e.g. 'cc -mbig-endian',
# in which case the parameters are ignored.
# The full path to the executable if found, or "" if not found.
# Returns 1 if found, or 0 if not.
#
proc find-executable-path {name} {
# Ignore any parameters
set name [lindex $name 0]
# The empty string is never a valid executable
if {$name ne ""} {
foreach p [split-path] {
dputs "Looking for $name in $p"
set exec [file join $p $name]
if {[file-isexec $exec]} {
dputs "Found $name -> $exec"
return $exec
}
}
}
return {}
}
# @find-executable name
#
# Searches the path for an executable with the given name.
# Note that the name may include some parameters, e.g. 'cc -mbig-endian',
# in which case the parameters are ignored.
# Returns 1 if found, or 0 if not.
#
proc find-executable {name} {
if {[find-executable-path $name] eq {}} {
return 0
}
return 1
}
# @find-an-executable ?-required? name ...
#
# Given a list of possible executable names,
# searches for one of these on the path.
#
# Returns the name found, or "" if none found.
# If the first parameter is '-required', an error is generated
# if no executable is found.
#
proc find-an-executable {args} {
set required 0
if {[lindex $args 0] eq "-required"} {
set args [lrange $args 1 end]
incr required
}
foreach name $args {
if {[find-executable $name]} {
return $name
}
}
if {$required} {
if {[llength $args] == 1} {
user-error "failed to find: [join $args]"
} else {
user-error "failed to find one of: [join $args]"
}
}
return ""
}
# @configlog msg
#
# Writes the given message to the configuration log, 'config.log'.
#
proc configlog {msg} {
if {![info exists ::autosetup(logfh)]} {
set ::autosetup(logfh) [open config.log w]
}
puts $::autosetup(logfh) $msg
}
# @msg-checking msg
#
# Writes the message with no newline to stdout.
#
proc msg-checking {msg} {
if {$::autosetup(msg-quiet) == 0} {
maybe-show-timestamp
puts -nonewline $msg
set ::autosetup(msg-checking) 1
}
}
# @msg-result msg
#
# Writes the message to stdout.
#
proc msg-result {msg} {
if {$::autosetup(msg-quiet) == 0} {
maybe-show-timestamp
puts $msg
set ::autosetup(msg-checking) 0
show-notices
}
}
# @msg-quiet command ...
#
# 'msg-quiet' evaluates it's arguments as a command with output
# from 'msg-checking' and 'msg-result' suppressed.
#
# This is useful if a check needs to run a subcheck which isn't
# of interest to the user.
proc msg-quiet {args} {
incr ::autosetup(msg-quiet)
set rc [uplevel 1 $args]
incr ::autosetup(msg-quiet) -1
return $rc
}
# Will be overridden by 'use misc'
proc error-stacktrace {msg} {
return $msg
}
proc error-location {msg} {
return $msg
}
##################################################################
#
# Debugging output
#
proc dputs {msg} {
if {$::autosetup(debug)} {
puts $msg
}
}
##################################################################
#
# User and system warnings and errors
#
# Usage errors such as wrong command line options
# @user-error msg
#
# Indicate incorrect usage to the user, including if required components
# or features are not found.
# 'autosetup' exits with a non-zero return code.
#
proc user-error {msg} {
show-notices
puts stderr "Error: $msg"
puts stderr "Try: '[file tail $::autosetup(exe)] --help' for options"
exit 1
}
# @user-notice msg
#
# Output the given message to stderr.
#
proc user-notice {msg} {
lappend ::autosetup(notices) $msg
}
# Incorrect usage in the auto.def file. Identify the location.
proc autosetup-error {msg} {
autosetup-full-error [error-location $msg]
}
# Like autosetup-error, except $msg is the full error message.
proc autosetup-full-error {msg} {
show-notices
puts stderr $msg
exit 1
}
proc show-notices {} {
if {$::autosetup(msg-checking)} {
puts ""
set ::autosetup(msg-checking) 0
}
flush stdout
if {[info exists ::autosetup(notices)]} {
puts stderr [join $::autosetup(notices) \n]
unset ::autosetup(notices)
}
}
proc maybe-show-timestamp {} {
if {$::autosetup(msg-timing) && $::autosetup(msg-checking) == 0} {
puts -nonewline [format {[%6.2f] } [expr {([clock millis] - $::autosetup(start)) % 10000 / 1000.0}]]
}
}
# @autosetup-require-version required
#
# Checks the current version of 'autosetup' against '$required'.
# A fatal error is generated if the current version is less than that required.
#
proc autosetup-require-version {required} {
if {[compare-versions $::autosetup(version) $required] < 0} {
user-error "autosetup version $required is required, but this is $::autosetup(version)"
}
}
proc autosetup_version {} {
return "autosetup v$::autosetup(version)"
}
##################################################################
#
# Directory/path handling
#
proc realdir {dir} {
set oldpwd [pwd]
cd $dir
set pwd [pwd]
cd $oldpwd
return $pwd
}
# Follow symlinks until we get to something which is not a symlink
proc realpath {path} {
while {1} {
if {[catch {
set path [file readlink $path]
}]} {
# Not a link
break
}
}
return $path
}
# Convert absolute path, $path into a path relative
# to the given directory (or the current dir, if not given).
#
proc relative-path {path {pwd {}}} {
set diff 0
set same 0
set newf {}
set prefix {}
set path [file-normalize $path]
if {$pwd eq ""} {
set pwd [pwd]
} else {
set pwd [file-normalize $pwd]
}
if {$path eq $pwd} {
return .
}
# Try to make the filename relative to the current dir
foreach p [split $pwd /] f [split $path /] {
if {$p ne $f} {
incr diff
} elseif {!$diff} {
incr same
}
if {$diff} {
if {$p ne ""} {
# Add .. for sibling or parent dir
lappend prefix ..
}
if {$f ne ""} {
lappend newf $f
}
}
}
if {$same == 1 || [llength $prefix] > 3} {
return $path
}
file join [join $prefix /] [join $newf /]
}
# Add filename as a dependency to rerun autosetup
# The name will be normalised (converted to a full path)
#
proc autosetup_add_dep {filename} {
lappend ::autosetup(deps) [file-normalize $filename]
}
##################################################################
#
# Library module support
#
# @use module ...
#
# Load the given library modules.
# e.g. 'use cc cc-shared'
#
# Note that module 'X' is implemented in either 'autosetup/X.tcl'
# or 'autosetup/X/init.tcl'
#
# The latter form is useful for a complex module which requires additional
# support file. In this form, '$::usedir' is set to the module directory
# when it is loaded.
#
proc use {args} {
global autosetup libmodule modsource
set dirs [list $autosetup(libdir)]
if {[info exists autosetup(srcdir)]} {
lappend dirs $autosetup(srcdir)/autosetup
}
foreach m $args {
if {[info exists libmodule($m)]} {
continue
}
set libmodule($m) 1
if {[info exists modsource(${m}.tcl)]} {
autosetup_load_module $m eval $modsource(${m}.tcl)
} else {
set locs [list ${m}.tcl ${m}/init.tcl]
set found 0
foreach dir $dirs {
foreach loc $locs {
set source $dir/$loc
if {[file exists $source]} {
incr found
break
}
}
if {$found} {
break
}
}
if {$found} {
# For the convenience of the "use" source, point to the directory
# it is being loaded from
set ::usedir [file dirname $source]
autosetup_load_module $m source $source
autosetup_add_dep $source
} else {
autosetup-error "use: No such module: $m"
}
}
}
}
proc autosetup_load_auto_modules {} {
global autosetup modsource
# First load any embedded auto modules
foreach mod [array names modsource *.auto] {
autosetup_load_module $mod eval $modsource($mod)
}
# Now any external auto modules
foreach file [glob -nocomplain $autosetup(libdir)/*.auto $autosetup(libdir)/*/*.auto] {
autosetup_load_module [file tail $file] source $file
}
}
# Load module source in the global scope by executing the given command
proc autosetup_load_module {module args} {
global autosetup
set prev $autosetup(module)
set autosetup(module) $module
if {[catch [list uplevel #0 $args] msg opts] ni {0 2 3}} {
autosetup-full-error [error-dump $msg $opts $::autosetup(debug)]
}
set autosetup(module) $prev
}
# Initial settings
set autosetup(exe) $::argv0
set autosetup(istcl) 1
set autosetup(start) [clock millis]
set autosetup(installed) 0
set autosetup(sysinstall) 0
set autosetup(msg-checking) 0
set autosetup(msg-quiet) 0
set autosetup(inittypes) {}
set autosetup(module) autosetup
# Embedded modules are inserted below here
set autosetup(installed) 1
set autosetup(sysinstall) 0
# ----- @module asciidoc-formatting.tcl -----
set modsource(asciidoc-formatting.tcl) {
# Copyright (c) 2010 WorkWare Systems http://www.workware.net.au/
# All rights reserved
# Module which provides text formatting
# asciidoc format
use formatting
proc para {text} {
regsub -all "\[ \t\n\]+" [string trim $text] " "
}
proc title {text} {
underline [para $text] =
nl
}
proc p {text} {
puts [para $text]
nl
}
proc code {text} {
foreach line [parse_code_block $text] {
puts " $line"
}
nl
}
proc codelines {lines} {
foreach line $lines {
puts " $line"
}
nl
}
proc nl {} {
puts ""
}
proc underline {text char} {
regexp "^(\[ \t\]*)(.*)" $text -> indent words
puts $text
puts $indent[string repeat $char [string length $words]]
}
proc section {text} {
underline "[para $text]" -
nl
}
proc subsection {text} {
underline "$text" ~
nl
}
proc bullet {text} {
puts "* [para $text]"
}
proc indent {text} {
puts " :: "
puts [para $text]
}
proc defn {first args} {
set sep ""
if {$first ne ""} {
puts "${first}::"
} else {
puts " :: "
}
set defn [string trim [join $args \n]]
regsub -all "\n\n" $defn "\n ::\n" defn
puts $defn
}
}
# ----- @module formatting.tcl -----
set modsource(formatting.tcl) {
# Copyright (c) 2010 WorkWare Systems http://www.workware.net.au/
# All rights reserved
# Module which provides common text formatting
# This is designed for documentation which looks like:
# code {...}
# or
# code {
# ...
# ...
# }
# In the second case, we need to work out the indenting
# and strip it from all lines but preserve the remaining indenting.
# Note that all lines need to be indented with the same initial
# spaces/tabs.
#
# Returns a list of lines with the indenting removed.
#
proc parse_code_block {text} {
# If the text begins with newline, take the following text,
# otherwise just return the original
if {![regexp "^\n(.*)" $text -> text]} {
return [list [string trim $text]]
}
# And trip spaces off the end
set text [string trimright $text]
set min 100
# Examine each line to determine the minimum indent
foreach line [split $text \n] {
if {$line eq ""} {
# Ignore empty lines for the indent calculation
continue
}
regexp "^(\[ \t\]*)" $line -> indent
set len [string length $indent]
if {$len < $min} {
set min $len
}
}
# Now make a list of lines with this indent removed
set lines {}
foreach line [split $text \n] {
lappend lines [string range $line $min end]
}
# Return the result
return $lines
}
}
# ----- @module getopt.tcl -----
set modsource(getopt.tcl) {
# Copyright (c) 2006 WorkWare Systems http://www.workware.net.au/
# All rights reserved
# Simple getopt module
# Parse everything out of the argv list which looks like an option
# Everything which doesn't look like an option, or is after --, is left unchanged
# Understands --enable-xxx as a synonym for --xxx to enable the boolean option xxx.
# Understands --disable-xxx to disable the boolean option xxx.
#
# The returned value is a dictionary keyed by option name
# Each value is a list of {type value} ... where type is "bool" or "str".
# The value for a boolean option is 0 or 1. The value of a string option is the value given.
proc getopt {argvname} {
upvar $argvname argv
set nargv {}
set opts {}
for {set i 0} {$i < [llength $argv]} {incr i} {
set arg [lindex $argv $i]
#dputs arg=$arg
if {$arg eq "--"} {
# End of options
incr i
lappend nargv {*}[lrange $argv $i end]
break
}
if {[regexp {^--([^=][^=]+)=(.*)$} $arg -> name value]} {
# --name=value
dict lappend opts $name [list str $value]
} elseif {[regexp {^--(enable-|disable-)?([^=]*)$} $arg -> prefix name]} {
if {$prefix in {enable- ""}} {
set value 1
} else {
set value 0
}
dict lappend opts $name [list bool $value]
} else {
lappend nargv $arg
}
}
#puts "getopt: argv=[join $argv] => [join $nargv]"
#array set getopt $opts
#parray getopt
set argv $nargv
return $opts
}
}
# ----- @module help.tcl -----
set modsource(help.tcl) {
# Copyright (c) 2010 WorkWare Systems http://workware.net.au/
# All rights reserved
# Module which provides usage, help and the command reference
proc autosetup_help {what} {
use_pager
puts "Usage: [file tail $::autosetup(exe)] \[options\] \[settings\]\n"
puts "This is [autosetup_version], a build environment \"autoconfigurator\""
puts "See the documentation online at http://msteveb.github.io/autosetup/\n"
if {$what in {all local}} {
# Need to load auto.def now
if {[file exists $::autosetup(autodef)]} {
# Load auto.def as module "auto.def"
autosetup_load_module auto.def source $::autosetup(autodef)
}
if {$what eq "all"} {
set what *
} else {
set what auto.def
}
} else {
use $what
puts "Options for module $what:"
}
options-show $what
exit 0
}
proc autosetup_show_license {} {
global modsource autosetup
use_pager
if {[info exists modsource(LICENSE)]} {
puts $modsource(LICENSE)
return
}
foreach dir [list $autosetup(libdir) $autosetup(srcdir)] {
set path [file join $dir LICENSE]
if {[file exists $path]} {
puts [readfile $path]
return
}
}
puts "LICENSE not found"
}
# If not already paged and stdout is a tty, pipe the output through the pager
# This is done by reinvoking autosetup with --nopager added
proc use_pager {} {
if {![opt-bool nopager] && [getenv PAGER ""] ne "" && [isatty? stdin] && [isatty? stdout]} {
if {[catch {
exec [info nameofexecutable] $::argv0 --nopager {*}$::argv |& {*}[getenv PAGER] >@stdout <@stdin 2>@stderr
} msg opts] == 1} {
if {[dict get $opts -errorcode] eq "NONE"} {
# an internal/exec error
puts stderr $msg
exit 1
}
}
exit 0
}
}
# Outputs the autosetup references in one of several formats
proc autosetup_reference {{type text}} {
use_pager
switch -glob -- $type {
wiki {use wiki-formatting}
ascii* {use asciidoc-formatting}
md - markdown {use markdown-formatting}
default {use text-formatting}
}
title "[autosetup_version] -- Command Reference"
section {Introduction}
p {
See http://msteveb.github.com/autosetup/ for the online documentation for 'autosetup'
}
p {
'autosetup' provides a number of built-in commands which
are documented below. These may be used from 'auto.def' to test
for features, define variables, create files from templates and
other similar actions.
}
automf_command_reference
exit 0
}
proc autosetup_output_block {type lines} {
if {[llength $lines]} {
switch $type {
section {
section $lines
}
subsection {
subsection $lines
}
code {
codelines $lines
}
p {
p [join $lines]
}
list {
foreach line $lines {
bullet $line
}
nl
}
}
}
}
# Generate a command reference from inline documentation
proc automf_command_reference {} {
lappend files $::autosetup(prog)
lappend files {*}[lsort [glob -nocomplain $::autosetup(libdir)/*.tcl]]
# We want to process all non-module files before module files
# and then modules in alphabetical order.
# So examine all files and extract docs into doc($modulename) and doc(_core_)
#
# Each entry is a list of {type data} where $type is one of: section, subsection, code, list, p
# and $data is a string for section, subsection or a list of text lines for other types.
# XXX: Should commands be in alphabetical order too? Currently they are in file order.
set doc(_core_) {}
lappend doc(_core_) [list section "Core Commands"]
foreach file $files {
set modulename [file rootname [file tail $file]]
set current _core_
set f [open $file]
while {![eof $f]} {
set line [gets $f]
# Find embedded module names
if {[regexp {^#.*@module ([^ ]*)} $line -> modulename]} {
continue
}
# Find lines starting with "# @*" and continuing through the remaining comment lines
if {![regexp {^# @(.*)} $line -> cmd]} {
continue
}
# Synopsis or command?
if {$cmd eq "synopsis:"} {
set current $modulename
lappend doc($current) [list section "Module: $modulename"]
} else {
lappend doc($current) [list subsection $cmd]
}
set lines {}
set type p
# Now the description
while {![eof $f]} {
set line [gets $f]
if {![regexp {^#(#)? ?(.*)} $line -> hash cmd]} {
break
}
if {$hash eq "#"} {
set t code
} elseif {[regexp {^- (.*)} $cmd -> cmd]} {
set t list
} else {
set t p
}
#puts "hash=$hash, oldhash=$oldhash, lines=[llength $lines], cmd=$cmd"
if {$t ne $type || $cmd eq ""} {
# Finish the current block
lappend doc($current) [list $type $lines]
set lines {}
set type $t
}
if {$cmd ne ""} {
lappend lines $cmd
}
}
lappend doc($current) [list $type $lines]
}
close $f
}
# Now format and output the results
# _core_ will sort first
foreach module [lsort [array names doc]] {
foreach item $doc($module) {
autosetup_output_block {*}$item
}
}
}
}
# ----- @module init.tcl -----
set modsource(init.tcl) {
# Copyright (c) 2010 WorkWare Systems http://www.workware.net.au/
# All rights reserved
# Module to help create auto.def and configure
proc autosetup_init {type} {
set help 0
if {$type in {? help}} {
incr help
} elseif {![dict exists $::autosetup(inittypes) $type]} {
puts "Unknown type, --init=$type"
incr help
}
if {$help} {
puts "Use one of the following types (e.g. --init=make)\n"
foreach type [lsort [dict keys $::autosetup(inittypes)]] {
lassign [dict get $::autosetup(inittypes) $type] desc
# XXX: Use the options-show code to wrap the description
puts [format "%-10s %s" $type $desc]
}
return
}
lassign [dict get $::autosetup(inittypes) $type] desc script
puts "Initialising $type: $desc\n"
# All initialisations happens in the top level srcdir
cd $::autosetup(srcdir)
uplevel #0 $script
}
proc autosetup_add_init_type {type desc script} {
dict set ::autosetup(inittypes) $type [list $desc $script]
}
# This is for in creating build-system init scripts
#
# If the file doesn't exist, create it containing $contents
# If the file does exist, only overwrite if --force is specified.
#
proc autosetup_check_create {filename contents} {
if {[file exists $filename]} {
if {!$::autosetup(force)} {
puts "I see $filename already exists."
return
} else {
puts "I will overwrite the existing $filename because you used --force."
}
} else {
puts "I don't see $filename, so I will create it."
}
writefile $filename $contents
}
}
# ----- @module install.tcl -----
set modsource(install.tcl) {
# Copyright (c) 2006-2010 WorkWare Systems http://www.workware.net.au/
# All rights reserved
# Module which can install autosetup
# autosetup(installed)=1 means that autosetup is not running from source
# autosetup(sysinstall)=1 means that autosetup is running from a sysinstall version
# shared=1 means that we are trying to do a sysinstall. This is only possible from the development source.
proc autosetup_install {dir {shared 0}} {
global autosetup
if {$shared} {
if {$autosetup(installed) || $autosetup(sysinstall)} {
user-error "Can only --sysinstall from development sources"
}
} elseif {$autosetup(installed) && !$autosetup(sysinstall)} {
user-error "Can't --install from project install"
}
if {$autosetup(sysinstall)} {
# This is the sysinstall version, so install just uses references
cd $dir
puts "[autosetup_version] creating configure to use system-installed autosetup"
autosetup_create_configure 1
puts "Creating autosetup/README.autosetup"
file mkdir autosetup
autosetup_install_readme autosetup/README.autosetup 1
return
}
if {[catch {
if {$shared} {
set target $dir/bin/autosetup
set installedas $target
} else {
if {$dir eq "."} {
set installedas autosetup
} else {
set installedas $dir/autosetup
}
cd $dir
file mkdir autosetup
set target autosetup/autosetup
}
set targetdir [file dirname $target]
file mkdir $targetdir
set f [open $target w]
set publicmodules {}
# First the main script, but only up until "CUT HERE"
set in [open $autosetup(dir)/autosetup]
while {[gets $in buf] >= 0} {
if {$buf ne "##-- CUT HERE --##"} {
puts $f $buf
continue
}
# Insert the static modules here
# i.e. those which don't contain @synopsis:
# All modules are inserted if $shared is set
puts $f "set autosetup(installed) 1"
puts $f "set autosetup(sysinstall) $shared"
foreach file [lsort [glob $autosetup(libdir)/*.{tcl,auto}]] {
set modname [file tail $file]
set ext [file ext $modname]
set buf [readfile $file]
if {!$shared} {
if {$ext eq ".auto" || [string match "*\n# @synopsis:*" $buf]} {
lappend publicmodules $file
continue
}
}
dputs "install: importing lib/[file tail $file]"
puts $f "# ----- @module $modname -----"
puts $f "\nset modsource($modname) \{"
puts $f $buf
puts $f "\}\n"
}
if {$shared} {
foreach {srcname destname} [list $autosetup(libdir)/README.autosetup-lib README.autosetup \
$autosetup(srcdir)/LICENSE LICENSE] {
dputs "install: importing $srcname as $destname"
puts $f "\nset modsource($destname) \\\n[list [readfile $srcname]\n]\n"
}
}
}
close $in
close $f
catch {exec chmod 755 $target}
set installfiles {autosetup-config.guess autosetup-config.sub autosetup-test-tclsh}
set removefiles {}
if {!$shared} {
autosetup_install_readme $targetdir/README.autosetup 0
# Install public modules
foreach file $publicmodules {
set tail [file tail $file]
autosetup_install_file $file $targetdir/$tail
}
lappend installfiles jimsh0.c autosetup-find-tclsh LICENSE
lappend removefiles config.guess config.sub test-tclsh find-tclsh
} else {
lappend installfiles {sys-find-tclsh autosetup-find-tclsh}
}
# Install support files
foreach fileinfo $installfiles {
if {[llength $fileinfo] == 2} {
lassign $fileinfo source dest
} else {
lassign $fileinfo source
set dest $source
}
autosetup_install_file $autosetup(dir)/$source $targetdir/$dest
}
# Remove obsolete files
foreach file $removefiles {
if {[file exists $targetdir/$file]} {
file delete $targetdir/$file
}
}
} error]} {
user-error "Failed to install autosetup: $error"
}
if {$shared} {
set type "system"
} else {
set type "local"
}
puts "Installed $type [autosetup_version] to $installedas"
if {!$shared} {
# Now create 'configure' if necessary
autosetup_create_configure 0
}
}
proc autosetup_create_configure {shared} {
if {[file exists configure]} {
if {!$::autosetup(force)} {
# Could this be an autosetup configure?
if {![string match "*\nWRAPPER=*" [readfile configure]]} {
puts "I see configure, but not created by autosetup, so I won't overwrite it."
puts "Remove it or use --force to overwrite."
return
}
} else {
puts "I will overwrite the existing configure because you used --force."
}
} else {
puts "I don't see configure, so I will create it."
}
if {$shared} {
writefile configure \
{#!/bin/sh
WRAPPER="$0"; export WRAPPER; "autosetup" "$@"
}
} else {
writefile configure \
{#!/bin/sh
dir="`dirname "$0"`/autosetup"
WRAPPER="$0"; export WRAPPER; exec "`"$dir/autosetup-find-tclsh"`" "$dir/autosetup" "$@"
}
}
catch {exec chmod 755 configure}
}
# Append the contents of $file to filehandle $f
proc autosetup_install_append {f file} {
dputs "install: include $file"
set in [open $file]
puts $f [read $in]
close $in
}
proc autosetup_install_file {source target} {
dputs "install: $source => $target"
if {![file exists $source]} {
error "Missing installation file '$source'"
}
writefile $target [readfile $source]\n
# If possible, copy the file mode
file stat $source stat
set mode [format %o [expr {$stat(mode) & 0x1ff}]]
catch {exec chmod $mode $target}
}
proc autosetup_install_readme {target sysinstall} {
set readme "README.autosetup created by [autosetup_version]\n\n"
if {$sysinstall} {
append readme \
{This is the autosetup directory for a system install of autosetup.
Loadable modules can be added here.
}
} else {
append readme \
{This is the autosetup directory for a local install of autosetup.
It contains autosetup, support files and loadable modules.
}
}
append readme {
*.tcl files in this directory are optional modules which
can be loaded with the 'use' directive.
*.auto files in this directory are auto-loaded.
For more information, see http://msteveb.github.io/autosetup/
}
dputs "install: autosetup/README.autosetup"
writefile $target $readme
}
}
# ----- @module markdown-formatting.tcl -----
set modsource(markdown-formatting.tcl) {
# Copyright (c) 2010 WorkWare Systems http://www.workware.net.au/
# All rights reserved
# Module which provides text formatting
# markdown format (kramdown syntax)
use formatting
proc para {text} {
regsub -all "\[ \t\n\]+" [string trim $text] " " text
regsub -all {([^a-zA-Z])'([^']*)'} $text {\1**`\2`**} text
regsub -all {^'([^']*)'} $text {**`\1`**} text
regsub -all {(http[^ \t\n]*)} $text {[\1](\1)} text
return $text
}
proc title {text} {
underline [para $text] =
nl
}
proc p {text} {
puts [para $text]
nl
}
proc codelines {lines} {
puts "~~~~~~~~~~~~"
foreach line $lines {
puts $line
}
puts "~~~~~~~~~~~~"
nl
}
proc code {text} {
puts "~~~~~~~~~~~~"
foreach line [parse_code_block $text] {
puts $line
}
puts "~~~~~~~~~~~~"
nl
}
proc nl {} {
puts ""
}
proc underline {text char} {
regexp "^(\[ \t\]*)(.*)" $text -> indent words
puts $text
puts $indent[string repeat $char [string length $words]]
}
proc section {text} {
underline "[para $text]" -
nl
}
proc subsection {text} {
puts "### `$text`"
nl
}
proc bullet {text} {
puts "* [para $text]"
}
proc defn {first args} {
puts "^"
set defn [string trim [join $args \n]]
if {$first ne ""} {
puts "**${first}**"
puts -nonewline ": "
regsub -all "\n\n" $defn "\n: " defn
}
puts "$defn"
}
}
# ----- @module misc.tcl -----
set modsource(misc.tcl) {
# Copyright (c) 2007-2010 WorkWare Systems http://www.workware.net.au/
# All rights reserved
# Module containing misc procs useful to modules
# Largely for platform compatibility
set autosetup(istcl) [info exists ::tcl_library]
set autosetup(iswin) [string equal windows $tcl_platform(platform)]
if {$autosetup(iswin)} {
# mingw/windows separates $PATH with semicolons
# and doesn't have an executable bit
proc split-path {} {
split [getenv PATH .] {;}
}
proc file-isexec {exec} {
# Basic test for windows. We ignore .bat
if {[file isfile $exec] || [file isfile $exec.exe]} {
return 1
}
return 0
}
} else {
# unix separates $PATH with colons and has and executable bit
proc split-path {} {
split [getenv PATH .] :
}
proc file-isexec {exec} {
file executable $exec
}
}
# Assume that exec can return stdout and stderr
proc exec-with-stderr {args} {
exec {*}$args 2>@1
}
if {$autosetup(istcl)} {
# Tcl doesn't have the env command
proc getenv {name args} {
if {[info exists ::env($name)]} {
return $::env($name)
}
if {[llength $args]} {
return [lindex $args 0]
}
return -code error "environment variable \"$name\" does not exist"
}
proc isatty? {channel} {
dict exists [fconfigure $channel] -xchar
}
} else {
if {$autosetup(iswin)} {
# On Windows, backslash convert all environment variables
# (Assume that Tcl does this for us)
proc getenv {name args} {
string map {\\ /} [env $name {*}$args]
}
} else {
# Jim on unix is simple
alias getenv env
}
proc isatty? {channel} {
set tty 0
catch {
# isatty is a recent addition to Jim Tcl
set tty [$channel isatty]
}
return $tty
}
}
# In case 'file normalize' doesn't exist
#
proc file-normalize {path} {
if {[catch {file normalize $path} result]} {
if {$path eq ""} {
return ""
}
set oldpwd [pwd]
if {[file isdir $path]} {
cd $path
set result [pwd]
} else {
cd [file dirname $path]
set result [file join [pwd] [file tail $path]]
}
cd $oldpwd
}
return $result
}
# If everything is working properly, the only errors which occur
# should be generated in user code (e.g. auto.def).
# By default, we only want to show the error location in user code.
# We use [info frame] to achieve this, but it works differently on Tcl and Jim.
#
# This is designed to be called for incorrect usage in auto.def, via autosetup-error
#
proc error-location {msg} {
if {$::autosetup(debug)} {
return -code error $msg
}
# Search back through the stack trace for the first error in a .def file
for {set i 1} {$i < [info level]} {incr i} {
if {$::autosetup(istcl)} {
array set info [info frame -$i]
} else {
lassign [info frame -$i] info(caller) info(file) info(line)
}
if {[string match *.def $info(file)]} {
return "[relative-path $info(file)]:$info(line): Error: $msg"
}
#puts "Skipping $info(file):$info(line)"
}
return $msg
}
# If everything is working properly, the only errors which occur
# should be generated in user code (e.g. auto.def).
# By default, we only want to show the error location in user code.
# We use [info frame] to achieve this, but it works differently on Tcl and Jim.
#
# This is designed to be called for incorrect usage in auto.def, via autosetup-error
#
proc error-stacktrace {msg} {
if {$::autosetup(debug)} {
return -code error $msg
}
# Search back through the stack trace for the first error in a .def file
for {set i 1} {$i < [info level]} {incr i} {
if {$::autosetup(istcl)} {
array set info [info frame -$i]
} else {
lassign [info frame -$i] info(caller) info(file) info(line)
}
if {[string match *.def $info(file)]} {
return "[relative-path $info(file)]:$info(line): Error: $msg"
}
#puts "Skipping $info(file):$info(line)"
}
return $msg
}
# Given the return from [catch {...} msg opts], returns an appropriate
# error message. A nice one for Jim and a less-nice one for Tcl.
# If 'fulltrace' is set, a full stack trace is provided.
# Otherwise a simple message is provided.
#
# This is designed for developer errors, e.g. in module code or auto.def code
#
#
proc error-dump {msg opts fulltrace} {
if {$::autosetup(istcl)} {
if {$fulltrace} {
return "Error: [dict get $opts -errorinfo]"
} else {
return "Error: $msg"
}
} else {
lassign $opts(-errorinfo) p f l
if {$f ne ""} {
set result "$f:$l: Error: "
}
append result "$msg\n"
if {$fulltrace} {
append result [stackdump $opts(-errorinfo)]
}
# Remove the trailing newline
string trim $result
}
}
}
# ----- @module text-formatting.tcl -----
set modsource(text-formatting.tcl) {
# Copyright (c) 2010 WorkWare Systems http://www.workware.net.au/
# All rights reserved
# Module which provides text formatting
use formatting
proc wordwrap {text length {firstprefix ""} {nextprefix ""}} {
set len 0
set space $firstprefix
foreach word [split $text] {
set word [string trim $word]
if {$word eq ""} {
continue
}
if {[info exists partial]} {
append partial " " $word
if {[string first $quote $word] < 0} {
# Haven't found end of quoted word
continue
}
# Finished quoted word
set word $partial
unset partial
unset quote
} else {
set quote [string index $word 0]
if {$quote in {' *}} {
if {[string first $quote $word 1] < 0} {
# Haven't found end of quoted word
# Not a whole word.
set first [string index $word 0]
# Start of quoted word
set partial $word
continue
}
}
}
if {$len && [string length $space$word] + $len >= $length} {
puts ""
set len 0
set space $nextprefix
}
incr len [string length $space$word]
# Use man-page conventions for highlighting 'quoted' and *quoted*
# single words.
# Use x^Hx for *bold* and _^Hx for 'underline'.
#
# less and more will both understand this.
# Pipe through 'col -b' to remove them.
if {[regexp {^'(.*)'(.*)} $word -> quoted after]} {
set quoted [string map {~ " "} $quoted]
regsub -all . $quoted "&\b&" quoted
set word $quoted$after
} elseif {[regexp {^[*](.*)[*](.*)} $word -> quoted after]} {
set quoted [string map {~ " "} $quoted]
regsub -all . $quoted "_\b&" quoted
set word $quoted$after
}
puts -nonewline $space$word
set space " "
}
if {[info exists partial]} {
# Missing end of quote
puts -nonewline $space$partial
}
if {$len} {
puts ""
}
}
proc title {text} {
underline [string trim $text] =
nl
}
proc p {text} {
wordwrap $text 80
nl
}
proc codelines {lines} {
foreach line $lines {
puts " $line"
}
nl
}
proc nl {} {
puts ""
}
proc underline {text char} {
regexp "^(\[ \t\]*)(.*)" $text -> indent words
puts $text
puts $indent[string repeat $char [string length $words]]
}
proc section {text} {
underline "[string trim $text]" -
nl
}
proc subsection {text} {
underline "$text" ~
nl
}
proc bullet {text} {
wordwrap $text 76 " * " " "
}
proc indent {text} {
wordwrap $text 76 " " " "
}
proc defn {first args} {
if {$first ne ""} {
underline " $first" ~
}
foreach p $args {
if {$p ne ""} {
indent $p
}
}
}
}
# ----- @module util.tcl -----
set modsource(util.tcl) {
# Copyright (c) 2012 WorkWare Systems http://www.workware.net.au/
# All rights reserved
# Module which contains miscellaneous utility functions
# @compare-versions version1 version2
#
# Versions are of the form 'a.b.c' (may be any number of numeric components)
#
# Compares the two versions and returns:
## -1 if v1 < v2
## 0 if v1 == v2
## 1 if v1 > v2
#
# If one version has fewer components than the other, 0 is substituted to the right. e.g.
## 0.2 < 0.3
## 0.2.5 > 0.2
## 1.1 == 1.1.0
#
proc compare-versions {v1 v2} {
foreach c1 [split $v1 .] c2 [split $v2 .] {
if {$c1 eq ""} {
set c1 0
}
if {$c2 eq ""} {
set c2 0
}
if {$c1 < $c2} {
return -1
}
if {$c1 > $c2} {
return 1
}
}
return 0
}
# @suffix suf list
#
# Takes a list and returns a new list with '$suf' appended
# to each element
#
## suffix .c {a b c} => {a.c b.c c.c}
#
proc suffix {suf list} {
set result {}
foreach p $list {
lappend result $p$suf
}
return $result
}
# @prefix pre list
#
# Takes a list and returns a new list with '$pre' prepended
# to each element
#
## prefix jim- {a.c b.c} => {jim-a.c jim-b.c}
#
proc prefix {pre list} {
set result {}
foreach p $list {
lappend result $pre$p
}
return $result
}
# @lpop list
#
# Removes the last entry from the given list and returns it.
proc lpop {listname} {
upvar $listname list
set val [lindex $list end]
set list [lrange $list 0 end-1]
return $val
}
}
# ----- @module wiki-formatting.tcl -----
set modsource(wiki-formatting.tcl) {
# Copyright (c) 2010 WorkWare Systems http://www.workware.net.au/
# All rights reserved
# Module which provides text formatting
# wiki.tcl.tk format output
use formatting
proc joinlines {text} {
set lines {}
foreach l [split [string trim $text] \n] {
lappend lines [string trim $l]
}
join $lines
}
proc p {text} {
puts [joinlines $text]
puts ""
}
proc title {text} {
puts "*** [joinlines $text] ***"
puts ""
}
proc codelines {lines} {
puts "======"
foreach line $lines {
puts " $line"
}
puts "======"
}
proc code {text} {
puts "======"
foreach line [parse_code_block $text] {
puts " $line"
}
puts "======"
}
proc nl {} {
}
proc section {text} {
puts "'''$text'''"
puts ""
}
proc subsection {text} {
puts "''$text''"
puts ""
}
proc bullet {text} {
puts " * [joinlines $text]"
}
proc indent {text} {
puts " : [joinlines $text]"
}
proc defn {first args} {
if {$first ne ""} {
indent '''$first'''
}
foreach p $args {
p $p
}
}
}
##################################################################
#
# Entry/Exit
#
if {$autosetup(debug)} {
main $argv
}
if {[catch {main $argv} msg opts] == 1} {
show-notices
autosetup-full-error [error-dump $msg $opts $autosetup(debug)]
if {!$autosetup(debug)} {
puts stderr "Try: '[file tail $autosetup(exe)] --debug' for a full stack trace"
}
exit 1
}