From affeb5ec093098fbd7502c8f4fe65ea5e30cf3c2 Mon Sep 17 00:00:00 2001
From: patthoyts <patthoyts>
Date: Mon, 22 Nov 2004 23:48:47 +0000
Subject: [PATCH] * win/makefile.vc: Improved the win build system. * demos/*:
Added a few sample applications, demos of broadcast, multicast and normal
operation. * tools/mpexpand.tcl: Added app for generating documentation.
---
ChangeLog | 5 +
demos/broadcast.tcl | 38 ++++++++
demos/multicast.tcl | 38 ++++++++
demos/udpcat.tcl | 64 +++++++++++++
doc/manpage.css | 218 ++++++++++++++++++++++++++++++++++++++++++++
doc/udp.man | 65 +++++++++++--
doc/udp.n | 80 ++++++++++++----
generic/udp_tcl.c | 14 ++-
tools/mpexpand.tcl | 165 +++++++++++++++++++++++++++++++++
win/makefile.vc | 103 +++++++++++++++------
win/rules.vc | 60 ++++++------
win/tcludp.rc | 16 ++--
12 files changed, 771 insertions(+), 95 deletions(-)
create mode 100644 demos/broadcast.tcl
create mode 100644 demos/multicast.tcl
create mode 100644 demos/udpcat.tcl
create mode 100644 doc/manpage.css
create mode 100644 tools/mpexpand.tcl
diff --git a/ChangeLog b/ChangeLog
index 690a7be..c1ec4b8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,10 @@
2004-11-22 Pat Thoyts <patthoyts@users.sourceforge.net>
+ * win/makefile.vc: Improved the win build system.
+ * demos/*: Added a few sample applications, demos of broadcast,
+ multicast and normal operation.
+ * tools/mpexpand.tcl: Added app for generating documentation.
+
* generic/udp_tcl.h: Done some testing with multicast and have
* generic/udp_tcl.c: rationalised the fconfigure/udp_conf interfaces
a bit better. The -ttl option will set the multicast ttl if the
diff --git a/demos/broadcast.tcl b/demos/broadcast.tcl
new file mode 100644
index 0000000..dc9a430
--- /dev/null
+++ b/demos/broadcast.tcl
@@ -0,0 +1,38 @@
+# multicast.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sf.net>
+#
+# Demonstrate the use of broadcast UDP sockets.
+#
+# You can send to ths using netcat:
+# echo HELLO | nc -u 192.168.255.255 7772
+#
+# $Id$
+
+package require udp 1.0.6
+
+proc udpEvent {chan} {
+ set data [read $chan]
+ set peer [fconfigure $chan -peer]
+ puts "$peer [string length $data] '$data'"
+ if {[string match "QUIT*" $data]} {
+ close $chan
+ set ::forever 1
+ }
+ return
+}
+
+# Select a subnet and the port number.
+set subnet 192.168.255.255
+set port 7772
+
+# Create a listening socket and configure for sending too.
+set s [udp_open $port]
+fconfigure $s -buffering none -blocking 0
+fconfigure $s -broadcast 1 -remote [list $subnet $port]
+fileevent $s readable [list udpEvent $s]
+
+# Announce our presence and run
+puts -nonewline $s "hello, world"
+set forever 0
+vwait ::forever
+
+exit
diff --git a/demos/multicast.tcl b/demos/multicast.tcl
new file mode 100644
index 0000000..ff4414d
--- /dev/null
+++ b/demos/multicast.tcl
@@ -0,0 +1,38 @@
+# multicast.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sf.net>
+#
+# Demonstrate the use of IPv4 multicast UDP sockets.
+#
+# You can send to ths using netcat:
+# echo HELLO | nc -u 224.5.1.21 7771
+#
+# $Id$
+
+package require udp 1.0.6
+
+proc udpEvent {chan} {
+ set data [read $chan]
+ set peer [fconfigure $chan -peer]
+ puts "$peer [string length $data] '$data'"
+ if {[string match "QUIT*" $data]} {
+ close $chan
+ set ::forever 1
+ }
+ return
+}
+
+# Select a multicast group and the port number.
+set group 224.5.1.21
+set port 7771
+
+# Create a listening socket and configure for sending too.
+set s [udp_open $port]
+fconfigure $s -buffering none -blocking 0
+fconfigure $s -mcastadd $group -remote [list $group $port]
+fileevent $s readable [list udpEvent $s]
+
+# Announce our presence and run
+puts -nonewline $s "hello, world"
+set forever 0
+vwait ::forever
+
+exit
diff --git a/demos/udpcat.tcl b/demos/udpcat.tcl
new file mode 100644
index 0000000..6cdec6e
--- /dev/null
+++ b/demos/udpcat.tcl
@@ -0,0 +1,64 @@
+# udpsend.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sf.net>
+#
+# Demo application - cat data from stdin via a UDP socket.
+#
+# $Id$
+
+package require udp 1.0.6
+
+proc Event {sock} {
+ global forever
+ set pkt [read $sock]
+ set peer [fconfigure $sock -peer]
+ puts "Received [string length $pkt] from $peer\n$pkt"
+ set forever 1
+ return
+}
+
+proc Send {host port {msg {}}} {
+ set s [udp_open]
+ fconfigure $s -blocking 0 -buffering none -translation binary \
+ -remote [list $host $port]
+ fileevent $s readable [list Event $s]
+ if {$msg == {}} {
+ fcopy stdin $s
+ } else {
+ puts -nonewline $s $msg
+ }
+
+ after 2000
+ close $s
+}
+
+proc Listen {port} {
+ set s [udp_open $port]
+ fconfigure $s -blocking 0 -buffering none -translation binary
+ fileevent $s readable [list Event $s]
+ return $s
+}
+
+# -------------------------------------------------------------------------
+# Runtime
+# udpsend listen -port N -blocking 0
+# udpsend send host port message
+# -------------------------------------------------------------------------
+set forever 0
+
+if {! $tcl_interactive} {
+ switch -exact -- [set cmd [lindex $argv 0]] {
+ send {
+ eval [list Send] [lrange $argv 1 end]
+ }
+ listen {
+ set s [Listen [lindex $argv 1]]
+ vwait ::forever
+ close $s
+ }
+ default {
+ puts "usage: udpcat send host port ?message?\
+ \n udpcat listen port"
+ }
+ }
+}
+
+
diff --git a/doc/manpage.css b/doc/manpage.css
new file mode 100644
index 0000000..8a4cfbd
--- /dev/null
+++ b/doc/manpage.css
@@ -0,0 +1,218 @@
+/*
+ * $Id$
+ * Author: Joe English, <jenglish@flightab.com>
+ * Created: 26 Jun 2000
+ * Description: CSS stylesheet for TCL man pages
+ */
+
+HTML {
+ background: #FFFFFF;
+ color: black;
+}
+
+BODY {
+ background: #FFFFFF;
+ color: black;
+}
+
+DIV.body {
+ margin-left: 10%;
+ margin-right: 10%;
+}
+DIV.header,DIV.footer {
+ width: 100%;
+ margin-left: 0%;
+ margin-right: 0%;
+}
+
+DIV.body H1,DIV.body H2 {
+ margin-left: -5%;
+}
+
+/* Navigation material: */
+
+DIV.navbar {
+ width: 100%;
+ margin-top: 5pt;
+ margin-bottom: 5pt;
+ margin-left: 0%;
+ margin-right: 0%;
+ padding-top: 5pt;
+ padding-bottom: 5pt;
+ background: #DDDDDD;
+ color: black;
+ border: 1px solid black;
+ text-align: center;
+ font-size: small;
+ font-family: sans-serif;
+}
+
+P.navaid {
+ text-align: center;
+}
+.navaid {
+ font-size: small;
+ font-family: sans-serif;
+}
+
+P.notice {
+ text-align: center;
+ font-size: small;
+ font-family: sans-serif;
+ font-style: italic;
+ color: red;
+}
+
+A.navaid:link { color: green; background: transparent; }
+A.navaid:visited { color: green; background: transparent; }
+A.navaid:active { color: yellow; background: transparent; }
+
+/* For most anchors, we should leave colors up to the user's preferences. */
+/*--
+A:link { color: blue; background: transparent; }
+A:visited { color: purple; background: transparent; }
+A:active { color: red; background: transparent; }
+--*/
+
+H1, H2, H3, H4 {
+ margin-top: 1em;
+ font-family: sans-serif;
+ font-size: large;
+ color: #005A9C;
+ background: transparent;
+ text-align: left;
+}
+
+H1.title {
+ text-align: center;
+}
+
+UL,OL {
+ margin-right: 0em;
+ margin-top: 3pt;
+ margin-bottom: 3pt;
+}
+UL LI {
+ list-style: disc;
+}
+OL LI {
+ list-style: decimal;
+}
+
+DT {
+ padding-top: 1ex;
+}
+
+DL.toc {
+ font: normal 12pt/16pt sans-serif;
+ margin-left: 10%;
+}
+
+UL.toc,UL.toc UL, UL.toc UL UL {
+ font: normal 12pt/14pt sans-serif;
+ list-style: none;
+}
+LI.tocentry,LI.tocheading {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+}
+
+.tocheading {
+ font-family: sans-serif;
+ font-weight: bold;
+ color: #005A9C;
+ background: transparent;
+}
+
+PRE {
+ display: block;
+ font-family: monospace;
+ white-space: pre;
+ margin: 0%;
+ padding-top: 0.5ex;
+ padding-bottom: 0.5ex;
+ padding-left: 1ex;
+ padding-right: 1ex;
+ width: 100%;
+}
+PRE.syntax {
+ color: black;
+ background: #80ffff;
+ border: 1px solid black;
+ font-family: serif;
+}
+PRE.example {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+}
+
+PRE.sample {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+}
+
+DIV.arglist {
+ border: 1px solid black;
+ width: 100%;
+}
+TH, THEAD TR, TR.heading {
+ color: #005A9C;
+ background: #DDDDDD;
+ text-align: center;
+ font-family: sans-serif;
+ font-weight: bold;
+}
+TR.syntax {
+ color: black;
+ background: #80ffff;
+}
+TR.desc {
+ color: black;
+ background: #f5dcb3;
+}
+
+/* TR.row[01] are used to get alternately colored table rows.
+ * Could probably choose better colors here...
+ */
+TR.row0 {
+ color: black;
+ background: #efffef;
+}
+
+TR.row1 {
+ color: black;
+ background: #efefff;
+}
+
+/* Workaround for Netscape bugs:
+ * Netscape doesn't seem to compute table widths properly.
+ * unless they're wrapped inside a DIV. (Additionally,
+ * it appears to require a non-zero border-width.)
+ */
+DIV.table {
+ border-width: 1px;
+ border-color: white;
+ width: 100%;
+}
+DIV.menu { /* Wrapper for TABLE class="menu" */
+ margin-top: 10px;
+ margin-bottom: 10px;
+ border: thin solid #005A9C;
+ width: 100%;
+ margin-left: 5%;
+}
+
+VAR {
+ font-style: italic;
+}
+
+/* For debugging: highlight unrecognized elements: */
+.unrecognized {
+ color: red; background: green;
+}
+
+/* EOF */
diff --git a/doc/udp.man b/doc/udp.man
index 00bd583..21efc71 100644
--- a/doc/udp.man
+++ b/doc/udp.man
@@ -3,7 +3,7 @@
script from tcllib: mpexpand nroff udp.man udp.n
mpexpand html udp.man udp.html
}]
-[manpage_begin udp n 1.0.5]
+[manpage_begin udp n 1.0.6]
[copyright {1999-2000 Columbia University; all rights reserved}]
[moddesc {Tcl UDP extension}]
[titledesc {Create UDP sockets in Tcl}]
@@ -11,7 +11,11 @@
[require udp 1.0]
[description]
-This package provides support for using UDP through Tcl.
+This package provides support for using UDP through Tcl. The package provides
+a new channel type and attempts to permit the use of packet oriented UDP
+over stream oriented Tcl channels. The package defined three commands but
+[cmd udp_conf] should be considered depreciated in favour of the standard
+Tcl command [cmd fconfigure].
[section "COMMANDS"]
@@ -30,7 +34,7 @@ if required.
for packets written to this [arg "sock"]. You must call this command before
writing data to the UDP socket.
-[call [cmd "udp_conf"] [arg "sock"] [arg [opt -myport]] [arg [opt -remote]] [arg [opt -peer]]]
+[call [cmd "udp_conf"] [arg "sock"] [arg [opt -myport]] [arg [opt -remote]] [arg [opt -peer]] [arg [opt "-broadcast bool"]] [arg [opt "-ttl count"]]]
In addition to being used to configure the remote host, the [cmd "udp_conf"]
command is used to obtain information about the UDP socket.
@@ -48,13 +52,31 @@ Returns the remote hostname and port number as set using
Returns the remote hostname and port number for the packet most recently
received by this socket.
+[lst_item "[arg -broadcast\ [opt boolean]]"]
+UDP packets can listen and send on the broadcast address. For some systems
+a flag must be set on the socket to use broadcast.
+With no argument this option will return the broadcast setting. With a
+boolean argument the setting can be modified.
+
+[lst_item "[arg -ttl\ [opt count]]"]
+
+The time-to-live is given as the number of router hops the packet may do. For
+multicast packets this is important in specifying the distribution of the
+packet. The system default for multicast is 1 which restricts the packet
+to the local subnet. To permit packets to pass routers, you must increase the
+ttl. A value of 31 should keep it within a site, while 255 is global.
+
+
[list_end]
[nl]
-[call [cmd "udp_conf"] [opt "[arg -mcastadd] [arg -mcastdrop]"]\
- [arg groupaddr]]
+[call [cmd "udp_conf"] [opt "[arg -mcastadd] groupaddr"]]
+[call [cmd "udp_conf"] [opt "[arg -mcastdrop] groupaddr"]]
-FIX ME
+[package tcludp] sockets can support IPv4 multicast operations. To recieve
+multicast packets the application has to notify the operating system that
+it should join a particular multicast group. These are specified as addresses
+in the range 224.0.0.0 to 239.255.255.255.
[call [cmd "udp_peek"] [arg "sock"] [opt [arg "buffersize"]]]
@@ -69,7 +91,7 @@ This function is not available on windows.
# Send data to a remote UDP socket
proc udp_puts {host port} {
set s [udp_open]
- udp_conf $s $host $port
+ fconfigure $s -remote [list $host $port]
puts $s "Hello, World"
close $f
}
@@ -81,7 +103,7 @@ package require udp
proc udpEventHandler {sock} {
set pkt [read $sock]
- set peer [udp_conf $sock -peer]
+ set peer [fconfigure $sock -peer]
puts "$peer: [string length $pkt] {$pkt}"
return
}
@@ -90,7 +112,7 @@ proc udp_listen {port} {
set srv [udp_open $port]
fconfigure $srv -buffering none -translation binary
fileevent $srv readable [list ::udpEventHandler $srv]
- puts "Listening on udp port: [udp_conf $srv -myport]"
+ puts "Listening on udp port: [fconfigure $srv -myport]"
return $srv
}
@@ -99,6 +121,31 @@ vwait forever
close $sock
}]
+[example {
+# A multicast demo.
+proc udpEvent {chan} {
+ set data [read $chan]
+ set peer [fconfigure $chan -peer]
+ puts "$peer [string length $data] '$data'"
+ if {[string match "QUIT*" $data]} {
+ close $chan
+ set ::forever 1
+ }
+ return
+}
+
+set group 224.5.1.21
+set port 7771
+set s [udp_open $port]
+fconfigure $s -buffering none -blocking 0
+fconfigure $s -mcastadd $group -remote [list $group $port]
+fileevent $s readable [list udpEvent $s]
+puts -nonewline $s "hello, world"
+set ::forever 0
+vwait ::forever
+exit
+}]
+
[section "HISTORY"]
Some of the code in this extension is copied from Michael Miller's tcludp
diff --git a/doc/udp.n b/doc/udp.n
index 10d260d..d1b2599 100644
--- a/doc/udp.n
+++ b/doc/udp.n
@@ -8,7 +8,7 @@
'\" mpexpand html udp.man udp.html
'\"
.so man.macros
-.TH "udp" n 1.0.5 "Tcl UDP extension"
+.TH "udp" n 1.0.6 "Tcl UDP extension"
.BS
.SH "NAME"
udp \- Create UDP sockets in Tcl
@@ -17,33 +17,39 @@ package require \fBTcl 8.0\fR
.sp
package require \fBudp 1.0\fR
.sp
-\fBudp_open\fR ?\fIport\fR?\fR
+\fBudp_open\fR ?\fIport\fR?
.sp
-\fBudp_conf\fR \fIsock\fR \fIhost\fR \fIport\fR\fR
+\fBudp_conf\fR \fIsock\fR \fIhost\fR \fIport\fR
.sp
-\fBudp_conf\fR \fIsock\fR \fI?-myport?\fR \fI?-remote?\fR \fI?-peer?\fR\fR
+\fBudp_conf\fR \fIsock\fR \fI?-myport?\fR \fI?-remote?\fR \fI?-peer?\fR \fI?-broadcast bool?\fR \fI?-ttl count?\fR
.sp
-\fBudp_conf\fR ?\fI-mcastadd\fR \fI-mcastdrop\fR? \fIgroupaddr\fR\fR
+\fBudp_conf\fR ?\fI-mcastadd\fR groupaddr?
.sp
-\fBudp_peek\fR \fIsock\fR ?\fIbuffersize\fR?\fR
+\fBudp_conf\fR ?\fI-mcastdrop\fR groupaddr?
+.sp
+\fBudp_peek\fR \fIsock\fR ?\fIbuffersize\fR?
.sp
.BE
.SH "DESCRIPTION"
-This package provides support for using UDP through Tcl.
+This package provides support for using UDP through Tcl. The package provides
+a new channel type and attempts to permit the use of packet oriented UDP
+over stream oriented Tcl channels. The package defined three commands but
+\fBudp_conf\fR should be considered depreciated in favour of the standard
+Tcl command \fBfconfigure\fR.
.SH "COMMANDS"
.TP
-\fBudp_open\fR ?\fIport\fR?\fR
+\fBudp_open\fR ?\fIport\fR?
\fBudp_open\fR will open a UDP socket. If \fIport\fR is specified the UDP
socket will be opened on that port. Otherwise the system will choose a port
and the user can use the \fBudp_conf\fR command to obtain the port number
if required.
.TP
-\fBudp_conf\fR \fIsock\fR \fIhost\fR \fIport\fR\fR
+\fBudp_conf\fR \fIsock\fR \fIhost\fR \fIport\fR
\fBudp_conf\fR in this configuration is used to specify the remote destination
for packets written to this \fIsock\fR. You must call this command before
writing data to the UDP socket.
.TP
-\fBudp_conf\fR \fIsock\fR \fI?-myport?\fR \fI?-remote?\fR \fI?-peer?\fR\fR
+\fBudp_conf\fR \fIsock\fR \fI?-myport?\fR \fI?-remote?\fR \fI?-peer?\fR \fI?-broadcast bool?\fR \fI?-ttl count?\fR
In addition to being used to configure the remote host, the \fBudp_conf\fR
command is used to obtain information about the UDP socket.
.RS
@@ -58,13 +64,31 @@ Returns the remote hostname and port number as set using
\fI-peer\fR
Returns the remote hostname and port number for the packet most recently
received by this socket.
+.TP
+\fI-broadcast ?boolean?\fR
+UDP packets can listen and send on the broadcast address. For some systems
+a flag must be set on the socket to use broadcast.
+With no argument this option will return the broadcast setting. With a
+boolean argument the setting can be modified.
+.TP
+\fI-ttl ?count?\fR
+The time-to-live is given as the number of router hops the packet may do. For
+multicast packets this is important in specifying the distribution of the
+packet. The system default for multicast is 1 which restricts the packet
+to the local subnet. To permit packets to pass routers, you must increase the
+ttl. A value of 31 should keep it within a site, while 255 is global.
.RE
.sp
.TP
-\fBudp_conf\fR ?\fI-mcastadd\fR \fI-mcastdrop\fR? \fIgroupaddr\fR\fR
-FIX ME
+\fBudp_conf\fR ?\fI-mcastadd\fR groupaddr?
.TP
-\fBudp_peek\fR \fIsock\fR ?\fIbuffersize\fR?\fR
+\fBudp_conf\fR ?\fI-mcastdrop\fR groupaddr?
+\fBtcludp\fR sockets can support IPv4 multicast operations. To recieve
+multicast packets the application has to notify the operating system that
+it should join a particular multicast group. These are specified as addresses
+in the range 224.0.0.0 to 239.255.255.255.
+.TP
+\fBudp_peek\fR \fIsock\fR ?\fIbuffersize\fR?
Examine a packet without removing it from the buffer.
This function is not available on windows.
.SH "EXAMPLES"
@@ -73,7 +97,7 @@ This function is not available on windows.
# Send data to a remote UDP socket
proc udp_puts {host port} {
set s [udp_open]
- udp_conf $s $host $port
+ fconfigure $s -remote [list $host $port]
puts $s "Hello, World"
close $f
}
@@ -84,7 +108,7 @@ package require udp
proc udpEventHandler {sock} {
set pkt [read $sock]
- set peer [udp_conf $sock -peer]
+ set peer [fconfigure $sock -peer]
puts "$peer: [string length $pkt] {$pkt}"
return
}
@@ -93,7 +117,7 @@ proc udp_listen {port} {
set srv [udp_open $port]
fconfigure $srv -buffering none -translation binary
fileevent $srv readable [list ::udpEventHandler $srv]
- puts "Listening on udp port: [udp_conf $srv -myport]"
+ puts "Listening on udp port: [fconfigure $srv -myport]"
return $srv
}
@@ -101,6 +125,30 @@ set sock [udp_listen 53530]
vwait forever
close $sock
.fi
+.nf
+# A multicast demo.
+proc udpEvent {chan} {
+ set data [read $chan]
+ set peer [fconfigure $chan -peer]
+ puts "$peer [string length $data] '$data'"
+ if {[string match "QUIT*" $data]} {
+ close $chan
+ set ::forever 1
+ }
+ return
+}
+
+set group 224.5.1.21
+set port 7771
+set s [udp_open $port]
+fconfigure $s -buffering none -blocking 0
+fconfigure $s -mcastadd $group -remote [list $group $port]
+fileevent $s readable [list udpEvent $s]
+puts -nonewline $s "hello, world"
+set ::forever 0
+vwait ::forever
+exit
+.fi
.SH "HISTORY"
Some of the code in this extension is copied from Michael Miller's tcludp
package. (http://www.neosoft.com/tcl/ftparchive/sorted/comm/tcludp-1.0/)
diff --git a/generic/udp_tcl.c b/generic/udp_tcl.c
index e04a244..63a6ccf 100644
--- a/generic/udp_tcl.c
+++ b/generic/udp_tcl.c
@@ -1155,18 +1155,22 @@ UdpMulticast(ClientData instanceData, Tcl_Interp *interp,
int ndx = LSearch(statePtr->groupsObj, grp);
if (ndx != -1) {
Tcl_Obj *old, *ptr;
+ int dup = 0;
old = ptr = statePtr->groupsObj;
statePtr->multicast--;
- if (Tcl_IsShared(ptr)) {
+ if ((dup = Tcl_IsShared(ptr))) {
ptr = Tcl_DuplicateObj(ptr);
}
Tcl_ListObjReplace(interp, ptr, ndx, 1, 0, NULL);
- statePtr->groupsObj = ptr;
- Tcl_IncrRefCount(ptr);
- Tcl_DecrRefCount(old);
+ if (dup) {
+ statePtr->groupsObj = ptr;
+ Tcl_IncrRefCount(ptr);
+ Tcl_DecrRefCount(old);
+ }
}
}
- Tcl_SetObjResult(interp, statePtr->groupsObj);
+ if (interp != NULL)
+ Tcl_SetObjResult(interp, statePtr->groupsObj);
return TCL_OK;
}
diff --git a/tools/mpexpand.tcl b/tools/mpexpand.tcl
new file mode 100644
index 0000000..4c0ff65
--- /dev/null
+++ b/tools/mpexpand.tcl
@@ -0,0 +1,165 @@
+#!/bin/sh
+# -*- tcl -*- \
+exec tclsh "$0" ${1+"$@"}
+
+lappend auto_path [file dirname [file dirname [info script]]]
+
+if 0 {
+ puts auto_path=\n\t[join $auto_path \n\t]
+ catch {puts tcl_pkgPath=\n\t[join $tcl_pkgPath \n\t]}
+ catch {puts tcl_libPath=\n\t[join $tcl_libPath \n\t]}
+
+ puts [package require doctools]
+ exit
+}
+
+package require doctools
+
+
+
+# ---------------------------------------------------------------------
+# 1. Handle command line options, input and output
+# 2. Initialize a doctools object.
+# 3. Run the input through the object.
+# 4. Write output.
+# ---------------------------------------------------------------------
+
+proc usage {{exitstate 1}} {
+ global argv0
+ puts "Usage: $argv0\
+ ?-h|--help|-help|-??\
+ ?-help-fmt|--help-fmt?\
+ ?-module module?\
+ ?-deprecated?\
+ ?-copyright text?\
+ format in|- ?out|-?"
+ exit $exitstate
+}
+
+# ---------------------------------------------------------------------
+
+proc fmthelp {} {
+ # Tcllib FR #527029: short reference of formatting commands.
+
+ global argv0
+ puts "$argv0 [doctools::help]"
+ exit 0
+}
+
+# ---------------------------------------------------------------------
+# 1. Handle command line options, input and output
+
+proc cmdline {} {
+ global argv0 argv format in out extmodule deprecated copyright
+
+ set copyright ""
+ set extmodule ""
+ set deprecated 0
+
+ while {[string match -* [set opt [lindex $argv 0]]]} {
+ switch -exact -- $opt {
+ -module {
+ set extmodule [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ continue
+ }
+ -copyright {
+ set copyright [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ continue
+ }
+ -deprecated {
+ set deprecated 1
+ set argv [lrange $argv 1 end]
+ }
+ -help - -h - --help - -? {
+ # Tcllib FR #527029
+ usage 0
+ }
+ -help-fmt - --help-fmt {
+ # Tcllib FR #527029
+ fmthelp
+ }
+ default {
+ # Unknown option
+ usage
+ }
+ }
+ }
+
+ if {[llength $argv] < 3} {
+ usage
+ }
+ foreach {format in out} $argv break
+
+ if {$format == {} || $in == {}} {
+ usage
+ }
+ if {$out == {}} {set out -}
+ return $format
+}
+
+# ---------------------------------------------------------------------
+# 3. Read input. Also providing the namespace with file information.
+
+proc get_input {} {
+ global in
+ if {[string equal $in -]} {
+ return [read stdin]
+ } else {
+ set if [open $in r]
+ set text [read $if]
+ close $if
+ return $text
+ }
+}
+
+# ---------------------------------------------------------------------
+# 4. Write output.
+
+proc write_out {text} {
+ global out
+ if {[string equal $out -]} {
+ puts -nonewline stdout $text
+ } else {
+ set of [open $out w]
+ puts -nonewline $of $text
+ close $of
+ }
+}
+
+
+# ---------------------------------------------------------------------
+# Get it all together
+
+proc main {} {
+ global format deprecated extmodule in copyright
+
+ #if {[catch {}
+ cmdline
+
+ ::doctools::new dt -format $format -deprecated $deprecated -file $in
+ if {$extmodule != {}} {
+ dt configure -module $extmodule
+ }
+ if {$copyright != {}} {
+ dt configure -copyright $copyright
+ }
+
+ write_out [dt format [get_input]]
+
+ set warnings [dt warnings]
+ if {[llength $warnings] > 0} {
+ puts stderr [join $warnings \n]
+ }
+
+ #{} msg]} {}
+ #puts stderr "Execution error: $msg"
+ #{}
+ return
+}
+
+
+# ---------------------------------------------------------------------
+main
+exit
diff --git a/win/makefile.vc b/win/makefile.vc
index e909bd9..2e91178 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -21,7 +21,7 @@
# RCS: @(#)$Id$
#-------------------------------------------------------------------------
-!if "$(MSVCDIR)" == ""
+!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCToolkitInstallDir)
MSG = ^
You will need to run vcvars32.bat from Developer Studio, first, to setup^
the environment. Jump to this line to read the new instructions.
@@ -164,6 +164,9 @@ DLLOBJS = \
$(TMP_DIR)\udp_tcl.obj \
$(TMP_DIR)\tcludp.res
+PRJDOCS = \
+ $(OUT_DIR)\udp.html
+
#-------------------------------------------------------------------------
# Target names and paths ( shouldn't need changing )
#-------------------------------------------------------------------------
@@ -179,25 +182,23 @@ PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib
PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME)
### Make sure we use backslash only.
-LIB_INSTALL_DIR = $(_INSTALLDIR)\lib
-BIN_INSTALL_DIR = $(_INSTALLDIR)\bin
-DOC_INSTALL_DIR = $(_INSTALLDIR)\doc
-SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(DOTVERSION)
-INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include
+PRJ_INSTALL_DIR = $(_INSTALLDIR)\$(PROJECT)$(DOTVERSION)
+BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR)
+DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR)
+SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR)
+DEMO_INSTALL_DIR = $(PRJ_INSTALL_DIR)\demos
+INCLUDE_INSTALL_DIR = $(_TCLDIR)\include
+LIB_INSTALL_DIR = $(_TCLDIR)\lib
### The following paths CANNOT have spaces in them.
GENERICDIR = $(ROOT)\generic
WINDIR = $(ROOT)\win
LIBDIR = $(ROOT)\library
DOCDIR = $(ROOT)\doc
+DEMODIR = $(ROOT)\demos
TOOLSDIR = $(ROOT)\tools
COMPATDIR = $(ROOT)\compat
-### Find a tclsh for testing and installation.
-!if !exist("$(TCLSH)")
-TCLSH = $(BIN_INSTALL_DIR)\tclsh$(TCL_VERSION).exe
-!endif
-
#---------------------------------------------------------------------
# Compile flags
#---------------------------------------------------------------------
@@ -211,9 +212,9 @@ cdebug =
!endif
!else if "$(MACHINE)" == "IA64"
### Warnings are too many, can't support warnings into errors.
-cdebug = -Z7 -Od
+cdebug = -Z7 -Od -GZ
!else
-cdebug = -Z7 -WX -Od
+cdebug = -Z7 -WX -Od -GZ
!endif
### Declarations common to all compiler options
@@ -294,17 +295,31 @@ TESTFLAGS = -file $(TESTPAT)
all: setup $(PROJECT)
$(PROJECT): setup $(PRJLIB)
-install: install-binaries install-libraries install-docs
+doc: setup $(PRJDOCS)
+install: install-binaries install-libraries install-docs install-demos
-test: setup $(PROJECT)
- set TCL_LIBRARY=$(ROOT)/library
+# Tests need to ensure we load the right dll file we
+# have to handle the output differently on Win9x.
+#
!if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE"
- $(TCLSH) "$(ROOT)/tests/all.tcl" $(TESTFLAGS)
+test: setup $(PROJECT)
+ $(TCLSH) <<
+load $(PRJLIB:\=/)
+cd "$(ROOT)/tests"
+set argv "$(TESTFLAGS)"
+source all.tcl
+<<
!else
- @echo Please wait while the tests are collected...
- $(TCLSH) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) > tests.log
- type tests.log | more
+test: setup $(PROJECT)
+ echo Please wait while the test results are collected
+ $(TCLSH) << >tests.log
+load $(PRJLIB:\=/)
+cd "$(ROOT)/tests"
+set argv "$(TESTFLAGS)"
+source all.tcl
+<<
+ type tests.log | more
!endif
setup:
@@ -341,6 +356,9 @@ $<
{$(WINDIR)}.rc{$(TMP_DIR)}.res:
$(rc32) -fo $@ -r -i "$(GENERICDIR)" -D__WIN32__ \
+ -DCOMMAVERSION=$(DOTVERSION:.=,),0 \
+ -DDOTVERSION=\"$(DOTVERSION)\" \
+ -DVERSION=\"$(VERSION)$(SUFX)\" \
!if $(DEBUG)
-d DEBUG \
!endif
@@ -352,8 +370,19 @@ $<
!endif
$<
+DOC2HTML = $(TCLSH) "$(TOOLSDIR)\mpexpand.tcl" html
+
+{$(DOCDIR)}.man{$(OUT_DIR)}.html:
+ $(DOC2HTML) $< $@
+ @$(TCLSH) <<
+set name $(@:\=/)
+set f [open $$name r]; set d [read $$f]; close $$f
+set d [regsub {</head>} $$d {<link rel="stylesheet" href="manpage.css" type="text/css"></head>}]
+set f [open $$name w]; puts -nonewline $$f $$d; close $$f
+<<
+
.SUFFIXES:
-.SUFFIXES:.c .rc
+.SUFFIXES:.c .rc .man
#---------------------------------------------------------------------
# Installation. (EDIT)
@@ -364,17 +393,32 @@ $<
#---------------------------------------------------------------------
install-binaries:
- @echo Installing to '$(SCRIPT_INSTALL_DIR)'
- @if not exist $(SCRIPT_INSTALL_DIR)\nul mkdir $(SCRIPT_INSTALL_DIR)
- $(CPY) $(PRJLIB) $(SCRIPT_INSTALL_DIR)
+ @echo Installing binaries to '$(SCRIPT_INSTALL_DIR)'
+ @if not exist $(SCRIPT_INSTALL_DIR)\nul mkdir "$(SCRIPT_INSTALL_DIR)"
+ @$(CPY) $(PRJLIB) "$(SCRIPT_INSTALL_DIR)" >NUL
install-libraries:
- @echo Installing to '$(SCRIPT_INSTALL_DIR)'
- @if exist $(LIBDIR)\nul $(CPY) $(LIBDIR)\*.tcl $(SCRIPT_INSTALL_DIR)
- @cd $(SCRIPT_INSTALL_DIR)
- @echo pkg_mkIndex -verbose . | $(TCLSH)
+ @echo Installing libraries to '$(SCRIPT_INSTALL_DIR)'
+# @$(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)" >NUL
+ @type << >"$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
+# Handcrafted pkgIndex for tcludp.
+if {[info exists ::tcl_platform(debug)]} {
+ package ifneeded $(PROJECT) $(DOTVERSION) [list load [file join $$dir $(PROJECT)$(VERSION)g.$(EXT)]]
+} else {
+ package ifneeded $(PROJECT) $(DOTVERSION) [list load [file join $$dir $(PROJECT)$(VERSION).$(EXT)]]
+}
+<<
+
+install-docs: $(PRJDOCS)
+ @echo Installing documentation to '$(DOC_INSTALL_DIR)'
+ @if not exist $(DOC_INSTALL_DIR)\NUL mkdir "$(DOC_INSTALL_DIR)"
+ @$(CPY) "$(DOCDIR)\manpage.css" "$(DOC_INSTALL_DIR)\" >NUL
+ @for %i in ($(PRJDOCS)) do @$(CPY) %i "$(DOC_INSTALL_DIR)\" > NUL
-install-docs:
+install-demos:
+ @echo Installing demos to '$(DEMO_INSTALL_DIR)'
+ @if not exist $(DEMO_INSTALL_DIR)\nul mkdir "$(DEMO_INSTALL_DIR)"
+ @$(CPY) $(DEMODIR)\*.tcl "$(DEMO_INSTALL_DIR)" >NUL
#---------------------------------------------------------------------
# Clean up
@@ -382,6 +426,7 @@ install-docs:
clean:
@if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR)
+ @if exist $(WINDIR)\version.vc del $(WINDIR)\version.vc
realclean: clean
@if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR)
diff --git a/win/rules.vc b/win/rules.vc
index cd24027..ba4b828 100644
--- a/win/rules.vc
+++ b/win/rules.vc
@@ -29,7 +29,7 @@ rc32 = $(RC) # built-in default.
### Assume the normal default.
_INSTALLDIR = C:\Program Files\Tcl
!else
-### Fix the path seperators.
+### Fix the path separators.
_INSTALLDIR = $(INSTALLDIR:/=\)
!endif
@@ -310,12 +310,17 @@ OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DO64BIT
!if "$(PROJECT)" != "tcl"
-!if !defined(TCLDIR)
+# If INSTALLDIR set to tcl root dir then reset to the lib dir.
!if exist("$(_INSTALLDIR)\include\tcl.h")
+_INSTALLDIR=$(_INSTALLDIR)\lib
+!endif
+
+!if !defined(TCLDIR)
+!if exist("$(_INSTALLDIR)\..\include\tcl.h")
TCLINSTALL = 1
-_TCLDIR = $(_INSTALLDIR)
-_TCL_H = $(_INSTALLDIR)\include\tcl.h
-TCLDIR = $(_INSTALLDIR)
+_TCLDIR = $(_INSTALLDIR)\..
+_TCL_H = $(_INSTALLDIR)\..\include\tcl.h
+TCLDIR = $(_INSTALLDIR)\..
!else
MSG=^
Failed to find tcl.h. Set the TCLDIR macro.
@@ -325,14 +330,15 @@ Failed to find tcl.h. Set the TCLDIR macro.
_TCLDIR = $(TCLDIR:/=\)
!if exist("$(_TCLDIR)\include\tcl.h")
TCLINSTALL = 1
+_TCL_H = $(_TCLDIR)\include\tcl.h
!elseif exist("$(_TCLDIR)\generic\tcl.h")
TCLINSTALL = 0
+_TCL_H = $(_TCLDIR)\generic\tcl.h
!else
MSG =^
Failed to find tcl.h. The TCLDIR macro does not appear correct.
!error $(MSG)
!endif
-_TCL_H = $(_TCLDIR)\generic\tcl.h
!endif
!if [nmakehlp -v $(_TCL_H) ""] == 0
@@ -343,24 +349,16 @@ TCL_VERSION = $(TCL_DOTVERSION:.=)
!endif
!if $(TCLINSTALL)
-TCLSH = "$(_INSTALLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe"
-TCLSTUBLIB = "$(_INSTALLDIR)\lib\tclstub$(TCL_VERSION).lib"
-TCLIMPLIB = "$(_INSTALLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib"
-TCL_LIBRARY = $(_INSTALLDIR)\lib
-TCLREGLIB = "$(_INSTALLDIR)\lib\tclreg11$(SUFX:t=).lib"
-TCLDDELIB = "$(_INSTALLDIR)\lib\tcldde12$(SUFX:t=).lib"
-COFFBASE = \must\have\tcl\sources\to\build\this\target
-TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target
-TCL_INCLUDES = -I"$(_INSTALLDIR)\include"
+TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe"
+TCLSTUBLIB = "$(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib"
+TCLIMPLIB = "$(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib"
+TCL_LIBRARY = $(_TCLDIR)\lib
+TCL_INCLUDES = -I"$(_TCLDIR)\include"
!else
TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX).exe"
TCLSTUBLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib"
TCLIMPLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib"
TCL_LIBRARY = $(_TCLDIR)\library
-TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg11$(SUFX:t=).lib"
-TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde12$(SUFX:t=).lib"
-COFFBASE = "$(_TCLDIR)\win\coffbase.txt"
-TCLTOOLSDIR = $(_TCLDIR)\tools
TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
!endif
@@ -373,11 +371,16 @@ TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
!if "$(PROJECT)" != "tcl" && "$(PROJECT)" != "tk"
!if !defined(TKDIR)
-!if exist("$(_INSTALLDIR)\include\tk.h")
+!if exist("$(_INSTALLDIR)\..\include\tk.h")
+TKINSTALL = 1
+_TKDIR = $(_INSTALLDIR)\..
+_TK_H = $(_TKDIR)\include\tk.h
+TKDIR = $(_TKDIR)
+!elseif exist("$(_TCLDIR)\include\tk.h")
TKINSTALL = 1
-_TKDIR = $(_INSTALLDIR)
-_TK_H = $(_INSTALLDIR)\include\tk.h
-TKDIR = $(_INSTALLDIR)
+_TKDIR = $(_TCLDIR)
+_TK_H = $(_TKDIR)\include\tk.h
+TKDIR = $(_TKDIR)
!else
MSG =^
Failed to find tk.h. Set the TKDIR macro.
@@ -387,14 +390,15 @@ Failed to find tk.h. Set the TKDIR macro.
_TKDIR = $(TKDIR:/=\)
!if exist("$(_TKDIR)\include\tk.h")
TKINSTALL = 1
+_TK_H = $(_TKDIR)\include\tk.h
!elseif exist("$(_TKDIR)\generic\tk.h")
TKINSTALL = 0
+_TK_H = $(_TKDIR)\generic\tk.h
!else
MSG =^
Failed to find tk.h. The TKDIR macro does not appear correct.
!error $(MSG)
!endif
-_TK_H = $(_TKDIR)\generic\tk.h
!endif
!if [nmakehlp -v $(_TCL_H) $(_TK_H)] == 0
@@ -405,10 +409,10 @@ TK_VERSION = $(TK_DOTVERSION:.=)
!endif
!if $(TKINSTALL)
-WISH = "$(_INSTALLDIR)\bin\wish$(TK_VERSION)$(SUFX).exe"
-TKSTUBLIB = "$(_INSTALLDIR)\lib\tkstub$(TK_VERSION).lib"
-TKIMPLIB = "$(_INSTALLDIR)\lib\tk$(TK_VERSION)$(SUFX).lib"
-TK_INCLUDES = -I"$(_INSTALLDIR)\include"
+WISH = "$(_TKDIR)\bin\wish$(TK_VERSION)$(SUFX).exe"
+TKSTUBLIB = "$(_TKDIR)\lib\tkstub$(TK_VERSION).lib"
+TKIMPLIB = "$(_TKDIR)\lib\tk$(TK_VERSION)$(SUFX).lib"
+TK_INCLUDES = -I"$(_TKDIR)\include"
!else
WISH = "$(_TKDIR)\win\$(BUILDDIRTOP)\wish$(TCL_VERSION)$(SUFX).exe"
TKSTUBLIB = "$(_TKDIR)\win\$(BUILDDIRTOP)\tkstub$(TCL_VERSION).lib"
diff --git a/win/tcludp.rc b/win/tcludp.rc
index fb16bf5..40d5abf 100644
--- a/win/tcludp.rc
+++ b/win/tcludp.rc
@@ -8,8 +8,8 @@
LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */
VS_VERSION_INFO VERSIONINFO
- FILEVERSION 1,0,6,0
- PRODUCTVERSION 1,0,6,0
+ FILEVERSION COMMAVERSION
+ PRODUCTVERSION COMMAVERSION
FILEFLAGSMASK 0x3fL
#ifdef DEBUG
FILEFLAGS VS_FF_DEBUG
@@ -24,12 +24,12 @@ BEGIN
BEGIN
BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */
BEGIN
- VALUE "FileDescription", "Tcl UDP extension\0"
- VALUE "OriginalFilename", "udp106.dll\0"
- VALUE "FileVersion", "1.0.6.0\0"
- VALUE "LegalCopyright", "Copyright \251 1999-2000 Columbia University; all rights reserved\0"
- VALUE "ProductName", "TclUDP\0"
- VALUE "ProductVersion", "1.0.6.0\0"
+ VALUE "FileDescription", "Tcl UDP " DOTVERSION " for Windows\0"
+ VALUE "OriginalFilename", "udp" VERSION ".dll\0"
+ VALUE "FileVersion", DOTVERSION "\0"
+ VALUE "LegalCopyright", "Copyright \251 1999-2000 Columbia University; all rights reserved\0"
+ VALUE "ProductName", "TclUDP " DOTVERSION " for Windows\0"
+ VALUE "ProductVersion", DOTVERSION "\0"
END
END
BLOCK "VarFileInfo"
--
2.23.0