From affeb5ec093098fbd7502c8f4fe65ea5e30cf3c2 Mon Sep 17 00:00:00 2001 From: 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 + * 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 +# +# 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 +# +# 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 +# +# 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, + * 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 {} $$d {}] +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