source: tol/tolsh/tolsh.vfs/lib/tcllib1.10/comm/comm.tcl @ 8597867d

1941-docker-image-to-testdevel
Last change on this file since 8597867d was 8597867d, checked in by Jorge Pérez <josp.jorge@…>, 16 years ago

closes #976, se incluye tcllib1.10, base64 debe eliminarse del raiz de lib ya que esta incluido en tcllib

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