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.34 2010/09/15 19:48:33 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 # Wait for offered version, without blocking the entire system. 918 # Bug 3066872. For a Tcl 8.6 implementation consider use of 919 # coroutines to hide the CSP and properly handle everything 920 # event based. 921 922 fconfigure $fid -blocking 0 923 fileevent $fid readable [list ::comm::commIncomingOffered $chan $fid $addr $remport] 924 return 925} 926 927proc ::comm::commIncomingOffered {chan fid addr remport} { 928 variable comm 929 930 # Check if we have a complete line. 931 if {[gets $fid protoline] < 0} { 932 #commDebug {puts stderr "commIncomingOffered: no data"} 933 if {[eof $fid]} { 934 commDebug {puts stderr "commIncomingOffered: eof on fid=$fid"} 935 catch { 936 close $fid 937 } 938 } 939 return 940 } 941 942 # Protocol version line has been received, disable event handling 943 # again. 944 fileevent $fid readable {} 945 fconfigure $fid -blocking 1 946 947 # a list of offered proto versions is the first word of first line 948 # remote id is the second word of first line 949 # rest of first line is ignored 950 951 set offeredvers [lindex $protoline 0] 952 set remid [lindex $protoline 1] 953 954 commDebug {puts stderr "<$chan> offered <$protoline>"} 955 956 # use the first supported version in the offered list 957 foreach v $offeredvers { 958 if {[info exists comm($v,vers)]} { 959 set vers $v 960 break 961 } 962 } 963 if {![info exists vers]} { 964 close $fid 965 if {[info exists comm($chan,silent)] && 966 [string is true -strict $comm($chan,silent)]} then return 967 error "Unknown offered protocols \"$protoline\" from $addr/$remport" 968 } 969 970 # If the remote host addr isn't our local host addr, 971 # then add it to the remote id. 972 if {[string equal [lindex [fconfigure $fid -sockname] 0] $addr]} { 973 set id $remid 974 } else { 975 set id [list $remid $addr] 976 } 977 978 # Detect race condition of two comms connecting to each other 979 # simultaneously. It is OK when we are talking to ourselves. 980 981 if {[info exists comm($chan,peers,$id)] && $id != $comm($chan,port)} { 982 983 puts stderr "commIncoming race condition: $id" 984 puts stderr "peers=$comm($chan,peers,$id) port=$comm($chan,port)" 985 986 # To avoid the race, we really want to terminate one connection. 987 # However, both sides are committed to using it. 988 # commConnect needs to be synchronous and detect the close. 989 # close $fid 990 # return $comm($chan,peers,$id) 991 } 992 993 # Make a protocol response. Avoid any temptation to use {$vers > 2} 994 # - this forces forwards compatibility issues on protocol versions 995 # that haven't been invented yet. DON'T DO IT! Instead, test for 996 # each supported version explicitly. I.e., {$vers >2 && $vers < 5} is OK. 997 998 switch $vers { 999 3 { 1000 # Respond with the selected version number 1001 puts $fid [list [list vers $vers]] 1002 flush $fid 1003 } 1004 } 1005 1006 # commit new connection 1007 commNewConn $chan $id $fid 1008 set comm($chan,vers,$id) $vers 1009} 1010 1011# ::comm::commNewConn -- 1012# 1013# Internal command. Common new connection processing 1014# 1015# Arguments: 1016# id Reference to the remote interp 1017# fid channel handle of the socket running the connection. 1018# 1019# Results: 1020# None. 1021 1022proc ::comm::commNewConn {chan id fid} { 1023 variable comm 1024 1025 commDebug {puts stderr "<$chan> commNewConn $id $fid"} 1026 1027 # There can be a race condition two where comms connect to each other 1028 # simultaneously. This code favors our outgoing connection. 1029 1030 if {[info exists comm($chan,peers,$id)]} { 1031 # abort this connection, use the existing one 1032 # close $fid 1033 # return -code return $comm($chan,peers,$id) 1034 } else { 1035 set comm($chan,pending,$id) {} 1036 set comm($chan,peers,$id) $fid 1037 } 1038 set comm($chan,fids,$fid) $id 1039 fconfigure $fid -translation lf -encoding $comm($chan,encoding) -blocking 0 1040 fileevent $fid readable [list ::comm::commCollect $chan $fid] 1041} 1042 1043# ::comm::commLostConn -- 1044# 1045# Internal command. Called to tidy up a lost connection, 1046# including aborting ongoing sends. Each send should clean 1047# themselves up in pending/result. 1048# 1049# Arguments: 1050# fid Channel handle of the socket which got lost. 1051# reason Message describing the reason of the loss. 1052# 1053# Results: 1054# reason 1055 1056proc ::comm::commLostConn {chan fid reason} { 1057 variable comm 1058 1059 commDebug {puts stderr "<$chan> commLostConn $fid $reason"} 1060 1061 catch {close $fid} 1062 1063 set id $comm($chan,fids,$fid) 1064 1065 # Invoke the callbacks of all commands which have such and are 1066 # still waiting for a response from the lost peer. Use an 1067 # appropriate error. 1068 1069 foreach s $comm($chan,pending,$id) { 1070 if {[string equal "callback" [lindex $s end]]} { 1071 set ser [lindex $s 0] 1072 if {[info exists comm($chan,return,$ser)]} { 1073 set args [list -id $id \ 1074 -serial $ser \ 1075 -chan $chan \ 1076 -code -1 \ 1077 -errorcode NONE \ 1078 -errorinfo "" \ 1079 -result $reason \ 1080 ] 1081 if {[catch {uplevel \#0 $comm($chan,return,$ser) $args} err]} { 1082 commBgerror $err 1083 } 1084 } 1085 } else { 1086 set comm($chan,return,$s) {-code error} 1087 set comm($chan,result,$s) $reason 1088 } 1089 } 1090 unset comm($chan,pending,$id) 1091 unset comm($chan,fids,$fid) 1092 catch {unset comm($chan,peers,$id)} ;# race condition 1093 catch {unset comm($chan,buf,$fid)} 1094 1095 # Cancel all outstanding futures for requests which were made by 1096 # the lost peer, if there are any. This does not destroy 1097 # them. They will stay around until the long-running operations 1098 # they belong too kill them. 1099 1100 CancelFutures $fid 1101 1102 # process lost hook now 1103 catch {CommRunHook $chan lost} 1104 1105 return $reason 1106} 1107 1108proc ::comm::commBgerror {err} { 1109 # SF Tcllib Patch #526499 1110 # (See http://sourceforge.net/tracker/?func=detail&aid=526499&group_id=12883&atid=312883 1111 # for initial request and comments) 1112 # 1113 # Error in async call. Look for [bgerror] to report it. Same 1114 # logic as in Tcl itself. Errors thrown by bgerror itself get 1115 # reported to stderr. 1116 if {[catch {bgerror $err} msg]} { 1117 puts stderr "bgerror failed to handle background error." 1118 puts stderr " Original error: $err" 1119 puts stderr " Error in bgerror: $msg" 1120 flush stderr 1121 } 1122} 1123 1124# CancelFutures: Mark futures associated with a comm channel as 1125# expired, done when the connection to the peer has been lost. The 1126# marked futures will not generate result anymore. They will also stay 1127# around until destroyed by the script they belong to. 1128 1129proc ::comm::CancelFutures {fid} { 1130 variable comm 1131 if {![info exists comm(future,fid,$fid)]} return 1132 1133 commDebug {puts stderr "\tCanceling futures: [join $comm(future,fid,$fid) \ 1134 "\n\t : "]"} 1135 1136 foreach future $comm(future,fid,$fid) { 1137 $future Cancel 1138 } 1139 1140 unset comm(future,fid,$fid) 1141 return 1142} 1143 1144############################################################################### 1145 1146# ::comm::commCollect -- 1147# 1148# Internal command. Called from the fileevent to read from fid 1149# and append to the buffer. This continues until we get a whole 1150# command, which we then invoke. 1151# 1152# Arguments: 1153# chan logical channel collecting the data 1154# fid channel handle of the socket we collect. 1155# 1156# Results: 1157# None. 1158 1159proc ::comm::commCollect {chan fid} { 1160 variable comm 1161 upvar #0 comm($chan,buf,$fid) data 1162 1163 # Tcl8 may return an error on read after a close 1164 if {[catch {read $fid} nbuf] || [eof $fid]} { 1165 commDebug {puts stderr "<$chan> collect/lost eof $fid = [eof $fid]"} 1166 commDebug {puts stderr "<$chan> collect/lost nbuf = <$nbuf>"} 1167 commDebug {puts stderr "<$chan> collect/lost [fconfigure $fid]"} 1168 1169 fileevent $fid readable {} ;# be safe 1170 commLostConn $chan $fid "target application died or connection lost" 1171 return 1172 } 1173 append data $nbuf 1174 1175 commDebug {puts stderr "<$chan> collect <$data>"} 1176 1177 # If data contains at least one complete command, we will 1178 # be able to take off the first element, which is a list holding 1179 # the command. This is true even if data isn't a well-formed 1180 # list overall, with unmatched open braces. This works because 1181 # each command in the protocol ends with a newline, thus allowing 1182 # lindex and lreplace to work. 1183 # 1184 # This isn't true with Tcl8.0, which will return an error until 1185 # the whole buffer is a valid list. This is probably OK, although 1186 # it could potentially cause a deadlock. 1187 1188 # [AK] Actually no. This breaks down if the sender shoves so much 1189 # data at us so fast that the receiver runs into out of memory 1190 # before the list is fully well-formed and thus able to be 1191 # processed. 1192 1193 while {![catch { 1194 set cmdrange [Word0 data] 1195 # word0 is essentially the pre-8.0 'lindex <list> 0', getting 1196 # the first word of a list, even if the remainder is not fully 1197 # well-formed. Slight API change, we get the char indices the 1198 # word is between, and a relative index to the remainder of 1199 # the list. 1200 }]} { 1201 # Unpack the indices, then extract the word. 1202 foreach {s e step} $cmdrange break 1203 set cmd [string range $data $s $e] 1204 commDebug {puts stderr "<$chan> cmd <$data>"} 1205 if {[string equal "" $cmd]} break 1206 if {[info complete $cmd]} { 1207 # The word is a command, step to the remainder of the 1208 # list, and delete the word we have processed. 1209 incr e $step 1210 set data [string range $data $e end] 1211 after idle \ 1212 [list ::comm::commExec $chan $fid $comm($chan,fids,$fid) $cmd] 1213 } 1214 } 1215} 1216 1217proc ::comm::Word0 {dv} { 1218 upvar 1 $dv data 1219 1220 # data 1221 # 1222 # The string we expect to be either a full well-formed list, or a 1223 # well-formed list until the end of the first word in the list, 1224 # with non-wellformed data following after, i.e. an incomplete 1225 # list with a complete first word. 1226 1227 if {[regexp -indices "^\\s*(\{)" $data -> bracerange]} { 1228 # The word is brace-quoted, starting at index 'lindex 1229 # bracerange 0'. We now have to find the closing brace, 1230 # counting inner braces, ignoring quoted braces. We fail if 1231 # there is no proper closing brace. 1232 1233 foreach {s e} $bracerange break 1234 incr s ; # index of the first char after the brace. 1235 incr e ; # same. but this is our running index. 1236 1237 set level 1 1238 set max [string length $data] 1239 1240 while {$level} { 1241 # We are looking for the first regular or backslash-quoted 1242 # opening or closing brace in the string. If none is found 1243 # then the word is not complete, and we abort our search. 1244 1245 # Bug 2972571: To avoid the bogus detection of 1246 # backslash-quoted braces we look for double-backslashes 1247 # as well and skip them. Without this a string like '{puts 1248 # \\}' will incorrectly find a \} at the end, missing the 1249 # end of the word. 1250 1251 if {![regexp -indices -start $e {((\\\\)|([{}])|(\\[{}]))} $data -> any dbs regular quoted]} { 1252 # ^^ ^ ^ 1253 # |\\ regular \quoted 1254 # any 1255 return -code error "no complete word found/1" 1256 } 1257 1258 foreach {ds de} $dbs break 1259 foreach {qs qe} $quoted break 1260 foreach {rs re} $regular break 1261 1262 if {$ds >= 0} { 1263 # Skip double-backslashes ... 1264 set e $de 1265 incr e 1266 continue 1267 } elseif {$qs >= 0} { 1268 # Skip quoted braces ... 1269 set e $qe 1270 incr e 1271 continue 1272 } elseif {$rs >= 0} { 1273 # Step one nesting level in or out. 1274 if {[string index $data $rs] eq "\{"} { 1275 incr level 1276 } else { 1277 incr level -1 1278 } 1279 set e $re 1280 incr e 1281 #puts @$e 1282 continue 1283 } else { 1284 return -code error "internal error" 1285 } 1286 } 1287 1288 incr e -2 ; # index of character just before the brace. 1289 return [list $s $e 2] 1290 1291 } elseif {[regexp -indices {^\s*(\S+)\s} $data -> wordrange]} { 1292 # The word is a simple literal which ends at the next 1293 # whitespace character. Note that there has to be a whitespace 1294 # for us to recognize a word, for while there is no whitespace 1295 # behind it in the buffer the word itself may be incomplete. 1296 1297 return [linsert $wordrange end 1] 1298 } 1299 1300 return -code error "no complete word found/2" 1301} 1302 1303# ::comm::commExec -- 1304# 1305# Internal command. Receives and executes a remote command, 1306# returning the result and/or error. Unknown protocol commands 1307# are silently discarded 1308# 1309# Arguments: 1310# chan logical channel collecting the data 1311# fid channel handle of the socket we collect. 1312# remoteid id of the other side. 1313# buf buffer containing the command to execute. 1314# 1315# Results: 1316# None. 1317 1318proc ::comm::commExec {chan fid remoteid buf} { 1319 variable comm 1320 1321 # buffer should contain: 1322 # send # {cmd} execute cmd and send reply with serial # 1323 # async # {cmd} execute cmd but send no reply 1324 # reply # {cmd} execute cmd as reply to serial # 1325 1326 # these variables are documented in the hook interface 1327 set cmd [lindex $buf 0] 1328 set ser [lindex $buf 1] 1329 set buf [lrange $buf 2 end] 1330 set buffer [lindex $buf 0] 1331 1332 # Save remoteid for "comm remoteid". This will only be valid 1333 # if retrieved before any additional events occur on this channel. 1334 # N.B. we could have already lost the connection to remote, making 1335 # this id be purely informational! 1336 set comm($chan,remoteid) [set id $remoteid] 1337 1338 # Save state for possible async result generation 1339 AsyncPrepare $chan $fid $cmd $ser 1340 1341 commDebug {puts stderr "<$chan> exec <$cmd,$ser,$buf>"} 1342 1343 switch -- $cmd { 1344 send - async - command {} 1345 callback { 1346 if {![info exists comm($chan,return,$ser)]} { 1347 commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""} 1348 return 1349 } 1350 1351 # Decompose reply command to assure it only uses "return" 1352 # with no side effects. 1353 1354 array set return {-code "" -errorinfo "" -errorcode ""} 1355 set ret [lindex $buffer end] 1356 set len [llength $buffer] 1357 incr len -2 1358 foreach {sw val} [lrange $buffer 1 $len] { 1359 if {![info exists return($sw)]} continue 1360 set return($sw) $val 1361 } 1362 1363 catch {CommRunHook $chan callback} 1364 1365 # this wakes up the sender 1366 commDebug {puts stderr "<$chan> --<<wakeup $ser>>--"} 1367 1368 # the return holds the callback command 1369 # string map the optional %-subs 1370 set args [list -id $id \ 1371 -serial $ser \ 1372 -chan $chan \ 1373 -code $return(-code) \ 1374 -errorcode $return(-errorcode) \ 1375 -errorinfo $return(-errorinfo) \ 1376 -result $ret \ 1377 ] 1378 set code [catch {uplevel \#0 $comm($chan,return,$ser) $args} err] 1379 catch {unset comm($chan,return,$ser)} 1380 1381 # remove pending serial 1382 upvar 0 comm($chan,pending,$id) pending 1383 if {[info exists pending]} { 1384 set pos [lsearch -exact $pending [list $ser callback]] 1385 if {$pos != -1} { 1386 set pending [lreplace $pending $pos $pos] 1387 } 1388 } 1389 if {$code} { 1390 commBgerror $err 1391 } 1392 return 1393 } 1394 reply { 1395 if {![info exists comm($chan,return,$ser)]} { 1396 commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""} 1397 return 1398 } 1399 1400 # Decompose reply command to assure it only uses "return" 1401 # with no side effects. 1402 1403 array set return {-code "" -errorinfo "" -errorcode ""} 1404 set ret [lindex $buffer end] 1405 set len [llength $buffer] 1406 incr len -2 1407 foreach {sw val} [lrange $buffer 1 $len] { 1408 if {![info exists return($sw)]} continue 1409 set return($sw) $val 1410 } 1411 1412 catch {CommRunHook $chan reply} 1413 1414 # this wakes up the sender 1415 commDebug {puts stderr "<$chan> --<<wakeup $ser>>--"} 1416 set comm($chan,result,$ser) $ret 1417 set comm($chan,return,$ser) [array get return] 1418 return 1419 } 1420 vers { 1421 set ::comm::comm($chan,vers,$id) $ser 1422 return 1423 } 1424 default { 1425 commDebug {puts stderr "<$chan> unknown command; discard \"$cmd\""} 1426 return 1427 } 1428 } 1429 1430 # process eval hook now 1431 set done 0 1432 set err 0 1433 if {[info exists comm($chan,hook,eval)]} { 1434 set err [catch {CommRunHook $chan eval} ret] 1435 commDebug {puts stderr "<$chan> eval hook res <$err,$ret>"} 1436 switch $err { 1437 1 { 1438 # error 1439 set done 1 1440 } 1441 2 - 3 { 1442 # return / break 1443 set err 0 1444 set done 1 1445 } 1446 } 1447 } 1448 1449 commDebug {puts stderr "<$chan> hook(eval) done=$done, err=$err"} 1450 1451 # exec command 1452 if {!$done} { 1453 commDebug {puts stderr "<$chan> exec ($buffer)"} 1454 1455 # Sadly, the uplevel needs to be in the catch to access the local 1456 # variables buffer and ret. These cannot simply be global because 1457 # commExec is reentrant (i.e., they could be linked to an allocated 1458 # serial number). 1459 1460 if {$comm($chan,interp) == {}} { 1461 # Main interpreter 1462 set thecmd [concat [list uplevel \#0] $buffer] 1463 set err [catch $thecmd ret] 1464 } else { 1465 # Redirect execution into the configured slave 1466 # interpreter. The exact command used depends on the 1467 # capabilities of the interpreter. A best effort is made 1468 # to execute the script in the global namespace. 1469 set interp $comm($chan,interp) 1470 1471 if {$comm($chan,interp,upl) == "ok"} { 1472 set thecmd [concat [list uplevel \#0] $buffer] 1473 set err [catch {interp eval $interp $thecmd} ret] 1474 } elseif {$comm($chan,interp,aset) == "hidden"} { 1475 set thecmd [linsert $buffer 0 interp invokehidden $interp uplevel \#0] 1476 set err [catch $thecmd ret] 1477 } else { 1478 set thecmd [concat [list interp eval $interp] $buffer] 1479 set err [catch $thecmd ret] 1480 } 1481 } 1482 } 1483 1484 # Check and handle possible async result generation. 1485 if {[AsyncCheck]} return 1486 1487 commSendReply $chan $fid $cmd $ser $err $ret 1488 return 1489} 1490 1491# ::comm::commSendReply -- 1492# 1493# Internal command. Executed to construct and send the reply 1494# for a command. 1495# 1496# Arguments: 1497# fid channel handle of the socket we are replying to. 1498# cmd The type of request (send, command) we are replying to. 1499# ser Serial number of the request the reply is for. 1500# err result code to place into the reply. 1501# ret result value to place into the reply. 1502# 1503# Results: 1504# None. 1505 1506proc ::comm::commSendReply {chan fid cmd ser err ret} { 1507 variable comm 1508 1509 commDebug {puts stderr "<$chan> res <$err,$ret> /$cmd"} 1510 1511 # The double list assures that the command is a single list when read. 1512 if {[string equal send $cmd] || [string equal command $cmd]} { 1513 # The catch here is just in case we lose the target. Consider: 1514 # comm send $other comm send [comm self] exit 1515 catch { 1516 set return [list return -code $err] 1517 # send error or result 1518 if {$err == 1} { 1519 global errorInfo errorCode 1520 lappend return -errorinfo $errorInfo -errorcode $errorCode 1521 } 1522 lappend return $ret 1523 if {[string equal send $cmd]} { 1524 set reply reply 1525 } else { 1526 set reply callback 1527 } 1528 puts $fid [list [list $reply $ser $return]] 1529 flush $fid 1530 } 1531 commDebug {puts stderr "<$chan> reply sent"} 1532 } 1533 1534 if {$err == 1} { 1535 commBgerror $ret 1536 } 1537 commDebug {puts stderr "<$chan> exec complete"} 1538 return 1539} 1540 1541proc ::comm::CommRunHook {chan event} { 1542 variable comm 1543 1544 # The documentation promises the hook scripts to have access to a 1545 # number of internal variables. For a regular hook we simply 1546 # execute it in the calling level to fulfill this. When the hook 1547 # is redirected into an interpreter however we do a best-effort 1548 # copying of the variable values into the interpreter. Best-effort 1549 # because the 'set' command may not be available in the 1550 # interpreter, not even hidden. 1551 1552 if {![info exists comm($chan,hook,$event)]} return 1553 set cmd $comm($chan,hook,$event) 1554 set interp $comm($chan,interp) 1555 commDebug {puts stderr "<$chan> hook($event) run <$cmd>"} 1556 1557 if { 1558 ($interp != {}) && 1559 ([lsearch -exact $comm($chan,events) $event] >= 0) 1560 } { 1561 # Best-effort to copy the context into the interpreter for 1562 # access by the hook script. 1563 set vars { 1564 addr buffer chan cmd fid host 1565 id port reason remport ret var 1566 } 1567 1568 if {$comm($chan,interp,set) == "ok"} { 1569 foreach v $vars { 1570 upvar 1 $v V 1571 if {![info exists V]} continue 1572 interp eval $interp [list set $v $V] 1573 } 1574 } elseif {$comm($chan,interp,set) == "hidden"} { 1575 foreach v $vars { 1576 upvar 1 $v V 1577 if {![info exists V]} continue 1578 interp invokehidden $interp set $v $V 1579 } 1580 } 1581 upvar 1 return AV 1582 if {[info exists AV]} { 1583 if {$comm($chan,interp,aset) == "ok"} { 1584 interp eval $interp [list array set return [array get AV]] 1585 } elseif {$comm($chan,interp,aset) == "hidden"} { 1586 interp invokehidden $interp array set return [array get AV] 1587 } 1588 } 1589 1590 commDebug {puts stderr "<$chan> /interp $interp"} 1591 set code [catch {interp eval $interp $cmd} res] 1592 } else { 1593 commDebug {puts stderr "<$chan> /main"} 1594 set code [catch {uplevel 1 $cmd} res] 1595 } 1596 1597 # Perform the return code propagation promised 1598 # to the hook scripts. 1599 switch -exact -- $code { 1600 0 {} 1601 1 { 1602 return -errorinfo $::errorInfo -errorcode $::errorCode -code error $res 1603 } 1604 3 {return} 1605 4 {} 1606 default {return -code $code $res} 1607 } 1608 return 1609} 1610 1611# ### ### ### ######### ######### ######### 1612## Hooks to link async return and future processing into the regular 1613## system. 1614 1615# AsyncPrepare, AsyncCheck: Initialize state information for async 1616# return upon start of a remote invokation, and checking the state for 1617# async return. 1618 1619proc ::comm::AsyncPrepare {chan fid cmd ser} { 1620 variable comm 1621 set comm(current,async) 0 1622 set comm(current,state) [list $chan $fid $cmd $ser] 1623 return 1624} 1625 1626proc ::comm::AsyncCheck {} { 1627 # Check if the executed command notified us of an async return. If 1628 # not we let the regular return processing handle the end of the 1629 # script. Otherwise we stop the caller from proceeding, preventing 1630 # a regular return. 1631 1632 variable comm 1633 if {!$comm(current,async)} {return 0} 1634 return 1 1635} 1636 1637# FutureDone: Action taken by an uncanceled future to deliver the 1638# generated result to the proper invoker. This also removes the future 1639# from the list of pending futures for the comm channel. 1640 1641proc comm::FutureDone {future chan fid cmd sid rcode rvalue} { 1642 variable comm 1643 commSendReply $chan $fid $cmd $sid $rcode $rvalue 1644 1645 set pos [lsearch -exact $comm(future,fid,$fid) $future] 1646 set comm(future,fid,$fid) [lreplace $comm(future,fid,$fid) $pos $pos] 1647 return 1648} 1649 1650# ### ### ### ######### ######### ######### 1651## Hooks to save command state across nested eventloops a remotely 1652## invoked command may run before finally activating async result 1653## generation. 1654 1655# DANGER !! We have to refer to comm internals using fully-qualified 1656# names because the wrappers will execute in the global namespace 1657# after their installation. 1658 1659proc ::comm::Vwait {varname} { 1660 variable ::comm::comm 1661 1662 set hasstate [info exists comm(current,async)] 1663 set hasremote 0 1664 if {$hasstate} { 1665 set chan [lindex $comm(current,state) 0] 1666 set async $comm(current,async) 1667 set state $comm(current,state) 1668 set hasremote [info exists comm($chan,remoteid)] 1669 if {$hasremote} { 1670 set remoteid $comm($chan,remoteid) 1671 } 1672 } 1673 1674 set code [catch {uplevel 1 [list ::comm::VwaitOrig $varname]} res] 1675 1676 if {$hasstate} { 1677 set comm(current,async) $async 1678 set comm(current,state) $state 1679 } 1680 if {$hasremote} { 1681 set comm($chan,remoteid) $remoteid 1682 } 1683 1684 return -code $code $res 1685} 1686 1687proc ::comm::Update {args} { 1688 variable ::comm::comm 1689 1690 set hasstate [info exists comm(current,async)] 1691 set hasremote 0 1692 if {$hasstate} { 1693 set chan [lindex $comm(current,state) 0] 1694 set async $comm(current,async) 1695 set state $comm(current,state) 1696 1697 set hasremote [info exists comm($chan,remoteid)] 1698 if {$hasremote} { 1699 set remoteid $comm($chan,remoteid) 1700 } 1701 } 1702 1703 set code [catch {uplevel 1 [linsert $args 0 ::comm::UpdateOrig]} res] 1704 1705 if {$hasstate} { 1706 set comm(current,async) $async 1707 set comm(current,state) $state 1708 } 1709 if {$hasremote} { 1710 set comm($chan,remoteid) $remoteid 1711 } 1712 1713 return -code $code $res 1714} 1715 1716# Install the wrappers. 1717 1718proc ::comm::InitWrappers {} { 1719 rename ::vwait ::comm::VwaitOrig 1720 rename ::comm::Vwait ::vwait 1721 1722 rename ::update ::comm::UpdateOrig 1723 rename ::comm::Update ::update 1724 1725 proc ::comm::InitWrappers {} {} 1726 return 1727} 1728 1729# ### ### ### ######### ######### ######### 1730## API: Future objects. 1731 1732snit::type comm::future { 1733 option -command -default {} 1734 1735 constructor {chan fid cmd ser} { 1736 set xfid $fid 1737 set xcmd $cmd 1738 set xser $ser 1739 set xchan $chan 1740 return 1741 } 1742 1743 destructor { 1744 if {!$canceled} { 1745 return -code error \ 1746 "Illegal attempt to destroy unresolved future \"$self\"" 1747 } 1748 } 1749 1750 method return {args} { 1751 # Syntax: | 0 1752 # : -code x | 2 1753 # : -code x val | 3 1754 # : val | 4 1755 # Allowing multiple -code settings, last one is taken. 1756 1757 set rcode 0 1758 set rvalue {} 1759 1760 while {[lindex $args 0] == "-code"} { 1761 set rcode [lindex $args 1] 1762 set args [lrange $args 2 end] 1763 } 1764 if {[llength $args] > 1} { 1765 return -code error "wrong\#args, expected \"?-code errcode? ?result?\"" 1766 } 1767 if {[llength $args] == 1} { 1768 set rvalue [lindex $args 0] 1769 } 1770 1771 if {!$canceled} { 1772 comm::FutureDone $self $xchan $xfid $xcmd $xser $rcode $rvalue 1773 set canceled 1 1774 } 1775 # assert: canceled == 1 1776 $self destroy 1777 return 1778 } 1779 1780 variable xfid {} 1781 variable xcmd {} 1782 variable xser {} 1783 variable xchan {} 1784 variable canceled 0 1785 1786 # Internal method for use by comm channels. Marks the future as 1787 # expired, no peer to return a result back to. 1788 1789 method Cancel {} { 1790 set canceled 1 1791 if {![llength $options(-command)]} {return} 1792 uplevel #0 [linsert $options(-command) end $self] 1793 return 1794 } 1795} 1796 1797# ### ### ### ######### ######### ######### 1798## Setup 1799::comm::InitWrappers 1800 1801############################################################################### 1802# 1803# Finish creating "comm" using the default port for this interp. 1804# 1805 1806if {![info exists ::comm::comm(comm,port)]} { 1807 if {[string equal macintosh $tcl_platform(platform)]} { 1808 ::comm::comm new ::comm::comm -port 0 -local 0 -listen 1 1809 set ::comm::comm(localhost) \ 1810 [lindex [fconfigure $::comm::comm(::comm::comm,socket) -sockname] 0] 1811 ::comm::comm config -local 1 1812 } else { 1813 ::comm::comm new ::comm::comm -port 0 -local 1 -listen 1 1814 } 1815} 1816 1817#eof 1818package provide comm 4.6.3.1 1819