# 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
}
}