tcl-hacks

Check-in [e570c71b81]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:add select object
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:e570c71b81bb6f2b10a5cd80e62b6d6c0c42f80d
User & Date: aspect 2018-08-05 09:08:14
Context
2018-12-11
07:07
merge tclish-args, which includes commits unrelated to its topic Leaf check-in: 0227bf5899 user: aspect tags: trunk
2018-08-05
09:08
add select object check-in: e570c71b81 user: aspect tags: trunk
2018-07-24
13:25
Note some teapot deficiencies while they're fresh check-in: 97b423d7fc user: aspect tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Added modules/select-0.tm.











































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
# A read handler can be given a varname, which will have the available data read up front.
# A read handler will normally fire at EOF with empty $data, so the user should check for that OR install an EOF handler.
# If an EOF handler is installed, it will be called automatically at EOF (after the 0-length read).
# Read/EOF handlers will be disabled at EOF.
# Timeout occurs at a fixed interval after the select loop is started.  Idler occurs after a fixed interval of no events firing.
#  - disabling a handler / removing a socket should be easy, including in loop mode. (close will do!)
#  - errors in dynamic-with's unwind?  For channel properties, we just want to ignore.
#  - multiple idlers/timeouts might be useful?  Can always be reinstalled at runtime.
namespace eval select {

    oo::class create Select {

        variable inset outset eofset afters idlers
        constructor args {
            namespace path [list {*}[namespace path] ::select]
            lassign {} inset outset eofset afters idlers
        }

        method <- args  { tailcall my <-/[llength $args] {*}$args }
        method !- args  { tailcall my !-/[llength $args] {*}$args }
        method -> args  { tailcall my ->/[llength $args] {*}$args }

        method !-/1 {chan}          { dict unset eofset $chan $script }
        method !-/2 {chan script}   { dict set eofset $chan $script }

        method ->/1 {chan}          { dict unset outset $chan $script }
        method ->/2 {chan script}   { dict set outset $chan $script }

        method <-/1 {chan}          { dict unset inset $chan }
        method <-/2 {chan script}   { dict set  inset $chan $script }
        method <-/3 {chan varname script} { dict set inset $chan "set [list $varname] \[read [list $chan]\] ; $script" }

        method timeout {ms script}  { set afters [dict create $ms $script] }
        method idle {ms script}     { set idlers [dict create $ms $script] }

        method run {}   { tailcall my Run 1 }
        method loop {}  { tailcall my Run 0 }

        export <- !- -> {[a-z]*}

        method Run {once} {

            set outs [lsort -uniq [dict keys $outset]]
            set ins  [lsort -uniq [concat [dict keys $inset] [dict keys $eofset]]]
            set all  [lsort -uniq [concat $ins $outs]]

            foreach chan $all   { dynamic-with  {chan configure $chan -blocking}    0 }
            foreach chan $outs  { dynamic-with  {chan configure $chan -buffering}   none }
            foreach chan $ins   { dynamic-with  {chan event $chan readable}         [list [info coroutine] read $chan] }
            foreach chan $outs  { dynamic-with  {chan event $chan writable}         [list [info coroutine] write $chan] }

            dict for {ms script} $afters {
                set after       [after $ms  [list [info coroutine] timeout $ms]]
                finally after cancel $after
            }

            set idler {}

            while 1 {

                dict for {ms script} $idlers {
                    set idler   [after $ms  [list [info coroutine] idler $ms]]
                }

                lassign [yieldm] action val

                after cancel $idler

                set script [switch $action {
                    timeout { dict get $afters $val }
                    idler   { dict get $idlers $val }
                    write   { dict get $outset $val }
                    read    { dict get  $inset $val }
                    default {
                        throw OOPS "Unexpected action \"$action\""
                    }
                }]

                uplevel 1 $script

                if {$action eq "read" && [dict exists $eofset $val] && [eof $val]} {
                    uplevel 1 [dict get $eofset $val]
                }

                if {$once} break
            }
        }
    }

    proc dynamic-with {args} {
        if {[llength $args] % 2 == 1} {
            set body [lindex $args end]
            set args [lrange $args 0 end-1]
        }
        dict for {cmd new} $args {
            set old [uplevel 1  "$cmd"]
            uplevel 1           "$cmd [list $new]"
            set fin             "$cmd [list $old]"
            lappend fins $fin
        }
        if {[info exists body]} {
            tailcall try $body finally [join $fins \n]
        } else {
            foreach fin $fins {
                uplevel 1 [list finally {*}$fin]
            }
        }
    }

    proc finally {args}  { tailcall trace add variable :#finally#: unset [list apply [list args $args]] }

    proc yieldm {args}   { yieldto string cat {*}$args }

    proc callback {args} { namespace code $args }

}

if {[info exists ::argv0] && $::argv0 eq [info script]} {

    proc main {} {

        set io [open "|socat - EXEC:tclsh,pty,stderr" r+]
        chan configure $io -buffering none
        chan configure stdout -buffering none

        select::Select create select
        select <- $io   data {
            puts -nonewline stdout $data
            if {[eof $io]}   { puts "\nEOF:io:[string length $data]" }
        }
        select <- stdin data {
            puts -nonewline $io $data
            if {[eof stdin]} { puts "\nEOF:stdin:[string length $data]" }
        }
        select !- stdin      { puts "EOF on stdin" ;      break }
        select !- $io        { puts "Subprocess exited" ; break }
        select idle 1000     { puts "Hurry up!" }
        select timeout 10000 { puts "You've had your 10s" ; break }
        select loop
        select destroy

        close $io
        exit 0

    }

    coroutine Main main
    vwait forever
}