Check-in [87a26578f9]
Not logged in
Home Downloads Timeline Branches Tags Tickets Wiki Login

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

Overview
Comment:cleanup in tkconclient
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 87a26578f9ab1eed967246af25ac317479cf6e78
User & Date: chw 2019-05-16 07:42:43.189
Context
2019-05-17
04:34
add pattern matching to materialicons as described in ticket [797b5ba3a2] check-in: 2222b5b7b0 user: chw tags: trunk
2019-05-16
07:42
cleanup in tkconclient check-in: 87a26578f9 user: chw tags: trunk
2019-05-15
21:29
add tcl upstream changes check-in: 8b0f3656fc user: chw tags: trunk
Changes
Unified Diff Ignore Whitespace Patch
Changes to assets/tkconclient1.0/tkconclient.tcl. 

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


# from http://wiki.tcl.tk/14701
#
# Useful on Android in ~/.wishrc for remote control
#
#    package require tkconclient
#    tkconclient::start 12345
#
# when USB debugging is on, forward port 12345 of the
# device with this command on the development system
#
#    adb forward tcp:12345 tcp:12345
#
# then use tkcon's attach to socket with localhost 12345




namespace eval tkconclient {
    variable script ""
    variable server ""
    variable socket ""
    namespace export start stop
    proc start {port {myaddr {}}} {
        variable socket
        variable server
        if {$socket ne "" || $server ne ""} stop


	if {$myaddr eq ""} {
	    set server [socket -server [namespace current]::accept $port]
	} else {
	    set server [socket -server [namespace current]::accept \
			    -myaddr $myaddr $port]
	}
    }
    proc stop {} {
        variable server
        if {$server ne ""} {
            closesocket
            close $server
            set server ""
        }
    }
    proc closesocket {} {
        variable socket
        if {$socket eq ""} {
            return
        }
        catch {close $socket}
        set socket ""
        # Restore [puts]
        rename ::puts ""
        rename [namespace current]::puts ::puts
    }
    proc accept {sock host port} {
        variable socket
        fconfigure $sock -blocking 0 -buffering none
        if {$socket ne ""} {
            puts $sock "Only one connection at a time, please!"
            close $sock
        } else {
            set socket $sock
            fileevent $sock readable [namespace current]::handle
            # Redirect [puts]
            rename ::puts [namespace current]::puts
            interp alias {} ::puts {} [namespace current]::_puts
        }
    }
    proc handle {} {
        variable script
        variable socket

>
|






|
|



|
>
>
>









|
>
>
|
|
|
|
|
|
















|












|








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

# Adapted from
#    https://wiki.tcl-lang.org/page/Tkcon+Remote+Access+over+TCP+Sockets
#
# Useful on Android in ~/.wishrc for remote control
#
#    package require tkconclient
#    tkconclient::start 12345
#
# when USB debugging is on, forward port 12345 of the device
# with the following adb command on the development system
#
#    adb forward tcp:12345 tcp:12345
#
# then use tkcon's attach to socket function with localhost 12345
# or alternatively use "netcat localhost 12345",
# or alternatively use "socat TCP:localhost:12345 STDIO",
# or use "telnet localhost 12345".

namespace eval tkconclient {
    variable script ""
    variable server ""
    variable socket ""
    namespace export start stop
    proc start {port {myaddr {}}} {
        variable socket
        variable server
        if {$socket ne "" || $server ne ""} {
            stop
        }
        if {$myaddr eq ""} {
            set server [socket -server [namespace current]::accept $port]
        } else {
            set server [socket -server [namespace current]::accept \
                            -myaddr $myaddr $port]
        }
    }
    proc stop {} {
        variable server
        if {$server ne ""} {
            closesocket
            close $server
            set server ""
        }
    }
    proc closesocket {} {
        variable socket
        if {$socket eq ""} {
            return
        }
        catch {close $socket}
        set socket ""
        # Restore puts command
        rename ::puts ""
        rename [namespace current]::puts ::puts
    }
    proc accept {sock host port} {
        variable socket
        fconfigure $sock -blocking 0 -buffering none
        if {$socket ne ""} {
            puts $sock "Only one connection at a time, please!"
            close $sock
        } else {
            set socket $sock
            fileevent $sock readable [namespace current]::handle
            # Redirect puts command
            rename ::puts [namespace current]::puts
            interp alias {} ::puts {} [namespace current]::_puts
        }
    }
    proc handle {} {
        variable script
        variable socket
︙︙
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

                }
                set script ""
            }
        } else {
            closesocket
        }
    }
    ## This procedure is partially borrowed from tkcon
    proc _puts args {
        variable socket
        set len [llength $args]
        foreach {arg1 arg2 arg3} $args { break }

        switch $len {
            1 {
                puts $socket $arg1

            }
            2 {
                switch -- $arg1 {
                    -nonewline - stdout - stderr {
                        puts $socket $arg2

                    }
                    default {

                        set len 0
                    }
                }
            }
            3 {
                if {$arg1 eq "-nonewline" &&
                    ($arg2 eq "stdout" || $arg2 eq "stderr")} {
                    puts $socket $arg3
                } elseif {($arg1 eq "stdout" || $arg1 eq "stderr") \
                              && $arg3 eq "-nonewline"} {
                    puts $socket $arg2
                } else {
                    set len 0
                }
            }
            default {
                set len 0
            }
        }
        ## $len == 0 means it wasn't handled above.
        if {$len == 0} {
            global errorCode errorInfo
            if {[catch [linsert $args 0 puts] msg]} {
                regsub tkcon_tcl_puts $msg puts msg
                regsub -all tkcon_tcl_puts $errorInfo puts errorInfo
                return -code error $msg
            }
            return $msg
        }
    }
}

package provide tkconclient 1.0









|



|
<



>



|
|
>

|
>
|






|
<
<
<
<
|


<
<
|
<
|
<
<
|
<
<
|
|
|
<






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

                }
                set script ""
            }
        } else {
            closesocket
        }
    }
    # Procedure partially borrowed from tkcon
    proc _puts args {
        variable socket
        set len [llength $args]
        lassign $args arg1 arg2 arg3

        switch $len {
            1 {
                puts $socket $arg1
                return
            }
            2 {
                switch -- $arg1 {
                    -nonewline {
                        puts -nonewline $socket $arg2
                        return
                    }
                    stdout - stderr {
                        puts $socket $arg2
                        return
                    }
                }
            }
            3 {
                if {$arg1 eq "-nonewline" &&
                    ($arg2 eq "stdout" || $arg2 eq "stderr")} {
                    puts -nonewline $socket $arg3




                    return
                }
            }


        }

        # not handled in switch above


        if {[catch [linsert $args 0 puts] msg]} {


            return -code error $msg
        }
        return $msg

    }
}

package provide tkconclient 1.0
jni/tcl/library/msgs/ja.msg became executable.
︙︙
Fossil version [bcbf150dc2] 2025-06-30 17:00:42