aboutsummaryrefslogtreecommitdiff
path: root/pddp
diff options
context:
space:
mode:
Diffstat (limited to 'pddp')
-rw-r--r--pddp/Makefile10
-rw-r--r--pddp/Makefile.objects3
-rw-r--r--pddp/Makefile.sources3
-rw-r--r--pddp/build_counter7
-rw-r--r--pddp/notes.txt10
-rw-r--r--pddp/pddp-all.exclude8
-rw-r--r--pddp/pddp-help.include0
-rw-r--r--pddp/pddp-shared.include5
-rw-r--r--pddp/pddp-test.exclude5
-rw-r--r--pddp/pddp-vicious.exclude3
-rwxr-xr-xpddp/pddpboot.tcl32
-rw-r--r--pddp/pddpclient.tcl82
-rw-r--r--pddp/pddplink.c136
-rw-r--r--pddp/pddpserver.tcl490
14 files changed, 794 insertions, 0 deletions
diff --git a/pddp/Makefile b/pddp/Makefile
new file mode 100644
index 0000000..b65c310
--- /dev/null
+++ b/pddp/Makefile
@@ -0,0 +1,10 @@
+ROOT_DIR = ..
+redefault: pddpboot default
+
+pddpboot: $(ROOT_DIR)/bin/pddpboot.tcl \
+ $(ROOT_DIR)/bin/pddpclient.tcl $(ROOT_DIR)/bin/pddpserver.tcl
+
+$(ROOT_DIR)/bin/%.tcl: %.tcl
+ cp $< $@
+
+include $(ROOT_DIR)/Makefile.common
diff --git a/pddp/Makefile.objects b/pddp/Makefile.objects
new file mode 100644
index 0000000..3ad9b7a
--- /dev/null
+++ b/pddp/Makefile.objects
@@ -0,0 +1,3 @@
+PDDPLINK_OBJECTS = \
+common/loud.o \
+common/os.o
diff --git a/pddp/Makefile.sources b/pddp/Makefile.sources
new file mode 100644
index 0000000..6349255
--- /dev/null
+++ b/pddp/Makefile.sources
@@ -0,0 +1,3 @@
+TYPES = PDDPLINK
+
+PDDPLINK_SOURCES = pddplink.c
diff --git a/pddp/build_counter b/pddp/build_counter
new file mode 100644
index 0000000..ddd868f
--- /dev/null
+++ b/pddp/build_counter
@@ -0,0 +1,7 @@
+#define PDDP_VERSION "0.1"
+#define PDDP_RELEASE "alpha"
+#define PDDP_BUILD 1
+
+#if 0
+PDDP_SNAPSHOT = 0.1-alpha1
+#endif
diff --git a/pddp/notes.txt b/pddp/notes.txt
new file mode 100644
index 0000000..e156fe1
--- /dev/null
+++ b/pddp/notes.txt
@@ -0,0 +1,10 @@
+TODO for pddp
+ * pddplink:
+ . standardize server's root directory (use $help_directory from pd.tk?)
+ . nonboxed version
+
+DONE for pddp
+
+alpha1
+ * prototype versions of the external "pddplink" and two pd-gui extensions
+ "pddpserver.tcl", "pddpclient.tcl"
diff --git a/pddp/pddp-all.exclude b/pddp/pddp-all.exclude
new file mode 100644
index 0000000..d9e9df1
--- /dev/null
+++ b/pddp/pddp-all.exclude
@@ -0,0 +1,8 @@
+*~
+*.o
+*.gz
+*.html
+*.out
+ref
+ref/*
+dumpsetups
diff --git a/pddp/pddp-help.include b/pddp/pddp-help.include
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/pddp/pddp-help.include
diff --git a/pddp/pddp-shared.include b/pddp/pddp-shared.include
new file mode 100644
index 0000000..ab7ac29
--- /dev/null
+++ b/pddp/pddp-shared.include
@@ -0,0 +1,5 @@
+shared/shared.h
+shared/common/loud.c
+shared/common/loud.h
+shared/common/os.c
+shared/common/os.h
diff --git a/pddp/pddp-test.exclude b/pddp/pddp-test.exclude
new file mode 100644
index 0000000..6b3cc43
--- /dev/null
+++ b/pddp/pddp-test.exclude
@@ -0,0 +1,5 @@
+*~
+import-result.pd
+import-debug.pd
+temporary
+temporary/*
diff --git a/pddp/pddp-vicious.exclude b/pddp/pddp-vicious.exclude
new file mode 100644
index 0000000..5e5a82e
--- /dev/null
+++ b/pddp/pddp-vicious.exclude
@@ -0,0 +1,3 @@
+*~
+old
+old/*
diff --git a/pddp/pddpboot.tcl b/pddp/pddpboot.tcl
new file mode 100755
index 0000000..3cec684
--- /dev/null
+++ b/pddp/pddpboot.tcl
@@ -0,0 +1,32 @@
+#!/bin/sh
+# \
+exec tclsh "$0" -- "$@"
+
+# Synopsis
+# test run:
+# ./pddpboot.tcl [root [port [path]]]
+# from Pd:
+# source pddpboot.tcl
+# ::pddp::srvUse root (or ::pddp::srvStart root [port])
+# ::pddp::cliOpen path
+# ... (more "::pddp::cliOpen" calls) ...
+# ::pddp::srvStop
+
+if {[namespace exists ::pddp]} { ;# created by pddplink's setup
+ puts stderr "Booting pddp"
+ set ::pddp::testrun 0
+} else {
+ puts stderr "Booting pddp, test run..."
+ namespace eval ::pddp { variable testrun 1 }
+}
+
+puts stderr "current directory: [pwd]"
+
+source pddpclient.tcl
+source pddpserver.tcl
+
+if {[info exists ::pddp::theDir]} {
+ puts stderr "restoring directory: $::pddp::theDir"
+ cd $::pddp::theDir
+ unset ::pddp::theDir
+}
diff --git a/pddp/pddpclient.tcl b/pddp/pddpclient.tcl
new file mode 100644
index 0000000..7633394
--- /dev/null
+++ b/pddp/pddpclient.tcl
@@ -0,0 +1,82 @@
+# pddpclient.tcl
+
+# Synopsis
+# not to be run by itself (see pddpboot.tcl)
+
+if {![namespace exists ::pddp]} {
+ puts stderr "Error: invalid invocation of pddpclient (boot pddp first)"
+ puts stderr "exiting..."
+ exit 1
+}
+
+if {$::pddp::testrun} { ;# true if sourced from standalone "pddpboot.tcl"
+ puts stderr "Loading pddpclient, test run..."
+ if {$argc > 3} {
+ set path [lindex $argv 3]
+ if {[string length $path]} {
+ puts stderr "Scheduling \"$path\" for opening"
+ after idle ::pddp::cliOpen $path
+ }
+ unset path
+ }
+} else {
+ puts stderr "Loading pddpclient"
+}
+
+namespace eval ::pddp {
+ variable theBrowserCommand
+
+ switch -- $::tcl_platform(platform) {
+ unix {
+ switch -- $tcl_platform(os) {
+ Darwin {
+ set theBrowserCommand "sh -c open %s"
+ }
+ Linux {
+ foreach candidate \
+ {firefox mozilla galeon konqueror netscape lynx} {
+ set browser [lindex [auto_execok $candidate] 0]
+ if {[string length $browser]} {
+ set theBrowserCommand "$browser %s &"
+ break
+ }
+ }
+ }
+ }
+ }
+ windows {
+ # should not this be just: [auto_execok start]?
+ set theBrowserCommand \
+ "rundll32 url.dll,FileProtocolHandler file:%s &"
+ }
+ }
+}
+
+proc ::pddp::cliError {err} {
+ puts stderr "Error in pddpclient: $err"
+}
+
+proc ::pddp::cliOpen {path} {
+ if {[string first "://" $path] < 1} {
+ if {[info exists ::pddp::thePort]} {
+ set path "http://localhost:$::pddp::thePort/$path"
+ } else {
+ cliError "pddpserver not running"
+ return
+ }
+ }
+ variable theBrowserCommand
+ if {[string length $theBrowserCommand]} {
+ set command [format $theBrowserCommand $path]
+ puts stderr "pddpclient: open $command"
+ if {[catch {eval [list exec] $command} err]} {
+ if {[lindex $::errorCode 0] eq "CHILDSTATUS"} {
+ cliError "$err (child status [lindex $::errorCode 2])"
+ } else {
+ cliError $err
+ }
+ }
+ } else {
+ cliError "browser unavailable"
+ }
+}
diff --git a/pddp/pddplink.c b/pddp/pddplink.c
new file mode 100644
index 0000000..d60a90a
--- /dev/null
+++ b/pddp/pddplink.c
@@ -0,0 +1,136 @@
+/* Copyright (c) 2005 krzYszcz and others.
+ * For information on usage and redistribution, and for a DISCLAIMER OF ALL
+ * WARRANTIES, see the file, "LICENSE.txt," in this distribution. */
+
+#include <stdio.h>
+#include <string.h>
+#include "m_pd.h"
+#include "m_imp.h" /* FIXME need access to c_externdir... */
+#include "g_canvas.h"
+#include "common/loud.h"
+#include "build_counter"
+
+#ifdef KRZYSZCZ
+//#define PDDPLINK_DEBUG
+#endif
+
+enum { PDDPLINK_PD, PDDPLINK_HTML }; /* LATER add others */
+
+typedef struct _pddplink
+{
+ t_object x_ob;
+ t_glist *x_glist;
+ int x_isboxed;
+ t_symbol *x_dirsym;
+ t_symbol *x_ulink;
+ t_atom x_openargs[2];
+ int x_linktype;
+ int x_ishit;
+} t_pddplink;
+
+static t_class *pddplink_class;
+
+/* FIXME need access to glob_pdobject... */
+static t_pd *pddplink_pdtarget(t_pddplink *x)
+{
+ t_pd *pdtarget = gensym("pd")->s_thing;
+ if (pdtarget && !strcmp(class_getname(*pdtarget), "pd"))
+ return (pdtarget);
+ else
+ return ((t_pd *)x); /* internal error */
+}
+
+static void pddplink_anything(t_pddplink *x, t_symbol *s, int ac, t_atom *av)
+{
+ if (x->x_ishit)
+ {
+ startpost("pddplink: internal error (%s", (s ? s->s_name : ""));
+ postatom(ac, av);
+ post(")");
+ }
+}
+
+static void pddplink_click(t_pddplink *x, t_floatarg xpos, t_floatarg ypos,
+ t_floatarg shift, t_floatarg ctrl, t_floatarg alt)
+{
+ x->x_ishit = 1;
+ switch (x->x_linktype)
+ {
+ case PDDPLINK_PD:
+ typedmess(pddplink_pdtarget(x), gensym("open"), 2, x->x_openargs);
+ break;
+ case PDDPLINK_HTML:
+ sys_vgui("after 0 {::pddp::cliOpen %s}\n", x->x_ulink->s_name);
+ break;
+ }
+ x->x_ishit = 0;
+}
+
+#ifdef PDDPLINK_DEBUG
+static void pddplink_debug(t_pddplink *x)
+{
+}
+#endif
+
+static void pddplink_free(t_pddplink *x)
+{
+}
+
+static void *pddplink_new(t_symbol *s1, t_symbol *s2)
+{
+ t_pddplink *x = (t_pddplink *)pd_new(pddplink_class);
+ t_symbol *dirsym;
+ x->x_glist = canvas_getcurrent();
+ x->x_isboxed = (s2 == gensym("box"));
+ x->x_dirsym = canvas_getdir(x->x_glist); /* FIXME */
+ if (!s1 || s1 == &s_)
+ {
+ x->x_linktype = PDDPLINK_HTML;
+ x->x_ulink = gensym("index.html");
+ }
+ else
+ {
+ int len = strlen(s1->s_name);
+ if (len > 3 && !strcmp(s1->s_name + len - 3, ".pd"))
+ x->x_linktype = PDDPLINK_PD;
+ else
+ x->x_linktype = PDDPLINK_HTML;
+ x->x_ulink = s1;
+ }
+ SETSYMBOL(&x->x_openargs[0], x->x_ulink);
+ SETSYMBOL(&x->x_openargs[1], x->x_dirsym);
+ x->x_ishit = 0;
+ if (x->x_isboxed)
+ {
+ inlet_new((t_object *)x, (t_pd *)x, 0, 0);
+ outlet_new((t_object *)x, &s_anything);
+ }
+ if (x->x_linktype == PDDPLINK_HTML)
+ sys_vgui("after 0 {::pddp::srvUse %s}\n", x->x_dirsym->s_name);
+ return (x);
+}
+
+void pddplink_setup(void)
+{
+ t_symbol *dirsym;
+ post("this is pddplink %s, %s %s build...",
+ PDDP_VERSION, loud_ordinal(PDDP_BUILD), PDDP_RELEASE);
+ pddplink_class = class_new(gensym("pddplink"),
+ (t_newmethod)pddplink_new,
+ (t_method)pddplink_free,
+ sizeof(t_pddplink),
+ CLASS_NOINLET | CLASS_PATCHABLE,
+ A_DEFSYM, A_DEFSYM, 0);
+ class_addanything(pddplink_class, pddplink_anything);
+ class_addmethod(pddplink_class, (t_method)pddplink_click,
+ gensym("click"),
+ A_FLOAT, A_FLOAT, A_FLOAT, A_FLOAT, A_FLOAT, 0);
+#ifdef PDDPLINK_DEBUG
+ class_addmethod(pddplink_class, (t_method)pddplink_debug,
+ gensym("debug"), 0);
+#endif
+ dirsym = pddplink_class->c_externdir; /* FIXME */
+ sys_vgui("namespace eval ::pddp {variable theDir [pwd]}; cd %s\n",
+ dirsym->s_name);
+ sys_gui("after 0 {source pddpboot.tcl}\n");
+}
diff --git a/pddp/pddpserver.tcl b/pddp/pddpserver.tcl
new file mode 100644
index 0000000..fe17948
--- /dev/null
+++ b/pddp/pddpserver.tcl
@@ -0,0 +1,490 @@
+# pddpserver.tcl
+
+# Synopsis
+# not to be run by itself (see pddpboot.tcl)
+
+# based on:
+
+# Simple Sample httpd/1.[01] server
+# Stephen Uhler (c) 1996-1997 Sun Microsystems
+
+# http://cvs.sourceforge.net/viewcvs.py/tclhttpd/tclhttpd/bin/mini/mini1.1.tcl
+
+# modified by krzYszcz (2005):
+# putting per-server data and all commands in a namespace "::pddp"
+# supporting sourcing from within Pd, through the "pddpboot.tcl" wrapper
+# inserting the .pd handler
+# lots of other changes, too many to list here (run "diff" if curious...)
+
+if {![namespace exists ::pddp]} {
+ puts stderr "Error: invalid invocation of pddpserver (boot pddp first)"
+ puts stderr "exiting..."
+ exit 1
+}
+
+if {$::pddp::testrun} { ;# true if sourced from standalone "pddpboot.tcl"
+ puts stderr "Loading pddpserver, test run..."
+ proc bgerror {msg} {
+ global errorInfo
+ puts stderr "bgerror: $msg\n$errorInfo"
+ }
+} else {
+ puts stderr "Loading pddpserver"
+ catch {console show}
+}
+
+namespace eval ::pddp {
+ variable thePort 8080
+ variable theState
+ variable theMimeTypes
+ variable theErrors
+ variable theErrorFormat
+
+ # "theState" contains the server state:
+ # root: the root of the document directory
+ # default: default document name
+ # listen: the main listening socket id
+ # naccepts: a count of accepted connections so far
+ # maxtime: the max time (msec) allowed to complete an http request
+ # maxused: the max # of requests for a socket
+ array set theState {
+ root ""
+ default index.html
+ listen ""
+ naccepts 0
+ nrequests 0
+ nerrors 0
+ maxtime 600000
+ maxused 25
+ bufsize 32768
+ }
+
+ set theState(root) $env(HOME)
+
+ array set theMimeTypes {
+ {} text/plain
+ .txt text/plain
+ .html text/html
+ .gif image/gif
+ .jpg image/jpeg
+ .pd text/html
+ }
+
+ # HTTP/1.[01] error codes (the ones we use)
+ array set theErrors {
+ 204 {No Content}
+ 400 {Bad Request}
+ 404 {Not Found}
+ 405 {Method Not Allowed}
+ 408 {Request Timeout}
+ 411 {Length Required}
+ 419 {Expectation Failed}
+ 500 {Internal Server Error}
+ 503 {Service Unavailable}
+ 504 {Service Temporarily Unavailable}
+ 505 {HTTP Version Not Supported}
+ }
+
+ # Generic error response
+ set theErrorFormat {
+ <title>Error: %1$s</title>
+ Got the error: <b>%2$s</b><br>
+ while trying to obtain <b>%3$s</b>
+ }
+}
+
+proc ::pddp::srvUse {{root {}} {port 8080}} {
+ variable theState
+ if {[string length $theState(listen)]} {
+ if {[string length $root] && ![string equal $root $theState(root)]} {
+ srvLog $theState(listen) Warning "Redirection attempt for $root"
+ }
+ } else {
+ srvStart $root $port
+ }
+}
+
+# Start the server by listening for connections on the desired port.
+
+proc ::pddp::srvStart {{root {}} {port 8080}} {
+ variable thePort
+ variable theState
+
+ puts stderr "Starting pddp server on [info hostname]"
+ if {[string length $root]} {
+ set theState(root) $root
+ }
+ # we do not handle multiple pddpservers, LATER rethink
+ srvStop
+ array set theState [list naccepts 0 nrequests 0 nerrors 0]
+
+ for { set thePort $port } {$thePort < 32767 } {incr thePort } {
+ if {[catch {set theState(listen) \
+ [socket -server ::pddp::srvAccept $thePort]} res]} {
+ if {$thePort == 0} {
+ # FIXME this is a critical error
+ set thePort 8080
+ }
+ } else { break }
+ }
+ if {$thePort == 32767} {
+ srvLog none Error "Could not find port available for listening"
+ } else {
+ if {$thePort == 0} {
+ set thePort [lindex [fconfigure $theState(listen) -sockname] 2]
+ }
+ srvLog $theState(listen) Port $thePort
+ srvLog $theState(listen) Root directory \"$root\"
+ }
+ after 120 update ;# FIXME might be needed on windows they say, test there
+ return $thePort
+}
+
+proc ::pddp::srvStop {} {
+ variable thePort
+ variable theState
+ if {[string length $theState(listen)]} {
+ if {[catch {close $theState(listen)} res]} {
+ srvLog $theState(listen) Warning [list $res while closing socket]
+ } else {
+ srvLog $theState(listen) Closed.
+ }
+ set theState(listen) ""
+ update
+ }
+}
+
+# Accept a new connection from the server and set up a handler
+# to read the request from the client.
+
+proc ::pddp::srvAccept {sock ipaddr port} {
+ variable theState
+ variable theSockData$sock
+ # reject remote requests, LATER revisit
+ if {[string equal $ipaddr "127.0.0.1"]} {
+ incr theState(naccepts)
+ srvReset $sock $theState(maxused)
+ srvLog $sock Connect $ipaddr $port
+ } else {
+ srvLog $sock Warning "rejecting remote connection request from $ipaddr"
+ srvSockDone $sock 1
+ }
+}
+
+# Initialize or reset the socket state
+
+proc ::pddp::srvReset {sock nlft} {
+ variable theState
+ upvar 0 ::pddp::theSockData$sock sockData
+ array set sockData [list state start linemode 1 version 0 nleft $nlft]
+ set sockData(cancel) \
+ [after $theState(maxtime) [list srvTimeout $sock]]
+ fconfigure $sock -blocking 0 -buffersize $theState(bufsize) \
+ -translation {auto crlf}
+ fileevent $sock readable [list ::pddp::srvRead $sock]
+}
+
+# Read data from a client request
+# 1) read the request line
+# 2) read the mime headers
+# 3) read the additional data (if post && content-length not satisfied)
+
+proc ::pddp::srvRead {sock} {
+ variable theState
+ upvar 0 ::pddp::theSockData$sock sockData
+
+ # Use line mode to read the request and the mime headers
+
+ if {$sockData(linemode)} {
+ set readCount [gets $sock line]
+ set state [string compare $readCount 0],$sockData(state)
+ switch -glob -- $state {
+ 1,start {
+ if {[regexp {(HEAD|POST|GET) ([^?]+)\??([^ ]*) HTTP/1.([01])} \
+ $line x sockData(proto) sockData(url) \
+ sockData(query) sockData(version)]} {
+ set sockData(state) mime
+ incr theState(nrequests)
+ srvLog $sock Request $sockData(nleft) $line
+ } else {
+ srvError $sock 400 $line
+ }
+ }
+ 0,start {
+ srvLog $sock Warning "Initial blank line fetching request"
+ }
+ 1,mime {
+ if {[regexp {([^:]+):[ ]*(.*)} $line {} key value]} {
+ set key [string tolower $key]
+ set sockData(key) $key
+ if {[info exists sockData(mime,$key)]} {
+ append sockData(mime,$key) ", $value"
+ } else {
+ set sockData(mime,$key) $value
+ }
+ } elseif {[regexp {^[ ]+(.+)} $line {} value] && \
+ [info exists sockData(key)]} {
+ append sockData(mime,$sockData($key)) " " $value
+ } else {
+ srvError $sock 400 $line
+ }
+ }
+ 0,mime {
+ if {$sockData(proto) == "POST" && \
+ [info exists sockData(mime,content-length)]} {
+ set sockData(linemode) 0
+ set sockData(count) $sockData(mime,content-length)
+ if {$sockData(version) && \
+ [info exists sockData(mime,expect)]} {
+ if {$sockData(mime,expect) == "100-continue"} {
+ puts $sock "100 Continue HTTP/1.1\n"
+ flush $sock
+ } else {
+ srvError $sock 419 $sockData(mime,expect)
+ }
+ }
+ fconfigure $sock -translation {binary crlf}
+ } elseif {$sockData(proto) != "POST"} {
+ srvRespond $sock
+ } else {
+ srvError $sock 411 "Confusing mime headers"
+ }
+ }
+ -1,* {
+ if {[eof $sock]} {
+ srvLog $sock Error "Broken connection fetching request"
+ srvSockDone $sock 1
+ } else {
+ puts stderr "Partial read, retrying"
+ }
+ }
+ default {
+ srvError $sock 404 "Invalid http state: $state,[eof $sock]"
+ }
+ }
+
+ # Use counted mode to get the post data
+
+ } elseif {![eof $sock]} {
+ append sockData(postdata) [read $sock $sockData(count)]
+ set sockData(count) [expr {$sockData(mime,content-length) - \
+ [string length $sockData(postdata)]}]
+ if {$sockData(count) == 0} {
+ srvRespond $sock
+ }
+ } else {
+ srvLog $sock Error "Broken connection reading POST data"
+ srvSockDone $sock 1
+ }
+}
+
+# Done with the socket, either close it, or set up for next fetch
+# sock: The socket I'm done with
+# doclose: If true, close the socket, otherwise set up for reuse
+
+proc ::pddp::srvSockDone {sock doclose} {
+ variable theState
+ upvar 0 ::pddp::theSockData$sock sockData
+
+ after cancel $sockData(cancel)
+ set nleft [incr sockData(nleft) -1]
+ unset sockData
+ if {$doclose} {
+ close $sock
+ } else {
+ srvReset $sock $nleft
+ }
+ return ""
+}
+
+# A timeout happened
+
+proc ::pddp::srvTimeout {sock} {
+ srvError $sock 408
+}
+
+# FIXME test if "path" has its patch window already open...
+proc ::pddp::srvPdHandler {sock path} {
+ set dir [file dirname $path]
+ set tail [file tail $path]
+ if {[catch {pd [concat pd open $tail $dir \;]}]} {
+ srvError $sock 504
+ } else {
+ srvError $sock 204
+ # FIXME raise; focus (test on windows)
+ }
+}
+
+# Handle file system queries. This is a place holder for a more
+# generic dispatch mechanism.
+
+proc ::pddp::srvRespond {sock} {
+ variable theState
+ variable theUrlCache
+ upvar 0 ::pddp::theSockData$sock sockData
+
+ regsub {(^http://[^/]+)?} $sockData(url) {} url
+ if {[info exists theUrlCache($url)]} {
+ set mypath $theUrlCache($url)
+ } else {
+ set mypath [srvUrl2File $theState(root) $url]
+ if {[file isdirectory $mypath]} {
+ append mypath / $theState(default)
+ }
+ set theUrlCache($url) $mypath
+ }
+ if {[string length $mypath] == 0} {
+ srvError $sock 400
+ } elseif {![file readable $mypath]} {
+ if {[string equal [file tail $mypath] "favicon.ico"]} {
+ srvError $sock 204 ;# FIXME design something
+ } else {
+ srvError $sock 404 $mypath
+ }
+ } else {
+ set ext [file extension $mypath]
+
+ if {[string equal $ext ".pd"]} {
+ srvPdHandler $sock $mypath
+ return
+ }
+
+ puts $sock "HTTP/1.$sockData(version) 200 Data follows"
+ puts $sock "Date: [srvGetDate [clock seconds]]"
+ puts $sock "Last-Modified: [srvGetDate [file mtime $mypath]]"
+ puts $sock "Content-Type: [srvContentType $ext]"
+ puts $sock "Content-Length: [file size $mypath]"
+
+ ## Should also close socket if recvd connection close header
+ set doclose [expr {$sockData(nleft) == 0}]
+
+ if {$doclose} {
+ puts $sock "Connection close:"
+ } elseif {$sockData(version) == 0 && \
+ [info exists sockData(mime,connection)]} {
+ if {$sockData(mime,connection) == "Keep-Alive"} {
+ set doclose 0
+ puts $sock "Connection: Keep-Alive"
+ }
+ }
+ puts $sock ""
+ flush $sock
+
+ if {$sockData(proto) != "HEAD"} {
+ set in [open $mypath]
+ fconfigure $sock -translation binary
+ fconfigure $in -translation binary
+ fcopy $in $sock -command \
+ [list ::pddp::srvCopyDone $in $sock $doclose]
+ } else {
+ srvSockDone $sock $doclose
+ }
+ }
+}
+
+# Callback when file is done being output to client
+# in: The fd for the file being copied
+# sock: The client socket
+# doclose: close the socket if true
+# bytes: The # of bytes copied
+# error: The error message (if any)
+
+proc ::pddp::srvCopyDone {in sock doclose bytes {error {}}} {
+ close $in
+ srvLog $sock Done $bytes bytes
+ srvSockDone $sock $doclose
+}
+
+# Convert the file suffix into a mime type.
+
+proc ::pddp::srvContentType {ext} {
+ variable theMimeTypes
+ set type text/plain
+ catch {set type $theMimeTypes($ext)}
+ return $type
+}
+
+# Respond with an error reply
+# sock: The socket handle to the client
+# code: The httpd error code
+# args: Additional information for error logging
+
+proc ::pddp::srvError {sock code args} {
+ variable theState
+ variable theErrors
+ variable theErrorFormat
+ upvar 0 ::pddp::theSockData$sock sockData
+
+ append sockData(url) ""
+ incr theState(nerrors)
+ set message [format $theErrorFormat $code $theErrors($code) $sockData(url)]
+ append head "HTTP/1.$sockData(version) $code $theErrors($code)" \n
+ append head "Date: [srvGetDate [clock seconds]]" \n
+ append head "Connection: close" \n
+ append head "Content-Length: [string length $message]" \n
+
+ # Because there is an error condition, the socket may be "dead"
+
+ catch {
+ fconfigure $sock -translation crlf
+ puts -nonewline $sock $head\n$message
+ flush $sock
+ } reason
+ srvSockDone $sock 1
+ if {$code < 300} {set status Status} else {set status Error}
+ srvLog $sock $status $code $theErrors($code) $args $reason
+}
+
+# Generate a date string in HTTP format.
+
+proc ::pddp::srvGetDate {seconds} {
+ return [clock format $seconds -format {%a, %d %b %Y %T %Z}]
+}
+
+# Log an Httpd transaction.
+# This should be replaced as needed.
+
+proc ::pddp::srvLog {sock args} {
+ puts stderr "pddp log ($sock): $args"
+}
+
+# Convert a url into a pathname. (UNIX version only)
+# This is probably not right, and belongs somewhere else.
+# - Remove leading http://... if any
+# - Collapse all /./ and /../ constructs
+# - expand %xx sequences -> disallow "/"'s and "."'s due to expansions
+
+proc ::pddp::srvUrl2File {root url} {
+ regsub -all {//+} $url / url ;# collapse multiple /'s
+ while {[regsub -all {/\./} $url / url]} {} ;# collapse /./
+ while {[regsub -all {/\.\.(/|$)} $url /\x81\\1 url]} {} ;# mark /../
+ while {[regsub "/\[^/\x81]+/\x81/" $url / url]} {} ;# collapse /../
+ if {![regexp "\x81|%2\[eEfF]" $url]} { ;# invalid /../, / or . ?
+ return $root[srvCgiMap $url]
+ } else {
+ return ""
+ }
+}
+
+# Decode url-encoded strings.
+
+proc ::pddp::srvCgiMap {data} {
+ regsub -all {([][$\\])} $data {\\\1} data
+ regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
+ return [subst $data]
+}
+
+if {$::pddp::testrun} { ;# true if tested as a standalone script
+ if {$argc > 1} {
+ set root [lindex $argv 1]
+ set port [lindex $argv 2]
+ if {![string is integer -strict $port]} {
+ set port 8080
+ }
+ } else {
+ set root $env(HOME)
+ set port 8080
+ }
+ ::pddp::srvStart $root $port
+ vwait forever
+}