1#
2# $Id: eclipse.tcl,v 1.3 2012/02/19 17:54:49 jschimpf Exp $
3#
4# BEGIN LICENSE BLOCK
5# Version: CMPL 1.1
6#
7# The contents of this file are subject to the Cisco-style Mozilla Public
8# License Version 1.1 (the "License"); you may not use this file except
9# in compliance with the License.  You may obtain a copy of the License
10# at www.eclipse-clp.org/license.
11#
12# Software distributed under the License is distributed on an "AS IS"
13# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied.  See
14# the License for the specific language governing rights and limitations
15# under the License.
16#
17# The Original Code is  The ECLiPSe Constraint Logic Programming System.
18# The Initial Developer of the Original Code is  Cisco Systems, Inc.
19# Portions created by the Initial Developer are
20# Copyright (C) 2006 Cisco Systems, Inc.  All Rights Reserved.
21#
22# Contributor(s):
23#
24# END LICENSE BLOCK
25#
26# This file contains some primitive procedures that are needed to
27# embed ECLiPSe into Tcl applications.
28#
29# Do NOT include any development support here!
30# Do NOT assume the existence of an interactive ECLiPSe toplevel!
31#
32
33package provide eclipse 1.0
34
35
36#----------------------------------------------------------------------
37# ec_resume ?async?
38#	resume ECLiPSe execution and execute posted goals and events
39#	returns success,fail,yield (or raises an error)
40#	if async, ECLiPSe is run in a separate thread
41#----------------------------------------------------------------------
42
43set ec_resume_active 0
44
45proc ec_resume {{async 0}} {
46    global ec_resume_active
47
48    if $ec_resume_active { error "ec_resume cannot be nested" }
49    set $ec_resume_active 1
50
51    while { 1 } {
52	set reslist [ec_resume_ $async]
53	if $async {
54	    # wait for the eclipse thread to finish
55	    # but allow gui interaction every 100 milliseconds
56	    while 1 {
57		set reslist [ec_resume_status 100]
58		if {$reslist != "running"} break
59		catch update
60	    }
61	}
62	set res [lindex $reslist 0]
63	switch $res {
64	    flushio {
65		set stream [lindex $reslist 1]
66		if [catch "ec_flushio_stream $stream" err] {
67		    if [catch  "tk_messageBox -icon error -type ok -message" $err"] {
68			return
69		    }
70
71		}
72		catch update
73	    }
74	    waitio {
75		set stream [lindex $reslist 1]
76		if [catch "ec_waitio_stream $stream" err] {
77		    if [catch "tk_messageBox -icon error -type ok -message" $err"] {
78			# unable to display messageBox, tk process gone
79			return
80		    }
81
82		}
83	    }
84	    success -
85	    fail -
86	    yield {
87		set $ec_resume_active 0
88		return $res
89	    }
90	    running {
91		error "Cannot do ec_resume while another ec_resume is running"
92	    }
93	    default {
94		set $ec_resume_active 0
95		error "Unexpected return from ec_resume: $reslist"
96	    }
97	}
98    }
99}
100
101#----------------------------------------------------------------------
102# ec_flush StreamNum ?length?
103#       remote interface compatible use of ec_resume
104#----------------------------------------------------------------------
105
106proc ec_flush {StreamNr {length {}}} {
107    flush [ec_streamnum_to_channel $StreamNr]
108    ec_rpc true
109}
110
111#----------------------------------------------------------------------
112# ec_handle_events
113#	restricted form of ec_resume
114#	execute only events (e.g. queue events, posted events)
115#	returns success (or raises an error)
116#----------------------------------------------------------------------
117
118proc ec_handle_events {} {
119
120    set reslist [ec_handle_events_]
121    while { 1 } {
122	set res [lindex $reslist 0]
123	switch $res {
124	    flushio {
125		set stream [lindex $reslist 1]
126		if [catch "ec_flushio_stream $stream" err] {
127		    if [catch "tk_messageBox -icon error -type ok -message $err"] {
128			# unable to display messageBox, tk process gone
129			return
130		    }
131		}
132		catch update
133	    }
134	    waitio {
135		set stream [lindex $reslist 1]
136		if [catch "ec_waitio_stream $stream" err] {
137		    if [catch "tk_messageBox -icon error -type ok -message $err"] {
138			return
139		    }
140		}
141	    }
142	    success {
143		return $res
144	    }
145	    running {
146		error "Cannot do ec_handle_events while ec_resume running"
147	    }
148	    default {
149		error "Unexpected return from ec_resume: $reslist"
150	    }
151	}
152	# now resume the Eclipse handler
153	set reslist [ec_resume_ 0]
154    }
155}
156
157#----------------------------------------------------------------------
158# Handling sockets
159#----------------------------------------------------------------------
160
161proc ec_open_socket {host port} {
162    global ec_socket
163
164    set ec_socket [socket $host $port]
165}
166
167#----------------------------------------------------------------------
168# Handling ECLiPSe queues
169#----------------------------------------------------------------------
170
171proc ec_queue_connect {eclipse_name access {command {}}} {
172    global ec_queue_out_handlers
173    global ec_queue_in_handlers
174
175    set channelid [ec_queue_open_ $eclipse_name $access]
176    if {$command != ""} { ec_set_queue_handler $eclipse_name $access $command }
177    return $channelid
178}
179
180proc ec_queue_create {eclipse_name access {command {}} {event {}}} {
181    global ec_queue_out_handlers
182    global ec_queue_in_handlers
183
184    if {(($command != {}) && ($event != {}))} {
185	error "Cannot define handlers on both ECLiPSe and Tcl sides for a queue $eclipse_name"
186    }
187
188    switch -- $access {
189	fromec -
190	r {
191	    set access fromec ;# ec_mode is the mode on ECLiPSe side
192	}
193
194	toec -
195	w {
196	    set access toec
197	}
198
199	default {error "$access is an invalid access mode for embedded ECLiPSe queue ($eclipse_name)"}
200    }
201
202    ec_rpc [list : sepia_kernel [list ecl_create_embed_queue $eclipse_name $access [list $event]]] (()(()()()))
203
204    return [ec_queue_connect $eclipse_name $access $command]
205
206}
207
208
209# mostly for compatibility with socket remote queues
210proc ec_async_queue_create {eclipse_name access {command {}} {event {}}} {
211
212    ec_queue_create $eclipse_name $access $command $event
213}
214
215proc ec_queue_close {eclipse_name} {
216    ec_rpc [list peer_queue_close $eclipse_name] (())
217}
218
219proc ec_write_exdr {channel data {format S}} {
220    puts -nonewline $channel [ec_tcl2exdr $data $format]
221}
222
223proc ec_set_queue_handler {eclipse_name access command} {
224    global ec_queue_out_handlers
225    global ec_queue_in_handlers
226
227    switch -- $access {
228	fromec  -
229	r {
230	    set ec_queue_out_handlers([ec_stream_nr $eclipse_name]) $command
231	}
232	toec    -
233	w {
234	    set ec_queue_in_handlers([ec_stream_nr $eclipse_name]) $command
235	}
236
237	default {
238	    error "ec_set_queue_handler: bad access mode, should be r or w"
239	}
240    }
241}
242
243proc ec_flushio_stream {stream} {
244    global ec_queue_out_handlers
245    if [info exists ec_queue_out_handlers($stream)] {
246	eval $ec_queue_out_handlers($stream) $stream
247    } else {
248	ec_stream_output_popup "Output occurred on ECLiPSe stream $stream" $stream
249    }
250}
251
252proc ec_waitio_stream {stream} {
253    global ec_queue_in_handlers
254    if [info exists ec_queue_in_handlers($stream)] {
255	eval $ec_queue_in_handlers($stream) $stream
256    } else {
257	ec_stream_input_popup "Input expected on ECLiPSe stream $stream" $stream
258    }
259}
260
261
262#----------------------------------------------------------------------
263# Sample stream I/O handlers
264#----------------------------------------------------------------------
265
266set ec_stream_input_string {}
267
268proc ec_stream_input_popup {Msg Stream} {
269    global ec_stream_input_string
270
271    toplevel .ec_stream_input_box
272    label .ec_stream_input_box.prompt  -width 40 -text $Msg
273    entry .ec_stream_input_box.input -bg white -width 40 -textvariable ec_stream_input_string
274    button .ec_stream_input_box.clear -text "clear" -command {.ec_stream_input_box.input delete 0 end}
275    button .ec_stream_input_box.ok -text "ok" -command {destroy .ec_stream_input_box}
276    bind .ec_stream_input_box.input <Return> {append ec_stream_input_string \n ; destroy .ec_stream_input_box}
277
278    pack .ec_stream_input_box.prompt -side top -fill x
279    pack .ec_stream_input_box.input -side top -fill x
280    pack .ec_stream_input_box.clear -side left -expand 1 -fill x
281    pack .ec_stream_input_box.ok -side left -expand 1 -fill x
282
283    focus .ec_stream_input_box.input
284    tkwait window .ec_stream_input_box
285    ec_queue_write $Stream $ec_stream_input_string
286    set ec_stream_input_string [string trimright $ec_stream_input_string \n]
287}
288
289
290# Sample queue_out_handler: output into text widget
291
292# Length is optional dummy arg. for compatibility with socket queues
293proc ec_stream_to_window_sync {Tag Window Stream {Length {}}} {
294    ec_stream_to_window $Tag $Window $Stream
295}
296
297proc ec_stream_to_window {Tag Window Stream} {
298
299    set data [ec_queue_read $Stream 1000]
300    while {$data != ""} {
301	regexp {^([0-9]+)[.]([0-9]+)$} [$Window index end-1char] whole line charp
302	if {$charp < 2000} {
303	    ;# always truncate
304	    $Window insert end $data $Tag
305	} else {
306	    ;# truncate printing of line if too long
307	    if {[lsearch [$Window tag names] trunc] != -1} {
308		;# not yet defined...
309		$Window tag configure trunc -background pink
310	    }
311	    if {[lsearch [$Window tag names end-2char] trunc] == -1} {
312		    ;# line is first truncated. Note -2 needed (rather than -1)
313		$Window insert end "..." trunc
314	    }
315	    set nl [string first "\n" $data]
316	    if {$nl != -1} {
317		;# if there is a nl, then a new line was started
318		$Window insert end [string range $data $nl end] $Tag
319	    }
320	}
321	set data [ec_queue_read $Stream 1000]
322    }
323
324    $Window see end
325}
326
327# Sample queue_out_handler: output into message popup
328
329proc ec_stream_output_popup {Msg Stream} {
330    if ![winfo exists .ec_stream_output_box] {
331	toplevel .ec_stream_output_box
332	label .ec_stream_output_box.msg  -width 40 -text $Msg
333	text .ec_stream_output_box.text -width 40 -height 5 -bg white -yscrollcommand ".ec_stream_output_box.vscroll set" -wrap none -xscrollcommand ".ec_stream_output_box.hscroll set"
334	scrollbar .ec_stream_output_box.vscroll -command ".ec_stream_output_box.text yview"
335	scrollbar .ec_stream_output_box.hscroll -command ".ec_stream_output_box.text xview" -orient horizontal
336	button .ec_stream_output_box.ok -text "ok" -command {destroy .ec_stream_output_box}
337	pack .ec_stream_output_box.msg -side top -fill x
338	pack .ec_stream_output_box.ok -side bottom -fill x
339	pack .ec_stream_output_box.vscroll -side left -fill y
340	pack .ec_stream_output_box.hscroll -side bottom -fill x
341	pack .ec_stream_output_box.text -expand 1 -fill both
342    }
343    ec_stream_to_window {} .ec_stream_output_box.text $Stream
344}
345
346#----------------------------------------------------------------------
347# Handler for embed_info queue
348#----------------------------------------------------------------------
349
350proc ec_info_queue_handler {InfoStream} {
351    global ec_embed_info_channel
352
353    set message [ec_read_exdr [ec_streamnum_to_channel $InfoStream]]
354    set command [lindex $message 0]
355    switch $command {
356	queue_connect {
357	    set eclipse_name [lindex $message 1]
358	    set access [lindex $message 3]
359	    ec_queue_connect $eclipse_name $access
360	}
361
362	queue_close {
363	    close [ec_streamnum_to_channel [lindex $message 1]]
364	}
365
366	default { error "Unrecognised message $message from embedded ECLiPSe."}
367    }
368}
369
370#----------------------------------------------------------------------
371# Init
372#    ec_init ?Name?
373#----------------------------------------------------------------------
374
375proc ec_init {{name host}} {
376    global tkecl
377    global ec_rpc_in_channel
378    global ec_rpc_out_channel
379    global ec_embed_info_channel
380
381    set res [ec_init_]
382    ;# ec_rpc channels are treated specially as the rpc connections is not
383    ;# yet formed at this point
384    set ec_rpc_in_channel [ec_queue_open_ ec_rpc_in w]
385    set ec_rpc_out_channel [ec_queue_open_ ec_rpc_out r]
386
387    if {[lindex [ec_rpc \
388          [list : sepia_kernel [list set_embed_peer $name tcl]] (()(()S))
389         ] 0] == "fail"} {
390	error "Peer name $name already in use."
391    }
392    ;# embed_info must be created after embed peer info has been set
393    set ec_embed_info_channel [ec_queue_create embed_info fromec ec_info_queue_handler]
394    set tkecl(ec_peer_name) $name
395
396    return $res
397}
398
399#----------------------------------------------------------------------
400# ec_rpc goal ?format?
401#	returns: instantiated goal, "fail" or "throw"
402#----------------------------------------------------------------------
403
404proc ec_rpc {Goal {Format S}} {
405    global ec_rpc_in_channel
406    global ec_rpc_out_channel
407
408    if [ec_running] {
409	error "Cannot do ec_handle_events while ec_resume running"
410    }
411    ec_write_exdr $ec_rpc_in_channel $Goal $Format
412    ec_handle_events
413    catch "ec_read_exdr $ec_rpc_out_channel" res
414    return $res
415}
416
417#----------------------------------------------------------------------
418#
419
420proc ec_streamnum_to_channel {nr} {
421    return ec_queue$nr
422}
423
424proc ec_streamname_to_channel {eclipse_name} {
425    return [ec_streamnum_to_channel [ec_stream_nr $eclipse_name]]
426}
427
428proc ec_streamname_to_streamnum {eclipse_name} {
429    return [ec_stream_nr $eclipse_name]
430}
431
432proc ec_channel_to_streamnum {channel} {
433    if {![regexp {^ec_queue([0-9]+)$} $channel cname nr]} {
434	error "$channel is not a valid channel name for a ECLiPSe-Tcl queue."
435    }
436    return $nr
437}
438
439#----------------------------------------------------------------------
440# interface type + info
441#----------------------------------------------------------------------
442
443proc ec_interface_type {} {
444    return embedded
445}
446
447proc ec_peer_name {} {
448    global tkecl
449
450    if [info exists tkecl(ec_peer_name)] {
451	return $tkecl(ec_peer_name)
452    } else {
453	error "ECLiPSe side not yet initialised."
454    }
455}
456
457#----------------------------------------------------------------------
458# Load the parts of the interface which are implemented in C:
459#
460# ec_init_
461# ec_cleanup
462# ec_set_option
463# ec_post_goal
464# ec_post_event
465# ec_resume_
466# ec_running
467# ec_handle_events_
468# ec_queue_write
469# ec_queue_read
470# ec_stream_nr
471# ec_queue_open_
472# ec_read_exdr
473# ec_tcl2exdr
474# ec_exdr2tcl
475#
476# CAUTION: ECLIPSEDIR is derived from the location of this Tcl file!
477# Before loading tkeclipse.so we cd to the right directory in order
478# to be able to find the dependencies without LD_LIBRARY_PATH.
479#----------------------------------------------------------------------
480
481set eclipsedir [file dirname [file dirname [info script]]]
482source [file join $eclipsedir lib_tcl eclipse_arch.tcl]
483
484set prev [pwd]
485cd [file join $eclipsedir lib [ec_arch]]
486if { [catch {
487	load [file join . tkexdr[info sharedlibextension]]
488	load [file join . tkeclipse[info sharedlibextension]]
489    } error]
490 } {
491    cd $prev
492    error "Problem loading the ECLiPSe shared libraries: $error"
493}
494cd $prev
495
496
497#----------------------------------------------------------------------
498# Set defaults
499# The user can change these before calling ec_init
500#----------------------------------------------------------------------
501
502# use queues for stdin/stdout/stderr and connect them to popups for now
503ec_set_option io 2
504set ec_queue_in_handlers(0) "ec_stream_input_popup {Input expected on ECLiPSe input stream:}"
505set ec_queue_out_handlers(1) "ec_stream_output_popup {Output occurred on ECLiPSe output stream:}"
506set ec_queue_out_handlers(2) "ec_stream_output_popup {Output occurred on ECLiPSe error stream:}"
507return ok
508
509