1# -*-mode: tcl; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
2#
3#       $Id: Send-some.tcl,v 1.9 2011-03-14 20:01:13 villate Exp $
4#
5###### send-some.tcl ######
6
7# Usage:
8# catch {close $socket}
9# source send-some.tcl ; openConnection $tohost $port $magic $program
10# one linux14 do
11# run-one.tcl octave  4448 billy1
12# then from any machine do:
13# can also open maxima at same time
14# source send-some.tcl ; openConnection linux14 4448 billy1 octave
15# then
16# sendOneWait octave 2+3
17# 5
18# If you specified -debug when starting the server then you can
19#    evaluate tcl commands in the process controlling 'program'
20#   eg:  sendCommand octave "list 1 1"
21
22
23
24#
25#-----------------------------------------------------------------
26#
27# myVwait --  this is a replacement for vwait which is missing from
28# the plugin tcl.   It is 'supposed' to be the same but in fact if it
29# is a fileevent handler that is supposed to do the setting, then the
30# fileevent handler might indeed get called continuously because the
31# file becomes readable, and myVwait which was checking a variable that
32# the handler set,  never gets a chance to return, since the handler
33# is called again and again.   So Remove the handler when it is invoked.
34# Note this uses tracing of the variable or array, and may interfere
35# with other tracing.
36#  Results:
37#
38#  Side Effects: waits till the variable is set if it was unset, or
39# until its value is different.
40#
41#----------------------------------------------------------------
42#
43proc myVwait { var  } {
44    global _waiting maxima_priv
45    set tem [split $var "(" ]
46    set variable [lindex $tem 0]
47    global $variable
48    lappend maxima_priv(myVwait) $variable
49
50
51    set index ""
52    if { [llength $tem ] > 1 } {
53	set index [lindex [split [lindex $tem 1] ")" ] 0]
54    }
55
56    set action  "_myaction [list $index]"
57    trace variable $variable w $action
58    set _waiting 1
59
60    while { [set _waiting] } {
61        #puts "still waiting _waiting=$_waiting"
62	update
63    }
64    set maxima_priv(myVwait) [ ldelete $variable $maxima_priv(myVwait)]
65    trace vdelete $variable w $action
66}
67
68proc _myaction { ind name1 name2 op } {
69    global _waiting
70    # puts "action $ind $name1 $name2 $op"
71    if { "$ind" == "$name2" } {
72
73	global $name1
74	set _waiting 0
75
76    }
77
78}
79
80# proc myVwait { x args } {uplevel "#0"  vwait $x }
81if { "[info commands vwait]" == "vwait"  } {
82    proc myVwait { x  } {
83        global maxima_priv
84# Fix for Tcl 8.5: linking unreachable global variables used to be ignored
85# in Tcl 8.4 but in 8.5 it raises an errror. The catch command should
86# restore the Tcl 8.4 behavior. (villate, 20080513)
87	catch {global $x}
88	lappend maxima_priv(myVwait) $x
89	vwait $x
90	set maxima_priv(myVwait) [ ldelete $x $maxima_priv(myVwait)]
91    }
92}
93
94proc omDoInterrupt { win } {
95    foreach v [ $win tag names] {
96	if { [regexp "com:pdata\\((\[a-z_A-Z]*)," $v junk program] } {
97	    set var [string range $v 4 end]
98	    # puts "interrupt program=$program,$var"
99	    after 10 uplevel "#0" set $var <interrupted>
100	    catch { sendInterrupt $program }
101	}
102    }
103}
104
105
106proc omDoAbort { win } {
107    foreach v [ $win tag names] {
108	set var [string range $v 4 end]
109	if { [regexp "com:pdata\\((\[a-z_A-Z]*)," $v junk program] } {
110	    set prog [programName $program]
111	    if { "[info command abort_$prog]" != "" } {
112		abort_$prog $program
113		after 200 uplevel "#0" set $var <aborted>
114	    }
115	    cleanPdata $program
116	    set var [string range $v 4 end]
117	    # rputs "interrupt program=$program,$var"
118	    after 200 uplevel "#0" set $var <aborted>
119	}
120    }
121}
122
123
124
125proc  msleep { n } {
126    global Msleeping
127    set Msleeping 1
128    after $n "set Msleeping 0"
129    debugsend "waiting Msleeping.."
130    myVwait Msleeping
131    debugsend "..donewaiting Msleeping"
132}
133proc message { msg } {
134    global maxima_priv _debugSend
135    if { $_debugSend } { puts "setting message=<$msg>" }
136    catch { set maxima_priv(load_rate) $msg }
137}
138proc sendOne { program  com }  {
139    global  pdata maxima_priv
140    incr pdata($program,currentExpr)
141    set socket $pdata($program,socket)
142
143    if { [eof $socket] } {
144        error [mc "connection closed"]
145    }
146    # puts "sending $program ([lindex [fconfigure $socket -peername] 1])"
147
148    message [concat [mc "sending"] "$program" [mc "on"] "[lindex [fconfigure $socket -peername] 1]"]
149    debugsend "sending.. {$com<$pdata($program,currentExpr)\|fayve>}"
150    set msg "$com<$pdata($program,currentExpr)\|fayve>\n"
151    proxyPuts $socket $msg
152}
153
154
155#
156#-----------------------------------------------------------------
157#
158# sendOneDoCommand --  sends to PROGRAM the COMMAND and then
159# when the result comes back it invokes the script CALLBACK with
160# one argument appended: the global LOCATION where the result
161# will be.   [uplevel "#0" set $LOCATION] would retrieve it.
162#
163#  Results: returns immediately the location that will be
164#  watched.
165#
166#  Side Effects: CALLBACK is invoked later by tracing the
167#  result field
168#
169#----------------------------------------------------------------
170#
171proc sendOneDoCommand {program command callback } {
172    global pdata
173
174    if { ![assureProgram $program 5000 2] } { return "cant connect"}
175
176    set ii [expr {$pdata($program,currentExpr) + 1}]
177    catch { unset pdata($program,results,$ii)}
178    trace variable pdata($program,results,$ii) w \
179	    [list invokeAndUntrace $callback]
180    sendOne $program $command
181    return pdata($program,results,$ii)
182}
183
184proc testit { program com } {
185    sendOneDoCommand $program $com "jimmy"
186    proc jimmy {s} { puts "<result is:[uplevel #0 set $s]>" ; flush stdout}
187}
188
189proc invokeAndUntrace { callback name1 name2 op args} {
190    #puts "callback:$callback $name1 $name2 $op, args=$args"
191    #puts "trace vdelete [set name1]($name2) w [list invokeAndUntrace $callback]"
192    trace vdelete [set name1]($name2) w [list invokeAndUntrace $callback]
193    lappend callback  [set name1]($name2)
194    # puts "callback=$callback" ; flush stdout
195
196    if { [catch { eval $callback } errmsg ] } {
197	global errorInfo
198	# report the error in the background
199	set com [list  error [concat [mc "had error in"] "$callback:[string range $errmsg 0 300].."]	$errorInfo]
200	after 1 $com
201    }
202}
203
204proc sendOneWait { program com } {
205    global pdata
206    if { ![assureProgram $program 5000 2] } { return "cant connect"}
207    set ii [expr {$pdata($program,currentExpr) + 1}]
208    catch { unset pdata($program,results,$ii)}
209
210
211    sendOne $program $com
212    set i $pdata($program,currentExpr)
213    set socket $pdata($program,socket)
214    if { $ii != $i } { error "expected $ii got $i as expression number " }
215    debugsend "waiting for pdata($program,results,$i)"
216
217    myVwait pdata($program,results,$i)
218    debugsend "..done waiting for pdata($program,results,$i)"
219    return $pdata($program,results,$i)
220}
221
222proc closeConnection { program } {
223    global pdata
224    catch {
225	set sock $pdata($program,socket)
226	set pdata(input,$sock) ""
227	cleanPdata $program
228	close $sock
229
230    }
231}
232
233proc dtrace { } {
234    global _debugSend
235    if { $_debugSend } {
236	puts "at: [info level -1]"
237	if { [info level]>2 } {puts "   from:[info level -2 ]"}
238    }
239}
240
241proc openConnection { tohost port magic program } {
242    global  pdata
243    dtrace
244    set msg "magic: $magic\n"
245    set retries 2
246    message [concat [mc "connecting to"] "nmtp($port)://$tohost/$program"]
247    debugsend "openConnection { $tohost $port $magic $program }"
248
249    while { [incr retries -1] > 0 \
250	    && [catch { set socket [openSocketAndSend $tohost $port $msg 1] }] }   {
251	debugsend retries=$retries
252	msleep 400
253    }
254
255    if { $retries == 0 } { return 0}
256
257    message [concat [mc "connected to"] "nmtp//$tohost:$port/$program"]
258    set pdata($program,socket) $socket
259    set pdata($program,currentExpr) 0
260    set pdata(input,$socket) ""
261    catch { fconfigure $socket -blocking 0 }
262    fileevent $socket readable "getResults $program $socket"
263    return 1
264
265}
266
267proc sendInterrupt { program } {
268    global pdata interrupt_signal
269    set socket $pdata($program,socket)
270    gui status [mc "Sending scoket interrupt"]
271    puts $socket $interrupt_signal
272    flush $socket
273}
274
275proc sendCommand { program c }   {
276    global  pdata
277    set socket $pdata($program,socket)
278    puts $socket "<command:$c>"
279    flush $socket
280}
281
282proc dumpInfo {program } {
283    sendCommand $program dumpInfo
284}
285
286proc getResults {  program socket } {
287    # debugsend "enter:getResults"
288    global pdata  next_command_available next_command results ii
289    if { [eof $socket] } {
290	close $socket ;
291	debugsend "closed $socket"
292	cleanPdata $program
293	return "<$program exitted>"
294    }
295    set s [read $socket]
296    if { "[string index $s 0]" != "" } {
297	set s [append pdata(input,$socket) $s]
298	while { [set inds [testForFayve $s]] != "" } {
299	    set input $pdata(input,$socket)
300	    # set next_command_available 1
301	    debugsend "input=$input"
302	    set gotback [string range $input 0 [expr {[lindex $inds 0] -1}]]
303	    set index [lindex $inds 2]
304	    set pdata($program,results,$index) $gotback
305    	    if { [string first "exitted>" $gotback] > 0 } {
306		close $socket
307		cleanPdata $program
308	    }
309
310	    debugsend "gotback{$index:$gotback}"
311	    set s \
312		    [string range $input [expr {1 + [lindex $inds 1]}] end ]
313	    set pdata(input,$socket) $s
314	}
315    }
316    return ""
317}
318
319proc cleanPdata { program } {
320    global pdata
321    catch { close $pdata($program,socket) }
322    catch { unset pdata($program,socket) }
323    catch { unset pdata($program,preeval) }
324    catch {
325	foreach v [array names $program,results,*] {
326	    unset pdata($v)
327	}
328    }
329}
330
331
332
333# number from run-main.tcl
334# set MathServer { linux1.ma.utexas.edu 4443 }
335
336proc currentTextWinWidth { } {
337    set width 79
338    catch {
339	set t [oget [omPanel .] textwin]
340	set width [expr {round([winfo width $t]*1.0 / [font measure [$t cget -font] 0]) - 12 }]
341    }
342    return $width
343}
344
345
346
347
348#
349#-----------------------------------------------------------------
350#
351# assureProgram --
352#
353#  Results: return 2 if the program was already open, and 1 if it is just
354# now opened.   0 if cant open it.
355#
356#  Side Effects: program is started.
357#
358#----------------------------------------------------------------
359#
360proc assureProgram { program timeout tries } {
361    # puts "assure: program=$program"
362    global pdata MathServer
363
364
365    if { $tries <=  0   } { return 0}
366
367    if  { [catch { set socket $pdata($program,socket) } ] \
368	    || [catch { eof $socket}] \
369	    || [eof $socket] \
370	    || [catch { set s [read $socket]; append pdata(input,$socket) $s }] } {
371	cleanPdata $program
372	message [concat [mc "connecting"] "[lindex $MathServer 0]"]
373	set msg "OPEN [programName $program] MMTP/1.0\nLineLength: [currentTextWinWidth]\n\n\n"
374	if {[catch {openSocketAndSend [lindex $MathServer 0] \
375		[lindex $MathServer 1] "$msg\n"} sock] } {
376	    error [concat [mc "Can't connect to"] "$MathServer." [mc "You can try another host by altering Base Program under the \"File\" menu."]]
377	}
378
379	set pdata($program,currentExpr) 0
380	fconfigure $sock -blocking 0
381	if { [eof $sock] } {return 0}
382	message [concat [mc"connected to"] "[lindex $MathServer 0]"]
383	debugsend $msg
384	set result ""
385	set pdata(waiting,$sock) 1
386	set script "close $sock ; debugsend {after closing} ; set pdata(waiting,$sock) -1"
387	debugsend "script=$script,timeout=$timeout"
388	set af [after $timeout $script ]
389	debugsend "after=$af"
390	while {1 } {
391	    debugsend "waiting pdata(waiting,$sock)=$pdata(waiting,$sock)"
392	    #	    puts "pdata=[array get pdata *$sock* ]"
393	    fileevent $sock readable "if { [eof $sock] }  {set pdata(waiting,$sock) -2} else { set pdata(waiting,$sock) 0 ;} ;fileevent $sock readable {} "
394	    set pdata(waiting,$sock) 1
395	    debugsend "waiting on  pdata(waiting,$sock)"
396	    myVwait pdata(waiting,$sock)
397
398	    debugsend "..done now pdata(waiting,$sock)=$pdata(waiting,$sock)"
399	    if { $pdata(waiting,$sock) < 0 } {
400		debugsend "timed out,$pdata(waiting,$sock)"
401		return 0
402	    }
403	    set me [read $sock]
404	    if { "[string index $me 0]" == ""  && [eof $sock] } {
405		debugsend "nothing there"
406		return 0
407	    }
408	    append result $me
409	    debugsend "result=<$result>"
410	    if { [regexp "RUNNING (\[^ \]+) MMTP\[^\n\]*\nHost: (\[^\n ]+)\nPort: (\[0-9\]+)\nMagic: (\[^\n \]+)\n" \
411		    $result junk prog tohost port magic] } {
412		after cancel $af
413		debugsend "doing openConnection  $tohost $port $magic $program"
414		close $sock
415		return [openConnection  $tohost $port $magic $program]
416	    }
417	}
418    } elseif { [eof $socket] } {
419	close $socket
420	unset pdata($program,socket)
421	return [assureProgram $program $timeout [expr {$tries -1}]]
422    } else {
423	# already open
424	return 2
425    }
426}
427
428# name may look like "maxima#1.2"
429proc programName { name } {
430    set name [file tail $name]
431    return [lindex [split $name #] 0]
432}
433
434global EOFexpr
435set EOFexpr "|fayve>"
436
437proc getMatch { s inds } {
438    return [string range $s [lindex $inds 0] [lindex $inds 1]]
439}
440
441proc testForFayve { input } {
442    global EOFexpr
443    set ind [string first $EOFexpr $input]
444    if { $ind < 0 } { return "" } else {
445	regexp -indices {<([0-9]+)\|fayve>} $input all first
446
447	set n [getMatch $input $first]
448	return "$all $n"
449    }
450}
451
452#### the following is correct but just a fair bit slower.. ####
453##### because of all the arguments to be parsed for the other..
454proc statServer1  {server {timeout 1000}} {
455    global statServer
456    set ans ""
457    if { ![catch { set s [eval socket $server]} ] } {
458	puts $s "STAT MMTP/1.0\n" ; flush $s
459	if { [readAllData $s -tovar statServer(data) \
460		-mimeheader statServer(header) -timeout $timeout ] > 0 } {
461	    set head $statServer(header)
462	    #	   puts "data=<$statServer(data)>"
463	    set res $statServer(header)\n\n$statServer(data)
464	    unset statServer
465	    return $res
466	}
467    }
468    return ""
469}
470
471
472#
473#-----------------------------------------------------------------
474#
475# needToDo --  Check if we have already done OPERATION for  NAME into data
476#
477#  Results: returns 0 if the data for name is not preloaded, and 1 otherwise
478#
479#  Side Effects: adds NAME to those preloaded for PROGRAM if not there
480#
481#----------------------------------------------------------------
482#
483proc preeval { program name } {
484    global pdata
485    assureProgram $program 5000 2
486    if { ![info exists pdata($program,preeval)] || \
487    [lsearch  $pdata($program,preeval) $name] < 0 } {
488	lappend pdata($program,preeval) $name
489	return 0
490    } else {
491	return 1
492    }
493}
494
495
496
497proc statServer  {server {timeout 1000}} {
498    global statServer1_
499    set ans ""
500    if { ![catch { set s [eval socket $server]} ] } {
501	puts $s "STAT MMTP/1.0\n" ; flush $s
502	if { [readDataTilEof $s data $timeout ] } {
503	    foreach v { jobs currentjobs } {
504		if { [regexp "\n$v: (\[^\n]*)\n" $data junk val] } {
505		    lappend ans $v $val
506		}
507	    }
508	}
509    }
510    return $ans
511}
512
513proc isAlive1 { s } {
514    global maxima_priv
515    if { [catch { read $s } ] } {
516	set maxima_priv(isalive) -1
517    } else {
518	set maxima_priv(isalive) 1
519    }
520    close $s
521}
522
523proc isAlive { server {timeout 1000} } {
524    global maxima_priv
525
526    if { [ catch { set s [eval socket -async $server] } ] } { return -1 }
527    set maxima_priv(isalive) 0
528    fconfigure $s -blocking 0
529    fileevent    $s writable     "isAlive1 $s"
530    set c1 "set maxima_priv(isalive) -2"
531    set after_id [after $timeout $c1]
532    myVwait maxima_priv(isalive)
533    catch { close $s}
534    after cancel $after_id
535    return $maxima_priv(isalive)
536}
537
538
539proc debugsend { s } {
540    global _debugSend
541    if { $_debugSend } {
542
543	puts $s
544	flush stdout
545    }
546}
547
548
549## endsource send-some.tcl
550