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