Artifact
24fbdf5512675c4e8b2c400f480a0f418b191589f6b0939a849419feb9d00952:
Attachment "refchan-async-redux.tcl" to
ticket [de232b49f2]
added by
apnadkarni
2024-04-02 07:37:43.
0000: 6e 61 6d 65 73 70 61 63 65 20 65 76 61 6c 20 72 namespace eval r
0010: 65 66 63 68 61 6e 20 7b 0d 0a 20 20 20 20 6e 61 efchan {.. na
0020: 6d 65 73 70 61 63 65 20 65 6e 73 65 6d 62 6c 65 mespace ensemble
0030: 20 63 72 65 61 74 65 0d 0a 20 20 20 20 6e 61 6d create.. nam
0040: 65 73 70 61 63 65 20 65 78 70 6f 72 74 20 2a 0d espace export *.
0050: 0a 20 20 20 20 23 20 43 68 61 6e 67 65 20 74 6f . # Change to
0060: 20 74 61 73 74 65 20 64 65 70 65 6e 64 69 6e 67 taste depending
0070: 20 6f 6e 20 68 6f 77 20 6d 75 63 68 20 43 50 55 on how much CPU
0080: 20 79 6f 75 20 77 61 6e 74 20 74 6f 20 68 6f 67 you want to hog
0090: 0d 0a 20 20 20 20 76 61 72 69 61 62 6c 65 20 64 .. variable d
00a0: 65 6c 61 79 20 30 0d 0a 0d 0a 20 20 20 20 70 72 elay 0.... pr
00b0: 6f 63 20 66 69 6e 61 6c 69 7a 65 20 7b 63 68 61 oc finalize {cha
00c0: 6e 20 61 72 67 73 7d 20 7b 0d 0a 20 20 20 20 20 n args} {..
00d0: 20 20 20 6e 61 6d 65 73 70 61 63 65 20 75 70 76 namespace upv
00e0: 61 72 20 63 5f 24 63 68 61 6e 20 74 69 6d 65 72 ar c_$chan timer
00f0: 20 74 69 6d 65 72 0d 0a 20 20 20 20 20 20 20 20 timer..
0100: 63 61 74 63 68 20 7b 61 66 74 65 72 20 63 61 6e catch {after can
0110: 63 65 6c 20 24 74 69 6d 65 72 7d 0d 0a 20 20 20 cel $timer}..
0120: 20 20 20 20 20 6e 61 6d 65 73 70 61 63 65 20 64 namespace d
0130: 65 6c 65 74 65 20 63 5f 24 63 68 61 6e 0d 0a 20 elete c_$chan..
0140: 20 20 20 7d 0d 0a 0d 0a 20 20 20 20 70 72 6f 63 }.... proc
0150: 20 69 6e 69 74 69 61 6c 69 7a 65 20 7b 63 68 61 initialize {cha
0160: 6e 20 61 72 67 73 7d 20 7b 0d 0a 20 20 20 20 20 n args} {..
0170: 20 20 20 6e 61 6d 65 73 70 61 63 65 20 65 76 61 namespace eva
0180: 6c 20 63 5f 24 63 68 61 6e 20 7b 7d 0d 0a 20 20 l c_$chan {}..
0190: 20 20 20 20 20 20 6e 61 6d 65 73 70 61 63 65 20 namespace
01a0: 75 70 76 61 72 20 63 5f 24 63 68 61 6e 20 77 61 upvar c_$chan wa
01b0: 74 63 68 69 6e 67 20 77 61 74 63 68 69 6e 67 0d tching watching.
01c0: 0a 20 20 20 20 20 20 20 20 6e 61 6d 65 73 70 61 . namespa
01d0: 63 65 20 75 70 76 61 72 20 63 5f 24 63 68 61 6e ce upvar c_$chan
01e0: 20 74 69 6d 65 72 20 74 69 6d 65 72 0d 0a 20 20 timer timer..
01f0: 20 20 20 20 20 20 73 65 74 20 77 61 74 63 68 69 set watchi
0200: 6e 67 20 7b 7d 0d 0a 20 20 20 20 20 20 20 20 6c ng {}.. l
0210: 69 73 74 20 66 69 6e 61 6c 69 7a 65 20 69 6e 69 ist finalize ini
0220: 74 69 61 6c 69 7a 65 20 73 65 65 6b 20 77 61 74 tialize seek wat
0230: 63 68 20 77 72 69 74 65 0d 0a 20 20 20 20 7d 0d ch write.. }.
0240: 0a 0d 0a 0d 0a 20 20 20 20 70 72 6f 63 20 77 61 ..... proc wa
0250: 74 63 68 20 7b 63 68 61 6e 20 61 72 67 73 7d 20 tch {chan args}
0260: 7b 0d 0a 20 20 20 20 20 20 20 20 6e 61 6d 65 73 {.. names
0270: 70 61 63 65 20 75 70 76 61 72 20 63 5f 24 63 68 pace upvar c_$ch
0280: 61 6e 20 77 61 74 63 68 69 6e 67 20 77 61 74 63 an watching watc
0290: 68 69 6e 67 0d 0a 20 20 20 20 20 20 20 20 69 66 hing.. if
02a0: 20 7b 22 77 72 69 74 65 22 20 69 6e 20 24 61 72 {"write" in $ar
02b0: 67 73 7d 20 7b 0d 0a 20 20 20 20 20 20 20 20 20 gs} {..
02c0: 20 20 20 69 66 20 7b 22 77 72 69 74 65 22 20 6e if {"write" n
02d0: 69 20 24 77 61 74 63 68 69 6e 67 7d 20 7b 0d 0a i $watching} {..
02e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
02f0: 6c 61 70 70 65 6e 64 20 77 61 74 63 68 69 6e 67 lappend watching
0300: 20 77 72 69 74 65 0d 0a 20 20 20 20 20 20 20 20 write..
0310: 20 20 20 20 7d 0d 0a 20 20 20 20 20 20 20 20 7d }.. }
0320: 20 65 6c 73 65 20 7b 0d 0a 20 20 20 20 20 20 20 else {..
0330: 20 20 20 20 20 73 65 74 20 77 61 74 63 68 69 6e set watchin
0340: 67 20 7b 7d 0d 0a 20 20 20 20 20 20 20 20 7d 0d g {}.. }.
0350: 0a 20 20 20 20 20 20 20 20 75 70 64 61 74 65 20 . update
0360: 24 63 68 61 6e 0d 0a 20 20 20 20 7d 0d 0a 0d 0a $chan.. }....
0370: 20 20 20 20 70 72 6f 63 20 77 72 69 74 65 20 7b proc write {
0380: 63 68 61 6e 20 64 61 74 61 7d 20 7b 0d 0a 20 20 chan data} {..
0390: 20 20 20 20 20 20 72 65 74 75 72 6e 20 5b 73 74 return [st
03a0: 72 69 6e 67 20 6c 65 6e 67 74 68 20 24 64 61 74 ring length $dat
03b0: 61 5d 0d 0a 20 20 20 20 7d 0d 0a 0d 0a 20 20 20 a].. }....
03c0: 20 23 20 70 61 72 61 70 68 72 61 73 65 64 20 66 # paraphrased f
03d0: 72 6f 6d 20 74 63 6c 6c 69 62 0d 0a 20 20 20 20 rom tcllib..
03e0: 70 72 6f 63 20 75 70 64 61 74 65 20 7b 63 68 61 proc update {cha
03f0: 6e 7d 20 7b 0d 0a 20 20 20 20 20 20 20 20 6e 61 n} {.. na
0400: 6d 65 73 70 61 63 65 20 75 70 76 61 72 20 63 5f mespace upvar c_
0410: 24 63 68 61 6e 20 77 61 74 63 68 69 6e 67 20 77 $chan watching w
0420: 61 74 63 68 69 6e 67 0d 0a 20 20 20 20 20 20 20 atching..
0430: 20 6e 61 6d 65 73 70 61 63 65 20 75 70 76 61 72 namespace upvar
0440: 20 63 5f 24 63 68 61 6e 20 74 69 6d 65 72 20 74 c_$chan timer t
0450: 69 6d 65 72 0d 0a 20 20 20 20 20 20 20 20 76 61 imer.. va
0460: 72 69 61 62 6c 65 20 64 65 6c 61 79 0d 0a 20 20 riable delay..
0470: 20 20 20 20 20 20 63 61 74 63 68 20 7b 61 66 74 catch {aft
0480: 65 72 20 63 61 6e 63 65 6c 20 24 74 69 6d 65 72 er cancel $timer
0490: 7d 0d 0a 20 20 20 20 20 20 20 20 69 66 20 7b 22 }.. if {"
04a0: 77 72 69 74 65 22 20 69 6e 20 24 77 61 74 63 68 write" in $watch
04b0: 69 6e 67 7d 20 7b 0d 0a 20 20 20 20 20 20 20 20 ing} {..
04c0: 20 20 20 20 73 65 74 20 74 69 6d 65 72 20 5b 61 set timer [a
04d0: 66 74 65 72 20 69 64 6c 65 20 61 66 74 65 72 20 fter idle after
04e0: 24 64 65 6c 61 79 20 5c 0d 0a 20 20 20 20 20 20 $delay \..
04f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0500: 20 20 20 20 20 5b 6e 61 6d 65 73 70 61 63 65 20 [namespace
0510: 63 6f 64 65 20 5b 6c 69 73 74 20 70 6f 73 74 20 code [list post
0520: 24 63 68 61 6e 5d 5d 5d 0d 0a 20 20 20 20 20 20 $chan]]]..
0530: 20 20 7d 0d 0a 20 20 20 20 7d 0d 0a 0d 0a 20 20 }.. }....
0540: 20 20 70 72 6f 63 20 70 6f 73 74 20 7b 63 68 61 proc post {cha
0550: 6e 7d 20 7b 0d 0a 20 20 20 20 20 20 20 20 76 61 n} {.. va
0560: 72 69 61 62 6c 65 20 64 65 6c 61 79 0d 0a 20 20 riable delay..
0570: 20 20 20 20 20 20 6e 61 6d 65 73 70 61 63 65 20 namespace
0580: 75 70 76 61 72 20 63 5f 24 63 68 61 6e 20 77 61 upvar c_$chan wa
0590: 74 63 68 69 6e 67 20 77 61 74 63 68 69 6e 67 0d tching watching.
05a0: 0a 20 20 20 20 20 20 20 20 6e 61 6d 65 73 70 61 . namespa
05b0: 63 65 20 75 70 76 61 72 20 63 5f 24 63 68 61 6e ce upvar c_$chan
05c0: 20 74 69 6d 65 72 20 74 69 6d 65 72 0d 0a 20 20 timer timer..
05d0: 20 20 20 20 20 20 69 66 20 7b 22 77 72 69 74 65 if {"write
05e0: 22 20 69 6e 20 24 77 61 74 63 68 69 6e 67 7d 20 " in $watching}
05f0: 7b 0d 0a 20 20 20 20 20 20 20 20 20 20 20 20 73 {.. s
0600: 65 74 20 74 69 6d 65 72 20 5b 61 66 74 65 72 20 et timer [after
0610: 69 64 6c 65 20 61 66 74 65 72 20 24 64 65 6c 61 idle after $dela
0620: 79 20 5c 0d 0a 20 20 20 20 20 20 20 20 20 20 20 y \..
0630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0640: 5b 6e 61 6d 65 73 70 61 63 65 20 63 6f 64 65 20 [namespace code
0650: 5b 6c 69 73 74 20 70 6f 73 74 20 24 63 68 61 6e [list post $chan
0660: 5d 5d 5d 0d 0a 20 20 20 20 20 20 20 20 20 20 20 ]]]..
0670: 20 63 68 61 6e 20 70 6f 73 74 65 76 65 6e 74 20 chan postevent
0680: 24 63 68 61 6e 20 77 72 69 74 65 0d 0a 20 20 20 $chan write..
0690: 20 20 20 20 20 7d 0d 0a 20 20 20 20 7d 0d 0a 7d }.. }..}
06a0: 0d 0a 73 65 74 20 66 20 5b 63 68 61 6e 20 63 72 ..set f [chan cr
06b0: 65 61 74 65 20 77 20 5b 6e 61 6d 65 73 70 61 63 eate w [namespac
06c0: 65 20 77 68 69 63 68 20 72 65 66 63 68 61 6e 5d e which refchan]
06d0: 5d 0d 0a 63 68 61 6e 20 63 6f 6e 66 69 67 75 72 ]..chan configur
06e0: 65 20 24 66 20 2d 62 6c 6f 63 6b 69 6e 67 20 30 e $f -blocking 0
06f0: 0d 0a 73 65 74 20 64 61 74 61 20 22 73 6f 6d 65 ..set data "some
0700: 20 64 61 74 61 22 0d 0a 73 65 74 20 78 20 30 0d data"..set x 0.
0710: 0a 63 68 61 6e 20 65 76 65 6e 74 20 24 66 20 77 .chan event $f w
0720: 72 69 74 61 62 6c 65 20 5b 6e 61 6d 65 73 70 61 ritable [namespa
0730: 63 65 20 63 6f 64 65 20 7b 0d 0a 20 20 20 20 70 ce code {.. p
0740: 75 74 73 20 24 66 20 24 64 61 74 61 0d 0a 20 20 uts $f $data..
0750: 20 20 69 6e 63 72 20 63 6f 75 6e 74 20 5b 73 74 incr count [st
0760: 72 69 6e 67 20 6c 65 6e 67 74 68 20 24 64 61 74 ring length $dat
0770: 61 5d 0d 0a 20 20 20 20 69 66 20 7b 24 63 6f 75 a].. if {$cou
0780: 6e 74 20 3e 20 32 36 32 31 34 34 7d 20 7b 0d 0a nt > 262144} {..
0790: 20 20 20 20 20 20 20 20 63 68 61 6e 20 65 76 65 chan eve
07a0: 6e 74 20 24 66 20 77 72 69 74 61 62 6c 65 20 7b nt $f writable {
07b0: 7d 0d 0a 20 20 20 20 20 20 20 20 73 65 74 20 78 }.. set x
07c0: 20 64 6f 6e 65 0d 0a 20 20 20 20 7d 0d 0a 7d 5d done.. }..}]
07d0: 0d 0a 73 65 74 20 74 6f 6b 65 6e 20 5b 61 66 74 ..set token [aft
07e0: 65 72 20 31 30 30 30 30 20 5b 6e 61 6d 65 73 70 er 10000 [namesp
07f0: 61 63 65 20 63 6f 64 65 20 7b 0d 0a 20 20 20 20 ace code {..
0800: 73 65 74 20 78 20 74 69 6d 65 6f 75 74 0d 0a 7d set x timeout..}
0810: 5d 5d 0d 0a 76 77 61 69 74 20 5b 6e 61 6d 65 73 ]]..vwait [names
0820: 70 61 63 65 20 77 68 69 63 68 20 2d 76 61 72 69 pace which -vari
0830: 61 62 6c 65 20 78 5d 0d 0a 63 6c 6f 73 65 20 24 able x]..close $
0840: 66 0d 0a 70 75 74 73 20 63 6f 75 6e 74 3a 24 63 f..puts count:$c
0850: 6f 75 6e 74 0d 0a 70 75 74 73 20 24 78 0d 0a 0d ount..puts $x...
0860: 0a .
