1# comm.tcl -- 2# 3# socket-based 'send'ing of commands between interpreters. 4# 5# %%_OSF_FREE_COPYRIGHT_%% 6# Copyright (C) 1995-1998 The Open Group. All Rights Reserved. 7# (Please see the file "comm.LICENSE" that accompanied this source, 8# or http://www.opengroup.org/www/dist_client/caubweb/COPYRIGHT.free.html) 9# Copyright (c) 2003-2007 ActiveState Corporation 10# 11# This is the 'comm' package written by Jon Robert LoVerso, placed 12# into its own namespace during integration into tcllib. 13# 14# Note that the actual code was changed in several places (Reordered, 15# eval speedup) 16# 17# comm works just like Tk's send, except that it uses sockets. 18# These commands work just like "send" and "winfo interps": 19# 20# comm send ?-async? <id> <cmd> ?<arg> ...? 21# comm interps 22# 23# See the manual page comm.n for further details on this package. 24# 25# RCS: @(#) $Id: comm.tcl,v 1.33 2009/11/04 17:51:53 andreas_kupries Exp $ 26 27package require Tcl 8.3 28package require snit ; # comm::future objects. 29 30namespace eval ::comm { 31 namespace export comm comm_send 32 33 variable comm 34 array set comm {} 35 36 if {![info exists comm(chans)]} { 37 array set comm { 38 debug 0 chans {} localhost 127.0.0.1 39 connecting,hook 1 40 connected,hook 1 41 incoming,hook 1 42 eval,hook 1 43 callback,hook 1 44 reply,hook 1 45 lost,hook 1 46 offerVers {3 2} 47 acceptVers {3 2} 48 defVers 2 49 defaultEncoding "utf-8" 50 defaultSilent 0 51 } 52 set comm(lastport) [expr {[pid] % 32768 + 9999}] 53 # fast check for acceptable versions 54 foreach comm(_x) $comm(acceptVers) { 55 set comm($comm(_x),vers) 1 56 } 57 catch {unset comm(_x)} 58 } 59 60 # Class variables: 61 # lastport saves last default listening port allocated 62 # debug enable debug output 63 # chans list of allocated channels 64 # future,fid,$fid List of futures a specific peer is waiting for. 65 # 66 # Channel instance variables: 67 # comm() 68 # $ch,port listening port (our id) 69 # $ch,socket listening socket 70 # $ch,socketcmd command to use to create sockets. 71 # $ch,silent boolean to indicate whether to throw error on 72 # protocol negotiation failure 73 # $ch,local boolean to indicate if port is local 74 # $ch,interp interpreter to run received scripts in. 75 # If not empty we own it! = We destroy it 76 # with the channel 77 # $ch,events List of hoks to run in the 'interp', if defined 78 # $ch,serial next serial number for commands 79 # 80 # $ch,hook,$hook script for hook $hook 81 # 82 # $ch,peers,$id open connections to peers; ch,id=>fid 83 # $ch,fids,$fid reverse mapping for peers; ch,fid=>id 84 # $ch,vers,$id negotiated protocol version for id 85 # $ch,pending,$id list of outstanding send serial numbers for id 86 # 87 # $ch,buf,$fid buffer to collect incoming data 88 # $ch,result,$serial result value set here to wake up sender 89 # $ch,return,$serial return codes to go along with result 90 91 if {0} { 92 # Propagate result, code, and errorCode. Can't just eval 93 # otherwise TCL_BREAK gets turned into TCL_ERROR. 94 global errorInfo errorCode 95 set code [catch [concat commSend $args] res] 96 return -code $code -errorinfo $errorInfo -errorcode $errorCode $res 97 } 98} 99 100# ::comm::comm_send -- 101# 102# Convenience command. Replaces Tk 'send' and 'winfo' with 103# versions using the 'comm' variants. Multiple calls are 104# allowed, only the first one will have an effect. 105# 106# Arguments: 107# None. 108# 109# Results: 110# None. 111 112proc ::comm::comm_send {} { 113 proc send {args} { 114 # Use pure lists to speed this up. 115 uplevel 1 [linsert $args 0 ::comm::comm send] 116 } 117 rename winfo tk_winfo 118 proc winfo {cmd args} { 119 if {![string match in* $cmd]} { 120 # Use pure lists to speed this up ... 121 return [uplevel 1 [linsert $args 0 tk_winfo $cmd]] 122 } 123 return [::comm::comm interps] 124 } 125 proc ::comm::comm_send {} {} 126} 127 128# ::comm::comm -- 129# 130# See documentation for public methods of "comm". 131# This procedure is followed by the definition of 132# the public methods themselves. 133# 134# Arguments: 135# cmd Invoked method 136# args Arguments to method. 137# 138# Results: 139# As of the invoked method. 140 141proc ::comm::comm {cmd args} { 142 set method [info commands ::comm::comm_cmd_$cmd*] 143 144 if {[llength $method] == 1} { 145 set chan ::comm::comm; # passed to methods 146 return [uplevel 1 [linsert $args 0 $method $chan]] 147 } else { 148 foreach c [info commands ::comm::comm_cmd_*] { 149 # remove ::comm::comm_cmd_ 150 lappend cmds [string range $c 17 end] 151 } 152 return -code error "unknown subcommand \"$cmd\":\ 153 must be one of [join [lsort $cmds] {, }]" 154 } 155} 156 157proc ::comm::comm_cmd_connect {chan args} { 158 uplevel 1 [linsert $args 0 [namespace current]::commConnect $chan] 159} 160proc ::comm::comm_cmd_self {chan args} { 161 variable comm 162 return $comm($chan,port) 163} 164proc ::comm::comm_cmd_channels {chan args} { 165 variable comm 166 return $comm(chans) 167} 168proc ::comm::comm_cmd_configure {chan args} { 169 uplevel 1 [linsert $args 0 [namespace current]::commConfigure $chan 0] 170} 171proc ::comm::comm_cmd_ids {chan args} { 172 variable comm 173 set res $comm($chan,port) 174 foreach {i id} [array get comm $chan,fids,*] {lappend res $id} 175 return $res 176} 177interp alias {} ::comm::comm_cmd_interps {} ::comm::comm_cmd_ids 178proc ::comm::comm_cmd_remoteid {chan args} { 179 variable comm 180 if {[info exists comm($chan,remoteid)]} { 181 set comm($chan,remoteid) 182 } else { 183 return -code error "No remote commands processed yet" 184 } 185} 186proc ::comm::comm_cmd_debug {chan bool} { 187 variable comm 188 return [set comm(debug) [string is true -strict $bool]] 189} 190 191# ### ### ### ######### ######### ######### 192## API: Setup async result generation for a remotely invoked command. 193 194# (future,fid,<fid>) -> list (future) 195# (current,async) -> bool (default 0) 196# (current,state) -> list (chan fid cmd ser) 197 198proc ::comm::comm_cmd_return_async {chan} { 199 variable comm 200 201 if {![info exists comm(current,async)]} { 202 return -code error "No remote commands processed yet" 203 } 204 if {$comm(current,async)} { 205 # Return the same future which were generated by the first 206 # call. 207 return $comm(current,state) 208 } 209 210 foreach {cmdchan cmdfid cmd ser} $comm(current,state) break 211 212 # Assert that the channel performing the request and the channel 213 # the current command came in are identical. Panic if not. 214 215 if {![string equal $chan $cmdchan]} { 216 return -code error "Internal error: Trying to activate\ 217 async return for a command on a different channel" 218 } 219 220 # Establish the future for the command and return a handle for 221 # it. Remember the outstanding futures for a peer, so that we can 222 # cancel them if the peer is lost before the promise implicit in 223 # the future is redeemed. 224 225 set future [::comm::future %AUTO% $chan $cmdfid $cmd $ser] 226 227 lappend comm(future,fid,$cmdfid) $future 228 set comm(current,state) $future 229 230 # Mark the current command as using async result return. We do 231 # this last to ensure that all errors in this method are reported 232 # through the regular channels. 233 234 set comm(current,async) 1 235 236 return $future 237} 238 239# hook -- 240# 241# Internal command. Implements 'comm hook'. 242# 243# Arguments: 244# hook hook to modify 245# script Script to add/remove to/from the hook 246# 247# Results: 248# None. 249# 250proc ::comm::comm_cmd_hook {chan hook {script +}} { 251 variable comm 252 if {![info exists comm($hook,hook)]} { 253 return -code error "Unknown hook invoked" 254 } 255 if {!$comm($hook,hook)} { 256 return -code error "Unimplemented hook invoked" 257 } 258 if {[string equal + $script]} { 259 if {[catch {set comm($chan,hook,$hook)} ret]} { 260 return 261 } 262 return $ret 263 } 264 if {[string match +* $script]} { 265 append comm($chan,hook,$hook) \n [string range $script 1 end] 266 } else { 267 set comm($chan,hook,$hook) $script 268 } 269 return 270} 271 272# abort -- 273# 274# Close down all peer connections. 275# Implements the 'comm abort' method. 276# 277# Arguments: 278# None. 279# 280# Results: 281# None. 282 283proc ::comm::comm_cmd_abort {chan} { 284 variable comm 285 286 foreach pid [array names comm $chan,peers,*] { 287 commLostConn $chan $comm($pid) "Connection aborted by request" 288 } 289} 290 291# destroy -- 292# 293# Destroy the channel invoking it. 294# Implements the 'comm destroy' method. 295# 296# Arguments: 297# None. 298# 299# Results: 300# None. 301# 302proc ::comm::comm_cmd_destroy {chan} { 303 variable comm 304 catch {close $comm($chan,socket)} 305 comm_cmd_abort $chan 306 if {$comm($chan,interp) != {}} { 307 interp delete $comm($chan,interp) 308 } 309 catch {unset comm($chan,port)} 310 catch {unset comm($chan,local)} 311 catch {unset comm($chan,silent)} 312 catch {unset comm($chan,interp)} 313 catch {unset comm($chan,events)} 314 catch {unset comm($chan,socket)} 315 catch {unset comm($chan,socketcmd)} 316 catch {unset comm($chan,remoteid)} 317 unset comm($chan,serial) 318 unset comm($chan,chan) 319 unset comm($chan,encoding) 320 unset comm($chan,listen) 321 # array unset would have been nicer, but is not available in 322 # 8.2/8.3 323 foreach pattern {hook,* interp,* vers,*} { 324 foreach k [array names comm $chan,$pattern] {unset comm($k)} 325 } 326 set pos [lsearch -exact $comm(chans) $chan] 327 set comm(chans) [lreplace $comm(chans) $pos $pos] 328 if { 329 ![string equal ::comm::comm $chan] && 330 ![string equal [info proc $chan] ""] 331 } { 332 rename $chan {} 333 } 334 return 335} 336 337# shutdown -- 338# 339# Close down a peer connection. 340# Implements the 'comm shutdown' method. 341# 342# Arguments: 343# id Reference to the remote interp 344# 345# Results: 346# None. 347# 348proc ::comm::comm_cmd_shutdown {chan id} { 349 variable comm 350 351 if {[info exists comm($chan,peers,$id)]} { 352 commLostConn $chan $comm($chan,peers,$id) \ 353 "Connection shutdown by request" 354 } 355} 356 357# new -- 358# 359# Create a new comm channel/instance. 360# Implements the 'comm new' method. 361# 362# Arguments: 363# ch Name of the new channel 364# args Configuration, in the form of -option value pairs. 365# 366# Results: 367# None. 368# 369proc ::comm::comm_cmd_new {chan ch args} { 370 variable comm 371 372 if {[lsearch -exact $comm(chans) $ch] >= 0} { 373 return -code error "Already existing channel: $ch" 374 } 375 if {([llength $args] % 2) != 0} { 376 return -code error "Must have an even number of config arguments" 377 } 378 # ensure that the new channel name is fully qualified 379 set ch ::[string trimleft $ch :] 380 if {[string equal ::comm::comm $ch]} { 381 # allow comm to be recreated after destroy 382 } elseif {[string equal $ch [info commands $ch]]} { 383 return -code error "Already existing command: $ch" 384 } else { 385 # Create the new channel with fully qualified proc name 386 proc $ch {cmd args} { 387 set method [info commands ::comm::comm_cmd_$cmd*] 388 389 if {[llength $method] == 1} { 390 # this should work right even if aliased 391 # it is passed to methods to identify itself 392 set chan [namespace origin [lindex [info level 0] 0]] 393 return [uplevel 1 [linsert $args 0 $method $chan]] 394 } else { 395 foreach c [info commands ::comm::comm_cmd_*] { 396 # remove ::comm::comm_cmd_ 397 lappend cmds [string range $c 17 end] 398 } 399 return -code error "unknown subcommand \"$cmd\":\ 400 must be one of [join [lsort $cmds] {, }]" 401 } 402 } 403 } 404 lappend comm(chans) $ch 405 set chan $ch 406 set comm($chan,serial) 0 407 set comm($chan,chan) $chan 408 set comm($chan,port) 0 409 set comm($chan,listen) 0 410 set comm($chan,socket) "" 411 set comm($chan,local) 1 412 set comm($chan,silent) $comm(defaultSilent) 413 set comm($chan,encoding) $comm(defaultEncoding) 414 set comm($chan,interp) {} 415 set comm($chan,events) {} 416 set comm($chan,socketcmd) ::socket 417 418 if {[llength $args] > 0} { 419 if {[catch [linsert $args 0 commConfigure $chan 1] err]} { 420 comm_cmd_destroy $chan 421 return -code error $err 422 } 423 } 424 return $chan 425} 426 427# send -- 428# 429# Send command to a specified channel. 430# Implements the 'comm send' method. 431# 432# Arguments: 433# args see inside 434# 435# Results: 436# varies. 437# 438proc ::comm::comm_cmd_send {chan args} { 439 variable comm 440 441 set cmd send 442 443 # args = ?-async | -command command? id cmd ?arg arg ...? 444 set i 0 445 set opt [lindex $args $i] 446 if {[string equal -async $opt]} { 447 set cmd async 448 incr i 449 } elseif {[string equal -command $opt]} { 450 set cmd command 451 set callback [lindex $args [incr i]] 452 incr i 453 } 454 # args = id cmd ?arg arg ...? 455 456 set id [lindex $args $i] 457 incr i 458 set args [lrange $args $i end] 459 460 if {![info complete $args]} { 461 return -code error "Incomplete command" 462 } 463 if {![llength $args]} { 464 return -code error \ 465 "wrong # args: should be \"send ?-async? id arg ?arg ...?\"" 466 } 467 if {[catch {commConnect $chan $id} fid]} { 468 return -code error "Connect to remote failed: $fid" 469 } 470 471 set ser [incr comm($chan,serial)] 472 # This is unneeded - wraps from 2147483647 to -2147483648 473 ### if {$comm($chan,serial) == 0x7fffffff} {set comm($chan,serial) 0} 474 475 commDebug {puts stderr "<$chan> send <[list [list $cmd $ser $args]]>"} 476 477 # The double list assures that the command is a single list when read. 478 puts $fid [list [list $cmd $ser $args]] 479 flush $fid 480 481 commDebug {puts stderr "<$chan> sent"} 482 483 # wait for reply if so requested 484 485 if {[string equal command $cmd]} { 486 # In this case, don't wait on the command result. Set the callback 487 # in the return and that will be invoked by the result. 488 lappend comm($chan,pending,$id) [list $ser callback] 489 set comm($chan,return,$ser) $callback 490 return $ser 491 } elseif {[string equal send $cmd]} { 492 upvar 0 comm($chan,pending,$id) pending ;# shorter variable name 493 494 lappend pending $ser 495 set comm($chan,return,$ser) "" ;# we're waiting 496 497 commDebug {puts stderr "<$chan> --<<waiting $ser>>--"} 498 vwait ::comm::comm($chan,result,$ser) 499 500 # if connection was lost, pending is gone 501 if {[info exists pending]} { 502 set pos [lsearch -exact $pending $ser] 503 set pending [lreplace $pending $pos $pos] 504 } 505 506 commDebug { 507 puts stderr "<$chan> result\ 508 <$comm($chan,return,$ser);$comm($chan,result,$ser)>" 509 } 510 511 array set return $comm($chan,return,$ser) 512 unset comm($chan,return,$ser) 513 set thisres $comm($chan,result,$ser) 514 unset comm($chan,result,$ser) 515 switch -- $return(-code) { 516 "" - 0 {return $thisres} 517 1 { 518 return -code $return(-code) \ 519 -errorinfo $return(-errorinfo) \ 520 -errorcode $return(-errorcode) \ 521 $thisres 522 } 523 default {return -code $return(-code) $thisres} 524 } 525 } 526} 527 528############################################################################### 529 530# ::comm::commDebug -- 531# 532# Internal command. Conditionally executes debugging 533# statements. Currently this are only puts commands logging the 534# various interactions. These could be replaced with calls into 535# the 'log' module. 536# 537# Arguments: 538# arg Tcl script to execute. 539# 540# Results: 541# None. 542 543proc ::comm::commDebug {cmd} { 544 variable comm 545 if {$comm(debug)} { 546 uplevel 1 $cmd 547 } 548} 549 550# ::comm::commConfVars -- 551# 552# Internal command. Used to declare configuration options. 553# 554# Arguments: 555# v Name of configuration option. 556# t Default value. 557# 558# Results: 559# None. 560 561proc ::comm::commConfVars {v t} { 562 variable comm 563 set comm($v,var) $t 564 set comm(vars) {} 565 foreach c [array names comm *,var] { 566 lappend comm(vars) [lindex [split $c ,] 0] 567 } 568 return 569} 570::comm::commConfVars port p 571::comm::commConfVars local b 572::comm::commConfVars listen b 573::comm::commConfVars socket ro 574::comm::commConfVars socketcmd socketcmd 575::comm::commConfVars chan ro 576::comm::commConfVars serial ro 577::comm::commConfVars encoding enc 578::comm::commConfVars silent b 579::comm::commConfVars interp interp 580::comm::commConfVars events ev 581 582# ::comm::commConfigure -- 583# 584# Internal command. Implements 'comm configure'. 585# 586# Arguments: 587# force Boolean flag. If set the socket is reinitialized. 588# args New configuration, as -option value pairs. 589# 590# Results: 591# None. 592 593proc ::comm::commConfigure {chan {force 0} args} { 594 variable comm 595 596 # query 597 if {[llength $args] == 0} { 598 foreach v $comm(vars) {lappend res -$v $comm($chan,$v)} 599 return $res 600 } elseif {[llength $args] == 1} { 601 set arg [lindex $args 0] 602 set var [string range $arg 1 end] 603 if {![string match -* $arg] || ![info exists comm($var,var)]} { 604 return -code error "Unknown configuration option: $arg" 605 } 606 return $comm($chan,$var) 607 } 608 609 # set 610 set opt 0 611 foreach arg $args { 612 incr opt 613 if {[info exists skip]} {unset skip; continue} 614 set var [string range $arg 1 end] 615 if {![string match -* $arg] || ![info exists comm($var,var)]} { 616 return -code error "Unknown configuration option: $arg" 617 } 618 set optval [lindex $args $opt] 619 switch $comm($var,var) { 620 ev { 621 if {![string equal $optval ""]} { 622 set err 0 623 if {[catch { 624 foreach ev $optval { 625 if {[lsearch -exact {connecting connected incoming eval callback reply lost} $ev] < 0} { 626 set err 1 627 break 628 } 629 } 630 }]} { 631 set err 1 632 } 633 if {$err} { 634 return -code error \ 635 "Non-event to configuration option: -$var" 636 } 637 } 638 # FRINK: nocheck 639 set $var $optval 640 set skip 1 641 } 642 interp { 643 if { 644 ![string equal $optval ""] && 645 ![interp exists $optval] 646 } { 647 return -code error \ 648 "Non-interpreter to configuration option: -$var" 649 } 650 # FRINK: nocheck 651 set $var $optval 652 set skip 1 653 } 654 b { 655 # FRINK: nocheck 656 set $var [string is true -strict $optval] 657 set skip 1 658 } 659 v { 660 # FRINK: nocheck 661 set $var $optval 662 set skip 1 663 } 664 p { 665 if { 666 ![string equal $optval ""] && 667 ![string is integer $optval] 668 } { 669 return -code error \ 670 "Non-port to configuration option: -$var" 671 } 672 # FRINK: nocheck 673 set $var $optval 674 set skip 1 675 } 676 i { 677 if {![string is integer $optval]} { 678 return -code error \ 679 "Non-integer to configuration option: -$var" 680 } 681 # FRINK: nocheck 682 set $var $optval 683 set skip 1 684 } 685 enc { 686 # to configure encodings, we will need to extend the 687 # protocol to allow for handshaked encoding changes 688 return -code error "encoding not configurable" 689 if {[lsearch -exact [encoding names] $optval] == -1} { 690 return -code error \ 691 "Unknown encoding to configuration option: -$var" 692 } 693 set $var $optval 694 set skip 1 695 } 696 ro { 697 return -code error "Readonly configuration option: -$var" 698 } 699 socketcmd { 700 if {$optval eq {}} { 701 return -code error \ 702 "Non-command to configuration option: -$var" 703 } 704 705 set $var $optval 706 set skip 1 707 } 708 } 709 } 710 if {[info exists skip]} { 711 return -code error "Missing value for option: $arg" 712 } 713 714 foreach var {port listen local socketcmd} { 715 # FRINK: nocheck 716 if {[info exists $var] && [set $var] != $comm($chan,$var)} { 717 incr force 718 # FRINK: nocheck 719 set comm($chan,$var) [set $var] 720 } 721 } 722 723 foreach var {silent interp events} { 724 # FRINK: nocheck 725 if {[info exists $var] && ([set $var] != $comm($chan,$var))} { 726 # FRINK: nocheck 727 set comm($chan,$var) [set ip [set $var]] 728 if {[string equal $var "interp"] && ($ip != "")} { 729 # Interrogate the interp about its capabilities. 730 # 731 # Like: set, array set, uplevel present ? 732 # Or: The above, hidden ? 733 # 734 # This is needed to decide how to execute hook scripts 735 # and regular scripts in this interpreter. 736 set comm($chan,interp,set) [Capability $ip set] 737 set comm($chan,interp,aset) [Capability $ip array] 738 set comm($chan,interp,upl) [Capability $ip uplevel] 739 } 740 } 741 } 742 743 if {[info exists encoding] && 744 ![string equal $encoding $comm($chan,encoding)]} { 745 # This should not be entered yet 746 set comm($chan,encoding) $encoding 747 fconfigure $comm($chan,socket) -encoding $encoding 748 foreach {i sock} [array get comm $chan,peers,*] { 749 fconfigure $sock -encoding $encoding 750 } 751 } 752 753 # do not re-init socket 754 if {!$force} {return ""} 755 756 # User is recycling object, possibly to change from local to !local 757 if {[info exists comm($chan,socket)]} { 758 comm_cmd_abort $chan 759 catch {close $comm($chan,socket)} 760 unset comm($chan,socket) 761 } 762 763 set comm($chan,socket) "" 764 if {!$comm($chan,listen)} { 765 set comm($chan,port) 0 766 return "" 767 } 768 769 if {[info exists port] && [string equal "" $comm($chan,port)]} { 770 set nport [incr comm(lastport)] 771 } else { 772 set userport 1 773 set nport $comm($chan,port) 774 } 775 while {1} { 776 set cmd [list $comm($chan,socketcmd) -server [list ::comm::commIncoming $chan]] 777 if {$comm($chan,local)} { 778 lappend cmd -myaddr $comm(localhost) 779 } 780 lappend cmd $nport 781 if {![catch $cmd ret]} { 782 break 783 } 784 if {[info exists userport] || ![string match "*already in use" $ret]} { 785 # don't eradicate the class 786 if { 787 ![string equal ::comm::comm $chan] && 788 ![string equal [info proc $chan] ""] 789 } { 790 rename $chan {} 791 } 792 return -code error $ret 793 } 794 set nport [incr comm(lastport)] 795 } 796 set comm($chan,socket) $ret 797 fconfigure $ret -translation lf -encoding $comm($chan,encoding) 798 799 # If port was 0, system allocated it for us 800 set comm($chan,port) [lindex [fconfigure $ret -sockname] 2] 801 return "" 802} 803 804# ::comm::Capability -- 805# 806# Internal command. Interogate an interp for 807# the commands needed to execute regular and 808# hook scripts. 809 810proc ::comm::Capability {interp cmd} { 811 if {[lsearch -exact [interp hidden $interp] $cmd] >= 0} { 812 # The command is present, although hidden. 813 return hidden 814 } 815 816 # The command is not a hidden command. Use info to determine if it 817 # is present as regular command. Note that the 'info' command 818 # itself might be hidden. 819 820 if {[catch { 821 set has [llength [interp eval $interp [list info commands $cmd]]] 822 }] && [catch { 823 set has [llength [interp invokehidden $interp info commands $cmd]] 824 }]} { 825 # Unable to interogate the interpreter in any way. Assume that 826 # the command is not present. 827 set has 0 828 } 829 return [expr {$has ? "ok" : "no"}] 830} 831 832# ::comm::commConnect -- 833# 834# Internal command. Called to connect to a remote interp 835# 836# Arguments: 837# id Specification of the location of the remote interp. 838# A list containing either one or two elements. 839# One element = port, host is localhost. 840# Two elements = port and host, in this order. 841# 842# Results: 843# fid channel handle of the socket the connection goes through. 844 845proc ::comm::commConnect {chan id} { 846 variable comm 847 848 commDebug {puts stderr "<$chan> commConnect $id"} 849 850 # process connecting hook now 851 CommRunHook $chan connecting 852 853 if {[info exists comm($chan,peers,$id)]} { 854 return $comm($chan,peers,$id) 855 } 856 if {[lindex $id 0] == 0} { 857 return -code error "Remote comm is anonymous; cannot connect" 858 } 859 860 if {[llength $id] > 1} { 861 set host [lindex $id 1] 862 } else { 863 set host $comm(localhost) 864 } 865 set port [lindex $id 0] 866 set fid [$comm($chan,socketcmd) $host $port] 867 868 # process connected hook now 869 if {[catch { 870 CommRunHook $chan connected 871 } err]} { 872 global errorInfo 873 set ei $errorInfo 874 close $fid 875 error $err $ei 876 } 877 878 # commit new connection 879 commNewConn $chan $id $fid 880 881 # send offered protocols versions and id to identify ourselves to remote 882 puts $fid [list $comm(offerVers) $comm($chan,port)] 883 set comm($chan,vers,$id) $comm(defVers) ;# default proto vers 884 flush $fid 885 return $fid 886} 887 888# ::comm::commIncoming -- 889# 890# Internal command. Called for an incoming new connection. 891# Handles connection setup and initialization. 892# 893# Arguments: 894# chan logical channel handling the connection. 895# fid channel handle of the socket running the connection. 896# addr ip address of the socket channel 'fid' 897# remport remote port for the socket channel 'fid' 898# 899# Results: 900# None. 901 902proc ::comm::commIncoming {chan fid addr remport} { 903 variable comm 904 905 commDebug {puts stderr "<$chan> commIncoming $fid $addr $remport"} 906 907 # process incoming hook now 908 if {[catch { 909 CommRunHook $chan incoming 910 } err]} { 911 global errorInfo 912 set ei $errorInfo 913 close $fid 914 error $err $ei 915 } 916 917 # a list of offered proto versions is the first word of first line 918 # remote id is the second word of first line 919 # rest of first line is ignored 920 set protoline [gets $fid] 921 set offeredvers [lindex $protoline 0] 922 set remid [lindex $protoline 1] 923 924 commDebug {puts stderr "<$chan> offered <$protoline>"} 925 926 # use the first supported version in the offered list 927 foreach v $offeredvers { 928 if {[info exists comm($v,vers)]} { 929 set vers $v 930 break 931 } 932 } 933 if {![info exists vers]} { 934 close $fid 935 if {[info exists comm($chan,silent)] && 936 [string is true -strict $comm($chan,silent)]} then return 937 error "Unknown offered protocols \"$protoline\" from $addr/$remport" 938 } 939 940 # If the remote host addr isn't our local host addr, 941 # then add it to the remote id. 942 if {[string equal [lindex [fconfigure $fid -sockname] 0] $addr]} { 943 set id $remid 944 } else { 945 set id [list $remid $addr] 946 } 947 948 # Detect race condition of two comms connecting to each other 949 # simultaneously. It is OK when we are talking to ourselves. 950 951 if {[info exists comm($chan,peers,$id)] && $id != $comm($chan,port)} { 952 953 puts stderr "commIncoming race condition: $id" 954 puts stderr "peers=$comm($chan,peers,$id) port=$comm($chan,port)" 955 956 # To avoid the race, we really want to terminate one connection. 957 # However, both sides are committed to using it. 958 # commConnect needs to be synchronous and detect the close. 959 # close $fid 960 # return $comm($chan,peers,$id) 961 } 962 963 # Make a protocol response. Avoid any temptation to use {$vers > 2} 964 # - this forces forwards compatibility issues on protocol versions 965 # that haven't been invented yet. DON'T DO IT! Instead, test for 966 # each supported version explicitly. I.e., {$vers >2 && $vers < 5} is OK. 967 968 switch $vers { 969 3 { 970 # Respond with the selected version number 971 puts $fid [list [list vers $vers]] 972 flush $fid 973 } 974 } 975 976 # commit new connection 977 commNewConn $chan $id $fid 978 set comm($chan,vers,$id) $vers 979} 980 981# ::comm::commNewConn -- 982# 983# Internal command. Common new connection processing 984# 985# Arguments: 986# id Reference to the remote interp 987# fid channel handle of the socket running the connection. 988# 989# Results: 990# None. 991 992proc ::comm::commNewConn {chan id fid} { 993 variable comm 994 995 commDebug {puts stderr "<$chan> commNewConn $id $fid"} 996 997 # There can be a race condition two where comms connect to each other 998 # simultaneously. This code favors our outgoing connection. 999 1000 if {[info exists comm($chan,peers,$id)]} { 1001 # abort this connection, use the existing one 1002 # close $fid 1003 # return -code return $comm($chan,peers,$id) 1004 } else { 1005 set comm($chan,pending,$id) {} 1006 set comm($chan,peers,$id) $fid 1007 } 1008 set comm($chan,fids,$fid) $id 1009 fconfigure $fid -translation lf -encoding $comm($chan,encoding) -blocking 0 1010 fileevent $fid readable [list ::comm::commCollect $chan $fid] 1011} 1012 1013# ::comm::commLostConn -- 1014# 1015# Internal command. Called to tidy up a lost connection, 1016# including aborting ongoing sends. Each send should clean 1017# themselves up in pending/result. 1018# 1019# Arguments: 1020# fid Channel handle of the socket which got lost. 1021# reason Message describing the reason of the loss. 1022# 1023# Results: 1024# reason 1025 1026proc ::comm::commLostConn {chan fid reason} { 1027 variable comm 1028 1029 commDebug {puts stderr "<$chan> commLostConn $fid $reason"} 1030 1031 catch {close $fid} 1032 1033 set id $comm($chan,fids,$fid) 1034 1035 # Invoke the callbacks of all commands which have such and are 1036 # still waiting for a response from the lost peer. Use an 1037 # appropriate error. 1038 1039 foreach s $comm($chan,pending,$id) { 1040 if {[string equal "callback" [lindex $s end]]} { 1041 set ser [lindex $s 0] 1042 if {[info exists comm($chan,return,$ser)]} { 1043 set args [list -id $id \ 1044 -serial $ser \ 1045 -chan $chan \ 1046 -code -1 \ 1047 -errorcode NONE \ 1048 -errorinfo "" \ 1049 -result $reason \ 1050 ] 1051 if {[catch {uplevel \#0 $comm($chan,return,$ser) $args} err]} { 1052 commBgerror $err 1053 } 1054 } 1055 } else { 1056 set comm($chan,return,$s) {-code error} 1057 set comm($chan,result,$s) $reason 1058 } 1059 } 1060 unset comm($chan,pending,$id) 1061 unset comm($chan,fids,$fid) 1062 catch {unset comm($chan,peers,$id)} ;# race condition 1063 catch {unset comm($chan,buf,$fid)} 1064 1065 # Cancel all outstanding futures for requests which were made by 1066 # the lost peer, if there are any. This does not destroy 1067 # them. They will stay around until the long-running operations 1068 # they belong too kill them. 1069 1070 CancelFutures $fid 1071 1072 # process lost hook now 1073 catch {CommRunHook $chan lost} 1074 1075 return $reason 1076} 1077 1078proc ::comm::commBgerror {err} { 1079 # SF Tcllib Patch #526499 1080 # (See http://sourceforge.net/tracker/?func=detail&aid=526499&group_id=12883&atid=312883 1081 # for initial request and comments) 1082 # 1083 # Error in async call. Look for [bgerror] to report it. Same 1084 # logic as in Tcl itself. Errors thrown by bgerror itself get 1085 # reported to stderr. 1086 if {[catch {bgerror $err} msg]} { 1087 puts stderr "bgerror failed to handle background error." 1088 puts stderr " Original error: $err" 1089 puts stderr " Error in bgerror: $msg" 1090 flush stderr 1091 } 1092} 1093 1094# CancelFutures: Mark futures associated with a comm channel as 1095# expired, done when the connection to the peer has been lost. The 1096# marked futures will not generate result anymore. They will also stay 1097# around until destroyed by the script they belong to. 1098 1099proc ::comm::CancelFutures {fid} { 1100 variable comm 1101 if {![info exists comm(future,fid,$fid)]} return 1102 1103 commDebug {puts stderr "\tCanceling futures: [join $comm(future,fid,$fid) \ 1104 "\n\t : "]"} 1105 1106 foreach future $comm(future,fid,$fid) { 1107 $future Cancel 1108 } 1109 1110 unset comm(future,fid,$fid) 1111 return 1112} 1113 1114############################################################################### 1115 1116# ::comm::commCollect -- 1117# 1118# Internal command. Called from the fileevent to read from fid 1119# and append to the buffer. This continues until we get a whole 1120# command, which we then invoke. 1121# 1122# Arguments: 1123# chan logical channel collecting the data 1124# fid channel handle of the socket we collect. 1125# 1126# Results: 1127# None. 1128 1129proc ::comm::commCollect {chan fid} { 1130 variable comm 1131 upvar #0 comm($chan,buf,$fid) data 1132 1133 # Tcl8 may return an error on read after a close 1134 if {[catch {read $fid} nbuf] || [eof $fid]} { 1135 commDebug {puts stderr "<$chan> collect/lost eof $fid = [eof $fid]"} 1136 commDebug {puts stderr "<$chan> collect/lost nbuf = <$nbuf>"} 1137 commDebug {puts stderr "<$chan> collect/lost [fconfigure $fid]"} 1138 1139 fileevent $fid readable {} ;# be safe 1140 commLostConn $chan $fid "target application died or connection lost" 1141 return 1142 } 1143 append data $nbuf 1144 1145 commDebug {puts stderr "<$chan> collect <$data>"} 1146 1147 # If data contains at least one complete command, we will 1148 # be able to take off the first element, which is a list holding 1149 # the command. This is true even if data isn't a well-formed 1150 # list overall, with unmatched open braces. This works because 1151 # each command in the protocol ends with a newline, thus allowing 1152 # lindex and lreplace to work. 1153 # 1154 # This isn't true with Tcl8.0, which will return an error until 1155 # the whole buffer is a valid list. This is probably OK, although 1156 # it could potentially cause a deadlock. 1157 1158 # [AK] Actually no. This breaks down if the sender shoves so much 1159 # data at us so fast that the receiver runs into out of memory 1160 # before the list is fully well-formed and thus able to be 1161 # processed. 1162 1163 while {![catch { 1164 set cmdrange [Word0 data] 1165 # word0 is essentially the pre-8.0 'lindex <list> 0', getting 1166 # the first word of a list, even if the remainder is not fully 1167 # well-formed. Slight API change, we get the char indices the 1168 # word is between, and a relative index to the remainder of 1169 # the list. 1170 }]} { 1171 # Unpack the indices, then extract the word. 1172 foreach {s e step} $cmdrange break 1173 set cmd [string range $data $s $e] 1174 commDebug {puts stderr "<$chan> cmd <$data>"} 1175 if {[string equal "" $cmd]} break 1176 if {[info complete $cmd]} { 1177 # The word is a command, step to the remainder of the 1178 # list, and delete the word we have processed. 1179 incr e $step 1180 set data [string range $data $e end] 1181 after idle \ 1182 [list ::comm::commExec $chan $fid $comm($chan,fids,$fid) $cmd] 1183 } 1184 } 1185} 1186 1187proc ::comm::Word0 {dv} { 1188 upvar 1 $dv data 1189 1190 # data 1191 # 1192 # The string we expect to be either a full well-formed list, or a 1193 # well-formed list until the end of the first word in the list, 1194 # with non-wellformed data following after, i.e. an incomplete 1195 # list with a complete first word. 1196 1197 if {[regexp -indices "^\\s*(\{)" $data -> bracerange]} { 1198 # The word is brace-quoted, starting at index 'lindex 1199 # bracerange 0'. We now have to find the closing brace, 1200 # counting inner braces, ignoring quoted braces. We fail if 1201 # there is no proper closing brace. 1202 1203 foreach {s e} $bracerange break 1204 incr s ; # index of the first char after the brace. 1205 incr e ; # same. but this is our running index. 1206 1207 set level 1 1208 set max [string length $data] 1209 1210 while {$level} { 1211 # We are looking for the first regular or backslash-quoted 1212 # opening or closing brace in the string. If none is found 1213 # then the word is not complete, and we abort our search. 1214 1215 if {![regexp -indices -start $e {(([{}])|(\\[{}]))} $data -> any regular quoted]} { 1216 # ^^ ^ 1217 # |regular \quoted 1218 # any 1219 return -code error "no complete word found/1" 1220 } 1221 1222 foreach {qs qe} $quoted break 1223 foreach {rs re} $regular break 1224 1225 if {$qs >= 0} { 1226 # Skip quoted braces ... 1227 set e $qe 1228 incr e 1229 continue 1230 } elseif {$rs >= 0} { 1231 # Step one nesting level in or out. 1232 if {[string index $data $rs] eq "\{"} { 1233 incr level 1234 } else { 1235 incr level -1 1236 } 1237 set e $re 1238 incr e 1239 #puts @$e 1240 continue 1241 } else { 1242 return -code error "internal error" 1243 } 1244 } 1245 1246 incr e -2 ; # index of character just before the brace. 1247 return [list $s $e 2] 1248 1249 } elseif {[regexp -indices {^\s*(\S+)\s} $data -> wordrange]} { 1250 # The word is a simple literal which ends at the next 1251 # whitespace character. Note that there has to be a whitespace 1252 # for us to recognize a word, for while there is no whitespace 1253 # behind it in the buffer the word itself may be incomplete. 1254 1255 return [linsert $wordrange end 1] 1256 } 1257 1258 return -code error "no complete word found/2" 1259} 1260 1261# ::comm::commExec -- 1262# 1263# Internal command. Receives and executes a remote command, 1264# returning the result and/or error. Unknown protocol commands 1265# are silently discarded 1266# 1267# Arguments: 1268# chan logical channel collecting the data 1269# fid channel handle of the socket we collect. 1270# remoteid id of the other side. 1271# buf buffer containing the command to execute. 1272# 1273# Results: 1274# None. 1275 1276proc ::comm::commExec {chan fid remoteid buf} { 1277 variable comm 1278 1279 # buffer should contain: 1280 # send # {cmd} execute cmd and send reply with serial # 1281 # async # {cmd} execute cmd but send no reply 1282 # reply # {cmd} execute cmd as reply to serial # 1283 1284 # these variables are documented in the hook interface 1285 set cmd [lindex $buf 0] 1286 set ser [lindex $buf 1] 1287 set buf [lrange $buf 2 end] 1288 set buffer [lindex $buf 0] 1289 1290 # Save remoteid for "comm remoteid". This will only be valid 1291 # if retrieved before any additional events occur on this channel. 1292 # N.B. we could have already lost the connection to remote, making 1293 # this id be purely informational! 1294 set comm($chan,remoteid) [set id $remoteid] 1295 1296 # Save state for possible async result generation 1297 AsyncPrepare $chan $fid $cmd $ser 1298 1299 commDebug {puts stderr "<$chan> exec <$cmd,$ser,$buf>"} 1300 1301 switch -- $cmd { 1302 send - async - command {} 1303 callback { 1304 if {![info exists comm($chan,return,$ser)]} { 1305 commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""} 1306 return 1307 } 1308 1309 # Decompose reply command to assure it only uses "return" 1310 # with no side effects. 1311 1312 array set return {-code "" -errorinfo "" -errorcode ""} 1313 set ret [lindex $buffer end] 1314 set len [llength $buffer] 1315 incr len -2 1316 foreach {sw val} [lrange $buffer 1 $len] { 1317 if {![info exists return($sw)]} continue 1318 set return($sw) $val 1319 } 1320 1321 catch {CommRunHook $chan callback} 1322 1323 # this wakes up the sender 1324 commDebug {puts stderr "<$chan> --<<wakeup $ser>>--"} 1325 1326 # the return holds the callback command 1327 # string map the optional %-subs 1328 set args [list -id $id \ 1329 -serial $ser \ 1330 -chan $chan \ 1331 -code $return(-code) \ 1332 -errorcode $return(-errorcode) \ 1333 -errorinfo $return(-errorinfo) \ 1334 -result $ret \ 1335 ] 1336 set code [catch {uplevel \#0 $comm($chan,return,$ser) $args} err] 1337 catch {unset comm($chan,return,$ser)} 1338 1339 # remove pending serial 1340 upvar 0 comm($chan,pending,$id) pending 1341 if {[info exists pending]} { 1342 set pos [lsearch -exact $pending [list $ser callback]] 1343 if {$pos != -1} { 1344 set pending [lreplace $pending $pos $pos] 1345 } 1346 } 1347 if {$code} { 1348 commBgerror $err 1349 } 1350 return 1351 } 1352 reply { 1353 if {![info exists comm($chan,return,$ser)]} { 1354 commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""} 1355 return 1356 } 1357 1358 # Decompose reply command to assure it only uses "return" 1359 # with no side effects. 1360 1361 array set return {-code "" -errorinfo "" -errorcode ""} 1362 set ret [lindex $buffer end] 1363 set len [llength $buffer] 1364 incr len -2 1365 foreach {sw val} [lrange $buffer 1 $len] { 1366 if {![info exists return($sw)]} continue 1367 set return($sw) $val 1368 } 1369 1370 catch {CommRunHook $chan reply} 1371 1372 # this wakes up the sender 1373 commDebug {puts stderr "<$chan> --<<wakeup $ser>>--"} 1374 set comm($chan,result,$ser) $ret 1375 set comm($chan,return,$ser) [array get return] 1376 return 1377 } 1378 vers { 1379 set ::comm::comm($chan,vers,$id) $ser 1380 return 1381 } 1382 default { 1383 commDebug {puts stderr "<$chan> unknown command; discard \"$cmd\""} 1384 return 1385 } 1386 } 1387 1388 # process eval hook now 1389 set done 0 1390 set err 0 1391 if {[info exists comm($chan,hook,eval)]} { 1392 set err [catch {CommRunHook $chan eval} ret] 1393 commDebug {puts stderr "<$chan> eval hook res <$err,$ret>"} 1394 switch $err { 1395 1 { 1396 # error 1397 set done 1 1398 } 1399 2 - 3 { 1400 # return / break 1401 set err 0 1402 set done 1 1403 } 1404 } 1405 } 1406 1407 commDebug {puts stderr "<$chan> hook(eval) done=$done, err=$err"} 1408 1409 # exec command 1410 if {!$done} { 1411 commDebug {puts stderr "<$chan> exec ($buffer)"} 1412 1413 # Sadly, the uplevel needs to be in the catch to access the local 1414 # variables buffer and ret. These cannot simply be global because 1415 # commExec is reentrant (i.e., they could be linked to an allocated 1416 # serial number). 1417 1418 if {$comm($chan,interp) == {}} { 1419 # Main interpreter 1420 set thecmd [concat [list uplevel \#0] $buffer] 1421 set err [catch $thecmd ret] 1422 } else { 1423 # Redirect execution into the configured slave 1424 # interpreter. The exact command used depends on the 1425 # capabilities of the interpreter. A best effort is made 1426 # to execute the script in the global namespace. 1427 set interp $comm($chan,interp) 1428 1429 if {$comm($chan,interp,upl) == "ok"} { 1430 set thecmd [concat [list uplevel \#0] $buffer] 1431 set err [catch {interp eval $interp $thecmd} ret] 1432 } elseif {$comm($chan,interp,aset) == "hidden"} { 1433 set thecmd [linsert $buffer 0 interp invokehidden $interp uplevel \#0] 1434 set err [catch $thecmd ret] 1435 } else { 1436 set thecmd [concat [list interp eval $interp] $buffer] 1437 set err [catch $thecmd ret] 1438 } 1439 } 1440 } 1441 1442 # Check and handle possible async result generation. 1443 if {[AsyncCheck]} return 1444 1445 commSendReply $chan $fid $cmd $ser $err $ret 1446 return 1447} 1448 1449# ::comm::commSendReply -- 1450# 1451# Internal command. Executed to construct and send the reply 1452# for a command. 1453# 1454# Arguments: 1455# fid channel handle of the socket we are replying to. 1456# cmd The type of request (send, command) we are replying to. 1457# ser Serial number of the request the reply is for. 1458# err result code to place into the reply. 1459# ret result value to place into the reply. 1460# 1461# Results: 1462# None. 1463 1464proc ::comm::commSendReply {chan fid cmd ser err ret} { 1465 variable comm 1466 1467 commDebug {puts stderr "<$chan> res <$err,$ret> /$cmd"} 1468 1469 # The double list assures that the command is a single list when read. 1470 if {[string equal send $cmd] || [string equal command $cmd]} { 1471 # The catch here is just in case we lose the target. Consider: 1472 # comm send $other comm send [comm self] exit 1473 catch { 1474 set return [list return -code $err] 1475 # send error or result 1476 if {$err == 1} { 1477 global errorInfo errorCode 1478 lappend return -errorinfo $errorInfo -errorcode $errorCode 1479 } 1480 lappend return $ret 1481 if {[string equal send $cmd]} { 1482 set reply reply 1483 } else { 1484 set reply callback 1485 } 1486 puts $fid [list [list $reply $ser $return]] 1487 flush $fid 1488 } 1489 commDebug {puts stderr "<$chan> reply sent"} 1490 } 1491 1492 if {$err == 1} { 1493 commBgerror $ret 1494 } 1495 commDebug {puts stderr "<$chan> exec complete"} 1496 return 1497} 1498 1499proc ::comm::CommRunHook {chan event} { 1500 variable comm 1501 1502 # The documentation promises the hook scripts to have access to a 1503 # number of internal variables. For a regular hook we simply 1504 # execute it in the calling level to fulfill this. When the hook 1505 # is redirected into an interpreter however we do a best-effort 1506 # copying of the variable values into the interpreter. Best-effort 1507 # because the 'set' command may not be available in the 1508 # interpreter, not even hidden. 1509 1510 if {![info exists comm($chan,hook,$event)]} return 1511 set cmd $comm($chan,hook,$event) 1512 set interp $comm($chan,interp) 1513 commDebug {puts stderr "<$chan> hook($event) run <$cmd>"} 1514 1515 if { 1516 ($interp != {}) && 1517 ([lsearch -exact $comm($chan,events) $event] >= 0) 1518 } { 1519 # Best-effort to copy the context into the interpreter for 1520 # access by the hook script. 1521 set vars { 1522 addr buffer chan cmd fid host 1523 id port reason remport ret var 1524 } 1525 1526 if {$comm($chan,interp,set) == "ok"} { 1527 foreach v $vars { 1528 upvar 1 $v V 1529 if {![info exists V]} continue 1530 interp eval $interp [list set $v $V] 1531 } 1532 } elseif {$comm($chan,interp,set) == "hidden"} { 1533 foreach v $vars { 1534 upvar 1 $v V 1535 if {![info exists V]} continue 1536 interp invokehidden $interp set $v $V 1537 } 1538 } 1539 upvar 1 return AV 1540 if {[info exists AV]} { 1541 if {$comm($chan,interp,aset) == "ok"} { 1542 interp eval $interp [list array set return [array get AV]] 1543 } elseif {$comm($chan,interp,aset) == "hidden"} { 1544 interp invokehidden $interp array set return [array get AV] 1545 } 1546 } 1547 1548 commDebug {puts stderr "<$chan> /interp $interp"} 1549 set code [catch {interp eval $interp $cmd} res] 1550 } else { 1551 commDebug {puts stderr "<$chan> /main"} 1552 set code [catch {uplevel 1 $cmd} res] 1553 } 1554 1555 # Perform the return code propagation promised 1556 # to the hook scripts. 1557 switch -exact -- $code { 1558 0 {} 1559 1 { 1560 return -errorinfo $::errorInfo -errorcode $::errorCode -code error $res 1561 } 1562 3 {return} 1563 4 {} 1564 default {return -code $code $res} 1565 } 1566 return 1567} 1568 1569# ### ### ### ######### ######### ######### 1570## Hooks to link async return and future processing into the regular 1571## system. 1572 1573# AsyncPrepare, AsyncCheck: Initialize state information for async 1574# return upon start of a remote invokation, and checking the state for 1575# async return. 1576 1577proc ::comm::AsyncPrepare {chan fid cmd ser} { 1578 variable comm 1579 set comm(current,async) 0 1580 set comm(current,state) [list $chan $fid $cmd $ser] 1581 return 1582} 1583 1584proc ::comm::AsyncCheck {} { 1585 # Check if the executed command notified us of an async return. If 1586 # not we let the regular return processing handle the end of the 1587 # script. Otherwise we stop the caller from proceeding, preventing 1588 # a regular return. 1589 1590 variable comm 1591 if {!$comm(current,async)} {return 0} 1592 return 1 1593} 1594 1595# FutureDone: Action taken by an uncanceled future to deliver the 1596# generated result to the proper invoker. This also removes the future 1597# from the list of pending futures for the comm channel. 1598 1599proc comm::FutureDone {future chan fid cmd sid rcode rvalue} { 1600 variable comm 1601 commSendReply $chan $fid $cmd $sid $rcode $rvalue 1602 1603 set pos [lsearch -exact $comm(future,fid,$fid) $future] 1604 set comm(future,fid,$fid) [lreplace $comm(future,fid,$fid) $pos $pos] 1605 return 1606} 1607 1608# ### ### ### ######### ######### ######### 1609## Hooks to save command state across nested eventloops a remotely 1610## invoked command may run before finally activating async result 1611## generation. 1612 1613# DANGER !! We have to refer to comm internals using fully-qualified 1614# names because the wrappers will execute in the global namespace 1615# after their installation. 1616 1617proc ::comm::Vwait {varname} { 1618 variable ::comm::comm 1619 1620 set hasstate [info exists comm(current,async)] 1621 set hasremote 0 1622 if {$hasstate} { 1623 set chan [lindex $comm(current,state) 0] 1624 set async $comm(current,async) 1625 set state $comm(current,state) 1626 set hasremote [info exists comm($chan,remoteid)] 1627 if {$hasremote} { 1628 set remoteid $comm($chan,remoteid) 1629 } 1630 } 1631 1632 set code [catch {uplevel 1 [list ::comm::VwaitOrig $varname]} res] 1633 1634 if {$hasstate} { 1635 set comm(current,async) $async 1636 set comm(current,state) $state 1637 } 1638 if {$hasremote} { 1639 set comm($chan,remoteid) $remoteid 1640 } 1641 1642 return -code $code $res 1643} 1644 1645proc ::comm::Update {args} { 1646 variable ::comm::comm 1647 1648 set hasstate [info exists comm(current,async)] 1649 set hasremote 0 1650 if {$hasstate} { 1651 set chan [lindex $comm(current,state) 0] 1652 set async $comm(current,async) 1653 set state $comm(current,state) 1654 1655 set hasremote [info exists comm($chan,remoteid)] 1656 if {$hasremote} { 1657 set remoteid $comm($chan,remoteid) 1658 } 1659 } 1660 1661 set code [catch {uplevel 1 [linsert $args 0 ::comm::UpdateOrig]} res] 1662 1663 if {$hasstate} { 1664 set comm(current,async) $async 1665 set comm(current,state) $state 1666 } 1667 if {$hasremote} { 1668 set comm($chan,remoteid) $remoteid 1669 } 1670 1671 return -code $code $res 1672} 1673 1674# Install the wrappers. 1675 1676proc ::comm::InitWrappers {} { 1677 rename ::vwait ::comm::VwaitOrig 1678 rename ::comm::Vwait ::vwait 1679 1680 rename ::update ::comm::UpdateOrig 1681 rename ::comm::Update ::update 1682 1683 proc ::comm::InitWrappers {} {} 1684 return 1685} 1686 1687# ### ### ### ######### ######### ######### 1688## API: Future objects. 1689 1690snit::type comm::future { 1691 option -command -default {} 1692 1693 constructor {chan fid cmd ser} { 1694 set xfid $fid 1695 set xcmd $cmd 1696 set xser $ser 1697 set xchan $chan 1698 return 1699 } 1700 1701 destructor { 1702 if {!$canceled} { 1703 return -code error \ 1704 "Illegal attempt to destroy unresolved future \"$self\"" 1705 } 1706 } 1707 1708 method return {args} { 1709 # Syntax: | 0 1710 # : -code x | 2 1711 # : -code x val | 3 1712 # : val | 4 1713 # Allowing multiple -code settings, last one is taken. 1714 1715 set rcode 0 1716 set rvalue {} 1717 1718 while {[lindex $args 0] == "-code"} { 1719 set rcode [lindex $args 1] 1720 set args [lrange $args 2 end] 1721 } 1722 if {[llength $args] > 1} { 1723 return -code error "wrong\#args, expected \"?-code errcode? ?result?\"" 1724 } 1725 if {[llength $args] == 1} { 1726 set rvalue [lindex $args 0] 1727 } 1728 1729 if {!$canceled} { 1730 comm::FutureDone $self $xchan $xfid $xcmd $xser $rcode $rvalue 1731 set canceled 1 1732 } 1733 # assert: canceled == 1 1734 $self destroy 1735 return 1736 } 1737 1738 variable xfid {} 1739 variable xcmd {} 1740 variable xser {} 1741 variable xchan {} 1742 variable canceled 0 1743 1744 # Internal method for use by comm channels. Marks the future as 1745 # expired, no peer to return a result back to. 1746 1747 method Cancel {} { 1748 set canceled 1 1749 if {![llength $options(-command)]} {return} 1750 uplevel #0 [linsert $options(-command) end $self] 1751 return 1752 } 1753} 1754 1755# ### ### ### ######### ######### ######### 1756## Setup 1757::comm::InitWrappers 1758 1759############################################################################### 1760# 1761# Finish creating "comm" using the default port for this interp. 1762# 1763 1764if {![info exists ::comm::comm(comm,port)]} { 1765 if {[string equal macintosh $tcl_platform(platform)]} { 1766 ::comm::comm new ::comm::comm -port 0 -local 0 -listen 1 1767 set ::comm::comm(localhost) \ 1768 [lindex [fconfigure $::comm::comm(::comm::comm,socket) -sockname] 0] 1769 ::comm::comm config -local 1 1770 } else { 1771 ::comm::comm new ::comm::comm -port 0 -local 1 -listen 1 1772 } 1773} 1774 1775#eof 1776package provide comm 4.6.1 1777