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
|
# -*- tcl -*-
# ### ### ### ######### ######### #########
##
# Class for handling of active/passive connectivity.
# ### ### ### ######### ######### #########
## Requirements
package require snit
# ### ### ### ######### ######### #########
## Implementation
snit::type ::transfer::connect {
# ### ### ### ######### ######### #########
## API
option -host localhost
option -port 0
option -mode active
option -translation {}
option -encoding {}
option -eofchar {}
method connect {command} {}
# active:
# - connect to host/port
#
# passive:
# - listen on port for connection
# ### ### ### ######### ######### #########
## Implementation
method connect {command} {
if {$options(-mode) eq "active"} {
set sock [socket $options(-host) $options(-port)]
$self Setup $sock
lappend command $self $sock
uplevel \#0 $command
return
} else {
set server [socket -server [mymethod Start $command] \
$options(-port)]
return [lindex [fconfigure $server -sockname] 2]
}
return
}
method Start {command sock peerhost peerport} {
close $server
$self Setup $sock
lappend command $self $sock
uplevel \#0 $command
return
}
method Setup {sock} {
foreach o {-translation -encoding -eofchar} {
if {$options($o) eq ""} continue
fconfigure $sock $o $options($o)
}
return
}
# ### ### ### ######### ######### #########
## Internal helper commands.
onconfigure -mode {newvalue} {
upvar 0 options(-mode) value
if {$value eq $newvalue} return
switch -exact -- $newvalue {
passive - active {
set value $newvalue
}
default {
return -code error "Bad value \"$newvalue\", expected active, or passive"
}
}
return
}
# ### ### ### ######### ######### #########
## Data structures
variable server {}
##
# ### ### ### ######### ######### #########
}
# ### ### ### ######### ######### #########
## Ready
package provide transfer::connect 0.1
|
