./xotcl-1.6.7/COPYRIGHT 0000664 0002265 0002265 00000003336 11654164542 014215 0 ustar neumann neumann * XOTcl - Extended OTcl
*
* Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
*
* (a) Vienna University of Economics and Business Administration
* Dept. of Information Systems / New Media
* A-1090, Augasse 2-6
* Vienna, Austria
*
* (b) University of Essen
* Specification of Software Systems
* Altendorferstraße 97-101
* D-45143 Essen, Germany
*
* Permission to use, copy, modify, distribute, and sell this
* software and its documentation for any purpose is hereby granted
* without fee, provided that the above copyright notice appear in
* all copies and that both that copyright notice and this permission
* notice appear in supporting documentation. We make no
* representations about the suitability of this software for any
* purpose. It is provided "as is" without express or implied
* warranty.
*
*
* This software is based upon MIT Object Tcl by David Wetherall and
* Christopher J. Lindblad, that contains the following copyright
* message:
*
* "Copyright 1993 Massachusetts Institute of Technology
*
* Permission to use, copy, modify, distribute, and sell this
* software and its documentation for any purpose is hereby granted
* without fee, provided that the above copyright notice appear in
* all copies and that both that copyright notice and this
* permission notice appear in supporting documentation, and that
* the name of M.I.T. not be used in advertising or publicity
* pertaining to distribution of the software without specific,
* written prior permission. M.I.T. makes no representations about
* the suitability of this software for any purpose. It is
* provided "as is" without express or implied warranty."
./xotcl-1.6.7/autoclean.sh 0000664 0002265 0002265 00000000145 11654164475 015231 0 ustar neumann neumann #!/bin/sh
make distclean
for configscript in `find . -name configure`
do
rm -f $configscript
done ./xotcl-1.6.7/COMPILE.win 0000664 0002265 0002265 00000004300 11654164542 014521 0 ustar neumann neumann $Id: COMPILE.win,v 1.1 2004/05/23 22:50:39 neumann Exp $
********************************
XOTcl Windows compilation guide:
********************************
- Consider to get a binary distribution of XOTcl from:
http://www.xotcl.org
- XOTcl compiles with the Visual CC Compiler
Visual CC Compilation:
**********************
In order to compile with VCC the following steps have to be performed:
1) Get tcl/tk sources, compile tcl and/or tk, and install them properly.
To compile XOTcl the sources of Tcl (and optionally Tk) are
needed. Tcl (and optionally Tk) must be installed properly. You get
the Tcl/tk sources from:
www.tcl.tk
For compilation instruction see Tcl's documentation.
2) Set the PATH environment to the Tcl binary directory. For instance
in the DOS box you may write something like:
SET PATH=c:\Progra~1\Tcl\bin;%PATH%
where "c:\Progra~1\Tcl\bin" is the Tcl binary directory.
3) Before you can start, you have to get the full sources of
XOTcl. These are packed in a tar.gz file, like xotcl-XXXXX.tar.gz,
and they are available from:
http://www.xotcl.org
Untar the xotcl source. You can do it using a program like Winzip
or with the tar command (e.g. in the cygwin distrbution).
Change into the win directory.
cd win
Open the file "configs.vc". Edit the
first lines with the path information for your system, i.e., where
to find tcl and tk sources and where to find the VCC compiler, and
where tcl/tk binaries are installed.
4) In the 'win' directory, invoke:
nmake -f makefile.vc
to compile xotcl.dll, XOTclSdbm, and Expat.
Moreover, package information and XOTcl documentation will be built.
You can build the xotclsh/xowish (per defaul deactivated), if you
need them:
nmake -f makefile.vc xotclshells
5) Optionally, you may test the XOTcl build:
nmake -f makefile.vc test
6) Now you can install XOTcl with:
tclsh83 installWin.tcl
More installation notes can be found in the README file.
Please report bugs and problems to the authors under one of these
mail adresses:
uwe.zdun@wu-wien.ac.at, zdun@xotcl.org
gustaf.neumann@wu-wien.ac.at, neumann@xotcl.org
./xotcl-1.6.7/apps/comm/secure-webserver.xotcl 0000775 0002265 0002265 00000004020 11654164542 021155 0 ustar neumann neumann #!/usr/bin/env tclsh
# $Id: secure-webserver.xotcl,v 1.2 2006/02/18 22:17:32 neumann Exp $
package require XOTcl; namespace import -force xotcl::*
@ @File {
description {
This small secure web server that provides its documents
via SSL (https, port 8443) and plain http (port 8086).
This file requires TLS. If you experice problems with
versions obtained from the Web, contact gustaf.neumann@wu-wien.ac.at
for a patch.
}
}
#
# We load the following packages:
#
package require xotcl::trace
package require xotcl::comm::httpd
#
# we set the default for document root to ../../src/doc and port to 8443
#
set root ../../doc
set port 8443
set class Httpsd
set cb callback ;# use this for triggering the callbacks
#set cb ""
foreach {att value} $argv {
switch -- $att {
-root {set root $value}
-port {set port $value}
-class {set class $value}
-cb {set cb $value}
}
}
#
# now we can start the web-server instance with these settings
#
Httpd h0 -port 8086 -root $root
$class h1 -port $port -root $root -infoCb $cb \
-requestCert 1 -requireValidCert 0
# Start des HTTP-Servers mit port 8086 und dem angegebenen Verzeichnis
#Httpd h2 -port 9086 -root $root \
-mixin {Responder BasicAccessControl} \
-addRealmEntry test {test test} -protectDir test "" {}
Object callback
callback proc error {chan msg} {
puts stderr "+++TLS/$chan: error: $msg"
}
callback proc verify {chan depth cert rc err} {
array set c $cert
if {$rc != "1"} {
puts stderr "+++TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)"
} else {
puts stderr "+++TLS/$chan: verify/$depth: $c(subject)"
}
return $rc
}
callback proc info {chan state minor msg} {
# For tracing
#upvar #0 tls::$chan cb
#set cb($major) $minor
#puts stderr "+++TLS/$chan: $major/$minor: $state"
puts stderr "+++TLS/$chan $state $minor: $msg"
}
callback proc unknown {option args} {
return -code error "bad option \"$option\": must be one of error, info, or verify"
}
#
# and finally call the event loop...
#
vwait forever
./xotcl-1.6.7/apps/comm/get-regression-nb.xotcl 0000775 0002265 0002265 00000030605 11654164542 021227 0 ustar neumann neumann #!/usr/bin/env tclsh
package require XOTcl; namespace import -force xotcl::*
# ./get-regression-nb.xotcl -host swt -parallel 0
# ./get-regression-nb.xotcl -host swt -sequential 0
#
# mit ~/wafe/src/cineast/webserver.xotcl (benotigt ~/wafe/test/*)
# ./get-regression-nb.xotcl -port 8086
#
# Vergleich webserver.xotcl mit Apache:
# 1) installation von Apache auf port 80
#
# 2) installation vom webserver.xotcl auf port 8086
#
# 3) von beiden server sollend die files in wafe/test/* unter
# http://SERVER+PORT/test/*
# erreichbar sein.
#
# 4) test der installation
# apache:
# cd wafe/src/cineast
# get-regression-nb.xotcl -sequential 0
# die ausgabe sollte mit totalbytes=6536120
# abgeschlossen werden
#
# webserver.xotcl:
# cd wafe/src/cineast
# get-regression-nb.xotcl -port 8086 -sequential 0
# die ausgabe sollte mit totalbytes=6536120
# abgeschlossen werden
#
# 5) grosser testlauf:
# rsh muss funktionieren: z.B.: rsh localhost date
#
# apache:
# cd wafe/src/cineast
# time get-regression-nb.xotcl -sequential 0 -clients 1
#
# webserver.xotcl:
# cd wafe/src/cineast
# time get-regression-nb.xotcl -port 8086 -sequential 0 -clients 1
#
# Ergebnisse auf meinem Rechner:
#
# der xotcl-webserver ist etwa 20% langsamer als apache.
# das logging (instproc log) aktivieren kostet ein paar weitere prozent....
# -gn
#
# mohegan:~/wafe/src/cineast> time ./get-regression-nb.xotcl -port 8086 -sequential 0 -clients 1
# Loading source file ~/wafe/src/cineast/Access.xotcl
# Loading source file ~/wafe/src/cineast/PCache.xotcl
# Loading source file ~/wafe/src/cineast/Connection.xotcl
# Loading source file ~/wafe/src/cineast/trace.xotcl
# 1 clients: 3.07 seconds (per client 3.07 seconds, 2127.31 KB/sec) server: 2127.31 KB/sec
# 2 clients: 6.36 seconds (per client 3.18 seconds, 1028.10 KB/sec) server: 2056.20 KB/sec
# 3 clients: 7.71 seconds (per client 2.57 seconds, 847.74 KB/sec) server: 2543.22 KB/sec
# 4 clients: 11.21 seconds (per client 2.80 seconds, 582.92 KB/sec) server: 2331.66 KB/sec
# 5 clients: 10.57 seconds (per client 2.11 seconds, 618.49 KB/sec) server: 3092.45 KB/sec
# 10 clients: 25.07 seconds (per client 2.51 seconds, 260.68 KB/sec) server: 2606.79 KB/sec
# 20 clients: 45.48 seconds (per client 2.27 seconds, 143.73 KB/sec) server: 2874.58 KB/sec
#0.420u 0.450s 1:49.65 0.7% 0+0k 0+0io 113263310pf+0w
#
#
#
# mohegan:~/wafe/src/cineast> time ./get-regression-nb.xotcl -port 80 -sequential 0 -clients 1
# Loading source file ~/wafe/src/cineast/Access.xotcl
# Loading source file ~/wafe/src/cineast/PCache.xotcl
# Loading source file ~/wafe/src/cineast/Connection.xotcl
# Loading source file ~/wafe/src/cineast/trace.xotcl
# 1 clients: 1.85 seconds (per client 1.85 seconds, 3542.58 KB/sec) server: 3542.58 KB/sec
# 2 clients: 4.71 seconds (per client 2.36 seconds, 1387.02 KB/sec) server: 2774.03 KB/sec
# 3 clients: 4.09 seconds (per client 1.36 seconds, 1596.58 KB/sec) server: 4789.74 KB/sec
# 4 clients: 7.74 seconds (per client 1.94 seconds, 844.43 KB/sec) server: 3377.71 KB/sec
# 5 clients: 9.46 seconds (per client 1.89 seconds, 690.67 KB/sec) server: 3453.33 KB/sec
# 10 clients: 20.91 seconds (per client 2.09 seconds, 312.52 KB/sec) server: 3125.24 KB/sec
# 20 clients: 39.01 seconds (per client 1.95 seconds, 167.55 KB/sec) server: 3351.08 KB/sec
#0.410u 0.360s 1:27.95 0.8% 0+0k 0+0io 112251994pf+0w
#
#
set CACHE_DIR [::xotcl::tmpdir]
package require xotcl::comm::httpAccess
package require xotcl::trace
set port ""
set host localhost
set cachingopts {0 1 2 2}
set parallel 1
set sequential 0
set clients 0
set local 1
foreach {att val} $argv {
switch -exact -- $att {
-port {set port $val}
-host {set host $val}
-memory {set cachingopts 0}
-parallel {set parallel $val}
-sequential {set sequential $val}
-clients {set clients $val}
-local {set local $val}
}
}
set hosts {
R2H2-11 R2H2-12 R2H2-13 R2H2-21 R2H2-22 R2H2-23 R2H2-31 R2H2-32
R2H2-33 R2H2-41 R2H2-42 R2H2-43 R2H2-51 R2H2-52 R2H2-53 R2H2-61
R2H2-62 R2H2-63 R2H2-73
matush nashawag sagumumpsketuck wawog willimantic wonkituck mashipaug
watuppa
}
#set hosts {
# matush nashawag sagumumpsketuck wawog willimantic wonkituck mashipaug
# R2H2-11 R2H2-12 R2H2-13 R2H2-21 R2H2-22 R2H2-23 R2H2-31 R2H2-32
# R2H2-33 R2H2-41 R2H2-42 R2H2-43 R2H2-51 R2H2-52 R2H2-53 R2H2-61
# R2H2-62 R2H2-63 R2H2-73
# watuppa
#}
set totalbytes 6536120
set totalbytes 1293240;# ohne 5m request
if {$clients} {
proc readable {handle rhost} {
if {[eof $handle]} {
incr ::running -1
if {[catch {close $handle} output]} {
if {![string match *$::totalbytes $output]} {
puts stderr "invalid output on client on host $rhost"
puts stderr "***********************************"
puts stderr $output
puts stderr "***********************************"
}
}
#puts stderr clients=$::running
if {$::running == 0} {
set ::xxx 1
}
} else {
gets $handle
}
}
proc clients {clients} {
append cmd "[pwd]/$::argv0 -host $::host " \
"-parallel $::parallel -sequential $::sequential"
if {$::port ne ""} {append cmd " -port $::port"}
set starttime [clock clicks]
set ::running $clients
for {set s 0} {$s < $clients} {incr s} {
if {$::local} {
set rhost localhost
} else {
set rhost [lindex $::hosts $s]
}
#puts stderr "rsh $rhost $cmd"
puts -nonewline stderr "$rhost "
set f($s) [open "| rsh $rhost $cmd"]
fconfigure $f($s) -blocking 0
fileevent $f($s) readable "readable $f($s) $rhost"
}
puts stderr ""
vwait ::xxx
set secs [expr {([clock clicks] -$starttime)/1000000.0}]
puts stderr "[format %3d $clients] clients: [format %6.2f $secs] seconds \
(per client [format %6.2f [expr {$secs/$clients}]] seconds,\
[format %7.2f [expr {$::totalbytes/($secs*1000.0)}]] KB/sec)\
server: [format %7.2f [expr {$::totalbytes*$clients/($secs*1000.0)}]] KB/sec"
}
clients 1
clients 2
clients 3
clients 4
clients 5
clients 10
clients 20
exit
}
persistentCache clear
proc assert {f r} {
set got [eval $f]
if {$got ne $r } {
puts stderr "assertion failed: \[$f\] == $r (got $got)"
quit
} else {
puts stderr "OK $r = $f"
}
}
proc head msg {
puts stderr ""
puts stderr "---------------------------- $msg"
}
proc test {msg cmd} {
set r [Object autoname r]
head $msg
if {[catch {eval $cmd} msg]} {
puts stderr "ERROR: $::errorInfo"
quit
}
$r destroy
}
Object userPwd
userPwd proc user {u} {
my set user $u
}
userPwd proc show {realm userVar pwVar} {
upvar $userVar u $pwVar pw
set u [my set user]
set pw jogl
return 1
}
# test "simple request" {
# SimpleRequest $r -caching 0 \
# -url http://localhost/index.html
# assert "$r getContentLength" 81
# }
# test "simple request" {
# SimpleRequest $r -caching 1 \
# -url http://localhost/index.html
# assert "$r getContentLength" 81
# }
# test "simple request" {
# SimpleRequest $r -caching 1 \
# -url http://localhost/index.html
# assert "$r getContentLength" 81
# }
# test "simple request" {
# persistentCache invalidate \
# http://localhost/index.html
# SimpleRequest $r -caching 1 \
# -url http://localhost/index.html
# assert "$r getContentLength" 81
# }
# test "simple request" {
# SimpleRequest $r -caching 0 \
# -url http://localhost/muster-d1klausur.ps
# assert "$r getContentLength" 163840
# }
set total 0
proc parallelRequests-1.0 {urls} {
ParallelSink psink -httpVersion 1.0 -init -requests $urls
incr ::total [psink set totalbytes]
psink destroy
}
proc parallelRequests-1.1 {urls} {
ParallelSink psink -init -requests $urls
incr ::total [psink set totalbytes]
psink destroy
}
if {$port ne ""} {set port :$port}
if {$parallel} {
parallelRequests-1.0 [list \
http://$host$port/test/file500.html \
http://$host$port/test/file5k.html \
http://$host$port/test/file50k.html \
http://$host$port/test/file500k.html \
http://$host$port/test/file5m.html \
http://$host$port/test/file500.html \
http://$host$port/test/file5k.html \
http://$host$port/test/file5k.html \
http://$host$port/test/file500.html \
http://$host$port/test/file500.html \
http://$host$port/test/file5k.html \
http://$host$port/test/file5k.html \
http://$host$port/test/file500.html \
http://$host$port/test/file5k.html \
http://$host$port/test/file5k.html \
http://$host$port/test/file500.html \
]
for {set i 1} {$i<10} {incr i} {
parallelRequests-1.1 [list \
http://$host$port/test/file50k.html \
http://$host$port/test/file5k1.html \
http://$host$port/test/file5k2.html \
http://$host$port/test/file5k3.html \
http://$host$port/test/file5k4.html \
http://$host$port/test/file5k5.html
]
}
puts stderr totalbytes=$::total
}
if {$sequential} {
set doc http://$host$port/test/suexec.html
set size 20680
foreach c $cachingopts {
test "caching $c $doc" {
SimpleRequest $r -caching $::c -url $::doc
assert "$r getContentLength" $::size
#puts stderr c=<[$r getContent]>
}
}
set doc http://$host$port/test/xvdocs.ps
set size 3678303
foreach c $cachingopts {
test "caching $c" {
SimpleRequest $r -caching $::c -url $::doc
assert "$r getContentLength" $::size
}
}
}
exit
test "simple request" {
SimpleRequest $r -caching 0 \
-url http://nestroy.wi-inf.uni-essen.de/Raumplan.html
assert "$r getContentLength" 662
}
test "simple request, larger file" {
SimpleRequest $r -caching 0 \
-url http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
}
test "use cache" {
SimpleRequest $r -caching 1 \
-url http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
}
test "specify filename, use cache and validate request" {
persistentCache invalidate \
http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
exec rm -f test.ps
SimpleRequest $r -caching 1 -fileName test.ps \
-url http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
assert "file size test.ps" 349970
assert {lindex [exec md5sum test.ps] 0} c6029c987e841430f3ca9bab157da12f
}
test "specify filename, and use cache and a validated file" {
exec rm -f test.ps
SimpleRequest $r -caching 1 -fileName test.ps \
-url http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
assert "file size test.ps" 349970
assert {lindex [exec md5sum test.ps] 0} c6029c987e841430f3ca9bab157da12f
}
test "specify filename, and do not use cache" {
exec rm -f test.ps
SimpleRequest $r -fileName test.ps -caching 0 \
-url http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
assert "file size test.ps" 349970
assert {lindex [exec md5sum test.ps] 0} c6029c987e841430f3ca9bab157da12f
}
test "specify filesink and use cache; no copying neccesary" {
persistentCache invalidate \
http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
SimpleRequest $r -useFileSink 1 -caching 1 \
-url http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
assert "file size test.ps" 349970
}
test "load a large file to the cache" {
persistentCache clearEntry http://swt.wi-inf.uni-essen.de/lx2.1.55
SimpleRequest $r -caching 1 \
-url http://swt.wi-inf.uni-essen.de/lx2.1.55
assert "$r getContentLength" 522411
}
test "load a validated large file" {
SimpleRequest $r -caching 1 \
-url http://swt.wi-inf.uni-essen.de/lx2.1.55
assert "$r getContentLength" 522411
}
test "pure loading test without cache" {
SimpleRequest $r -caching 0 \
-url http://swt.wi-inf.uni-essen.de/lx2.1.55
assert "$r getContentLength" 522411
}
test "redirect" {
SimpleRequest $r -caching 1 \
-url http://mohegan.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
}
test "authentication" {
SimpleRequest $r -caching 1 \
-url http://nestroy.wi-inf.uni-essen.de/cgi-bin/w3-msql/Forschung/Publikationen/protected/index.html
assert "$r getContentLength" 1164
}
puts stderr after
quit
### request joining
### load to file depending on content type
./xotcl-1.6.7/apps/comm/server.key 0000664 0002265 0002265 00000001567 11654164542 016644 0 ustar neumann neumann -----BEGIN RSA PRIVATE KEY-----
MIICXQIBAAKBgQDVg+HdA4RAKyYRaxKRSdAw7mQpephZslIf/ZR7Oe3RKZjxu7Sj
PYG56GSc8y6hiaKuGnDmJcEGXZCXWNtUuACVsNlFrlVbGSEfAbXbz6H4eaaX2d2P
KzrjOc//8+5emaFZRelVTYY4sWNLcCuWV2FIhwMJMblYieXM6iEQg4XzdQIDAQAB
AoGAVdY2OC8QvOdb34bHKSeejf1YwSArHWxF/dxpE/0e8YaimRQYM8QnYgDeagaN
yZ1WjF3O44dsCU4WMfIkAvQSL19RLSgT+jPb3Uu9Aotwmg4x+55BKctRphXKiIfu
+a0IfAFDIt8FMRS08AoSB6eBgOBlhTZM2Y0IuC6QTqaBcwUCQQD5XSiEzh44uMOl
N4FbO0MI2NC3pbPg5u1fEJtIawoYOYxbeGHrlOYO2ZN3ZP6+2g5V0kX5tMMeObhE
qQLlmNETAkEA2zJ/Tk3IE5ByEBcGjG26nJ1zLlY13NaiIg+AoSP+7rHg5TPhoQp1
VVwcqd4ZWCyqgYDFl2TsiiZwKcEIFJBCVwJBANoLpZSLD04V8a2UXV5C8ZjYzZjo
IeP0yXco9D9cqZUJLTwGhckTiB9QDWyHOWH1FjfhCCMS9tKFMiWHi+rrt1UCQQDC
rlvxURX1gmI8NicjzEVk2la1fe5C4QKJW9lzxUOj/qpvB6BK5r4FfVUb7d32uV0K
vjNAXmvT24XdH8usb9/rAkBR1sqUkqwwm0CSe0Rz9IhSlkwWlmvEzSmEguqrd7Zb
rbYJ9NTnV1uFSAX9vcU7lDRp69il6XmyhOL06FYLRaNa
-----END RSA PRIVATE KEY-----
./xotcl-1.6.7/apps/comm/filename.key 0000664 0002265 0002265 00000001703 11654164542 017106 0 ustar neumann neumann -----BEGIN RSA PRIVATE KEY-----
Proc-Type: 4,ENCRYPTED
DEK-Info: DES-EDE3-CBC,075071A5AF5C1D8A
qmihZRxmNNlGCx9lVC4QQPQS25e4aAg3oHjxDaZ0yyDSKsWz4J04lo2x63QT/88i
z9YUQqyC8ry53D5y3aQKiFuXlDDvX6PtPS+cQANA8g5qOIHsMF3yINfrVEmWkPjx
xOYF2qIGI0ISPTT5AkTN3KVmYE7rbFvqgQMklj/SlNBqeUmKvn1rhUCFAd0jYXa9
imaKVMj08q4GItLAqPoJNY4K73IHZeaW8GEWAJ5E/KEzYFBnYUiPUN8UPCCQsC+b
ViRF226hCFSu8yDBah8R/u6W9rEa+Vs/T7Cyklnot2FDyCU0EW/lhKBKfEKTmXAe
sBzN7F1hrLFifUD7VzJ2K7zKh7pMy3X+D+0PUjVaIyZWDIH3nOiTzfK6kxksjoE5
P+fp5IL4okEJgD6MoLJHGWTwfhH9K6QBX01My3s22q5zuiJ3SajRCFlLDn7jTTPV
2OQ9+2FksxJYa5Z5/n63Vslz0+yKv9AVTbrtfrbbRJtmpbElCPrvhzVsuWksRS3A
biZxD5PkWiYDvNm34eOAOARb7n0awTOZ1bqdccT+rhcvo7c+MypIY0/AfZKZK4hN
bWxHR3wZUv+wffx1CBxvsBBomV8XqcqJliVHgdvwDdzl3Z2HbYK3w92RXNY36FYw
C1iqALuxE9nhzyEv0ARfjcXTu0lUmFZOfi4oizzMVj7u2q4mGt0+ZuKBs/fTEEm1
3L1nLnalGb5ko5OTZ4DMQlP1HCU3UZslImAcc3FFa/WNzhG07/YAlcTS18YUbJYF
19Yx6qrYfrZA2UZq0+8DFa8XgOHCFO0KqQHRfRB/7tGNGxX5md8+9w==
-----END RSA PRIVATE KEY-----
./xotcl-1.6.7/apps/comm/webclient.xotcl 0000775 0002265 0002265 00000000423 11654164542 017644 0 ustar neumann neumann #!../../src/xotclsh
package require XOTcl; namespace import -force xotcl::*
@ @File {description {For a sample webclient, see packages/comm/xocomm.test}}
package require xotcl::comm::httpAccess
set hostport localhost:8086
SimpleRequest r0 -url http://$hostport/logo-100.jpg
./xotcl-1.6.7/apps/comm/ftp.xotcl 0000775 0002265 0002265 00000000414 11654164542 016461 0 ustar neumann neumann #!/usr/bin/env tclsh
package require XOTcl; namespace import -force xotcl::*
@ @File {description { A tiny FTP client }}
package require xotcl::comm::ftp
SimpleRequest r1 -url ftp://prep.ai.mit.edu/README
if {[r1 success]} {
puts "Got:"
puts [r1 getContent]
}
./xotcl-1.6.7/apps/comm/webserver.xotcl 0000775 0002265 0002265 00000007413 11654164542 017702 0 ustar neumann neumann #!../../src/xotclsh
# $Id: webserver.xotcl,v 1.9 2007/08/14 16:38:26 neumann Exp $
array set opts {-root ../../doc -port 8086 -protected-port 9096 -pkgdir .}
array set opts $argv
lappend auto_path $opts(-pkgdir)
#if {$::tcl_platform(platform) eq "windows"} {lappend auto_path .}
package require XOTcl 1; namespace import -force xotcl::*
proc ! string {
set f [open [::xotcl::tmpdir]/log w+];
puts $f "[clock format [clock seconds]] $string"
close $f
}
@ @File {
description {
This small demo program starts two different webservers:
Firstly, it provides a sample web server that povides the documents in
../../src/doc (or the files specified with -root) at port 8086
(or at the port specified via the -port option) as unprotected resources.
Secondly, it starts a second webserver with basic access control
(it accepts test/test as user/password) on port 9096 (or on the
port specified via -protected-port). If it receives an request
for an resource named "exit", it terminates. For all other requests
it returns actual information about the user and the issued request.
To see, how it works, contact it e.g. from netscape.
}
}
! "#### webserver starting"
# We load the following packages:
#
#::xotcl::package import ::xotcl::comm::httpd
package require -exact xotcl::comm::httpd 1.1
! "#### httpd required"
# now we can start the web-server instance with these settings
#
Httpd h1 -port $opts(-port) -root $opts(-root)
@ Httpd h1 {description "unprotected web server"}
! "#### h1 started"
# specialized worker, which executes tcl commands in web pages
@ Class SpecializedWorker { description {
Specialized worker that can be passed to any webserver
}}
Class SpecializedWorker -superclass Httpd::Wrk
@ SpecializedWorker instproc respond {} { description {
This method handles all responses from the webserver to the client.
We implent here "exit", and we return the information about the actual
request and user in HTML format for all other requests.
This method is an example, how to access on the server side
request specific infomation.
}}
SpecializedWorker instproc respond {} {
if {[my set resourceName] eq "exit"} {
set ::forever 1
#my showVars
#my set version 1.0;### ????
#puts stderr HERE
}
# return for all other requests the same response
foreach {a v} [my array get meta] {
append m
$a
$v
\n
}
set content {
Request Info
method:
[my set method]
resource:
[my set resourceName]
user:
[my set user]
version:
HTTP/[my set version]
response port:
[my set port]
request comes from:
[my set ipaddr]
Request Header Fields
$m
}
set c [subst $content]
my replyCode 200
my connection puts "Content-Type: text/html"
my connection puts "Content-Length: [string length $c]\n"
my connection puts-nonewline $c
my close
}
@ Httpd h2 {
description "Web server with basic authentication using the specialied worker"}
if {[info exists env(USER)]} {
set USER "$env(USER)"
} elseif {[info exists env(USERNAME)]} {
set USER "$env(USERNAME)"
} else {
set USER unknown
}
if {$::tcl_platform(platform) eq "windows"} {
set USER unknown
}
Httpd h2 -port $opts(-protected-port) -root $opts(-root) \
-httpdWrk SpecializedWorker \
-mixin Httpd::BasicAccessControl \
-addRealmEntry test "u1 test $USER test" -protectDir test "" {}
! "#### h2 started"
#
# and finally call the event loop...
#
vwait forever
./xotcl-1.6.7/apps/comm/client.pem 0000664 0002265 0002265 00000006340 11654164542 016577 0 ustar neumann neumann issuer :/C=DE/ST=NRW/L=Essen/O=University of Essen/OU=SWT/CN=Fredj Dridi/Email=Fredj.Dridi@uni-essen.de
subject:/CN=Fredj Dridi/Email=fredj_dridi@yahoo.com
serial :02
Certificate:
Data:
Version: 3 (0x2)
Serial Number: 2 (0x2)
Signature Algorithm: md5WithRSAEncryption
Issuer: C=DE, ST=NRW, L=Essen, O=University of Essen, OU=SWT, CN=Fredj Dridi/Email=Fredj.Dridi@uni-essen.de
Validity
Not Before: Apr 28 08:24:43 2000 GMT
Not After : Apr 28 08:24:43 2001 GMT
Subject: CN=Fredj Dridi/Email=fredj_dridi@yahoo.com
Subject Public Key Info:
Public Key Algorithm: rsaEncryption
RSA Public Key: (1024 bit)
Modulus (1024 bit):
00:e4:df:a7:f3:ed:61:df:30:ad:d9:6f:63:f2:d1:
85:9b:72:b2:c6:e4:fd:50:11:c5:0a:29:59:02:60:
29:f6:2c:6a:35:08:89:49:ad:d4:44:1d:7f:14:18:
61:4d:e8:66:87:30:01:52:cd:7d:16:72:0e:24:38:
19:a5:a7:dc:cf:7a:5d:79:ea:48:c6:c4:ae:52:a6:
94:36:7f:f3:24:43:b0:21:5a:f2:d5:6d:66:38:4c:
b7:7a:0e:ce:12:01:b0:46:4b:ea:08:b4:e0:aa:b8:
96:dc:3e:15:e0:24:92:84:1f:77:d0:8d:73:d2:f3:
ac:82:b0:61:60:1a:6a:fc:b9
Exponent: 65537 (0x10001)
X509v3 extensions:
X509v3 Subject Alternative Name:
email:fredj_dridi@yahoo.com
X509v3 Basic Constraints: critical
CA:FALSE
X509v3 Authority Key Identifier:
keyid:D2:B8:E3:2D:A2:5A:22:78:3A:38:F1:1F:F5:7C:AD:8D:A6:C4:41:0F
X509v3 Extended Key Usage:
TLS Web Client Authentication, E-mail Protection
Signature Algorithm: md5WithRSAEncryption
01:88:26:35:b9:c7:c9:5a:90:ff:b8:9c:37:fa:48:0e:03:82:
b4:18:df:49:e7:5d:42:3a:48:e3:e4:84:c7:b6:ef:cc:91:4c:
47:9d:34:f9:51:0b:63:d0:35:f9:ad:a5:a9:3d:ef:75:23:0c:
14:77:59:79:59:58:c8:74:df:01:b8:de:f2:78:47:64:1a:7e:
4b:09:31:5e:f5:34:e2:ad:5e:e8:81:00:f1:af:fe:48:31:0b:
a9:b1:4d:53:51:9a:15:1f:55:ba:30:e4:0e:02:05:20:4b:de:
9c:d9:86:f1:e4:d9:18:c4:93:03:19:06:a5:f3:cb:2a:28:a0:
fd:de
-----BEGIN CERTIFICATE-----
MIICuzCCAiSgAwIBAgIBAjANBgkqhkiG9w0BAQQFADCBljELMAkGA1UEBhMCREUx
DDAKBgNVBAgTA05SVzEOMAwGA1UEBxMFRXNzZW4xHDAaBgNVBAoTE1VuaXZlcnNp
dHkgb2YgRXNzZW4xDDAKBgNVBAsTA1NXVDEUMBIGA1UEAxMLRnJlZGogRHJpZGkx
JzAlBgkqhkiG9w0BCQEWGEZyZWRqLkRyaWRpQHVuaS1lc3Nlbi5kZTAeFw0wMDA0
MjgwODI0NDNaFw0wMTA0MjgwODI0NDNaMDwxFDASBgNVBAMTC0ZyZWRqIERyaWRp
MSQwIgYJKoZIhvcNAQkBFhVmcmVkal9kcmlkaUB5YWhvby5jb20wgZ8wDQYJKoZI
hvcNAQEBBQADgY0AMIGJAoGBAOTfp/PtYd8wrdlvY/LRhZtyssbk/VARxQopWQJg
KfYsajUIiUmt1EQdfxQYYU3oZocwAVLNfRZyDiQ4GaWn3M96XXnqSMbErlKmlDZ/
8yRDsCFa8tVtZjhMt3oOzhIBsEZL6gi04Kq4ltw+FeAkkoQfd9CNc9LzrIKwYWAa
avy5AgMBAAGjcjBwMCAGA1UdEQQZMBeBFWZyZWRqX2RyaWRpQHlhaG9vLmNvbTAM
BgNVHRMBAf8EAjAAMB8GA1UdIwQYMBaAFNK44y2iWiJ4OjjxH/V8rY2mxEEPMB0G
A1UdJQQWMBQGCCsGAQUFBwMCBggrBgEFBQcDBDANBgkqhkiG9w0BAQQFAAOBgQAB
iCY1ucfJWpD/uJw3+kgOA4K0GN9J511COkjj5ITHtu/MkUxHnTT5UQtj0DX5raWp
Pe91IwwUd1l5WVjIdN8BuN7yeEdkGn5LCTFe9TTirV7ogQDxr/5IMQupsU1TUZoV
H1W6MOQOAgUgS96c2Ybx5NkYxJMDGQal88sqKKD93g==
-----END CERTIFICATE-----
./xotcl-1.6.7/apps/comm/get-regression.xotcl 0000664 0002265 0002265 00000012164 11654164542 020627 0 ustar neumann neumann #!/usr/bin/env tclsh
package require XOTcl; namespace import -force xotcl::*
package require xotcl::comm::httpAccess
package require xotcl::trace
persistentCache clear
proc assert {f r} {
set got [eval $f]
if {$got ne $r } {
puts stderr "assertion failed: \[$f\] == $r (got $got)"
quit
} else {
puts stderr "OK $r = $f"
}
}
proc head msg {
puts stderr ""
puts stderr "---------------------------- $msg"
}
proc test {msg cmd} {
set r [Object autoname r]
head $msg
if {[catch {eval $cmd} msg]} {
puts stderr "ERROR: $::errorInfo"
quit
}
$r destroy
}
Object userPwd
userPwd proc user {u} {
my set user $u
}
userPwd proc show {realm userVar pwVar} {
upvar $userVar u $pwVar pw
set u [my set user]
set pw jogl
return 1
}
# test "simple request" {
# SimpleRequest $r -caching 0 \
# -url http://localhost/index.html
# assert "$r getContentLength" 81
# }
# test "simple request" {
# SimpleRequest $r -caching 1 \
# -url http://localhost/index.html
# assert "$r getContentLength" 81
# }
# test "simple request" {
# SimpleRequest $r -caching 1 \
# -url http://localhost/index.html
# assert "$r getContentLength" 81
# }
# test "simple request" {
# persistentCache invalidate \
# http://localhost/index.html
# SimpleRequest $r -caching 1 \
# -url http://localhost/index.html
# assert "$r getContentLength" 81
# }
# test "simple request" {
# SimpleRequest $r -caching 0 \
# -url http://localhost/muster-d1klausur.ps
# assert "$r getContentLength" 163840
# }
proc parallelRequests {urls} {
JoinSink joinsink -requests [llength $urls]
set i 0
foreach url $urls {
TimedMemorySink sink$i
set t$i [Access [Access autoname a] -url $url \
-informObject [list joinsink sink$i] \
-caching 0]
incr i
}
set i 0
foreach url $urls { sink$i reportTimes;incr i}
joinsink destroy
}
# parallelRequests {
# http://localhost/muster-d1klausur.ps
# http://localhost/muster-d1klausur2.ps
# }
# quit
foreach c {0 1 2 2} {
test "caching $c" {
SimpleRequest $r -caching $::c \
-url http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
}
}
test "simple request" {
SimpleRequest $r -caching 0 \
-url http://nestroy.wi-inf.uni-essen.de/Raumplan.html
assert "$r getContentLength" 662
}
test "simple request, larger file" {
SimpleRequest $r -caching 0 \
-url http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
}
test "use cache" {
SimpleRequest $r -caching 1 \
-url http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
}
test "specify filename, use cache and validate request" {
persistentCache invalidate \
http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
exec rm -f test.ps
SimpleRequest $r -caching 1 -fileName test.ps \
-url http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
assert "file size test.ps" 349970
assert {lindex [exec md5sum test.ps] 0} c6029c987e841430f3ca9bab157da12f
}
test "specify filename, and use cache and a validated file" {
exec rm -f test.ps
SimpleRequest $r -caching 1 -fileName test.ps \
-url http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
assert "file size test.ps" 349970
assert {lindex [exec md5sum test.ps] 0} c6029c987e841430f3ca9bab157da12f
}
test "specify filename, and do not use cache" {
exec rm -f test.ps
SimpleRequest $r -fileName test.ps -caching 0 \
-url http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
assert "file size test.ps" 349970
assert {lindex [exec md5sum test.ps] 0} c6029c987e841430f3ca9bab157da12f
}
test "specify filesink and use cache; no copying neccesary" {
persistentCache invalidate \
http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
SimpleRequest $r -useFileSink 1 -caching 1 \
-url http://nestroy.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
assert "file size test.ps" 349970
}
test "load a large file to the cache" {
persistentCache clearEntry http://swt.wi-inf.uni-essen.de/lx2.1.55
SimpleRequest $r -caching 1 \
-url http://swt.wi-inf.uni-essen.de/lx2.1.55
assert "$r getContentLength" 522411
}
test "load a validated large file" {
SimpleRequest $r -caching 1 \
-url http://swt.wi-inf.uni-essen.de/lx2.1.55
assert "$r getContentLength" 522411
}
test "pure loading test without cache" {
SimpleRequest $r -caching 0 \
-url http://swt.wi-inf.uni-essen.de/lx2.1.55
assert "$r getContentLength" 522411
}
test "redirect" {
SimpleRequest $r -caching 1 \
-url http://mohegan.wi-inf.uni-essen.de/Lv/muster-d1klausur.ps
assert "$r getContentLength" 349970
}
test "authentication" {
SimpleRequest $r -caching 1 \
-url http://nestroy.wi-inf.uni-essen.de/cgi-bin/w3-msql/Forschung/Publikationen/protected/index.html
assert "$r getContentLength" 1164
}
puts stderr after
quit
### request joining
### load to file depending on content type
./xotcl-1.6.7/apps/comm/secure-webclient.xotcl 0000775 0002265 0002265 00000003015 11654164542 021130 0 ustar neumann neumann #!/usr/bin/env tclsh
# $Id: secure-webclient.xotcl,v 1.2 2006/02/18 22:17:32 neumann Exp $
package require XOTcl; namespace import -force xotcl::*
@ @File {
description {
A sample secure web client that queries an secure web-server.
It needs to be adopted with different https URLs for testing...
}
}
#
package require xotcl::comm::httpAccess
package require xotcl::comm::ftp
package require xotcl::trace
#set version 1.1
set hostport localhost:8086
set http_server http://localhost:8086/
set https_server https://localhost:8443/
set slowURL "http://quote.yahoo.com/q?s=^DJI&d=1d"
set ftpURL "ftp://mohegan.wi-inf.uni-essen.de/welcome.msg"
set secureURL "https://wawog.wi-inf.uni-essen.de/"
set secureURL "https://test17.wu-wien.ac.at:1234/"
proc printError msg {puts stderr !!!$msg!!!}
puts "\nTrying to get a secure page ..... <$https_server>"
SimpleRequest r0 -url $https_server
puts stderr "\n content = {[r0 getContent]}"
puts -nonewline "\nTrying to load image logo-100.jpg ... (not secure)"
SimpleRequest r2 -url $http_server/logo-100.jpg
if {[r2::sink set contentLength] == 1706} {
puts "suceeded! Loaded 1706 bytes!"
} else {
puts "failed! Loaded [r2::sink set contentLength] (!= 1706) bytes"
exit
}
puts -nonewline "\nTrying to load image logo-100.jpg secure ... "
SimpleRequest r1 -url $https_server/logo-100.jpg
if {[r1::sink set contentLength] == 1706} {
puts "suceeded! Loaded 1706 bytes!"
} else {
puts "failed! Loaded [r1::sink set contentLength] (!= 1706) bytes"
exit
}
exit
./xotcl-1.6.7/apps/comm/server.pem 0000664 0002265 0002265 00000006764 11654164542 016641 0 ustar neumann neumann issuer :/C=DE/ST=NRW/L=Essen/O=University of Essen/OU=SWT/CN=Fredj Dridi/Email=Fredj.Dridi@uni-essen.de
subject:/C=DE/ST=NRW/L=Essen/O=University of Essen/OU=SWT/CN=tp600e.wi-inf.uni-essen.de/Email=dridi@tp600e.wi-inf.uni-essen.de
serial :01
Certificate:
Data:
Version: 3 (0x2)
Serial Number: 1 (0x1)
Signature Algorithm: md5WithRSAEncryption
Issuer: C=DE, ST=NRW, L=Essen, O=University of Essen, OU=SWT, CN=Fredj Dridi/Email=Fredj.Dridi@uni-essen.de
Validity
Not Before: Apr 28 08:21:19 2000 GMT
Not After : Apr 28 08:21:19 2001 GMT
Subject: C=DE, ST=NRW, L=Essen, O=University of Essen, OU=SWT, CN=tp600e.wi-inf.uni-essen.de/Email=dridi@tp600e.wi-inf.uni-essen.de
Subject Public Key Info:
Public Key Algorithm: rsaEncryption
RSA Public Key: (1024 bit)
Modulus (1024 bit):
00:d5:83:e1:dd:03:84:40:2b:26:11:6b:12:91:49:
d0:30:ee:64:29:7a:98:59:b2:52:1f:fd:94:7b:39:
ed:d1:29:98:f1:bb:b4:a3:3d:81:b9:e8:64:9c:f3:
2e:a1:89:a2:ae:1a:70:e6:25:c1:06:5d:90:97:58:
db:54:b8:00:95:b0:d9:45:ae:55:5b:19:21:1f:01:
b5:db:cf:a1:f8:79:a6:97:d9:dd:8f:2b:3a:e3:39:
cf:ff:f3:ee:5e:99:a1:59:45:e9:55:4d:86:38:b1:
63:4b:70:2b:96:57:61:48:87:03:09:31:b9:58:89:
e5:cc:ea:21:10:83:85:f3:75
Exponent: 65537 (0x10001)
X509v3 extensions:
X509v3 Authority Key Identifier:
keyid:D2:B8:E3:2D:A2:5A:22:78:3A:38:F1:1F:F5:7C:AD:8D:A6:C4:41:0F
X509v3 Extended Key Usage:
TLS Web Server Authentication, TLS Web Client Authentication, Microsoft Server Gated Crypto, Netscape Server Gated Crypto
X509v3 Basic Constraints: critical
CA:FALSE
Signature Algorithm: md5WithRSAEncryption
38:b5:a1:1c:93:c4:aa:6e:3f:d6:ea:11:7f:7b:2b:11:db:7b:
22:b3:d2:a8:b3:f3:20:64:6a:25:b4:fe:0d:ac:12:49:a0:6e:
6d:ef:fb:99:a2:7c:bc:50:b0:eb:42:ef:0a:32:fa:a9:69:e0:
11:10:9b:00:05:15:97:59:ac:dc:5f:f2:cd:81:28:3e:e6:96:
86:f4:d7:99:71:52:c3:ca:0f:4a:48:d8:66:b0:da:e8:d1:45:
84:c4:12:b2:43:ec:63:b6:25:e8:0a:5a:4c:fb:e2:ec:03:36:
6f:cd:f9:2a:5c:52:ba:02:29:92:f5:bf:c4:96:ff:9e:ed:a3:
cf:02
-----BEGIN CERTIFICATE-----
MIIDIjCCAougAwIBAgIBATANBgkqhkiG9w0BAQQFADCBljELMAkGA1UEBhMCREUx
DDAKBgNVBAgTA05SVzEOMAwGA1UEBxMFRXNzZW4xHDAaBgNVBAoTE1VuaXZlcnNp
dHkgb2YgRXNzZW4xDDAKBgNVBAsTA1NXVDEUMBIGA1UEAxMLRnJlZGogRHJpZGkx
JzAlBgkqhkiG9w0BCQEWGEZyZWRqLkRyaWRpQHVuaS1lc3Nlbi5kZTAeFw0wMDA0
MjgwODIxMTlaFw0wMTA0MjgwODIxMTlaMIGtMQswCQYDVQQGEwJERTEMMAoGA1UE
CBMDTlJXMQ4wDAYDVQQHEwVFc3NlbjEcMBoGA1UEChMTVW5pdmVyc2l0eSBvZiBF
c3NlbjEMMAoGA1UECxMDU1dUMSMwIQYDVQQDExp0cDYwMGUud2ktaW5mLnVuaS1l
c3Nlbi5kZTEvMC0GCSqGSIb3DQEJARYgZHJpZGlAdHA2MDBlLndpLWluZi51bmkt
ZXNzZW4uZGUwgZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBANWD4d0DhEArJhFr
EpFJ0DDuZCl6mFmyUh/9lHs57dEpmPG7tKM9gbnoZJzzLqGJoq4acOYlwQZdkJdY
21S4AJWw2UWuVVsZIR8BtdvPofh5ppfZ3Y8rOuM5z//z7l6ZoVlF6VVNhjixY0tw
K5ZXYUiHAwkxuViJ5czqIRCDhfN1AgMBAAGjZzBlMB8GA1UdIwQYMBaAFNK44y2i
WiJ4OjjxH/V8rY2mxEEPMDQGA1UdJQQtMCsGCCsGAQUFBwMBBggrBgEFBQcDAgYK
KwYBBAGCNwoDAwYJYIZIAYb4QgQBMAwGA1UdEwEB/wQCMAAwDQYJKoZIhvcNAQEE
BQADgYEAOLWhHJPEqm4/1uoRf3srEdt7IrPSqLPzIGRqJbT+DawSSaBube/7maJ8
vFCw60LvCjL6qWngERCbAAUVl1ms3F/yzYEoPuaWhvTXmXFSw8oPSkjYZrDa6NFF
hMQSskPsY7Yl6ApaTPvi7AM2b835KlxSugIpkvW/xJb/nu2jzwI=
-----END CERTIFICATE-----
./xotcl-1.6.7/apps/comm/filename.crt 0000664 0002265 0002265 00000002432 11654164542 017106 0 ustar neumann neumann -----BEGIN CERTIFICATE-----
MIIDmDCCAwGgAwIBAgIBADANBgkqhkiG9w0BAQQFADCBlTELMAkGA1UEBhMCYXQx
EDAOBgNVBAgTB0F1c3RyaWExDzANBgNVBAcTBlZpZW5uYTEQMA4GA1UEChMHV1Ut
V2llbjELMAkGA1UECxMCV0kxHjAcBgNVBAMTFW1vaGVnYW4ud3Utd2llbi5hYy5h
dDEkMCIGCSqGSIb3DQEJARYVbmV1bWFubkB3dS13aWVuLmFjLmF0MB4XDTAyMDQw
MjEwNDUwN1oXDTAyMDUwMjEwNDUwN1owgZUxCzAJBgNVBAYTAmF0MRAwDgYDVQQI
EwdBdXN0cmlhMQ8wDQYDVQQHEwZWaWVubmExEDAOBgNVBAoTB1dVLVdpZW4xCzAJ
BgNVBAsTAldJMR4wHAYDVQQDExVtb2hlZ2FuLnd1LXdpZW4uYWMuYXQxJDAiBgkq
hkiG9w0BCQEWFW5ldW1hbm5Ad3Utd2llbi5hYy5hdDCBnzANBgkqhkiG9w0BAQEF
AAOBjQAwgYkCgYEA5iT1aT1zU5mfqabGQWcdLyGVFlJBuiKnD2wCVDBIJFVYk6EJ
FrFadKgUXNa0Sxrav/5BJyG2ObOrS4BH6yAl8f90QbAokFp9HeW5wkkAhjkSe1Rw
vcts9F+R6OhcBxO+tQ6maR9wIGfWoK+vWDyfO7wnHjiL2YZFW73mDBUuHO8CAwEA
AaOB9TCB8jAdBgNVHQ4EFgQUbnmEzLNHBNqySdNmPzLSf+yjEc8wgcIGA1UdIwSB
ujCBt4AUbnmEzLNHBNqySdNmPzLSf+yjEc+hgZukgZgwgZUxCzAJBgNVBAYTAmF0
MRAwDgYDVQQIEwdBdXN0cmlhMQ8wDQYDVQQHEwZWaWVubmExEDAOBgNVBAoTB1dV
LVdpZW4xCzAJBgNVBAsTAldJMR4wHAYDVQQDExVtb2hlZ2FuLnd1LXdpZW4uYWMu
YXQxJDAiBgkqhkiG9w0BCQEWFW5ldW1hbm5Ad3Utd2llbi5hYy5hdIIBADAMBgNV
HRMEBTADAQH/MA0GCSqGSIb3DQEBBAUAA4GBANj6u54TmwEJg/Ldvfx+Qrax+66n
zh1EYzxrlYp6eNQVPEyOsF1DJh150Lci1Mm/i71D87yJRVjagTv5dAUdupy9Zf6c
AMMv6KvK5G7q6LC9ArwNiBObsmQUlN7+PzRmG9CerRJ6W8eEYnYB0EHhYVKc8cED
F4mixcF1HGQJI/qN
-----END CERTIFICATE-----
./xotcl-1.6.7/apps/comm/link-checker.xotcl 0000775 0002265 0002265 00000011133 11654164542 020227 0 ustar neumann neumann #!/usr/bin/env tclsh
# $Id: link-checker.xotcl,v 1.5 2006/09/27 08:12:39 neumann Exp $
# -gn july 2000
package require XOTcl; namespace import -force xotcl::*
@ @File {
description {
A simple link checking program that checks in parallel
pages of a site.
Options:
-url
Start-URL
-foreign
0 or 1, specifies, whether foreign links of
local pages should be checked (default 1)
-local
A string match pattern to decide
which url should be treated as local
e.g. -local *wu-wien.ac.at/*
Per default the locality filter ist set
to the name of the host followed by '/*'
-restrict
0 or 1, sets the locality filter to the subtree
implied by the URL
-verbose
0 or 1 or 2, verbosity level (default 0)
}
}
if {$tcl_version<8.2} {
puts stderr "This script requires Tcl 8.2 or newer"
exit -1
}
set opt(-url) http://localhost:8000/
set opt(-url) http://nm.wu-wien.ac.at/Lehre/
set opt(-verbose) 0; # 0, 1 (show check), or 2 (show ignore)
set opt(-foreign) 1; # 0, 1 (check foreign links on local pages)
set opt(-restrict) 0; # 0, 1
## per default, lc checks the
array set opt $argv
if {$opt(-restrict)} {
regexp {://(.*)$} $opt(-url) _ opt(-local)
set opt(-local) [string trimright $opt(-local) /]*
puts stderr "locality filter set to '$opt(-local)'"
}
if {![info exists opt(-local)]} {
regexp {http://([^/:]+)} $opt(-url) _ opt(-local)
append opt(-local) /*
puts stderr "locality filter set to '$opt(-local)'"
}
#package require xotcl::package; package verbose 1
package require xotcl::comm::httpAccess
package require xotcl::trace
proc printError {m} {}
Class Checker -superclass ParallelSink \
-parameter {verbose foreign local}
Checker array set ref {A HREF IMG SRC}
Checker set ref_re {[[:space:]]*=[[:space:]]*([[:graph:]]+)}
Checker instproc report {msg {level 1}} {
my instvar verbose
if {$verbose>$level} {puts stderr $msg}
return 0
}
Checker instproc isLocal {url} {
my instvar local
string match *://$local $url
}
Checker instproc isToCheck {url request methodvar} {
my instvar foreign
upvar $methodvar method
if {![regexp -nocase {http://([^/:]+)} $url _ host]} {
return [my report "ignored, no http: $url"]
}
set method GET
if {![my isLocal $url]} {
if {$foreign} {
#puts stderr "parenturl: [$request set parentUrl] -> [my isLocal [$request set parentUrl]]"
if {[$request info vars parentUrl] ne "" &&
![my isLocal [$request set parentUrl]]} {
return [my report "ignored, nor local: $url"]
} else {
set method HEAD
}
} else {
return [my report "ignored, nor local: $url"]
}
}
if {[regexp -nocase {[.](gif|jpg|ps|pdf|gz)$} $url]} {
set method HEAD
#return [my report "ignored due to extension: $url"]
}
return 1
}
Checker instproc checkLink {request link} {
set resolved [resolve $link [$request set url]]
if {[my isToCheck $resolved $request method]} {
my instvar checked
if {![info exists checked($resolved)]} {
my report "checking .......... $resolved" 0
set checked($resolved) 1
my scheduleRequest $method $resolved [$request set url]
} else {
#puts stderr "already checked $resolved"
}
}
}
Checker instproc checkText {request} {
if {![my isLocal [$request set url]]} return
[self class] instvar ref ref_re
set content [$request getContent]
set start 0
while {[regexp -nocase -indices -start $start -- \
{<(A|IMG)([^>]*?)} $content a b c]} {
set elem [string toupper \
[string range $content [lindex $b 0] [lindex $b 1]]]
set attribs [string range $content [lindex $c 0] [lindex $c 1]]
#regsub -all {[\n ]+} $attribs " " attribs
if {[regexp -nocase $ref($elem)$ref_re $attribs _ i]} {
my checkLink $request [string trim $i '\"]
}
set start [lindex $c 1]
}
}
Checker instproc endCb r {
#showObj $r
switch [$r set contentType] {
text/html {my checkText $r}
}
next
}
Checker instproc cancelCb r {
#$r showVars
puts stderr "ERROR in page [$r set parentUrl]"
puts stderr " Link: [$r set url]"
puts stderr " cause [$r set errormsg]\n"
next
}
Checker csink \
-verbose $opt(-verbose) -foreign $opt(-foreign) -local $opt(-local) \
-sinkClass MemorySink -httpVersion 1.0 -maxsimultaneous 30
csink requests $opt(-url)
puts stderr "sumbytes: [csink set sumbytes] requests: [csink set numrequests]"
csink destroy
./xotcl-1.6.7/apps/comm/test-tls-server.xotcl 0000775 0002265 0002265 00000004203 11654164542 020753 0 ustar neumann neumann #!../../src/xotclsh
# $Id: test-tls-server.xotcl,v 1.5 2006/09/27 08:12:39 neumann Exp $
#
# sample secure server that reflect all incoming data to the client
# It uses tls1.3 package of Matt Newman
# Fredj Dridi
package require tls
proc bgerror {err} {
global errorInfo
puts stderr "BG Error: $errorInfo"
}
#
# Sample callback - just reflect data back to client
#
proc reflectCB {chan {verbose 0}} {
puts stderr "\n*** reflectCB $chan $verbose"
fconfigure $chan -translation {auto crlf}
set data {}
if {[catch {set n [::gets $chan data]} msg]} {
set error $msg
puts stderr "\nEOF ($data)"
catch {close $chan}
return 0
}
puts stderr n=<$n>
if {$verbose && $data ne ""} {
puts stderr "data=<$data>"
}
if {[eof $chan]} { ;# client gone or finished
puts stderr "\nEOF"
close $chan ;# release the servers client channel
return
}
#puts -nonewline $chan $data
#flush $chan
}
proc acceptCB { chan ip port } {
puts stderr "\n*** acceptCB $chan $ip $port"
tls::import $chan -cafile cacert.pem -certfile server.pem \
-server 1 -request 1 -require 1 -keyfile server.key -command callback
if {![tls::handshake $chan]} {
puts stderr "\nHandshake pending"
return
}
array set cert [tls::status $chan]
puts stderr "\n"
parray cert
fileevent $chan readable [list reflectCB $chan 1]
}
set chan [socket -server acceptCB 8443]
puts stderr "Server waiting connection on $chan (8443)"
## Sample Callback that gives SSL information
Object callback
callback proc error {chan msg} {
puts stderr "+++TLS/$chan: error: $msg"
}
callback proc verify {chan depth cert rc err} {
array set c $cert
if {$rc != "1"} {
puts stderr "+++TLS/$chan: verify/$depth: ** Bad Cert **: $err (rc = $rc)"
} else {
puts stderr "+++TLS/$chan: verify/$depth: $c(subject)"
}
return $rc
}
callback proc info {chan state minor msg} {
puts stderr "+++TLS/$chan $state $minor: $msg"
}
callback proc unknown {option args} {
my showCall
return -code error "bad option \"$option\": must be one of error, info, or verify"
}
# Go into the eventloop
vwait forever
./xotcl-1.6.7/apps/comm/test-tls-client.xotcl 0000775 0002265 0002265 00000004231 11654164542 020724 0 ustar neumann neumann #!../../src/xotclsh
#
# $Id: test-tls-client.xotcl,v 1.2 2006/02/18 22:17:32 neumann Exp $
package require tls
proc bgerror {err} {
global errorInfo
puts stderr "BG Error: $errorInfo"
}
array set opts {
-port 8443
-host localhost
}
array set opts $argv
proc readCB {CHAN} {
#puts stderr "*** CALL: readCB $CHAN"
if {![eof $CHAN]} {
set rData [gets $CHAN]
puts stderr "\nREADING ..."
puts stderr "------------------------------------------------------"
puts stderr <$rData>
puts stderr "------------------------------------------------------"
#fileevent $CHAN writable [list writeCB $CHAN]
} else {
catch {close $CHAN}
puts stderr "\nSocket ($CHAN) is closed."
exit
}
}
proc writeCB {CHAN} {
#puts stderr "*** CALL: writeCB $CHAN"
#puts stderr "fileevent $CHAN writable {}"
fileevent $CHAN writable {}
set wData "GET / HTTP/1.1\r\nHost: localhost\r\nAccept: */*\r\n\r\n"
#set wData "GET\n"
puts -nonewline $CHAN $wData
flush $CHAN
#puts stderr "\nfileevent $CHAN readable [list readCB $CHAN]"
fileevent $CHAN readable [list readCB $CHAN]
}
puts stderr "\n\n\n~~~~~~~~~~~~ Trying $opts(-host):$opts(-port)"
#
# Create socket
#
set chan [socket -async $opts(-host) $opts(-port)]
tls::import $chan -command callback -cafile cacert.pem -certfile client.pem -server 0 -keyfile client.key -request 1 -require 1
puts stderr "setting channel to auto binary"
fconfigure $chan -translation {auto binary}
puts stderr "fileevent $chan writable [list writeCB $chan]"
fileevent $chan writable [list writeCB $chan]
Object callback
callback proc error {chan msg} {
puts stderr "+++TLS/$chan: error: $msg"
}
callback proc verify {chan depth cert rc err} {
array set c $cert
if {$rc != "1"} {
puts stderr "+++TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)"
} else {
puts stderr "+++TLS/$chan: verify/$depth: $c(subject)"
}
return $rc
}
callback proc info {chan state minor msg} {
puts stderr "+++TLS/$chan $state $minor: $msg"
}
callback proc unknown {option args} {
my showCall
return -code error "bad option \"$option\": must be one of error, info, or verify"
}
vwait forever
./xotcl-1.6.7/apps/COPYRIGHT 0000664 0002265 0002265 00000003336 11654164542 015160 0 ustar neumann neumann * XOTcl - Extended OTcl
*
* Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
*
* (a) Vienna University of Economics and Business Administration
* Dept. of Information Systems / New Media
* A-1090, Augasse 2-6
* Vienna, Austria
*
* (b) University of Essen
* Specification of Software Systems
* Altendorferstraße 97-101
* D-45143 Essen, Germany
*
* Permission to use, copy, modify, distribute, and sell this
* software and its documentation for any purpose is hereby granted
* without fee, provided that the above copyright notice appear in
* all copies and that both that copyright notice and this permission
* notice appear in supporting documentation. We make no
* representations about the suitability of this software for any
* purpose. It is provided "as is" without express or implied
* warranty.
*
*
* This software is based upon MIT Object Tcl by David Wetherall and
* Christopher J. Lindblad, that contains the following copyright
* message:
*
* "Copyright 1993 Massachusetts Institute of Technology
*
* Permission to use, copy, modify, distribute, and sell this
* software and its documentation for any purpose is hereby granted
* without fee, provided that the above copyright notice appear in
* all copies and that both that copyright notice and this
* permission notice appear in supporting documentation, and that
* the name of M.I.T. not be used in advertising or publicity
* pertaining to distribution of the software without specific,
* written prior permission. M.I.T. makes no representations about
* the suitability of this software for any purpose. It is
* provided "as is" without express or implied warranty."
./xotcl-1.6.7/apps/persistence/persistenceTest.xotcl 0000775 0002265 0002265 00000002464 11654164542 022454 0 ustar neumann neumann #!../../src/xotclsh
package require XOTcl; namespace import -force xotcl::*
package require xotcl::store::persistence
package require xotcl::mixinStrategy
PersistenceMgr jufpMgr
PersistenceMgr tclpMgr -dbPackage TclGdbm
Class PersistenceTest -parameter {{countVar 0} {appendVar ""} pm}
PersistenceTest instproc init args {
my mixinStrategy Persistent=Eager
my persistenceMgr [my set pm]
my persistent {countVar appendVar}
next
}
PersistenceTest instproc incrCount {} {
puts "in [self] countVar now is [my countVar]"
my incr countVar
}
PersistenceTest instproc appendV {x} {
my append appendVar $x
puts "append is: [my appendVar]"
}
PersistenceTest instproc test {} {
# first we increment a counter:
my incrCount
# now we 5x append something to appendVar
for {set i 0} {$i<5} {incr i} {
my appendV a
}
# now we list all keys in the database
puts "Variables stored in [my persistenceMgr].db: [[my persistenceMgr] names]"
# now we delete append var
puts "Deleting append:[[my persistenceMgr] delete [self]::appendVar]"
# now we list the keys again
puts "Variables stored in [my persistenceMgr].db: [[my persistenceMgr] names]"
}
PersistenceTest persistenceJufTest -pm jufpMgr -init -test
#PersistenceTest persistenceTclTest -pm tclpMgr -init -test
#PersistenceTest instproc count ./xotcl-1.6.7/apps/scripts/simpleFilters.xotcl 0000664 0002265 0002265 00000002343 11654164542 021246 0 ustar neumann neumann # $Id: simpleFilters.xotcl,v 1.1 2004/05/23 22:50:39 neumann Exp $
@ @File {
description {
Some simple examples of (inst)filters taken from the paper
'Filters as a Language Support for Design Patterns in
Object-Oriented Scripting Languages'. They demonstrate filters,
filter chains and filter inheritance.
}
}
Class A
A instproc Filter-1 args {
puts " pre-part of [self proc]" ;# pre part
next ;# next call
puts " post-part of [self proc]" ;# post part
}
A instproc printSomething args {
puts " actual called proc: [self proc]"
}
A a1
A instfilter Filter-1
#a1 set x 1
puts "A call surrounded by pre/post messages:"
a1 printSomething
A instfilter {}
A instproc Filter-2 args {
puts " only a pre-part in [self proc]"
next
}
A instproc Filter-3 args {
next
puts " only a post-part in [self proc]"
}
A instfilter {Filter-1 Filter-2 Filter-3}
puts "Now a filter chain:"
a1 printSomething
A instfilter {}
Class B -superclass A
B instproc Filter-B args {
puts " entering method: [self proc]"
next
}
B b1; B b2
A instfilter {Filter-1 Filter-2 Filter-3}
B instfilter Filter-B
puts "And finally inheritance:"
b1 printSomething
B instfilter {}
A instfilter {}
./xotcl-1.6.7/apps/scripts/adapter.xotcl 0000664 0002265 0002265 00000001304 11654164542 020040 0 ustar neumann neumann # $Id: adapter.xotcl,v 1.1 2004/05/23 22:50:39 neumann Exp $
Class Adapter -superclass Class
@ @File {
description {
Simple adapter pattern meta-class taken from the paper
'Filters as a Language Support for Design Patterns in
Object-Oriented Scripting Languages'.
}
}
Adapter instproc adapterFilter args {
set r [self calledproc]
my instvar adaptee specificRequest
if {[info exists specificRequest($r)]} {
return [eval $adaptee $specificRequest($r) $args]
}
next
}
Adapter instproc init args {
my instfilterappend adapterFilter
next
my instproc setRequest {r sr} {
my set specificRequest($r) $sr
}
my instproc setAdaptee {a} {
my set adaptee $a
}
}
./xotcl-1.6.7/apps/scripts/pinger.xotcl 0000664 0002265 0002265 00000003175 11654164542 017714 0 ustar neumann neumann #$Id: pinger.xotcl,v 1.1 2004/05/23 22:50:39 neumann Exp $
# include the pattern
source observer.xotcl
Class Pinger
@ @File {
description {
Pinger example for the observer pattern taken from the paper
'Filters as a Language Support for Design Patterns in
Object-Oriented Scripting Languages'.
It demonstrates how to observe a network connection.
}
}
Observer::Subject Pinger::Collector -parameter {hostName {update 1}}
Observer Pinger::Diagram
Observer Pinger::TextOutput
Pinger::Collector instproc init args {
my instvar update hostName
set f [open "| ping -i $update $hostName" r]
fconfigure $f -blocking false
fileevent $f readable "[self] ping \[gets $f\]"
}
Pinger::Collector instproc getResponse {} {
puts "in--- [self] [format %-12s [self proc]] ([self class])"
}
Pinger::Collector instproc ping {string} {
puts "in--- [self] [format %-12s [self proc]] ([self class])"
puts $string
}
Pinger::Diagram instproc update {subject args} {
puts "in--- [self] [format %-12s [self proc]] ([self class]) -- SUBJECT: $subject"
$subject getResponse
# do something with the response
}
Pinger::TextOutput instproc update {subject args} {
puts "in--- [self] [format %-12s [self proc]] ([self class]) -- SUBJECT: $subject"
$subject getResponse
# do something with the response
}
namespace eval ::Pinger {
Collector ::c1 -hostName 132.252.180.231
Collector ::c2 -hostName 137.208.7.48
Diagram ::d1
Diagram ::d2
Diagram ::d3
TextOutput ::t1
}
c1 attachPre ping d1 d2
c1 attachPost ping d2 d3
c1 attachPost ping t1
c2 attachPost ping t1 d2
#c1 detachPre ping d1
#c1 detachPost ping d2 d3
vwait forever
./xotcl-1.6.7/apps/scripts/soccerClub.xotcl 0000664 0002265 0002265 00000017676 11654164542 020527 0 ustar neumann neumann # $Id: soccerClub.xotcl,v 1.7 2007/08/14 16:38:26 neumann Exp $
# This is a simple introductory example for the language XOTcl.
# It demonstrates the basic language constructs on the example of
# a soccer club.
package require XOTcl; namespace import -force xotcl::*
# All the characters in this example are fictitious, and any
# resemblance to actual persons, living or deceased, is coincidental.
# In XOTcl we do not have to provide the above file description
# as a comment, but we can use the @ object, which is used generally
# to provide any kind of information, metadata, and documentation on
# a running program. Here, we just give a file description.
# Now makeDoc.xotcl will automatically document this file for us.
@ @File {
description {
This is a simple introductory example for the language XOTcl.
It demonstrates the basic language constructs on the example of
a soccer club.
}
}
#
# All things and entities in XOTcl are objects, a special kind of objects
# are classes. These define common properties for other objects. For a
# soccer club, we firstly require a common class for all kinds of members.
#
# Common to all members is that they have a name. Common properties defined
# across all instances of a class are called "Parameters" in XOTcl.
#
Class ClubMember -parameter {{name ""}}
# A special club member is a Player. Derived classes can be build with
# inheritance (specified through 'superclass'). Players may have a
# playerRole (defaults to NONE):
Class Player -superclass ClubMember -parameter {{playerRole NONE}}
# other club member types are trainers, player-trainers, and presidents
Class Trainer -superclass ClubMember
Class President -superclass ClubMember
# the PlayerTrainer uses multiple inheritance by being both a player
# and a trainer
Class PlayerTrainer -superclass {Player Trainer}
#
# Now we define the SoccerTeam class.
#
Class SoccerTeam -parameter {name location type}
# We may add a player. This is done by a method. Instance methods are
# in XOTcl defined with 'instproc'. All club members are aggregated in
# the team (denoted by :: namespace syntax).
SoccerTeam instproc newPlayer args {
# we use a unique autoname for the object to prevent name
# collisions, like ::player01, ::player02, ...
eval Player [self]::[my autoname player%02d] $args
}
# A player can be transfered to another team. The player object does
# not change internally (e.g. the playerRole stays the same). Therefore we
# 'move' it to the destination team.
SoccerTeam instproc transferPlayer {playername destinationTeam} {
# We use the aggregation introspection option 'children' in order
# to get all club members
foreach player [my info children] {
# But we only remove matching playernames of type "Player". We do
# not want to remove another club member type who has the same
# name.
if {[$player istype Player] && [$player name] == $playername} {
# We simply 'move' the player object to the destination team.
# Again we use a unique autoname in the new scope
$player move [set destinationTeam]::[$destinationTeam autoname player%02d]
}
}
}
# Finally we define two convenience methods to print the members/players to
# stdout with puts.
SoccerTeam instproc printMembers {} {
puts "Members of [my name]:"
foreach m [my info children] {puts " [$m name]"}
}
SoccerTeam instproc printPlayers {} {
puts "Players of [my name]:"
foreach m [my info children] {
if {[$m istype Player]} {puts " [$m name]"}
}
}
# Now let us build to example soccer team objects.
SoccerTeam lyon -name "Olympique Lyon" -location "Lyon"
SoccerTeam bayernMunich -name "F.C. Bayern München" -location "Munich"
# With 'addPlayer' we can create new aggregated player objects
#
# Let us start some years in the past, when "Franz Beckenbauer" was
# still a player.
set fb [bayernMunich newPlayer -name "Franz Beckenbauer" \
-playerRole PLAYER]
# 'playerRole' may not take any value. It may either be NONE, PLAYER,
# or GOALY ... such rules may be given as assertions (here: an instinvar
# gives an invariant covering all instances of a class). In XOTcl
# the rules are syntactically identical to 'if' statements
Player instinvar {
{[my set playerRole] eq "NONE" ||
[my set playerRole] eq "PLAYER" ||
[my set playerRole] eq "GOALY"}
}
# If we break the invariant and turn assertions checking on, we should
# get an error message:
$fb check all
if {[catch {$fb set playerRole SINGER} errMsg]} {
puts "CAUGHT EXCEPTION: playerRole has either to be NONE, PLAYER, or TRAINER"
# turn assertion checking off again and reset to PLAYER
$fb check {}
$fb set playerRole PLAYER
}
# But soccer players may play quite different, orthogonal
# roles. E.g. Franz Beckenbauer was also a singer (a remarkably bad
# one). However, we can not simply add such orthogonal, extrinsic
# extensions with multiple inheritance or delegation. Otherwise we
# would have either to build a lot of unnecessary helper classes, like
# PlayerSinger, PlayerTrainerSinger, etc., or we would have to build
# such helper objects. This either leads to an unwanted combinatorial
# explosion of class or object number.
#
# Here we can use a per-object mixin, which is a language construct
# that expresses that a class is used as a role or as an extrinsic
# extension to an object.
# First we just define the Singer class.
Class Singer
Singer instproc sing text {
puts "[my name] sings: $text, lala."
}
# Now we register this class as a per-object mixin on the player object:
$fb mixin Singer
# And now Franz Beckenbauer is able to sing:
$fb sing "lali"
# But Franz Beckenbauer has already retired. When a player retires, we
# have an intrinsic change of the classification. He *is* not a player
# anymore. But still he has the same name, is club member, and
# is a singer (brrrrrr).
# Before we perform the class change, we extend the Player class to
# support it. I.e. the playerRole is not valid after class change
# anymore (we unset the instance variable).
Player instproc class args {
my unset playerRole
next
}
# Now we can re-class the player object to its new class (now Franz
# Beckenbauer is President of Bayern Munich.
$fb class President
# Check that the playerRole isn't there anymore.
if {[catch {$fb set playerRole} errMsg]} {
puts "CAUGHT EXCEPTION: The player role doesn't exist anymore (as it should be after the class change)"
}
# But still Franz Beckenbauer can entertain us with what he believes
# is singing:
$fb sing "lali"
# Now we define some new players for Bayern Munich:
bayernMunich newPlayer -name "Oliver Kahn" -playerRole GOALY
bayernMunich newPlayer -name "Giovanne Elber" -playerRole PLAYER
# if we enlist the players of Munich Franz Beckenbauer is not enlisted
# anymore:
bayernMunich printPlayers
# But as a president he still appears in the list of members:
bayernMunich printMembers
# Now consider an orthonogal extension of a transfer list. Every
# transfer in the system should be notified. But since the transfer
# list is orthogonal to SoccerTeams we do not want to interfere with
# the existing implementation at all. Moreover, the targeted kind of
# extension has also to work on all subclasses of SoccerTeam. Firstly, we
# just create the extension as an ordinary class:
Class TransferObserver
TransferObserver instproc transferPlayer {pname destinationTeam} {
puts "Player '$pname' is transfered to Team '[$destinationTeam name]'"
next
}
# Now we can apply the class as a per-class mixin, which functions
# exactly like a per-object mixin, but on all instances of a class and
# its subclasses. The 'next' primitive ensures that the original
# method on 'SoccerTeam' is called after notifying the transfer (with
# puts to stdout)
SoccerTeam instmixin TransferObserver
# If we perform a transfer of one of the players, he is moved to the new
# club and the transfer is reported to the stdout:
bayernMunich transferPlayer "Giovanne Elber" lyon
# Finally we verify the transfer by printing the players:
lyon printPlayers
bayernMunich printPlayers
./xotcl-1.6.7/apps/scripts/parameter.xotcl 0000664 0002265 0002265 00000011767 11654164542 020416 0 ustar neumann neumann ### Sample file for parameter testing....
### For every class "-parameter" can be specified which accepts
### a list of parameter specifications.
###
### * If a parameter specification consists of a single word,
### the word is considered as the parameter name and
### a standard setter/getter method with this name is created.
###
### * If the parameter specification consists of two words, the
### second word is treated as the default value, which is stored
### in the class object.
###
### * If a default value exists in the class object, a
### corresponding instance variable with the name of the
### parameter is created automatically during initialization
### of the object.
###
### * If the parameter specification consists of more than two words,
### various parameter methods (starting with "-") with arguments
### can be specified. In the following example
### Class C -parameter {{a 1} {b -default 1}}
### C c1
### both a and b receive 1 as default value.
###
### * In order to call the standard getter method use the method
### with the name of the parameter with one parameter. For example,
### in order to call the standard getter for parameter a, use
### puts [c1 a]
### In order to use the standard setter for b, use the method with
### two parameters.
### c1 b 123
###
### * There are two ways to specify custom setter/getter methods for
### parameters: (a) the custom setter/getter can be defined within the
### class hierarchy of the object, or (b) the custom getter/setter can
### be specified on a different object. The custom setter/getter
### method are called, from the standard setter/getter methods
### automatically if specified.
### * In order to use approach (a) the parameter methods -getter
### and -setter can be used to specify the custom getter and
### and setter methods:
### Class D -parameter {{a -setter myset -getter myget}}
### The methods myset and myget are called like set with
### one or two arguments. They are responsible for setting and
### retrieving the appropiate values. It is possible to
### specify any one of these parameter methods.
### * In order to use approach (b) a parameter methods -access
### is use to specify an object responsible for setting/getting
### these values. This has the advantage that the custom getter and
### setter methods can be inherited from a separate class hierarchy,
### such they can used for any object without cluttering its
### interface.
### * In order to keep the parameter specification short the access
### object my contain instance variables setter or getter, naming the
### setter/getter methods. If these instance variables are not
### in the access object, "set" is used per default for getter and
### setter. These default values can be still overridden by the
### parameter methods -setter or -getter.
### * If the access object is specified,