[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [ccp4bb]: CCP4 on MS Windows OS
> Alun,
>
> I got the .exe self-extracting version for Win2K, installed it as "adminstrator"
> on Win2K, after installing first the Tcl/Tk and Blt pre-builts. Seemed to
> install fine, defined all the environment variables, programs,etc.
>
> I logged out and logged back in as "david" (power user)
>
> I then ran ccp4i off the "Start" menu, and it told me I had to define "HOME" (it
> thought it was c:\david, which did not exist). So I defined HOME (C:\User
> Files\David; does exist) and tried ccp4i again. This time it gave this error
> message:
>
> couldn't read file "C/Program Files/PX/CCP4/CCP4nt4_1_1b/ccp4i/etc/types.def",
"whats wrong?" = its the spaces in the file names. sigh.... I have
actually just compiled a new version of ccp4 for win and hoped to have it
out today... might now be next week as ive just hit some problems and im
away tomorrow and maybe friday in york. anyhow to solve "some" of your
problems try the following fix:
replace the C/Program Files/PX/CCP4/CCP4nt4_1_1b/ccp4i/bin/system.tcl with
the file ive included here. its only a one line change but allows
spaces in some paths....
the problem arises in that W2000 seems to save paths in its registry in
the 'proper' way with all the spaces etc. WinNT does not - it saves them
in the truncated dos manner eg "program files" becomes "progra~1" so thats
why I have not come accross the problem under testing on WinNT.
I also know that this problem comes up when you try to open a browser from
ccp4i (eg by right clicking) - this is one of the problems that is
delaying me!
Let me know if you hit any more problems - I am contactable even if out of
the office!
Alun
_____________________________________________________
Alun Ashton, awa@ccp4.ac.uk Tel: +44 1925 603528
CCP4, ccp4@ccp4.ac.uk Fax: +44 1925 603825
http://www.ccp4.ac.uk/
Daresbury Lab, Daresbury, Warrington, UK, WA4 4AD
##################################################################
# CCP4Interface
#
# This code is distributed under the terms and conditions of the
# CCP4 licence agreement as `Part ii)' software. See the conditions
# in the CCP4 manual for a copyright statement.
#
#
# This script is run first by all CCP4 interface programs
# It sets up some basic system dependent functions (mostly
# to do with file handling and operating system functions)
# and then runs the script whose name is passed to it on the
# command line
#
# Liz Potterton Mar97
##################################################################
#=========================================================================
proc WarningMessage { message { args {} } } {
#=========================================================================
global warning_message_flag
global system
# Minimal WarningMessage proc to output info from NT
# There is another version of this proc in util_windows.tcl
# which will get used after util_windows.tcl has been sourced
# NB util_windows.tcl is NOT sourced when running script so
# will always default ot this version
# If called from a script then just output to a log file
# if { [GetSystemVar task_log_file] != "" } {
# WriteToLog "$message"
# } elseif { $system(OPSYS) == "UNIX" } {
# puts "$message"
# return
# }
set title "Warning"
set w .warning_message
set help_file ""
set button_text "Dismiss"
set stop 1
set transient 0
set command "warning_message_command chooseopt dismiss"
set nargs [llength $args]; set n 0
while { $n < $nargs } {
set comd [lindex $args $n]
if { $comd == "-help" } {
incr n; set help_file [lindex $args $n]
} elseif { $comd == "-title" } {
incr n; set title [lindex $args $n]
} elseif { $comd == "-nostop" } {
set stop 0
} elseif { $comd == "-transient" } {
set transient 1
} elseif { $comd == "-button" } {
incr n; set button_text [lindex $args $n]
} elseif { $comd == "-command" } {
incr n; append command "; [lindex $args $n]"
}
incr n
}
# If there is already a warning mesage up then just add in the extra message
if { [catch {winfo exists .warning_message} winfo_exists] } {
puts "$message"
return
}
if { !$winfo_exists } {
set w .warning_message
toplevel $w
wm title $w "Warning Message"
wm iconname $w Warning
frame $w.f1; pack $w.f1
label $w.f1.text \
-wraplength "15 c" \
-justify left \
-text "$message"
frame $w.f1.b
pack $w.f1.text $w.f1.b -side top
button $w.f1.b.b1 -text Dismiss -command "$command"
pack $w.f1.b.b1
catch "grab $w"
}
wm deiconify $w
catch "grab $w"
vwait warning_message_flag
}
#---------------------------------------------------------------------
proc warning_message_command { arrayname returntext } {
#---------------------------------------------------------------------
global warning_message_flag
catch "grab release .warning_message"
destroy .warning_message
set warning_message_flag 1
}
#
# These are series of procedures which are, or might be, system dependent
#
#----------------------------------------------------------------
proc GetEnvPath { var { report 1 } } {
#----------------------------------------------------------------
global system
global env
# Get environment variable - cope with whether input var has
# leading '$' or not
regsub {^\$} $var {} var1
# On NT change the separators to unix style /
if { [regexp WINDOWS $system(OPSYS)] } {
set status [catch { global env;
regsub -all {\\} $env($var1) \/ path } nc ]
} else {
set status [catch {global env; set p1 $env($var1)} path ]
}
if { $status } {
set path ""
if { $report } {
WarningMessage "Can not get environment variable for $var" }
}
return $path
}
#-----------------------------------------------------------------------
proc TestEnvVariables { } {
#-----------------------------------------------------------------------
global env
global system
# Run at startup to check CCP4 environment roughly in place
set env(CCP4_TOP) [GetEnvPath CCP4]
Report 2 "Using CCP4 programs from $env(CCP4_TOP)" -notime
set error_list {}
foreach envvar [list CCP4I_TOP CCP4I_HELP CCP4_TOP \
CBIN CLIBD CLIBS CCP4_SCR BINSORT_SCR HOME ] {
set path [GetEnvPath $envvar 0]
if { $path == "" } {
append error_list "$envvar is undefined\n"
} elseif { ![file exists $path ] || ![file isdirectory $path ] } {
append error_list "$envvar is defined as $path
which does not exists or is not a directory\n"
}
}
foreach envvar [list PATH CCP4_OPEN PUBLIC_FONT84 ] {
set path [GetEnvPath $envvar 0]
if { $path == "" } {
append error_list "$envvar is undefined\n"
}
}
if { $error_list != "" } {
if { [regexp WINDOWS $system(OPSYS)] } {
append error_list \
"\n You should exit CCP4i and check the installation"
} else {
append error_list \
"\n You should exit CCP4i and do the usual CCP4 setup
If you still get this message then check your installation"
}
# Probably hav not source the window utility code
if { [llength [info procs ChooseOptionDialog]] <= 0 } {
source [file join $env(CCP4I_TOP) src util_windows.tcl]
source [file join $env(CCP4I_TOP) src window.tcl]
}
if { [ regexp Exit \
[ChooseOptionDialog "Undefined environment variables" \
Undefined "Undefined environment variables:\n $error_list" \
[list Exit Continue ] ] ] } { puts "Exiting CCP4i"; return 0 }
}
return 1
}
#-----------------------------------------------------------------------
proc GetFullFileName { file { dir {} } args } {
#-----------------------------------------------------------------------
global directories
if { $file == "" } { return "" }
# if { $dir == {} } { set dir $directories(CURRENT_PROJECT) }
# puts "GetFullFileName $file $dir"
if { [llength [file split $file]] > 1 ||
$dir == {} ||
[StringSame "$dir" "[GetSystemVar PATHNAME_LABEL]" "FULL_PATH" "CURRENT" ] } {
return "$file"
} else {
return "[FileJoin [GetDefaultDirPath $dir] $file]"
}
}
#-----------------------------------------------------------------------
proc GetFullFileName1 { file { dir {} } args } {
#-----------------------------------------------------------------------
# This is used from ExecuteScript and handles the case when the input
# file name has a directory separator
global directories
if { $file == "" } { return "" }
# if { $dir == {} } { set dir $directories(CURRENT_PROJECT) }
# puts "GetFullFileName $file $dir"
if { [lindex [file split $file] 0] == "/" ||
$dir == {} ||
[StringSame "$dir" "[GetSystemVar PATHNAME_LABEL]" "FULL_PATH" "CURRENT" ] } {
return "$file"
} else {
return "[FileJoin [GetDefaultDirPath $dir] $file]"
}
}
#------------------------------------------------------------------------
proc GetCurrentProject {} {
#------------------------------------------------------------------------
global directories
return $directories(CURRENT_PROJECT)
}
#------------------------------------------------------------------------
proc GetDefaultDirPath { {dirIn {} } } {
#------------------------------------------------------------------------
global directories
# Set a default of the current directory
set dir $dirIn
set nodefault 0
if { $dir == "" && [info exists directories(CURRENT_PROJECT)] } {
set dir $directories(CURRENT_PROJECT)
set nodefault 1
}
if { [StringSame "$dir" "[GetSystemVar PATHNAME_LABEL]" ] } {
set directory [GetCurrentDir]
return $directory
} else {
set directory ""
set aliaslist [array names directories PROJECT_ALIAS,*]
if { [llength $aliaslist] > 0 } {
foreach item $aliaslist {
if { $directories($item) == $dir } {
GetIndx $item root c1 c2
set directory $directories([Indxv PROJECT_PATH $c1])
}
}
}
if { $directory != "" && [file exists $directory] && \
[file isdirectory $directory] } { return $directory }
set aliaslist [array names directories DEF_DIR_ALIAS,*]
# puts "aliaslist $aliaslist"
if { [llength $aliaslist] > 0 } {
foreach item $aliaslist {
if { $directories($item) == $dir } {
GetIndx $item root c1 c2
set directory $directories([Indxv DEF_DIR_PATH $c1])
}
}
}
if { $directory != "" && [file exists $directory] && \
[file isdirectory $directory] } { return $directory }
# If all else fails return $CCP4_SCR for the SCRATCH or TEMPORARY
if [regexp SCRATCH|TEMPORARY $dir ] {
set directory [GetEnvPath CCP4_SCR]
return $directory
}
}
if { !$nodefault } { set directory [GetCurrentDir] }
return $directory
}
#----------------------------------------------------------------
proc SearchPath {topname args } {
#----------------------------------------------------------------
global system
# get the full path name for a file
# this procedure will need to search the users local directory
if { ![regexp CCP4 $topname] } { set topname CCP4I_$topname }
# If user has file in .CCP4/CCP4I_TOP/... then use that
set ff [eval [concat FileJoin "[GetSystemVar DOT]" $topname $args ]]
if { [file exists $ff ] } { return $ff }
return [eval [concat FileJoin "[GetEnvPath $topname]" $args ]]
}
#-----------------------------------------------------------
proc ChangeDirectory { dir } {
#-----------------------------------------------------------
# Change to directory $dir - usually necessary with non-CCP4
# programs procheck/Shelx
cd $dir
}
#-------------------------------------------------------------
proc GetUserId { } {
#-------------------------------------------------------------
global env
global system
# Return the user id
if { ![regexp WINDOWS $system(OPSYS)] } {
return $env(USER)
} else {
set log [GetTmpFileName]
if { [Execute [BinPath iam] {} status report -log $log] &&
[ReadFile $log logtext] } {
DeleteFile $log
return [string trim $logtext]
} else {
return 'UNKOWN'
}
}
}
#----------------------------------------------------------
proc GetVersion {} {
#----------------------------------------------------------
global system
return $system(VERSION)
}
#-----------------------------------------------------------
proc ReturnUnixInfo { command infoVar } {
#-----------------------------------------------------------
# run a unix command via the open command so the output
# is piped directly to variable info
upvar $infoVar info
global system
if { ![regexp WINDOWS $system(OPSYS) ] } {
if [catch {set input [open "|$command" r]
set info [read $input]
close $input} ] { puts "info $info";return 0 }
return 1
} else {
WarningMessage "Trying to use ReturnUnixInfo for $command"
return 0
}
}
#-----------------------------------------------------------
proc IsProcessActive { process_name args } {
#-----------------------------------------------------------
# Use ps command to find out if there is a process called
# process_name current active
#NT fix
global system
if { [regexp WINDOWS $system(OPSYS)] } {
# WarningMessage "Attempting to run IsProcessActive"
return 1
}
set proclist [exec ps -u[GetUserId]]
if { [lsearch -regexp $proclist "$process_name"] >= 0 } {
return 1
} else {
return 0
}
}
#------------------------------------------------------------
proc FileJoin { args } {
#------------------------------------------------------------
# use the tcl file join procedure
# This is not available in pre7.6 (?) tcl so possible
# problems on VMS
global system
if { [regexp {^\$} [lindex $args 0]] } {
lappend pathlist [GetEnvPath [lindex $args 0 ]]
} else {
lappend pathlist [lindex $args 0]
}
foreach item [lrange $args 1 end] {
regsub {^\/} $item {} item1
lappend pathlist $item1
}
set cmd [concat "file join" $pathlist]
set status [catch $cmd filename]
if { $status == 0 } {
return $filename
} else {
set filename [lindex $args 0 ]
foreach item [lrange $args 1 end] {
append filename "/" $item
}
return $filename
}
}
#--------------------------------------------------------
proc FileRootName { filename } {
#--------------------------------------------------------
set root [file rootname [file tail $filename] ]
return $root
}
#---------------------------------------------------------------
proc FullPathName { filn0 ext { dir "" } } {
#---------------------------------------------------------------
# If the input file name has some directory structure then leave the
# name as it is - otherwise assume it is in the default directory
# specified by dir
set no_extension 0
if { $filn0 == "" } { return "" }
if { $dir != "" } {
set directory [GetDefaultDirPath $dir]
} else {
set directory ""
}
if { "[string range $filn0 0 0 ]" == "\$" } {
set pp [string first "/" $filn0 ]
if { $pp > 0 } {
set envar [string range $filn0 0 [expr $pp - 1 ] ]
set envarpath [GetEnvPath $envar ]
if { $envarpath != ""} {
set filn1 [FileJoin $envarpath [string range $filn0 $pp end] ]
} else {
set filn1 $filn0
}
} else {
# the input is apparently just an environment variable - humpf - daft user
set envarpath [GetEnvPath $filn0 ]
if { $envarpath != "" } {
set filn1 $envarpath
} else {
set filn1 $filn0
}
set no_extension 1
}
} elseif { [file dirname $filn0 ] == "." } {
set filn1 [FileJoin $directory $filn0]
} else {
set filn1 $filn0
}
if { $no_extension || $ext == "" } {
return $filn1
} else {
return [AddDefaultExt $filn1 $ext]
}
}
#----------------------------------------------------------------------
proc AddDefaultExt { filein extin args } {
#----------------------------------------------------------------------
set replace 0
set n 0; set nargs [llength $args]
while { $n < $nargs } {
set comd [lindex $args $n]
if [regexp -- -r $comd] {
set replace 1
}
incr n
}
if { [string index $extin 0] == "." } {
set ext [string range $extin 1 end]
} else {
set ext $extin
}
set file [string trim $filein]
if { $replace } {
set file [string trimright [file rootname $file] "." ] }
if {[file extension $file] == ""} {
return $file.$ext
} else {
return $file
}
}
#================================================================
# Save global parameters in an array called system_save
# this just helps keep things tidy.
#--------------------------------------------------------------------------
proc GetSystemVar { symbol } {
#--------------------------------------------------------------------------
global system_save
global system
if [info exists system_save($symbol)] {
return $system_save($symbol)
} elseif [info exists system($symbol)] {
return $system($symbol)
} else {
return ""
}
}
#--------------------------------------------------------------------------
proc SetSystemVar {symbol name} {
#--------------------------------------------------------------------------
global system_save
set system_save($symbol) $name
}
#----------------------------------------------------------------
proc OpenFile { filename channel {mode a+ } } {
#----------------------------------------------------------------
upvar $channel f
if [file isdirectory $filename] { return 0 }
# puts "OpenFile mode $mode"
# this is a fix for directory trees with spaces eg spaced user name
# return [expr 1 - [catch "open $filename $mode" f ] ]
return [expr 1 - [catch { open $filename $mode} f ] ]
}
#--------------------------------------------------------------------
proc CloseFile { f {filename ""} } {
#--------------------------------------------------------------------
if { [catch "close $f" ] } {
WarningMessage "Error closing file $filename
Probably due to disk being full or exceeding disk quota"
return 0
} else {
return 1
}
}
#--------------------------------------------------------------------
proc ReadFile { filename textVar args } {
#--------------------------------------------------------------------
upvar $textVar text
set noblank 0
set nocomment 0
set split 0
set n 0; set nargs [llength $args]
while { $n < $nargs } {
switch -regexp -- [lindex $args $n] \
split {
set split 1
} nobl {
set noblank 1
} noco {
set nocomment 1
incr n; set comment [lindex $args $n]
}
incr n
}
if { ![OpenFile $filename f r ] } { return 0 }
if { [catch "read $f" tt ] } { CloseFile $f; return 0 }
CloseFile $f
if { $split || $noblank || $nocomment } {
set ttsplit [split $tt \n]
# Strip out blank lines and comment lines
if { $noblank && $nocomment } {
foreach line $ttsplit {
if { [string length [string trim $line ] ] > 0 && ![eval regexp {$comment} {$line} ] } {
lappend tclean "$line" }
}
} elseif { $noblank } {
foreach line $ttsplit {
if { [string length [string trim $line ] ] > 0 } { lappend tclean $line }
}
} elseif { $nocomment } {
if { $noblank } { set ttsplit $text; set text {} }
foreach line $ttsplit {
if { $line == "" || ![eval regexp {$comment} {$line} ] } {
lappend tclean "$line" }
}
} else {
set tclean $ttsplit
}
# If doing noblank/nocomment but don't want text splitting
if { $split } { set text $tclean } else {
foreach line $tclean { append text $line \n } }
} else {
set text $tt
}
return 1
}
#--------------------------------------------------------------------
proc ReadEndOfFile { filename nlines textVar args } {
#--------------------------------------------------------------------
upvar $textVar text
global system
# NT
if { [regexp WINDOWS $system(OPSYS)] } {
if { [ReadFile $filename tt -split] } {
set ttlen [llength $tt]
set f [expr $ttlen - $nlines]
if { $f < 0 } { set f 0 }
if { [lsearch $args "-split"] >= 0 } {
set text [lrange $tt $f end]
} else {
foreach l [lrange $tt $f end] {
append text $l \n
}
}
return 1
} else {
return 0
}
} else {
# Use Unix tail command to read last nlines lines of a file
if [catch {set input [open "|tail -$nlines $filename" r]
set tt [read $input]
close $input } ] {
return 0
}
if { [lsearch $args "-split"] < 0 } {
set text $tt
} else {
set text [split $tt \n]
}
return 1
}
}
#--------------------------------------------------------------------
proc WriteFile { filename text args } {
#--------------------------------------------------------------------
if { [lsearch -regexp $args -overwrite] >= 0 } {
if { ![OpenFile $filename fo w] } { return 0 }
} else {
if { ![OpenFile $filename fo a+] } { return 0 }
}
if [catch {puts $fo "$text"}] { return 0 }
return [CloseFile $fo]
}
#--------------------------------------------------------------------
proc CreateTmpFile { filenameVar text } {
#--------------------------------------------------------------------
upvar $filenameVar filename
set filename [GetTmpFileName]
OpenFile $filename f w
puts $f $text
CloseFile $f
}
#--------------------------------------------------------------------
proc DeleteFile {file } {
#--------------------------------------------------------------------
if { [file isfile $file] } {
catch {file delete $file}
return 1
} elseif { [file isdirectory $file] } {
catch {file delete -force $file}
return 1
}
}
#-----------------------------------------------------------------
proc FileWritable { file } {
#-----------------------------------------------------------------
return [file writable $file ]
}
#-----------------------------------------------------------------
proc GetPid {} {
#-----------------------------------------------------------------
set process [GetSystemVar process]
if { $process == "" } {
set process [pid]
SetSystemVar process $process
}
return $process
}
#--------------------------------------------------------------------
proc DeleteFiles { args } {
#--------------------------------------------------------------------
foreach file $args {
DeleteFile $file
}
}
#--------------------------------------------------------------------
proc GetCurrentDir { } {
#--------------------------------------------------------------------
return [pwd]
}
#--------------------------------------------------------------------
proc MoveFile { filein fileout args } {
#--------------------------------------------------------------------
if { ![file exists $filein] } {
Report 1 "MoveFile: input file $filein does not exist"
return 0
}
if { [file exists $fileout] } {
if { [lsearch -regexp $args over ] >= 0 } {
DeleteFile $fileout
} else {
Report 1 "MoveFile: output file $fileout already exist"
return 0
}
}
if { [catch {file rename $filein $fileout } ] } {
return 0
} else {
return 1
}
}
#--------------------------------------------------------------------
proc CopyFile { filein fileout args } {
#--------------------------------------------------------------------
if { ![file exists $filein] } {
puts "CopyFile: input file $filein does not exist"
return 0
}
if { [file exists $fileout] && \
[lsearch -regexp $args over] < 0 } {
Report 1 "CopyFile: output file $fileout already exist"
return 0
} else {
file delete $fileout
}
if { [catch {file copy $filein $fileout } ] } {
Report 1 "CopyFile: error copying from $filein to $fileout"
return 0
} else {
return 1
}
}
#--------------------------------------------------------------------
proc CopyDir { filein fileout } {
#--------------------------------------------------------------------
if { ![file exists $filein] } {
Report 1 "CopyDir: input $filein does not exist"
return 0
}
if { [file exists $fileout] } {
Report 1 "CopyDir: output $fileout already exist"
return 0
}
# NT fix - remove the 'exec' from the command - why was it there??
# if { [catch {exec file copy $filein $fileout } ] }
if { [catch {file copy $filein $fileout } ] } {
Report 1 "CopyDir: error copying from $filein to $fileout"
return 0
} else {
return 1
}
}
#-----------------------------------------------------------------------
proc CompressFile { filein args } {
#-----------------------------------------------------------------------
global system
set overwrite 0
set uncompress 0
set nargs [llength $args]; set n 0
while { $n < $nargs } {
switch -regexp -- [lindex $args $n] \
over {
set overwrite 1
} unco {
set uncompress 1
}
incr n
}
# Uncompress
if { $uncompress } { return [UnCompressFile $filein] }
# NT fix
if { [regexp WINDOWS $system(OPSYS)] } {
WarningMessage "Attempting to run CompressFile"
return 0
}
if { ![file exists $filein] } {
puts "CompressFile: input file $filein does not exist"
return 0
}
append fileout $filein ".gz"
if {[file exists $fileout] } {
if { $overwrite } {
Report 1 "Overwriting existing compressed file: $fileout"
DeleteFile $fileout
} else {
Report 1 "Compressed file already exists: $fileout"
return 0
}
}
if { [catch {exec gzip $filein } ] } {
return 0
} else {
return 1
}
}
#-----------------------------------------------------------------------
proc UnCompressFile { filein } {
#-----------------------------------------------------------------------
global system
# Uncompress the file $filein - if this file does not exist try
# adding the usual compress extension ( .gz ) to file name
# This routine will be mostly used with the database for archiving
# It is probably safer to pass in file name without the compress extension
# and let this routine sort it out which compress program is being used
# NT fix
if { [regexp WINDOWS $system(OPSYS) ] } {
WarningMessage "Attempting to run UnCompressFile"
return 0
}
set file $filein
if { ![file exists $file] } {
set file [FileJoin file [CompressExtension]]
if { ![file exists $file] } {
Report 1 "UnCompressFile: input file $filein does not exist"
return 0
}
}
if { [catch {exec gunzip $file } ] } {
return 0
} else {
return 1
}
}
#---------------------------------------------------------------------
proc UnTarFile { file } {
#---------------------------------------------------------------------
global system
# NT fix
if { [regexp WINDOWS $system(OPSYS) ] } {
WarningMessage "Attempting to run UnCompressFile"
return 0
}
return [expr 1 - [catch {exec tar xf $file } ] ]
}
#--------------------------------------------------------------------
proc CompressExtension {} {
#--------------------------------------------------------------------
return "gz"
}
#--------------------------------------------------------------------
proc TranscribeFile { filein fileout } {
#--------------------------------------------------------------------
if { [OpenFile $filein fi r ] <= 0 } {
Report 2 "ERROR opening file $filein"
return 0 }
if { [OpenFile $fileout fo a+ ] <= 0 } {
Report 2 "ERROR opening file $fileout"
return 0 }
puts $fo "[read $fi]"
CloseFile $fi
CloseFile $fo
return 1
}
#---------------------------------------------------------------------
proc CreateDir { dir } {
#---------------------------------------------------------------------
if { [ file exists $dir ] } {
Report 3 "ERROR cannot create directory: $dir already exists"
return 0
}
return [expr 1 - [catch {file mkdir $dir } ] ]
}
#--------------------------------------------------------------------
proc ChangeDirectory { dir } {
#--------------------------------------------------------------------
if { [file exists $dir] && [file isdirectory $dir ] } {
return [expr 1 - [catch "cd $dir"] ]
} else {
return 0
}
}
#---------------------------------------------------------------------
proc ChangeFileExt { filename ext } {
#---------------------------------------------------------------------
set t [file extension $filename]
if { $t != "" } {
set nt [expr [string first $t $filename ] - 1 ]
set file [string range $filename 0 $nt ]
} else {
set file $filename
}
if { [string first "." $ext] == 0 } {
append file $ext
} else {
append file "." $ext
}
return $file
}
#-------------------------------------------------------------------------
proc GetHostname { } {
#-------------------------------------------------------------------------
global system
return [info hostname]
}
#========================================================================
# **ExtractFromFile
#
# Avoid all that grep and awk stuff to extract words from a file
#
# filename input file name
# search_string search string NB must be EXACTLY as in file but
# with * as first and last character if string is
# embedded within line
# lineinc return the text from the lineinc'th line after
# the line with the search_string
# word_index list of indexes to the words required returning
# if word_index==0 return the whole line
# data return list of data
#
#========================================================================
proc ExtractFromFile { fileid search_string lineinc word_index } {
global extractfromfile_line
set data {}
set line {}
# puts "ExtractFromFile fileid $fileid search_string $search_string lineinc $lineinc"
set extractfromfile_line [GetSystemVar extractfromfile_line]
set n_lines_read 0
if {$search_string == "" } {
set line $extractfromfile_line
if { $lineinc > 0 } {
for { set i 1 } { $i <= $lineinc } { incr i } {
incr n_lines_read
if { [catch "gets $fileid line" status ] } {
puts "ExtractFromFile could not increment $lineinc lines"
puts "Possible end-of-file after"
puts "$linetmp"
return ""
}
}
}
} else {
while { [gets $fileid linetmp ] >= 0 } {
incr n_lines_read
if { [string match $search_string $linetmp ] == 1 } {
if { $lineinc > 0 } {
for { set i 1 } { $i <= $lineinc } { incr i } {
incr n_lines_read
if { [catch "gets $fileid line" status ] } {
puts "ExtractFromFile could not increment $lineinc lines"
puts "Possible end-of-file after"
puts "$linetmp"
return ""
}
}
} else {
set line $linetmp
}
break
}
}
}
SetSystemVar extractfromfile_line $line
SetSystemVar extractfromfile_lines_read $n_lines_read
if [regexp a $word_index 0] {
set data $line
} else {
set data [GetWords $line $word_index]
}
return $data
}
#--------------------------------------------------------------------
proc GetWords { line word_index } {
#--------------------------------------------------------------------
# convert the string to a list
set tmp_list [split $line " "]
# Remove any null list element that derives from multiple spacing
# in the input list
set tmp_list0 ""
foreach element $tmp_list {
if { $element != "" } { lappend tmp_list0 $element }
}
foreach element $word_index {
lappend out [lindex $tmp_list0 $element]
}
return $out
}
#----------------------------------------------------------------------
proc ExtractTextLine { tt search_string lineinc word_index dataVar args } {
#----------------------------------------------------------------------
upvar $dataVar data
set retval 1
set data [ExtractFromText "$tt" "$search_string" $lineinc $word_index $args ]
if { $data == {} || [lindex $data 0] == {} } { set retval 0 }
# puts "data $data retval $retval"
# if { !$retval } { puts "$search_string" }
return $retval
}
#----------------------------------------------------------------------
proc ExtractNextLine { lineVar {skip_blank 1} { trim 1} } {
#----------------------------------------------------------------------
upvar $lineVar line
global extractText
global extractTextLen
global extractLine
if { $extractLine >= $extractTextLen } { return 0 }
incr extractLine
if { $skip_blank } {
while { [string trim [lindex $extractText $extractLine]] == "" } {
if { $extractLine < $extractTextLen } {
incr extractLine
} else {
return 0
}
}
}
if { $trim } {
set line [string trim [lindex $extractText $extractLine]]
} else {
set line [lindex $extractText $extractLine]
}
return 1
}
#----------------------------------------------------------------------
proc ExtractFromText { tt search_string lineinc word_index args } {
#----------------------------------------------------------------------
# Perform similar function to grep and awk
# Search the text $tt for incidence of $search_string and
# then step on to the $lineinc'th line after the present one
# Return either the whole line if $word_index=0 or if word_index
# is a list of the index of the words to return
# NB the words in a line are taken as starting from 0
# If $tt = '-' then use previous text
# If search_string == "" then apply lineincfrom current position and
# return the word_index words
global extractText
global extractTextLen
global extractLine
if { $tt != "-" } {
set extractText [split $tt \n]
append extractText {}
set extractTextLen [llength $extractText]
set extractLine 0
} elseif { $search_string != "" } {
incr extractLine
if { $extractLine > $extractTextLen } { return "" }
}
# if {$search_string == "" && [regexp all $word_index] } {
# Find the next non-blank line
# incr extractLine $lineinc
# if { $extractLine > $extractTextLen } { return "" }
# while { $extractLine < $extractTextLen && \
# [string trim [lindex $extractText $extractLine]] == "" } {
# incr extractLine
# }
# return [lindex $extractText $extractLine]
# }
if {$search_string != "" } {
while { $extractLine < $extractTextLen && \
![regexp $search_string [lindex $extractText $extractLine]] } {
incr extractLine
}
}
incr extractLine $lineinc
if { $extractLine <= $extractTextLen } {
set line [lindex $extractText $extractLine]
} else {
return ""
}
# puts "extractLine search_string $search_string $extractLine $line"
switch $word_index \
all {
return $line
} last {
return [lindex $line end]
} default {
return [GetWords $line $word_index]
}
}
#---------------------------------------------------------------------------
proc Indxv { name c1 { c2 {} } } {
#---------------------------------------------------------------------------
set element $name
if { $c1 != "" } { append element "," $c1 }
if { $c2 != "" } { append element "_" $c2 }
return $element
}
#---------------------------------------------------------------------------
proc GetIndx { element rootVar c1Var c2Var } {
#---------------------------------------------------------------------------
upvar $rootVar root
upvar $c1Var c1
upvar $c2Var c2
set c1 ""
set c2 ""
if { ![regexp {([^,]*),([^,]*)} $element tt root indx ] } {
set root $element
return
}
if { ![regexp {([^_]*)_([^_]*)} $indx tt c1 c2 ] } {
set c1 $indx
}
return
}
#--------------------------------------------------------------------
proc InitialiseArray1 { filnVar arrayname } {
#--------------------------------------------------------------------
upvar #0 $arrayname array
InitialiseArray $array($filnVar) $arrayname
}
#-------------------------------------------------------------------------
proc ReadDefTaskname { filn tasknameVar } {
#-------------------------------------------------------------------------
upvar $tasknameVar taskname
if { ![OpenFile $filn f r ] } {
Report 3 "Could not open initialisation file $filn"
return 0
}
set taskname ""
while { $taskname == "" && [gets $f line] >= 0 } {
if { [regexp CCP4I $line] && [regexp DEF $line] } {
set taskname [lindex $line 3]
}
}
CloseFile $f
return 1
}
#===========================================================================
proc InitialiseArray { filn arrayname taskname args } {
#===========================================================================
upvar #0 $arrayname array
# Initialise an array from a def file
# Create a parameter PARAM_LIST which is list of names of all input
# parameters - this list usaully used to write out the same file
set check 1
set query_check 0
set nargs [llength $args]; set n 0
while { $n < $nargs } {
set comd [lindex $args $n]
if [regexp -- "-nocheck" $comd] {
set check 1
} elseif [regexp -- "-reportlabel" $comd] {
set query_check 1
}
incr n
}
if { [catch {open $filn r } f ] } {
Report 3 "Could not open initialisation file $filn"
return 0
}
if { ![ElementExists $arrayname PARAM_LIST] } {
set array(PARAM_LIST) ""
}
if { $check } {
set checked 0
while { $checked == 0 && [gets $f line] >= 0 } {
if { [string first CCP4I $line] >= 0 &&
[string first SCRIPT $line] >= 0 } {
if { ( [string first DEF $line] >= 0 || [string first DB $line] >= 0) &&
[string first $taskname $line] >=0 } {
set checked 1
} else {
set checked -1
}
}
}
if { $checked <= 0 } {
if { $query_check } {
set action [ ChooseOptionDialog "Correct File" "Correct File" \
"The file $filn
has script identifier: $line
which is not correct for initialising $taskname
do you want to continue reading the file?" \
[list "Abort Reading" "Continue Reading" ] ]
if { $action == "Abort Reading" } {
close $f
return 0
}
} else {
puts "Def file $filn"
puts "does not have correct file label $taskname"
}
}
}
# merge lines which have continuation character
set textin [split [ read $f ] "\n"]
CloseFile $f
set full_text ""
foreach line $textin {
if { [string range $line end end] == "\\" } {
append buffer [string range $line 0 [expr [string length $line] -2]]
} else {
append buffer $line
lappend full_text $buffer
set buffer ""
}
}
if { [llength $full_text] <= 0 } { return 0 }
set nl 0; set nl_full_text [llength $full_text]
while { $nl < $nl_full_text } { incr nl; set line [lindex $full_text $nl]
if { [string length $line ] > 0 } {
# Handle insertion of data from another def file
if { [string range $line 0 0 ] == "@" } {
eval "set filename [string range $line 1 end]"
if { [ReadFile $filename tmp_full_text -split] } {
set full_text [concat $full_text $tmp_full_text]
set nl_full_text [llength $full_text]
}
} elseif { [string range $line 0 0 ] != "#" } {
set element [lindex $line 0 ]
set value [lindex $line 1 ]
GetIndx $element root c1 c2
# If the next word begins with an underscore then it is a type for the
# data
if { [ string index $value 0 ] == "_" } {
set array(_$element) $value
if [catch "set value [lrange $line 2 end]"] {
Report 1 "ERROR reading value of parameter $element from file $filn"
set value ""
}
}
if { [string length $element] > 0 } {
set array($element) $value
if { $c1 == "" || $c1 == 0 } {
if { [lsearch $array(PARAM_LIST) $element ] < 0 } {
lappend array(PARAM_LIST) $element
}
}
}
}
}
}
# set INITIAL_DEF to contain the name of the initialisation def file
# if it is not the interface default
set filn_list [file split $filn]
set ll [llength $filn_list]
if [regexp tasks [lindex $filn_list [expr $ll -2]]] {
set array(INITIAL_DEF) ""
} else {
set array(INITIAL_DEF) $filn
}
# puts "INITIAL_DEF $array(INITIAL_DEF)"
# puts " $arrayname PARAM_LIST $array(PARAM_LIST) "
return 1
}
#----------------------------------------------------------------------
proc SetDomain {} {
#----------------------------------------------------------------------
# Is the present host machine in a machine domain?
global system
global domains
if { ![ElementExists domains N_DOMAINS] || $domains(N_DOMAINS) == 0 } {
return 0
}
set host [lindex [split [GetHostname] . ] 0 ]
for { set n 1 } { $n <= $domains(N_DOMAINS) } { incr n } {
if { [lsearch -exact $domains(DOMAIN_MACHINES,$n) $host] >= 0 } {
puts "$host in domain $domains(DOMAIN_NAME,$n)"
set system(GENERIC_DOMAIN) $system(DOMAIN)
set system(DOMAIN) $domains(DOMAIN_NAME,$n)
break
}
}
}
#----------------------------------------------------------------------
proc InitialisePreferences { taskname arrayname args } {
#----------------------------------------------------------------------
# Initialise preferences by reading first the program defaults and
# then any existing user preferences file
global system
upvar #0 $arrayname array
set read_user 1
set filename {}
set nargs [llength $args]; set n 0
while { $n < $nargs } {
switch -regexp -- [lindex $args $n] \
nous {
set read_user 0
} file {
incr n; set filename [lindex $args $n]
}
incr n
}
set retval 1
InitialiseArray [SearchPath TOP etc $taskname.def.dist] $arrayname $taskname
if { $filename != "" } {
InitialiseArray $filename $arrayname $taskname
} elseif { $read_user &&
[file exists [set filename [datapath $taskname.def -username -domain]]] } {
InitialiseArray $filename $arrayname $taskname
set retval 2
} elseif { $read_user &&
[file exists [set filename [datapath $taskname.def -domain ]]] } {
InitialiseArray $filename $arrayname $taskname
set retval 2
} elseif { [file exists [set filename \
[SearchPath TOP etc $system(DOMAIN) $taskname.def ]]] } {
InitialiseArray $filename $arrayname $taskname
} elseif { [file exists \
[set filename [SearchPath TOP etc $taskname.def ]]] } {
InitialiseArray $filename $arrayname $taskname
} else {
# The only def file for these parameters was the *.def.dist - so probably first
# run of interface - so try running autoconf
if { [llength [info proc autoconf_[subst $system(OPSYS)]_$taskname]] > 0 } {
if { [autoconf_[subst $system(OPSYS)]_$taskname $arrayname $taskname ] } {
if { [file writable [SearchPath TOP etc $system(DOMAIN)] ] } {
set filename [SearchPath TOP etc $system(DOMAIN) $taskname.def]
puts "Creating new configure parameters file $filename"
SaveArray $taskname $filename $arrayname -save_types
} else {
WarningMessage \
"You are the first person to run this version of CCP4i and
it is trying to automatically configure and save information
to the file:
[SearchPath TOP etc $system(DOMAIN) $taskname.def]
but you do not have write permission for this directory.
Please get the person who installed CCP4i to run it and
do the configure.
It is OK to continue running CCP4i."
}
}
}
}
# WarningMessage "InitialisePreferences $taskname $filename"
# The INITIALISATION_MODE indicates if using installation-wide
# parameters (=0) or user's customised parameters (=1)
set array(INITIALISATION_MODE) [expr $retval - 1]
switch -regexp -- $taskname \
directories {
catch {update_defdir_menu $arrayname}
} configure {
set_configured_menus $arrayname TYPEDEF_LIST
}
return $retval
}
#--------------------------------------------------------------------
proc update_defdir_menu { arrayname { counter "" } } {
#--------------------------------------------------------------------
# Update the project/alias menu that appears in the file selection lines
upvar #0 $arrayname array
global system
set ll [list "[GetSystemVar PATHNAME_LABEL]" ]
for { set n 1 } { $n <= $array(N_PROJECTS) } { incr n } {
lappend ll $array(PROJECT_ALIAS,$n)
}
for { set n 1 } { $n <= $array(N_DEF_DIRS) } { incr n } {
lappend ll $array(DEF_DIR_ALIAS,$n)
}
set array(DEFDIR_MENU) $ll
set lw ""
foreach w $system(DEFDIR_WIDGET_LIST) {
if [winfo exists [lindex $w 0] ] {
update_menu0 [lindex $w 0] [lindex $w 1] [lindex $w 2] $ll
lappend lw $w
}
}
set system(DEFDIR_WIDGET_LIST) $lw
}
#---------------------------------------------------------------------
proc autoconf_UNIX_configure { arrayname taskname } {
#---------------------------------------------------------------------
# Called when ccp4i first used - there is no $CCP4I_TOP/etc/configure.def
# Initial parameters from $CCP4I_TOP/etc/configure.def.init are modified
# in this routine
upvar #0 $arrayname array
Report 1 "Running auto-configure for $taskname"
# Set the background colour
catch {
frame .fdummy
set configure(COLOUR_BACKGROUND) [.fdummy cget -background]
destroy .fdummy
}
set array(START_NETSCAPE) [SearchPath TOP utils start_netscape.csh]
#If this is standard bltwish installation then the exe is
# .../bin/bltwish
# and the bltGraph.pro is in .../lib/bltv.v/bltGraph.pro
if { ![catch {exec which bltwish} exe_path] } {
catch {
set local_dir [file dirname [file dirname $exe_path]]
set libdirs [lsort -decreasing [glob [file join $local_dir lib blt*]]]
if { [llength $libdirs ] > 0 } {
if [file exists [file join [lindex $libdirs 0] bltGraph.pro]] {
set array(BLT_LIBRARY) [lindex $libdirs 0]
}
}
}
}
set array(RUN_CCP4I) ccp4ish
WarningMessage "set ccp4irun thing"
set array(RUN_LOGGRAPH) loggraph
return 1
}
#---------------------------------------------------------------------
proc autoconf_WINDOWS_configure { arrayname taskname } {
#---------------------------------------------------------------------
# Called when ccp4i first used - there is no $CCP4I_TOP/etc/configure.def
# Initial parameters from $CCP4I_TOP/etc/configure.def.init are modified
# in this routine
upvar #0 $arrayname array
Report 1 "Running auto-configure for $taskname"
# Set the background colour
catch {
frame .fdummy
set configure(COLOUR_BACKGROUND) [.fdummy cget -background]
destroy .fdummy
}
package require registry 1.0
set htmlfile {}
set tclfile {}
catch {
set ht [registry get \
HKEY_CLASSES_ROOT\\htmlfile\\shell\\open\\command {}]
regsub -all {\\} $ht \/ htmlfile }
catch {
set tc [registry get \
HKEY_CLASSES_ROOT\\TclScript\\shell\\open\\command {}]
regsub -all {\\} $tc \/ tclfile }
# WarningMessage "htmlfile $htmlfile tclfile $tclfile"
if { [llength $htmlfile] > 0 } {
set array(HYPERTEXT_VIEWER) [lindex $htmlfile 0]
}
if { [llength $tclfile] > 0 &&
[regsub wish [lindex $tclfile 0] tclsh tclsh] > 0 } {
set array(RUN_TCLSH) $tclsh
} else {
set array(RUN_TCLSH) tclsh80
}
set array(RUN_CCP4I) "$array(RUN_TCLSH) \[file join \[GetEnvPath CCP4I_TOP] bin ccp4ish.tcl]"
set array(RUN_BLTWISH) bltwish
set array(RUN_LOGGRAPH) "bltwish \[file join \[GetEnvPath CCP4I_TOP] bin loggraph.tcl]"
return 1
}
#--------------------------------------------------------------------------
proc autoconf_WINDOWS_system { arrayname taskname } {
#--------------------------------------------------------------------------
upvar #0 $arrayname array
set uid [GetUserId]
set array(LOGIN_NAME) WINDOWS
if { $uid != "" } { set array(LOGIN_NAME) $uid }
}
#-----------------------------------------------------------------------
proc set_configured_menus { arrayname paramlistVar } {
#-----------------------------------------------------------------------
upvar #0 $arrayname array
if { ![ElementExists $arrayname $paramlistVar] } {
Report 1 "Parameter list $paramlistVar does not exist in $arrayname"
return
}
foreach p $array($paramlistVar) {
if { [llength $p] > 3 } {
set_typedef_menu $arrayname [lindex $p 0] \
[lindex $p 1] [lindex $p 2] [lindex $p 3]
} else {
set_typedef_menu $arrayname [lindex $p 0] \
[lindex $p 1] [lindex $p 2]
}
}
}
#-----------------------------------------------------------------------
proc set_typedef_menu {arrayname defVar nitemsVar menuVar { aliasVar "" } } {
#-----------------------------------------------------------------------
upvar #0 $arrayname array
global typedef
# puts "set_typedef_menu defVar $defVar nitems $array($nitemsVar)"
if { $array($nitemsVar) < 1 } {
if { $aliasVar != "" } {
set typedef($defVar) { menu {"Not Installed"} {"Not Installed"} }
} else {
set typedef($defVar) { menu {"Not Installed"} }
}
} else {
for { set n 1 } { $n <= $array($nitemsVar) } { incr n } {
lappend lm $array([Indxv $menuVar $n])
if { $aliasVar != "" } { lappend la $array([Indxv $aliasVar $n]) }
}
if { $aliasVar != "" } {
set typedef($defVar) [list menu $lm $la ]
} else {
set typedef($defVar) [list menu $lm ]
}
}
}
#====================================================================
proc datapath { filename args } {
#====================================================================
# Get the full path name for a configure file in the user's home
# directory. The path nmae my be more complex if there is a USERNAME
# defined (eg used when several students in a class have same login)
global system
global env
set create 0
set user 0
set domain 0
set dir [GetSystemVar DOT]
set nargs [llength $args]; set n 0
while { $n < $nargs } {
switch -regexp -- [lindex $args $n] \
user {
if { $system(USERNAME) != "" } {
set dir [file join $dir $system(USERNAME)]
set user 1
}
} domain {
if { $system(DOMAIN) != "" } {
set dir [file join $dir $system(DOMAIN)]
set domain 1
}
} create {
set create 1
}
incr n }
# If the directory structure is not in place for the file then create it
if { $create && ![file exists $dir] } {
if { $user && ![file exists \
[file join [GetSystemVar DOT] $system(USERNAME)]] } {
CreateDir [file join [GetSystemVar DOT] $system(USERNAME)]
}
if { $domain } {
CreateDir $dir
}
}
if { [file exist $filename ] } {
return $filename
} else {
set filn [FileJoin $dir $filename]
return $filn
}
}
#==================================================================
proc nextword { linein continueVar {mode " "}} {
#==================================================================
upvar $linein line
upvar $continueVar continue
set continue 0
set len ""
set linetmp [string trimleft $line]
if { [string length $linetmp] <= 0 ||
[regexp {"\" \""|"\"\""} $linetmp ] == 1 } return ""
# The next word or phrase starts with quotes - take everything between these
# and the next quotes
if { [ regsub -- {^\"} $linetmp "" word1 ] } {
regexp -- {([^\"]*)\"} $word1 word
set continue [ expr 1 - [regsub -- {\"$} $word1 "" word] ]
# if { $continue == 1 } { puts "word1 $word1" }
} else {
scan $linetmp %s word
}
# set error [regsub -- {^\"} $word "" word1]
# set error [regsub -- {\"$} $word1 "" word]
if { $mode == "pare" } {
set line [string trimleft \
[string range $linetmp [expr [string length $word] + 1 ] end] ]
}
return $word
}
#======================================================================
proc WriteIdentifier { f script args } {
#======================================================================
# Write simple identifer to top of file
global system
global job_params
# Setup the standard file header info
set date [GetDate]
set user [GetUserId]
set text "#CCP4I VERSION $system(VERSION)
#CCP4I SCRIPT $script
#CCP4I DATE $date
#CCP4I USER $user"
# Expect args to be in pairs of keyword and parameter
# if parameter is a null string then test if it is an element of job_params array
set nargs [llength $args]; set n 0
while { $n < $nargs } {
set keyword [lindex $args $n ]
incr n;set param [lindex $args $n]
if { $param == "" && [ElementExists job_params $keyword] } {
set param $job_params($keyword)
}
append text "\n#CCP4I $keyword $param"
incr n
}
# If f is a channel id then write text to that channel
# If f is null string then put text in that string ot return to
# calling procedure
if { $f == {} } { return "$text\n" } else { puts $f $text }
}
#=================================================================================
# Trivial but useful ....
#=================================================================================
proc max { args } {
set m [lindex [lindex $args 0 ] 0 ]
foreach ll $args {
foreach l $ll {
if { $l > $m } { set m $l }
}
}
return $m
}
proc min { args } {
set m [lindex [lindex $args 0 ] 0 ]
foreach ll $args {
foreach l $ll {
if { $l < $m } { set m $l }
}
}
return $m
}
proc iremainder { n m } {
# and we just hope it all stays in integer ..
set i [expr $n / $m ]
set ii [expr $n - ($m * $i) ]
return $ii
}
proc push { stackVar levelVar value } {
upvar $levelVar level
upvar $stackVar stack
lappend stack $value
incr level
}
proc pop { stackVar levelVar } {
upvar $levelVar level
upvar $stackVar stack
if { [llength $stack ] == 0 } {
set value ""
} else {
set value [lindex $stack end]
incr level -1
set stack [lreplace $stack end end ]
}
return $value
}
# Limit max decimal places in output string
#----------------------------------------------------------------
proc maxdecimal { input prec } {
#----------------------------------------------------------------
# round a fraction to prec decimal places
# leave rational fractions unchanged and round up irrational
set bignum [expr pow( 10,$prec )]
set out [expr int($bignum * $input)/$bignum ]
if { $out < $input } { set out [expr $out + pow(10,-$prec )] }
return $out
}
#---------------------------------------------------------
proc sortorder { listin orderVar { mode {} } } {
#---------------------------------------------------------
upvar $orderVar order
# listin is a list of whatevers - return a list order
# which is the offsets to position in listin for sorted
# This is grossly inefficient!
# mode is standard arguments to the sort function
set cmd "set ll \[lsort $mode \$listin\]"
eval "$cmd"
# Handle multiple instances of a value
# in the input list
set order {}
set ilast {}
foreach item $ll {
if { $item == $ilast } {
set ii [expr $i + 1 ]
} else {
set ii 0
}
set i [expr $ii + [lsearch [lrange $listin $ii end] $item ] ]
lappend order $i
set ilast $item
}
}
#-----------------------------------------------------
proc ElementExists { arrayname element } {
#-----------------------------------------------------
# if { ![array exists $arrayname] } { return 0 }
upvar #0 $arrayname array
if { [array names array $element] == $element } {
return 1
} else {
return 0
}
}
#---------------------------------------------------------------------
proc IfSet { args } {
#---------------------------------------------------------------------
foreach param $args {
if { $param == "" } { return 0 }
}
return 1
}
#----------------------------------------------------------------
proc ArraySearch { arrayname var text } {
#----------------------------------------------------------------
upvar #0 $arrayname array
# Search array for element with a value of 'text'
# Expect the array element name to take the form array(var,index)
set elements [GetIndexedElements $arrayname $var ]
foreach element $elements {
if { [StringSame $text $array($element) ] } { return $element }
}
return ""
}
#-------------------------------------------------------------------
proc StringSame { args } {
#-------------------------------------------------------------------
# String comparison - by default case sensitive
# optional first argument -case makes comparison case insensitive
# The next argument (string1) is compared with all sebsequent
# arguments and if it is the same as any of them them return 1
# otherwise return 0
set case 1
set nargs [expr [llength $args ] -1 ]; set n 0
if { [lindex $args 0 ] == "-case" } { set case 0 ; incr n }
set string1 [lindex $args $n]; incr n
if { $case } { set string1 [string toupper $string1] }
foreach string2 [lrange $args $n $nargs ] {
if { $case } { set string2 [string toupper $string2] }
if { [string compare $string1 $string2 ] == 0 } { return 1 }
}
return 0
}
#-------------------------------------------------------------
proc ParseArgs { keylist iflist paramlist initlist input } {
#-------------------------------------------------------------
if { ![info exists input ] } { return 0 }
if { [set nargs [llength $input ]] <= 0 } { return 0 }
puts "nargs $nargs"
foreach pname $iflist {
if { $pname != "" } {
eval "upvar $pname v_$pname
set v_$pname 0"
}
}
set i -1; foreach p $paramlist { incr i
set j -1; foreach pname $p { incr j
eval "upvar $pname v_$pname
set v_$pname [lindex [lindex $initlist $i] $j]"
eval puts \"v_$pname \$v_[subst $pname]\"
incr i
}
}
set n 0; while { $n < $nargs } {
if { [set i [lsearch -regexp $keylist [lindex $input $n]]] >= 0 } {
puts "hit $i"
if {[lindex $iflist $i] != "" } { eval "set v_[lindex $iflist $i] 1" }
foreach pname [lindex $paramlist $i] {
incr n; eval "set v_$pname [lindex $input $n]"
}
}
incr n
}
}
#---------------------------------------------------------------
proc GetDate { args } {
#---------------------------------------------------------------
# If there is no input secs then find the current time
# otherwise use the input time secs and convert to user
# friendly format dependent on format input
# full full date and time
# time time only
# date date only
# brief time for any time today otherwise date
#
set format full
set secs {}
set nargs [llength $args]; set n 0
while { $n < $nargs } {
switch -regexp -- [lindex $args $n] \
format {
incr n; set format [lindex $args $n]
} clock {
incr n; set secs [lindex $args $n]
}
incr n
}
if { $secs == "" } { set secs [clock seconds] }
if { [llength $secs ] > 1 } {
if { $format == "brief" } {
return [ append time [string range $secs 0 6] [string range $secs 9 10] ]
} else {
return $secs
}
}
if { $format == "seconds"} { return $secs }
if { $format == "full" } {
set date [clock format $secs -format "%d %b %Y %H:%M:%S" ]
} elseif { $format == "time" } {
set date [clock format $secs -format "%H:%M:%S" ]
} elseif { $format == "date" } {
set date [clock format $secs -format "%d %b %Y" ]
} elseif { $format == "brief" } {
set today [ clock format [clock seconds] -format "%Y %j" ]
set input [ clock format $secs -format "%Y %j" ]
if { [lindex $input 0 ] == [lindex $today 0 ] &&
[lindex $input 1 ] == [lindex $today 1 ] } {
set date [clock format $secs -format "%H:%M:%S" ]
} else {
set date [clock format $secs -format "%d %b %y" ]
}
}
return "$date"
}
#---------------------------------------------------------------
proc Report { level text args } {
#---------------------------------------------------------------
global preferences
if { [ElementExists preferences REPORT_LEVEL] &&
$level < $preferences(REPORT_LEVEL) } { return }
if { $text == "" } { return }
if { [lsearch $args -notime] < 0 } { set text "[GetDate -format time] $text" }
set logfile [GetSystemVar SESSION_LOG]
if { $logfile != "" } {
WriteFile $logfile "$text"
} else {
puts "$text"
}
# Old code to write report to log window
# $frame configure -state normal
# $frame insert end "\n$text" texttag
# $frame yview moveto 1.0
# $frame configure -state disabled
}
#------------------------------------------------------------------------
proc GetTmpFileName { args } {
#------------------------------------------------------------------------
global job_params
global preferences
set ex ""
set defdir ""
set dir ""
set job_id ""
set number [expr [GetSystemVar number_tmp_files] +1 ]
set n_args [llength $args]; set n 0
while { $n < $n_args } {
switch -regexp -- [lindex $args $n] \
ext {
incr n; set ex [lindex $args $n]
} defdir {
incr n; set defdir [lindex $args $n]
} dir {
incr n; set dir [lindex $args $n]
} map {
if { $preferences(MAP_OUTPUT_DEFDIR) == "TEMPORARY" } {
set defdir TEMPORARY
} else {
set defdir $job_params(PROJECT)
}
}
incr n
}
if { [ElementExists job_params JOB_ID] } {
append job_id $job_params(PROJECT) _ $job_params(JOB_ID)
} else {
set job_id [GetPid]
}
if { $ex == "" || [string match "_*" $ex ] } {
set ext $ex
} else {
set ext "_$ex"
}
set fname "[subst $job_id]_[subst $number][subst $ext].tmp"
if { $dir == "" && $defdir != "" } { set dir [GetDefaultDirPath $defdir] }
if { $dir == "" } { set dir [GetDefaultDirPath TEMPORARY] }
if { $dir != "" } {
set file [FileJoin $dir $fname]
} else {
set file $fname
}
SetSystemVar number_tmp_files $number
return $file
}
#---------------------------------------------------------------------------
proc GetFileFormat { file { default {}} } {
#---------------------------------------------------------------------------
global typedef
set ext [file extension $file]
if { $ext == "" } { return $default }
foreach filetype $typedef(file_types) {
set defext [lindex $typedef($filetype) 2]
if { [StringSame $ext $defext] } {
return [lindex $typedef($filetype) 1]
}
}
return $default
}
#----------------------------------------------------------------------
proc BinPath { program } {
#----------------------------------------------------------------------
global system
global configure
if { [StringSame WINDOWS $system(OPSYS)] && [StringSame fft $program] } {
set program fftbig }
if { [ElementExists configure NFULLPATHS] &&
$configure(NFULLPATHS) > 0 } {
for { set n 1 } { $n <= $configure(NFULLPATHS) } { incr n } {
if { [StringSame $configure(FULLPATH_PROG,$n) $program] } {
return "$configure(FULLPATH_PATH,$n)"
}
}
}
return $program
# If there was no search path defined might need to use the following
# return [FileJoin $env(CBIN) $program]
}
#------------------------------------------------------------------------
proc InitialiseDotCCP4 { } {
#------------------------------------------------------------------------
# Make sure we have a $HOME/.CCP4 directory
global system
switch $system(OPSYS) \
UNIX {
set dot [file join [GetEnvPath HOME] .CCP4]
} WINDOWS {
set dot [file join [GetEnvPath SystemRoot] Profiles $system(LOGIN_NAME) CCP4]
}
if { ![file exists $dot ] } {
Report 1 "Creating a home directory for CCP4 at $dot"
CreateDir $dot
CreateDir $dot/windows
CreateDir $dot/unix
CreateDir $dot/CCP4I_TOP
CreateDir $dot/CCP4I_TOP/bin
CreateDir $dot/CCP4I_TOP/src
CreateDir $dot/CCP4I_TOP/etc
CreateDir $dot/CCP4I_TOP/tasks
CreateDir $dot/CCP4I_TOP/scripts
CreateDir $dot/CCP4I_TOP/templates
CreateDir $dot/CCP4I_TOP/utils
CreateDir $dot/CCP4I_TOP/loggraph
CreateDir $dot/CCP4I_TOP/sketch
CreateDir $dot/monomer
# Copy the directories.def to its new home
if { [regexp UNIX $system(OPSYS)] &&
[file exists [file join [GetEnvPath HOME] .CCP4_directories] ] } {
CopyFile [file join [GetEnvPath HOME] .CCP4_directories] \
[file join $dot unix directories.def ]
}
} elseif { ![file isdirectory $dot] } {
puts "There is $dot but it is apparently not a directory"
stop
}
SetSystemVar DOT $dot
}
#----------------------------------------------------------------------
proc Execute { command script statusout reportout { args {} } } {
#----------------------------------------------------------------------
#Quick Execute - baby brother to the Execute in execute.tcl
# Used to run programs internal to graphical ccp4i
upvar $statusout status
upvar $reportout report
set program_success 0
set logfile {}
set nargs [llength $args] ; set n 0
while { $n < $nargs } {
set comd [lindex $args $n ]
switch -regexp -- $comd \
success {
incr n; set success [lindex $args $n ]
} log {
incr n; set logfile [lindex $args $n ]
}
incr n
}
set cmd "set status \[catch \{exec $command"
if { $script != "" && $script != " " } { append cmd " < " $script }
if { $logfile != "" } {
if { [file exists $logfile ]} {
append cmd " >> " $logfile
} else {
append cmd " > " $logfile
}
}
append cmd "\} report \]"
# If in environment with Report function then just put
# out a diagnostic level report
# if { [info procs "Report" ] == "Report" } {
# Report 0 "Running: $command "
# }
eval "$cmd"
# status is the value returned by catch and 0 means command
# successful
return [ expr 1 - $status ]
}
#
#
# The followin procedures are used by ccp4i processes which are acting as clients
# to the 'main' ccp4i gui. For example loggraph acting as client to sfanal task
#
# This setup assumes that the process is a client of only one server
#
#------------------------------------------------------------------------
proc OpenClientSocket { server_host server_port args } {
#------------------------------------------------------------------------
global system
set listen 0
set nargs [llength $args]; set n 0
while { $n < $nargs } {
switch -regexp -- [lindex $args $n] \
listen {
set listen 1
incr n; set listen_command [lindex $args $n]
}
incr n
}
if { ![catch "socket $server_host $server_port" sockid] } {
set system(SERVER_HOST) $server_host
set system(SERVER_PORT) $server_port
set system(CLIENT_PORT) $sockid
fconfigure $system(CLIENT_PORT) -buffering line \
-blocking [expr 1 - $listen]
if { $listen } { ListenClientSocket $sockid 500 $listen_command }
return 1
} else {
return 0
}
}
#------------------------------------------------------------------------
proc ListenClientSocket { sockid delay command } {
#------------------------------------------------------------------------
if { ![catch {gets $sockid} input] && $input != "" } {
# puts "ListenClientSocket input $input"
eval [concat $command $input]
}
after $delay [list ListenClientSocket $sockid $delay $command ]
}
#------------------------------------------------------------------------
proc TestSocket { args } {
#------------------------------------------------------------------------
# Test is socket is open
global system
set nargs [llength $args]; set n 0
while { $n < $nargs } {
switch -regexp -- [lindex $args $n] \
server {
set socket $system(SERVER_SOCKET)
} client {
set socket $system(CLIENT_SOCKET)
} socket {
incr n; set socket [lindex $args $n]
}
incr n
}
set status [expr 1 - [catch {fconfigure $socket} response ] ]
# puts "TestSocket socket $socket $response $status"
return $status
}
#------------------------------------------------------------------------
proc PutsSocket { message args } {
#------------------------------------------------------------------------
global system
set nargs [llength $args]; set n 0
while { $n < $nargs } {
switch -regexp -- [lindex $args $n] \
client {
set socket $system(CLIENT_PORT)
} server {
set socket $system(SERVER_SOCKET)
} socket {
incr n; set socket [lindex $args $n]
}
incr n
}
# puts "PutsSocket message $message socket $socket"
return [expr 1 - \
[catch { puts $socket $message } ] ]
}
#======================================================================
# SETUP - this is at top level and makes sure ccp4i bombs out
# if CPC4I_TOP is not set
#======================================================================
global system_save
set system_save(PATHNAME_LABEL) "Full path.."
if { ![ElementExists system TK_VERSION] || $system(TK_VERSION) < 8.0 } {
set system_save(BLT_TABLE) table
} else {
set system_save(BLT_TABLE) blt::table
}
if { [regexp find [package require BLT] ] } {
WarningMessage "BLT extension to Tcl/Tk not installed. See your system manager or the CCP4i installation documentation."
return 0
}