File: TheServer.tcl

package info (click to toggle)
coccinella 0.96.20-9
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 13,184 kB
  • sloc: tcl: 124,744; xml: 206; makefile: 66; sh: 62
file content (203 lines) | stat: -rw-r--r-- 6,215 bytes parent folder | download | duplicates (4)
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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
#  TheServer.tcl ---
#  
#       This file is part of The Coccinella application. It implements the
#       server part and contains procedures for creating new server side sockets,
#       handling canvas operations and file transfer.
#      
#  Copyright (c) 1999-2005  Mats Bengtsson
#  
#   This program is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 3 of the License, or
#   (at your option) any later version.
#   
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#   
#   You should have received a copy of the GNU General Public License
#   along with this program.  If not, see <http://www.gnu.org/licenses/>.
#  
# $Id: TheServer.tcl,v 1.32 2007-09-14 08:11:47 matben Exp $
    
package provide TheServer 1.0

namespace eval ::TheServer:: { 

    ::hooks::register launchFinalHook       ::TheServer::LaunchHook
}

proc ::TheServer::LaunchHook { } {
    global  prefs canvasSafeInterp
    
    if {$prefs(makeSafeServ)} {
	set canvasSafeInterp [interp create -safe]
	
	# Make an alias in the safe interpreter to enable drawing in the canvas.
	$canvasSafeInterp alias SafeCanvasDraw ::CanvasUtils::CanvasDrawSafe
    }

    # Start the server. It was necessary to have an 'update idletasks' command here
    # because when starting the script directly, and not from within wish, somehow
    # there was a timing problem in '::TheServer::DoStartServer'.
    # Don't start the server if we are a client only.

    if {$prefs(autoStartServer)} {
	after $prefs(afterStartServer) [list ::TheServer::DoStartServer $prefs(thisServPort)]
    }
}

# ::TheServer::DoStartServer ---
#
#       This belongs to the server part, but is necessary for autoStartServer.
#       Some operations can be critical since the app is not yet completely 
#       launched.
#       Therefore 'after idle'.(?)

proc ::TheServer::DoStartServer {thisServPort} {
    global  prefs state this
    
    if {[catch {
	socket -server [namespace current]::SetupChannel $thisServPort
    } sock]} {
	after 500 {::UI::MessageBox -message [mc "Cannot start server socket. Perhaps you are not connected."] \
	  -icon error -title [mc "Error"] -type ok}
    } else {
	set state(serverSocket) $sock
	set state(isServerUp) 1
	
	# Sometimes this gives 0.0.0.0, why I don't know.
	set sockname [fconfigure $sock -sockname]
	if {[lindex $sockname 0] ne "0.0.0.0"} {
	    set this(ipnum) [lindex $sockname 0]
	}

	# Stop before quitting.
	::hooks::register quitAppHook ::TheServer::DoStopServer
    }
}

# ::TheServer::DoStopServer --
#   
#       Closes the server socket, prevents new connections, but existing ones
#       are kept alive.
#       
# Arguments:
#       
# Results:
#       none

proc ::TheServer::DoStopServer { } {
    global  state
    
    catch {close $state(serverSocket)}
    set state(isServerUp) 0
}

# ::TheServer::SetupChannel --
#   
#       Handles remote connections to the server port. 
#       Sets up the callback routine.
#       
# Arguments:
#       channel     the socket
#       ip          ip number
#       port        port number
#       
# Results:
#       socket event handler set up.

proc ::TheServer::SetupChannel {channel ip port} {
    
    # This is the important code that sets up the server event handler.
    fileevent $channel readable [list ::TheServer::HandleClientRequest $channel $ip $port]

    # Everything should be done with 'fileevent'.
    fconfigure $channel -blocking 0

    # Everything is lineoriented except binary transfer operations.
    fconfigure $channel -buffering line
    
    # For nonlatin characters to work be sure to use Unicode/UTF-8.
    catch {fconfigure $channel -encoding utf-8}

    Debug 2 "---> Connection made to $ip:${port} on channel $channel."
    
    ::hooks::run serverNewConnectionHook $channel $ip $port
}

# ::TheServer::HandleClientRequest --
#
#       This is the actual server that reads client requests. 
#       The most important is the CANVAS command which is a complete
#       canvas command that is prefixed only by the widget path.
#
# Arguments:
#       channel
#       ip
#       port
#       
# Results:
#       one line read from socket.

proc ::TheServer::HandleClientRequest {channel ip port} {
    global  fileTransportChannel prefs
        
    # If client closes socket to this server.
        
    if {[catch {eof $channel} iseof] || $iseof} {

	::Debug 2 "::TheServer::HandleClientRequest:: eof channel=$channel"
	fileevent $channel readable {}
	
	# Update entry only for nontemporary channels.
	if {[info exists fileTransportChannel($channel)]} {
	    unset fileTransportChannel($channel)
	} else {
	    ::hooks::run serverEofHook $channel $ip $port
	}
		
    } elseif {[gets $channel line] != -1} {
		
	# Interpret the command we just read. 
	# Non Jabber only supports a single whiteboard instance.
	ExecuteClientRequest $channel $ip $port $line
    }
}

proc ::TheServer::ExecuteClientRequest {channel ip port line args} {
    global  fileTransportChannel
    
    if {![regexp {^([A-Z ]+): *(.*)$} $line x cmd instr]} {
	return
    }
    
    switch -exact -- $cmd {
	GET {

	    # Do not interfer with put/get operations.
	    fileevent $channel readable {}
	    set fileName [lindex $instr 0]
	    set optList [lrange $instr 1 end]
	    set opts [::Import::GetTclSyntaxOptsFromTransport $optList]
	    set fileTransportChannel($channel) 1
	    
	    ::hooks::run serverGetRequestHook $channel $ip $fileName $opts
	}
	PUT {
	    fileevent $channel readable {}
	    set fileName [file tail [lindex $instr 0]]
	    set optList [lrange $instr 1 end]
	    set opts [::Import::GetTclSyntaxOptsFromTransport $optList]
	    set fileTransportChannel($channel) 1
	    
	    ::hooks::run serverPutRequestHook $channel $fileName $opts
	}
	default {
	    ::hooks::run serverCmdHook $channel $ip $port $line
	}
    }    
}

#-------------------------------------------------------------------------------