1# BEGIN LICENSE BLOCK 2# Version: CMPL 1.1 3# 4# The contents of this file are subject to the Cisco-style Mozilla Public 5# License Version 1.1 (the "License"); you may not use this file except 6# in compliance with the License. You may obtain a copy of the License 7# at www.eclipse-clp.org/license. 8# 9# Software distributed under the License is distributed on an "AS IS" 10# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 11# the License for the specific language governing rights and limitations 12# under the License. 13# 14# The Original Code is The ECLiPSe Constraint Logic Programming System. 15# The Initial Developer of the Original Code is Cisco Systems, Inc. 16# Portions created by the Initial Developer are 17# Copyright (C) 2006 Cisco Systems, Inc. All Rights Reserved. 18# 19# Contributor(s): 20# 21# END LICENSE BLOCK 22# 23# $Id: tkec_remote.tcl,v 1.1 2006/09/23 01:54:19 snovello Exp $ 24# 25# This file contains some primitive procedures that are needed to 26# connect ECLiPSe to Tcl via the remote interface 27# 28# Do NOT include any development support here! 29# Do NOT assume the existence of an interactive ECLiPSe toplevel! 30# 31 32package provide remote_eclipse 1.0 33 34# remote protocol version. Must correspond to the ECLiPSe version; 35# which is accessed via get_flag(remote_protocol_version, V) 36set ec_remote(ec_remote_version) {remote_protocol 1} 37 38set ec_remote(ec_running) 1 39set ec_remote(ec_connected) 0 40set ec_remote(interaction_nesting) 0 41set ec_remote(ec_running_start_command) {} 42set ec_remote(ec_yield_command) {} 43set ec_remote(ec_running_end_command) {} 44set ec_remote(ec_disconnect_command) {} 45 46proc ec_running_set_commands {{startcmd {}} {endcmd {}} {yieldcmd {}} {disconcmd {}}} { 47 global ec_remote 48 49 set ec_remote(ec_running_start_command) $startcmd 50 set ec_remote(ec_running_end_command) $endcmd 51 set ec_remote(ec_yield_command) $yieldcmd 52 set ec_remote(ec_disconnect_command) $disconcmd 53} 54 55proc ec_running {} { 56 global ec_remote 57 58 return $ec_remote(ec_running) 59} 60 61proc ec_connected {} { 62 global ec_remote 63 64 return $ec_remote(ec_connected) 65} 66 67proc ec_resume {{type resume} {format ()}} { 68 global ec_remote 69 70 if {[ec_running]} { 71 error "Calling ec_resume while ECLiPSe side has control" 72 } 73 74 while {1} { 75 set ec_remote(ec_running) 1 76 if {$ec_remote(ec_running_start_command) != {}} { 77 eval $ec_remote(ec_running_start_command) 78 } 79 ec_write_exdr $ec_remote(ec_rpc_control_channel) $type $format 80 flush $ec_remote(ec_rpc_control_channel) ;# this hands over to ECLiPSe 81 82 incr ec_remote(interaction_nesting) 1 83 if [catch {wait_ecyield $type} return] { 84 ;# if error occurs, unilaterally disconnect 85 ec_disconnect_tcl_side 86 set return disconnect 87 } 88 incr ec_remote(interaction_nesting) -1 89 90 ;# execute yield command if at outer level and not disconnected 91 if {($ec_remote(ec_yield_command) != {} && \ 92 $ec_remote(interaction_nesting) == 0 && $return != "disconnect")} { 93 eval $ec_remote(ec_yield_command) 94 } 95 if {$return != "resume"} { 96 break ;# break out of resume 97 } else { 98 set type resume 99 set format () 100 } 101 } 102 return $return 103} 104 105 106proc wait_ecyield {type} { 107 global ec_remote 108 109 update idletasks ;# update windows before handing over 110 if [catch {ec_read_exdr $ec_remote(ec_rpc_control_channel)} reslist] { 111 ;# cannot read from control channel, assume connection lost... 112 ;# Tk bug: the tk_messageBox freezes the whole program! 113# tk_messageBox -icon error -type ok -message "Control connection to ECLiPSe lost" 114 error "connection to eclipse side lost" 115 } 116 117 set ec_remote(ec_running) 0 118 if {$ec_remote(ec_running_end_command) != {}} { 119 eval $ec_remote(ec_running_end_command) 120 } 121 122 set res [lindex $reslist 0] 123 switch $res { 124 ec_flushio { 125 set stream [lindex $reslist 1] 126 set length [lindex $reslist 2] 127 if [catch "ec_flushio_stream $stream $length" err] { 128 tk_messageBox -icon error -type ok -message $err 129 } 130 131 update 132 if {$type == "rpc"} { 133 return [ec_resume resume] 134 } else { 135 return resume 136 } 137 } 138 ec_waitio { 139 set stream [lindex $reslist 1] 140 if [catch "ec_waitio_stream $stream" err] { 141 tk_messageBox -icon error -type ok -message $err 142 } 143 144 update 145 if {$type == "rpc"} { 146 return [ec_resume resume] 147 } else { 148 return resume 149 } 150 } 151 yield { 152 return yield 153 } 154 socket_client { 155 set port [lindex $reslist 1] 156 set eclipse_name [lindex $reslist 2] 157 set queue_type [lindex $reslist 3] 158 set access [lindex $reslist 4] 159 if {$queue_type == "sync"} { 160 ec_sync_queue_connect $port $eclipse_name $access 161 } else { 162 ec_async_queue_connect $port $eclipse_name 163 } 164 return resume 165 } 166 socket_accept { 167 if {[lindex $type 0] == "socket_connect"} { 168 ;# must be a reply to a resume on socket_connect 169 set eclipse_name [lindex $reslist 1] 170 set nr [lindex $reslist 2] 171 if {[lindex $type 1] == $eclipse_name} { 172 ;# eclipse queue name must be the same 173 if {$nr == "fail"} { 174 if [info exists ec_remote(name_channel,$eclipse_name)] { 175 close $ec_remote(name_channel,$eclipse_name) 176 unset $ec_remote(name_channel,$eclipse_name) 177 178 } 179 tk_messageBox -icon error -type ok -message "Unable to establish queue connection $eclipse_name with host ECLiPSe" 180 181 } else { 182 ;# set the book-keeping info 183 set socketchannel $ec_remote(name_channel,$eclipse_name) 184 185 set ec_remote(nr_name,$nr) $eclipse_name 186 set ec_remote(channel_nr,$socketchannel) $nr 187 } 188 return socket_accept 189 } 190 ;# error has occurred 191 error "Unexpected control messages received during queue creation" 192 } 193 return socket_accept 194 } 195 queue_close { 196 set nr [lindex $reslist 1] 197 close_queue_tcl_side $nr 198 return resume 199 } 200 201 disconnect { 202 ec_disconnect eclipse 203 return disconnect 204 } 205 disconnect_yield { 206 ;# perform disconnection on Tcl side 207 ec_disconnect_tcl_side 208 return disconnect 209 } 210 default { 211 error "Unexpected return from ec_resume: $reslist" 212 } 213 } 214} 215 216 217 218 219#---------------------------------------------------------------------- 220# Handling ECLiPSe queues 221#---------------------------------------------------------------------- 222 223proc ec_queue_create {eclipse_name access {command {}} {event {}}} { 224 global ec_queue_out_handlers ec_queue_in_handlers 225 global ec_remote 226 227 if {(($command != {}) && ($event != {}))} { 228 error "Cannot define handlers on both ECLiPSe and Tcl sides for a synchronous queue $eclipse_name" 229 } 230 231 switch -- $access { 232 fromec - 233 r { 234 set access fromec ;# ec_mode is the mode on ECLiPSe side 235 } 236 237 toec - 238 w { 239 set access toec 240 } 241 242 default {error "$access is an invalid access mode for remote ECLiPSe synchrnous queue ($eclipse_name)"} 243 } 244 245 if [info exists ec_remote(name_channel,$eclipse_name)] { 246 error "Queue name $eclipse_name already in use (ec_queue_create)" 247 } 248 249 ec_resume [list queue_create $eclipse_name sync $access [list $event]] {(()()()())} 250 if [info exists ec_remote(name_channel,$eclipse_name)] { 251 if {$command != ""} { 252 ec_set_queue_handler $eclipse_name $access $command 253 } 254 ;# return the channel name as per embedded interface 255 return $ec_remote(name_channel,$eclipse_name) 256 } else { 257 ;# something went wrong; queue not created 258 error "Unable to create queue $eclipse_name in ec_queue_create" 259 } 260} 261 262proc ec_queue_close {eclipse_name} { 263 global ec_remote 264 265 if [catch "set nr [ec_streamname_to_streamnum $eclipse_name]"] { 266 error "No such ECLiPSe queue $eclipse_name in ec_queue_close" 267 } else { 268 ec_resume [list queue_close $nr] {(I)} 269 close_queue_tcl_side $nr 270 } 271 272} 273 274proc close_queue_tcl_side {nr} { 275 global ec_remote 276 277 if [info exists ec_remote(nr_name,$nr)] { 278 set name $ec_remote(nr_name,$nr) 279 unset ec_remote(nr_name,$nr) 280 set channel $ec_remote(name_channel,$name) 281 unset ec_remote(name_channel,$name) 282 unset ec_remote(channel_nr,$channel) 283 catch {close $channel} 284 } 285} 286 287proc ec_sync_queue_connect {port eclipse_name access} { 288 global ec_remote 289 290 set try 1 291 while {1} { 292 if [catch "socket $ec_remote(host) $port" socketchannel] { 293 incr try 294 if {$try > 10} { 295 set status fail 296 set socketchannel fail 297 break 298 } 299 } else { 300 set status success 301 set ec_remote(name_channel,$eclipse_name) $socketchannel 302 303 switch $access { 304 fromec { 305 fconfigure $socketchannel -translation binary -blocking 1 306 } 307 toec { 308 fconfigure $socketchannel -translation binary -blocking 0 309 } 310 } 311 break 312 } 313 } 314 315 ec_resume [list socket_connect $eclipse_name $status] {(()())} 316 return socketchannel 317} 318 319proc ec_async_queue_create {eclipse_name {access {}} {rcommand {}} {wevent {}}} { 320 global ec_remote 321 322 if {$access == "r"} { 323 set access fromec 324 } elseif {$access == "w"} { 325 set access toec 326 } 327 328 if [info exists ec_remote(name_channel,$eclipse_name)] { 329 error "Queue name $eclipse_name already in use (ec_async_queue_create)" 330 } 331 332 ec_resume [list queue_create $eclipse_name async $access [list $wevent]] {(()()()())} 333 if [info exists ec_remote(name_channel,$eclipse_name)] { 334 ec_set_queue_handler $eclipse_name r $rcommand 335 return $ec_remote(name_channel,$eclipse_name) 336 } else { 337 ;# something went wrong; queue not created 338 error "Unable to create queue $eclipse_name in ec_async_queue_create" 339 } 340} 341 342proc ec_async_queue_connect {port eclipse_name} { 343 global ec_remote 344 345 set try 1 346 while {1} { 347 if [catch "socket $ec_remote(host) $port" socketchannel] { 348 incr try 349 if {$try > 10} { 350 set status fail 351 set socketchannel fail 352 break 353 } 354 } else { 355 set status success 356 set ec_remote(name_channel,$eclipse_name) $socketchannel 357 358 fconfigure $socketchannel -blocking 0 -translation binary 359 break 360 } 361 } 362 363 ec_resume [list socket_connect $eclipse_name $status] {(()())} 364 set ec_remote(async,$eclipse_name) 1 ;# is a asynchron. stream 365 return $socketchannel 366} 367 368 369proc ec_async_io {stream command} { 370 set socketchannel [ec_streamnum_to_channel $stream] 371 if [eof $socketchannel] { 372 catch {close $socketchannel} 373 tk_messageBox -icon error -type ok -message "Connection for remote queue $stream to ECLiPSe lost" 374 return 375 } 376 eval $command $stream 377} 378 379# mapping from ECLiPSe stream name to Tcl channel name 380proc ec_streamname_to_channel {eclipse_name} { 381 global ec_remote 382 383 if [info exists ec_remote(name_channel,$eclipse_name)] { 384 return $ec_remote(name_channel,$eclipse_name) 385 } else { 386 error "No such ECLiPSe stream (ec_streamname_to_channel $eclipse_name)" 387 } 388} 389 390# mapping from ECLiPSe physical stream number to Tcl channel name 391proc ec_streamnum_to_channel {nr} { 392 global ec_remote 393 394 if [info exists ec_remote(nr_name,$nr)] { 395 return $ec_remote(name_channel,$ec_remote(nr_name,$nr)) 396 } else { 397 error "No such ECLiPSe stream (ec_streamnum_to_channel $nr)" 398 } 399} 400 401# mapping from Tcl channel name to ECLiPSe stream number 402proc ec_channel_to_streamnum {channel} { 403 global ec_remote 404 405 if [info exists ec_remote(channel_nr,$channel)] { 406 return $ec_remote(channel_nr,$channel) 407 } else { 408 error "No such ECLiPSe stream (ec_channel_to_streamnum $channel)" 409 } 410} 411 412# mapping from ECLiPSe stream name to physical number 413proc ec_streamname_to_streamnum {eclipse_name} { 414 global ec_remote 415 416 if [info exists ec_remote(name_channel,$eclipse_name)] { 417 return $ec_remote(channel_nr,$ec_remote(name_channel,$eclipse_name)) 418 } else { 419 error "No such ECLiPSe stream (ec_stream_nr $eclipse_name)" 420 } 421} 422 423proc ec_stream_nr {eclipse_name} { 424 ec_streamname_to_streamnum $eclipse_name 425} 426 427 428 429proc ec_write_exdr {channel data {format S}} { 430 puts -nonewline $channel [ec_tcl2exdr $data $format] 431} 432 433proc ec_flush {nr {len {}}} { 434 global ec_remote 435 436 if {![ec_running]} { 437 set channel [ec_streamnum_to_channel $nr] 438 flush $channel ;# non-blocking; may be buffered 439 if {$len != {}} { 440 ec_resume [list rem_flushio $nr $len] {(II)} 441 } else { 442 ec_resume [list rem_flushio $nr] {(I)} 443 } 444 } else { 445 error "Cannot perform an ec_flush while ECLiPSe is active." 446 } 447} 448 449proc ec_set_queue_handler {eclipse_name access command} { 450 global ec_queue_out_handlers ec_queue_in_handlers 451 global ec_remote 452 453 if [info exists ec_remote(async,$eclipse_name)] { 454 ;# async stream 455 switch -- $access { 456 fromec - 457 r { 458 if {$command != {}} { 459 set channel [ec_streamname_to_channel $eclipse_name] 460 set nr [ec_streamname_to_streamnum $eclipse_name] 461 fileevent $channel readable "eval ec_async_io $nr $command " 462 } 463 } 464 465 toec - 466 w { 467 if {$command != {}} { 468 error "Cannot specify a write handler with asynchronous queues" 469 } 470 } 471 472 default { error "ec_set_queue_handler: bad access mode, should be r" } 473 } 474 475 } else { 476 ;# non-async stream 477 switch -- $access { 478 fromec - 479 r { 480 set ec_queue_out_handlers([ec_stream_nr $eclipse_name]) $command 481 } 482 483 toec - 484 w { 485 set ec_queue_in_handlers([ec_stream_nr $eclipse_name]) $command 486 } 487 default { error "ec_set_queue_handler: bad access mode, should be r or w" } 488 } 489 } 490} 491 492 493proc ec_flushio_stream {stream length} { 494 global ec_queue_out_handlers ec_socketstream_r 495 496 set channel [ec_streamnum_to_channel $stream] 497 if [eof $channel] { 498 catch {close $channel} 499 tk_messageBox -icon error -type ok -message "Connection for remote queue $stream to ECLiPSe lost" 500 return 501 } 502 if [info exists ec_queue_out_handlers($stream)] { 503 eval $ec_queue_out_handlers($stream) $stream $length 504 } else { 505 ec_stream_output_popup "Output occurred on ECLiPSe stream $stream" $stream $length 506 } 507} 508 509proc ec_waitio_stream {stream} { 510 global ec_queue_in_handlers 511 512 set channel [ec_streamnum_to_channel $stream] 513 if [eof $channel] { 514 catch {close $channel} 515 tk_messageBox -icon error -type ok -message "Connection for remote queue $stream lost" 516 return 517 } 518 519 if [info exists ec_queue_in_handlers($stream)] { 520 eval $ec_queue_in_handlers($stream) $stream 521 } else { 522 ec_stream_input_popup "Input expected on ECLiPSe stream $stream" $stream 523 } 524} 525 526proc ec_queue_write {eclipse_name data} { 527 puts -nonewline [ec_streamname_to_channel $eclipse_name] $data 528} 529 530proc ec_queue_read {eclipse_name size} { 531 read [ec_streamname_to_channel $eclipse_name] $size 532} 533 534#--------------------------------------------------------------------- 535# Disconnect 536#--------------------------------------------------------------------- 537 538# disconnect from ECLiPSe. side is the side that initiated 539proc ec_disconnect {{side tcl}} { 540 global ec_remote 541 542 switch -- $side { 543 tcl { 544 if {[ec_connected]} { 545 # only need to disconnect if still connected. 546 if {![ec_running]} { 547 if {[ec_resume disconnect] == "disconnect"} { 548 ;# disconnect status returned only when disconnect on Tcl 549 ;# side has occurred 550 return 551 } else { 552 ;# something is wrong... disconnect on Tcl side anyway 553 tk_messageBox -icon error -type ok -message "Unexpected response from ELiPSe to disconnect request.\n ECLiPSe side may not have disconnected properly." 554 ec_disconnect_tcl_side 555 } 556 557 } else { 558 ;# eclipse running currently, so disconnect cannot be done 559 ;# in both directions at the moment. Disconnect at Tcl end 560 ;# only 561 ec_write_exdr $ec_remote(ec_rpc_control_channel) disconnect_resume () 562 flush $ec_remote(ec_rpc_control_channel) 563 ec_disconnect_tcl_side 564 } 565 } 566 567 } 568 569 eclipse { 570 ec_write_exdr $ec_remote(ec_rpc_control_channel) disconnect_resume () 571 flush $ec_remote(ec_rpc_control_channel) 572 ec_disconnect_tcl_side 573 574 } 575 } 576 577} 578 579#------------------------------------------------------------------ 580# Disconnect actions on Tcl side 581#------------------------------------------------------------------ 582proc ec_disconnect_tcl_side {} { 583 global ec_remote 584 585 catch {close $ec_remote(ec_rpc_in_channel)} 586 set ec_remote(ec_rpc_in_channel) {} 587 set ec_remote(ec_rpc_out_channel) {} 588 589 catch {close $ec_remote(ec_rpc_control_channel)} 590 set ec_remote(ec_rpc_control_channel) {} 591 592 foreach streamindex [array names ec_remote name_channel,* ] { 593 close_queue_tcl_side [ec_channel_to_streamnum $ec_remote($streamindex)] 594 } 595 596 set ec_remote(ec_running) 1 597 set ec_remote(ec_connected) 0 598 if {$ec_remote(ec_disconnect_command) != {}} { 599 eval $ec_remote(ec_disconnect_command) 600 } 601} 602 603#---------------------------------------------------------------------- 604# Sample stream I/O handlers 605#---------------------------------------------------------------------- 606 607set ec_stream_input_string {} 608 609proc ec_stream_input_popup {Msg Stream} { 610 global ec_stream_input_string 611 612 toplevel .ec_stream_input_box 613 label .ec_stream_input_box.prompt -width 40 -text $Msg 614 entry .ec_stream_input_box.input -bg white -width 40 -textvariable ec_stream_input_string 615 button .ec_stream_input_box.clear -text "clear" -command {.ec_stream_input_box.input delete 0 end} 616 button .ec_stream_input_box.ok -text "ok" -command {destroy .ec_stream_input_box} 617 bind .ec_stream_input_box.input <Return> {destroy .ec_stream_input_box} 618 619 pack .ec_stream_input_box.prompt -side top -fill x 620 pack .ec_stream_input_box.input -side top -fill x 621 pack .ec_stream_input_box.clear -side left -expand 1 -fill x 622 pack .ec_stream_input_box.ok -side left -expand 1 -fill x 623 624 focus .ec_stream_input_box.input 625 tkwait window .ec_stream_input_box 626 puts -nonewline [ec_streamnum_to_channel $Stream] $ec_stream_input_string 627 ec_flush $Stream [string length $ec_stream_input_string] 628} 629 630 631# Sample queue_out_handler: output into text widget 632 633proc ec_stream_to_window_sync {Tag Window Stream Length} { 634 635 set channel [ec_streamnum_to_channel $Stream] 636 if [eof $channel] { 637 catch {close $socketchannel} 638 tk_messageBox -icon error -type ok -message "Connection for remote queue $Stream to ECLiPSe lost" 639 return 640 } 641 642 set data [read $channel $Length] 643 644 $Window insert end $data $Tag 645 $Window see end 646} 647 648 649proc ec_stream_to_window {Tag Window Stream} { 650 651 set channel [ec_streamnum_to_channel $Stream] 652 if [eof $channel] { 653 catch {close $socketchannel} 654 tk_messageBox -icon error -type ok -message "Connection for remote queue $Stream to ECLiPSe lost" 655 return 656 } 657 658 set data [read $channel 2000] 659 660 while {$data != ""} { 661 regexp {^([0-9]+)[.]([0-9]+)$} [$Window index end-1char] whole line charp 662 if {$charp < 2000} { 663 ;# always truncate 664 $Window insert end $data $Tag 665 } else { 666 ;# truncate printing of line if too long 667 if {[lsearch [$Window tag names] trunc] != -1} { 668 ;# not yet defined... 669 $Window tag configure trunc -background pink 670 } 671 if {[lsearch [$Window tag names end-2char] trunc] == -1} { 672 ;# line is first truncated. Note -2 needed (rather than -1) 673 $Window insert end "..." trunc 674 } 675 set nl [string first "\n" $data] 676 if {$nl != -1} { 677 ;# if there is a nl, then a new line was started 678 $Window insert end [string range $data $nl end] $Tag 679 } 680 } 681 update idletasks 682 set data [read $channel 1000] 683 } 684 685 $Window see end 686} 687 688# Sample queue_out_handler: output into message popup 689 690proc ec_stream_output_popup {Msg Stream length} { 691 if ![winfo exists .ec_stream_output_box] { 692 toplevel .ec_stream_output_box 693 label .ec_stream_output_box.msg -width 40 -text $Msg 694 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" 695 scrollbar .ec_stream_output_box.vscroll -command ".ec_stream_output_box.text yview" 696 scrollbar .ec_stream_output_box.hscroll -command ".ec_stream_output_box.text xview" -orient horizontal 697 button .ec_stream_output_box.ok -text "ok" -command {destroy .ec_stream_output_box} 698 pack .ec_stream_output_box.msg -side top -fill x 699 pack .ec_stream_output_box.ok -side bottom -fill x 700 pack .ec_stream_output_box.vscroll -side left -fill y 701 pack .ec_stream_output_box.hscroll -side bottom -fill x 702 pack .ec_stream_output_box.text -expand 1 -fill both 703 } 704 ec_stream_to_window_sync {} .ec_stream_output_box.text $Stream $length 705} 706 707 708 709 710#---------------------------------------------------------------------- 711# ec_rpc goal ?format? 712# returns: instantiated goal, "fail" or "throw" 713#---------------------------------------------------------------------- 714 715 716proc ec_rpc {Goal {Format S}} { 717 global ec_remote 718 719 if {[ec_running]} { 720 error "Cannot perform an rpc while ECLiPSe is active or disconnected" 721 } 722 ec_write_exdr $ec_remote(ec_rpc_out_channel) $Goal $Format 723 flush $ec_remote(ec_rpc_out_channel) 724 725 set return [ec_resume rpc] ;# hand over to ECLiPSe for rpc 726 if {$return != "disconnect"} { 727 ec_read_exdr $ec_remote(ec_rpc_in_channel) 728 } 729} 730 731 732#---------------------------------------------------------------------- 733# Load the parts of the interface which are implemented in C: 734# 735# ec_read_exdr 736# ec_tcl2exdr 737# ec_exdr2tcl 738#---------------------------------------------------------------------- 739 740set eclipsedir [file dirname [file dirname [info script]]] 741source [file join $eclipsedir lib_tcl eclipse_arch.tcl] 742load [file join $eclipsedir lib [ec_arch] tkexdr[info sharedlibextension]] 743 744 745# obsolete, for compatibility only 746proc ec_control_name {} { 747 return [ec_control_name] 748} 749 750#---------------------------------------------------------------------- 751# Init 752#---------------------------------------------------------------------- 753 754proc ec_remote_init {host port {init {}} {pass {}} {format S}} { 755 756 global ec_remote 757 758 set ec_remote(ec_running) 0 759 set ec_remote(host) $host 760 set ec_remote(port) $port 761 set ec_remote(ec_rpc_control_channel) [socket $ec_remote(host) $ec_remote(port)] 762 fconfigure $ec_remote(ec_rpc_control_channel) -blocking 1 -translation binary 763 ec_write_exdr $ec_remote(ec_rpc_control_channel) $ec_remote(ec_remote_version) (I) 764 flush $ec_remote(ec_rpc_control_channel) 765 set version_response [ec_read_exdr $ec_remote(ec_rpc_control_channel)] 766 if {$version_response != "yes"} { 767 close $ec_remote(ec_rpc_control_channel) 768 error "Incompatible remote versions. Expect $ec_remote(ec_remote_version), got $version_response" 769 } 770 ec_write_exdr $ec_remote(ec_rpc_control_channel) $pass $format 771 flush $ec_remote(ec_rpc_control_channel) 772 set ec_remote(control_stream) [ec_read_exdr $ec_remote(ec_rpc_control_channel)] 773 ;# get ECLiPSe name of rpc control stream 774 ec_write_exdr $ec_remote(ec_rpc_control_channel) tcl 775 flush $ec_remote(ec_rpc_control_channel) 776 set ec_remote(ec_rpc_in_channel) [socket $ec_remote(host) $ec_remote(port)] 777 fconfigure $ec_remote(ec_rpc_in_channel) -blocking 1 -translation binary 778 set ec_remote(ec_rpc_out_channel) $ec_remote(ec_rpc_in_channel) 779 if {[ec_read_exdr $ec_remote(ec_rpc_in_channel)] != $ec_remote(control_stream)} { 780 ec_disconnect 781 } else { 782 set ec_remote(ec_connected) 1 783 if {$init != {}} { 784 eval $init 785 } 786 } 787# ec_resume resume 788} 789 790# cope with Tcl side root window dying properly 791wm protocol . WM_DELETE_WINDOW "ec_disconnect tcl; exit" 792 793#------------------------------------------------------------------------ 794# interface type + info 795#------------------------------------------------------------------------ 796 797proc ec_interface_type {} { 798 return remote 799} 800 801proc ec_peer_name {} { 802 global ec_remote 803 804 if [info exists ec_remote(control_stream)] { 805 return $ec_remote(control_stream) 806 } else { 807 error "Connection with ECLiPSe not yet established." 808 } 809 810} 811 812 813 814 815