OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [tests/] [remote.tcl] - Blame information for rev 1774

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom 
# This file contains Tcl code to implement a remote server that can be
2 
# used during testing of Tcl socket code. This server is used by some
3 
# of the tests in socket.test.
4 
#
5 
# Source this file in the remote server you are using to test Tcl against.
6 
#
7 
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
8 
#
9 
# See the file "license.terms" for information on usage and redistribution
10 
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
11 
#
12 
# RCS: @(#) $Id: remote.tcl,v 1.1.1.1 2002-01-16 10:25:36 markom Exp $
13 
 
14 
# Initialize message delimitor
15 
 
16 
# Initialize command array
17 
catch {unset command}
18 
set command(0) ""
19 
set callerSocket ""
20 
 
21 
# Detect whether we should print out connection messages etc.
22 
if {![info exists VERBOSE]} {
23 
    set VERBOSE 0
24 
}
25 
 
26 
proc __doCommands__ {l s} {
27 
    global callerSocket VERBOSE
28 
 
29 
    if {$VERBOSE} {
30 
        puts "--- Server executing the following for socket $s:"
31 
        puts $l
32 
        puts "---"
33 
    }
34 
    set callerSocket $s
35 
    if {[catch {uplevel #0 $l} msg]} {
36 
        list error $msg
37 
    } else {
38 
        list success $msg
39 
    }
40 
}
41 
 
42 
proc __readAndExecute__ {s} {
43 
    global command VERBOSE
44 
 
45 
    set l [gets $s]
46 
    if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
47 
        if {[info exists command($s)]} {
48 
            puts $s [list error incomplete_command]
49 
        }
50 
        puts $s "--Marker--Marker--Marker--"
51 
        return
52 
    }
53 
    if {[string compare $l ""] == 0} {
54 
        if {[eof $s]} {
55 
            if {$VERBOSE} {
56 
                puts "Server closing $s, eof from client"
57 
            }
58 
            close $s
59 
        }
60 
        return
61 
    }
62 
    append command($s) $l "\n"
63 
    if {[info complete $command($s)]} {
64 
        set cmds $command($s)
65 
        unset command($s)
66 
        puts $s [__doCommands__ $cmds $s]
67 
    }
68 
    if {[eof $s]} {
69 
        if {$VERBOSE} {
70 
            puts "Server closing $s, eof from client"
71 
        }
72 
        close $s
73 
    }
74 
}
75 
 
76 
proc __accept__ {s a p} {
77 
    global VERBOSE
78 
 
79 
    if {$VERBOSE} {
80 
        puts "Server accepts new connection from $a:$p on $s"
81 
    }
82 
    fileevent $s readable [list __readAndExecute__ $s]
83 
    fconfigure $s -buffering line -translation crlf
84 
}
85 
 
86 
set serverIsSilent 0
87 
for {set i 0} {$i < $argc} {incr i} {
88 
    if {[string compare -serverIsSilent [lindex $argv $i]] == 0} {
89 
        set serverIsSilent 1
90 
        break
91 
    }
92 
}
93 
if {![info exists serverPort]} {
94 
    if {[info exists env(serverPort)]} {
95 
        set serverPort $env(serverPort)
96 
    }
97 
}
98 
if {![info exists serverPort]} {
99 
    for {set i 0} {$i < $argc} {incr i} {
100 
        if {[string compare -port [lindex $argv $i]] == 0} {
101 
            if {$i < [expr $argc - 1]} {
102 
                set serverPort [lindex $argv [expr $i + 1]]
103 
            }
104 
            break
105 
        }
106 
    }
107 
}
108 
if {![info exists serverPort]} {
109 
    set serverPort 2048
110 
}
111 
 
112 
if {![info exists serverAddress]} {
113 
    if {[info exists env(serverAddress)]} {
114 
        set serverAddress $env(serverAddress)
115 
    }
116 
}
117 
if {![info exists serverAddress]} {
118 
    for {set i 0} {$i < $argc} {incr i} {
119 
        if {[string compare -address [lindex $argv $i]] == 0} {
120 
            if {$i < [expr $argc - 1]} {
121 
                set serverAddress [lindex $argv [expr $i + 1]]
122 
            }
123 
            break
124 
        }
125 
    }
126 
}
127 
if {![info exists serverAddress]} {
128 
    set serverAddress 0.0.0.0
129 
}
130 
 
131 
if {$serverIsSilent == 0} {
132 
    set l "Remote server listening on port $serverPort, IP $serverAddress."
133 
    puts ""
134 
    puts $l
135 
    for {set c [string length $l]} {$c > 0} {incr c -1} {puts -nonewline "-"}
136 
    puts ""
137 
    puts ""
138 
    puts "You have set the Tcl variables serverAddress to $serverAddress and"
139 
    puts "serverPort to $serverPort. You can set these with the -address and"
140 
    puts "-port command line options, or as environment variables in your"
141 
    puts "shell."
142 
    puts ""
143 
    puts "NOTE: The tests will not work properly if serverAddress is set to"
144 
    puts "\"localhost\" or 127.0.0.1."
145 
    puts ""
146 
    puts "When you invoke tcltest to run the tests, set the variables"
147 
    puts "remoteServerPort to $serverPort and remoteServerIP to"
148 
    puts "[info hostname]. You can set these as environment variables"
149 
    puts "from the shell. The tests will not work properly if you set"
150 
    puts "remoteServerIP to \"localhost\" or 127.0.0.1."
151 
    puts ""
152 
    puts -nonewline "Type Ctrl-C to terminate--> "
153 
    flush stdout
154 
}
155 
 
156 
if {[catch {set serverSocket \
157 
        [socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} {
158 
    puts "Server on $serverAddress:$serverPort cannot start: $msg"
159 
} else {
160 
    vwait __server_wait_variable__
161 
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.