scid 1:4.5.1.cvs20140429-2ubuntu1 / usr / games / sc_remote

#!/bin/sh
# Emacs please open me in -*-Tcl-*- mode
# the next line restarts using wish if it is in the path \
	exec wish "$0" ${1+"$@"}
#
###############################################################################
#
#
# Copyright (C) 2002 Mark Norman Oakden.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
###############################################################################
#
# sc_remote: Load a scid databases in an existing Scid instances
#
# usage: sc_remote [-nostatus] [ [ [DB ... ] DB ] DB ]
#
# Scid is a free chess database app. For more information,
# visit the Scid website: http://scid.sourceforge.net/
#
#
###############################################################################
#
# We are running in wish but don't need the Tk window (although we have to 
# use wish to get the winfo and send commands).  
#
wm withdraw .
#
set debugging 0
#
# showStatus determines whether a status window is displayed or not
#
set showStatus 0
#
# msgWidth is the width of status messages in the status window
#
set msgWidth 25
#
# textFont should be a fixed width font for the status window
#
set textFont [list fixed 11 normal roman]
#
# debug proc
#
proc dputs { args } {
    global debugging
    if {$debugging} {
	eval puts $args
    }
}

#
# we will wait for smallTime between retries of a busy interpreter
#
set smallTime 400 ;# in milliseconds 1000 == 1 second
#
# we will retry a maximum of maxRetries times for a busy interpreter to
# become unbusy
#
set maxRetries 10 
#
###############################################################################
#
# Functions:
#
proc usage {} {
    set me [file tail [info script]]
    puts stdout "Usage: $me \[-nostatus|-status\] \[<Scid flags>\] \[DB \[DB ...\]\]"
    exit
}

proc dismissStatusWin {} {
    global statusWinDismissed
    wm withdraw .
    set statusWinDismissed 1
}

proc makeStatusWindow { {lines 4} } {
    global showStatus msgWidth textFont
    if { ! $showStatus } { return }
    dputs "making status window height=$lines"
    wm protocol . WM_DELETE_WINDOW dismissStatusWin
    label .name -text "sc_remote Status"
    text .t -wrap none -width [expr $msgWidth + 32] -height $lines \
	    -font $textFont -background \#ffffff \
	    -xscrollcommand [list .x set] \
	    -yscrollcommand [list .y set]
    scrollbar .x -orient horizontal -command [list .t xview]
    scrollbar .y -command [list .t yview]
    grid .name -
    grid .y -row 1 -column 1 -sticky ns
    grid .x -row 2 -column 0 -sticky ew
    grid .t -row 1 -column 0 -sticky news
    button .close -command dismissStatusWin -text "Dismiss"
    grid .close -
    grid columnconfigure . 0 -weight 1
    grid columnconfigure . 1 -weight 0
    grid rowconfigure . 1 -weight 1
    grid rowconfigure . 2 -weight 0
    # tags for message colours
    .t tag configure green -foreground \#228b22
    .t tag configure amber -foreground \#ff8c00
    .t tag configure red -foreground \#8b0000
    #
    .t configure -state disabled
    centreWin .
    update
}

proc setStringWidth { str {width 12} {padchar " "} } {
    # padchar is assumed of length 1 later so ensure it is now
    if { [string length $padchar] != 1 } {
	set padchar " "
    }
    if { [set l [string length $str]] == $width } {
	return $str
    }
    if { $l > $width } {
	return [string range $str 0 [expr $width - 1]]
    } else {
	# use a for loop rather than string repeat for back compatibility
	# in Tcl/Tk versions
	for { set i $l } { $i < $width } { incr i } {
	    append str $padchar
	}
	return $str
    }
}

# tag shold be one of the tags defined in the makeStatusWindow function
proc updateStatus { file mesg {tag amber} } {
    global showStatus msgWidth
    if { ! $showStatus } { return }
    set mesg [setStringWidth $mesg $msgWidth]
    set t .t
    $t configure -state normal
    if { [set ind [$t search $file 1.0 end]] != "" } {
	# update the existing line for $file
	set l [lindex [split $ind .] 0]
	$t delete $l.0 $l.$msgWidth
	$t insert $l.0 $mesg $tag
	#$t see $l.0
    } else {
	# add a new line for $file
	$t insert end $mesg $tag
	$t insert end " "
	$t insert end $file
	$t insert end "\n"
	#$t see end
    }
    $t configure -state disabled
    raise .
    update
}
#
# centreWin is borrowed from Scid source (misc.tcl)
# and is Copyright (C) Shane Hudson
#
# centreWin:
#   Centers a window on the screen.
#
proc centreWin {w} {
  wm withdraw $w
  update idletasks
  set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
                 - [winfo vrootx .]}]
  set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
                 - [winfo vrooty .]}]
  wm geom $w +$x+$y
  wm deiconify $w
}
#
# getScidList returns a list of Scid interpreters on the current display
#
proc getScidList {} {
    set ret [list]
    foreach i [winfo interps] {
	if { [validScidInterp $i] } {
	    lappend ret $i
	}
    }
    dputs "Found the following list of scid interpreters /$ret/"
    return $ret
}
#
# validScidInterp tests that an interpreter found on the display is
# indeed a contactable Scid.  First the name is matched against the
# pattern "scid*", then a send is tried with the "sc_info version"
# command.  Finally, a variable (scidExeDir) which is set within the 
# scid script is tested for existance. If all three of these tests
# succeed we assume we have a Scid.
#
proc validScidInterp { scid } {
    if { ! [string match "scid*" $scid] } {
	return 0
	# we "catch" the first [send] since we don't yet know if [send]
	# works
    } elseif { [catch {send $scid sc_info version} res] } {
	return 0
    } elseif { ! [send $scid info exists scidExeDir] } {
	return 0
    } else {
	return 1
    }
}
#
# querySlotStatus interrogates a scid interpreter for the list of files 
# loaded in its slots.
#
# It will return a list of 2*N elements, where N is the number of non-
# clipbase slots, in the form (where $scid is the name of the interp)
#
#   $scid,1 filename1 $scid,2 - $scid,3 filename2 $scid,4 -
#
# i.e in a suitable form for array set...
#
proc querySlotStatus { scid } {
    set ret [list]
    set cb [send $scid sc_info clipbase]
    set max [send $scid sc_base count total]
    for { set i 1 } { $i <= $max } { incr i } {
	if { $i == $cb } { continue } 
	lappend ret $scid,$i
	set f [send $scid sc_base filename $i]
	# [<anything>] is assumed to be [empty] or a translation since
	# we shouldn't see [clipbase] (or translation thereof) here
	if { [string match {\[*\]} $f] } {
	    set f "-"
	}
	lappend ret $f
    }
    return $ret
}
#
# fillSlotTable fills up a slots array with all slot info for Scids
# on this display
#
# note that [array set] will add to an existing array, overwriting 
# elements if necessary
#
proc fillSlotTable { arrName } {
    upvar $arrName arr
    foreach scid [getScidList] {
	array set arr [querySlotStatus $scid]
    }
}
#
# index slot table creates an array having keys which are the 
# values in the slots array and whose values are lists of the
# indexes in the slots array with that value
#
proc indexSlotTable { slotArrName indexArrName } {
    upvar $slotArrName slots
    upvar $indexArrName index
    foreach {key val} [array get slots] {
	lappend index($val) $key
    }
}
#
# isBusy tests a Scid interp for busy status (assumed busy if cursor of .
# is "watch") - actually this isn't quite sufficient since scid may be 
# busy starting up - we also need to check the startup window for the
# "Startup completed" message...
#
proc isBusy { interp } {
    set ret 0
    if { [send $interp winfo exists .splash.t] } {
	# splash screen text widget exists see if startup is finished
	set cmd [list .splash.t search "Startup complete" 1.0 end]
	if { "[send $interp $cmd]" == "" } {
	    # startup isn't complete yet - assume busy
	    dputs "isBusy: no \"Startup complete\" message - assume busy"
	    return 1
	}
    } else {
	# there was no splash screen yet - assume busy
	dputs "isBusy: no splash screen text widget - assume busy"
	return 1
    }
    # if we got here then there is a splash screen and it contains 
    # "Startup complete".  Now we go by the cursor status
    dputs "isBusy - using cursor status to determine busy status"
    return [expr { "watch" == "[send $interp . cget -cursor]" }]
}
#
# ldelete removes all occurences of an item from a list
#
proc ldelete { li el } {
    upvar $li l
    while { [set indx [lsearch -exact $l $el]] != -1 } {
        set l [lreplace $l $indx $indx]
    }
    return
}
# 
# The fullname function is stolen from Scid source (end.tcl)
# and is Copyright (C) Shane Hudson
#
# fullname:
#   Given a file name, returns its absolute name.
#
proc fullname {fname} {
    # modified MNO - don't immediately return on absolute pathname
    # - try to add suffix in that case too.
    if { [file pathtype $fname] != "absolute"} {
	set old [pwd]
	if {[catch {cd [file dirname $fname]}]} { return $fname }
	set fname [file join [pwd] [file tail $fname]]
	catch {cd $old}
    }
    # Try adding a suffix like ".si3" or ".pgn" to the filename if
    # it has no extension, by checking if a file by that name with
    # a known Scid-readable extension exists:
    if {[file extension $fname] == ""} {
        foreach suffix [list si3 si pgn PGN pgn.gz epd EPD epd.gz sor] {
            if {[file exists "$fname.$suffix"]} {
                dputs "Assuming suffix \".$suffix\" for \"$fname\""
                append fname ".$suffix"
                break
            }
        }
    }
    return $fname
}
#
###############################################################################
#
# find which databases are in which slots and store in slots array:-
# the slots array and slotIndex array are assumed not to pre-exist!
#
array set slots {}
array set slotIndex {}
fillSlotTable slots
indexSlotTable slots slotIndex
#
# create the to-open list from our command line args.  Filter off any
# arguments which start with a "-" into scidArgs list which will be 
# passed to any new Scid we invoke.  If we see a "-nostatus" argument
# switch off the status Window and don't pass this arg to Scid.
#
if { $argc == 0 } {
    usage
}
#
set toOpen [list]
set scidArgs [list]
foreach arg $argv {
    if { [string match "-*" $arg] } {
	if { "-nostatus" == $arg } {
	    set showStatus 0
	} elseif { "-status" == $arg } {
	    set showStatus 1
	} else {
	    lappend scidArgs $arg
	}
    } else {
	set f [fullname $arg]
	lappend toOpen $f
    }
}
#
# make a statusWindow if one is required
#
makeStatusWindow [llength $toOpen]
#
# initialise status window
#
# updateStatus already tests $showStatus and exits if it is 0 however,
# I'll check it again here for speed...
#
if { $showStatus } {
    foreach db $toOpen {
	updateStatus $db "Testing..." amber
    }
}
#
# for each database DB in the to-open list,  If DB is already open 
# and the Scid is not open, we switch the active slot to that with DB, 
# raise the Scid instance and remove the DB from to-open list.  If
# the instance was busy, we add an entry to the deferredSwitch array
# to indicate a slot to try to switch in that Scid after all other
# operations are complete.
# 
# the deferredSwitch array will contain one entry per Scid interpreter
# that was found to be busy at this stage, whose value is set to the
# slot number to switch to.  We only store one slot per interp since
# it doesn't make sense to switch to more than one slot.
#
catch {unset deferredSwitch} 
array set deferredSwitch {}
dputs "Checking if the requested databases are already open in a Scid"
foreach db $toOpen {
    # if the file is .s? or .s?3, strip the extension before comparing
    # since Scid reports these without extensions in 
    if { [string match "*.s?*" $db] } {
	set cdb [file rootname $db]
    } else {
	set cdb $db
    }
    if { [info exists slotIndex($cdb)] } {
	updateStatus $db "Already open..." amber
	dputs "The database $db is open..."
	foreach {interp slot} [split [lindex $slotIndex($cdb) 0] \,] \
		{break}
	dputs "  ... in $interp slot $slot, attempting to switch to it"
	if { [isBusy $interp] } {
	    updateStatus $db "Scid busy..." amber
	    dputs " ... interp $interp is busy - deferring switch to end"
	    set deferredSwitch($interp) $slot
	} else {
	    #send $interp sc_base switch $slot
	    send $interp ::file::SwitchToBase $slot
	    send $interp ::tree::refresh
	    send $interp ::windows::stats::Refresh
	    send $interp ::windows::switcher::Refresh
	    send $interp wm deiconify .
	    send $interp update
	    send $interp raise .
	    updateStatus $db "Done (Displayed)" green
	}
	ldelete toOpen $db
    }
}
#
# while the to-open list is not empty, if there are entries in the 
# free slot list, load first DB in to-open list in that Scid instance
# and delete it from the to-open list. If no slots are available exec 
# a new Scid instance with DB as command line arg.  After each DB
# update the slot listings and indexes
#
while { [llength $toOpen] > 0 } {
    dputs "Dealing with remaining non-open databases /$toOpen/ ..."
    set next [lindex $toOpen 0]
    dputs "  next database is $next"
    ldelete toOpen $next
    # if there are free slots - use one...
    if { [info exists slotIndex(-) ] } {
	foreach {interp slot} [split [lindex $slotIndex(-) 0] \,] {
	    # test each interp for busy status, once per free slot
	    # until we get a non-busy interp
	    if { [isBusy $interp] } {
		dputs "skipping interpreter $interp - it was busy (first pass)"
		continue
	    } else {
		dputs "using interpreter $interp - it isn't busy (first pass)"
		break
	    }
	}
	# if we got here, either interp is  a non-busy interp
	# or *all* interps were busy when we checked before. for
	# safety, test for busy status.
	set iterations 0
	dputs "(Re-)Checking busy status of $interp"
	while { [isBusy $interp] && ( $iterations < $maxRetries ) } {
	    dputs "$interp is busy, waiting - iteration number $iterations"
	    after $smallTime
	    incr iterations
	}
	# If interp is still busy now, give up and open a new scid
	# otherwise open $next in $interp
	if { [isBusy $interp] } {
	    # The bracketing and eval is required because:- 
	    # 1. scidArgs may be a list and 
	    # 2. $next may contain spaces.
	    updateStatus $next "Done (Open new Scid)" green
	    dputs "Gave up waiting for interp $interp exec a new one for $next"
	    eval {exec nohup scid} $scidArgs {$next} &
	    # wait a short time for the new Scid to startup so that it 
	    # will show up in the updated slot list
	    dputs "waiting 250ms"
	    after 250
	} else {
	    dputs "$interp is not busy - opening new db $next in it"
	    updateStatus $next "Done (Open existing Scid)" green
	    send $interp wm deiconify .
	    send $interp ::file::Open $next
	    send $interp raise .
	}
    } else {
	# no interps with free slots were available so background 
	# execute scid to open $next.  
	dputs "Couldn't find any free slots, start a new interp for $next"
	updateStatus $next "Done (Open new Scid)" green
	eval {exec nohup scid} $scidArgs {$next} &
	# wait a short time for the new Scid to startup so that it 
	# will show up in the updated slot list
	dputs "waiting 250ms"
	after 250
    }
    # update the slot list/index
    dputs "Updating lists"
    catch {unset slots}
    array set slots {}
    fillSlotTable slots
    #
    catch {unset slotIndex}
    array set slotIndex {}
    indexSlotTable slots slotIndex
}
#
# Try the deferred switches again, this time with delays/retries
# (Multiple consecutive close brackets hold no fear for lisp hackers!)
#
while { [llength [set l [array names deferredSwitch]]] > 0 } {
    dputs "Processing deferred switch operations"
    set interp [lindex $l 0]
    set slot $deferredSwitch($interp)
    set iterations 0
    dputs "Checking busy status of $interp"
    while { [isBusy $interp] && ( $iterations < $maxRetries ) } {
	dputs "$interp is busy, waiting - iteration number $iterations"
	updateStatus $slots($interp,$slot) "Scid busy - Waiting..." amber
	after $smallTime
	incr iterations
    }
    # If interp is still busy now, give up, otherwise execute a switchBase
    # in the interp.
    if { ! [isBusy $interp] } {
	dputs "inter $interp is now not busy - switching it to slot $slot"
	updateStatus $slots($interp,$slot)  "Done (Deferred Display)" green
	send $interp ::file::SwitchToBase $slot
	send $interp ::tree::refresh
	send $interp ::windows::stats::Refresh
	send $interp ::windows::switcher::Refresh
	send $interp wm deiconify .
	send $interp update
	send $interp raise .
    } else {
	updateStatus $slots($interp,$slot)  "Gave up - Scid still busy" red
	dputs "interp $interp still busy - giving up on switching slots"
    }
    unset deferredSwitch($interp)
}
# 
# check if the status window was intially displayed and has now been 
# dismissed, and if not, wait until it is
if { ! [info exists statusWinDismissed] && $showStatus } {
    # don't exit until statusWin is dismissed
    raise .
    vwait statusWinDismissed
}
after 500 exit
#
###############################################################################