From aebe147ae46e27127faa5c9d777de6b9ab822cc9 Mon Sep 17 00:00:00 2001 From: "N.N." Date: Mon, 30 May 2005 09:29:26 +0000 Subject: toxy alpha18 and pddp alpha2 (see notes.txt for toxy, pddp and shared) svn path=/trunk/externals/miXed/; revision=3094 --- pddp/Makefile | 8 - pddp/build_counter | 4 +- pddp/notes.txt | 17 +- pddp/pddpboot.tcl | 32 ---- pddp/pddpclient.tcl | 82 --------- pddp/pddplink.c | 304 +++++++++++++++++++++++++++++--- pddp/pddpserver.tcl | 490 ---------------------------------------------------- 7 files changed, 302 insertions(+), 635 deletions(-) delete mode 100755 pddp/pddpboot.tcl delete mode 100644 pddp/pddpclient.tcl delete mode 100644 pddp/pddpserver.tcl (limited to 'pddp') diff --git a/pddp/Makefile b/pddp/Makefile index b65c310..fc022be 100644 --- a/pddp/Makefile +++ b/pddp/Makefile @@ -1,10 +1,2 @@ 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/build_counter b/pddp/build_counter index ddd868f..627f0ec 100644 --- a/pddp/build_counter +++ b/pddp/build_counter @@ -1,7 +1,7 @@ #define PDDP_VERSION "0.1" #define PDDP_RELEASE "alpha" -#define PDDP_BUILD 1 +#define PDDP_BUILD 2 #if 0 -PDDP_SNAPSHOT = 0.1-alpha1 +PDDP_SNAPSHOT = 0.1-alpha2 #endif diff --git a/pddp/notes.txt b/pddp/notes.txt index e156fe1..168f51e 100644 --- a/pddp/notes.txt +++ b/pddp/notes.txt @@ -1,10 +1,25 @@ TODO for pddp * pddplink: . standardize server's root directory (use $help_directory from pd.tk?) - . nonboxed version DONE for pddp +alpha2 + * loading tcl scripts through "package require pddp": + . storing them in an immediate subdirectory of the path of pddplink's binary + . storing a hand-crafted pkgIndex.tcl there + . pddplink's setup appends the path of its binary to tcl's "auto_path" + * pddpserver asks for auto-assigning its port first, then starts + incrementing from 32768 + * pddplink's appearance controlled with creation options (an option switch + is any symbol starting from '-' followed by a letter) + * options currently recognized: + . "-box" (standard object box) + . "-text" followed by any number of non-option atoms (body text) + * nonboxed version (default) has a custom widgetbehavior, which is a thin + layer on top of the standard text widgetbehavior (using all rtext routines), + so that merging into core Pd, as a new object type, T_LINK, would be easy. + alpha1 * prototype versions of the external "pddplink" and two pd-gui extensions "pddpserver.tcl", "pddpclient.tcl" diff --git a/pddp/pddpboot.tcl b/pddp/pddpboot.tcl deleted file mode 100755 index 3cec684..0000000 --- a/pddp/pddpboot.tcl +++ /dev/null @@ -1,32 +0,0 @@ -#!/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 deleted file mode 100644 index 7633394..0000000 --- a/pddp/pddpclient.tcl +++ /dev/null @@ -1,82 +0,0 @@ -# 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 index d60a90a..d746bbd 100644 --- a/pddp/pddplink.c +++ b/pddp/pddplink.c @@ -2,6 +2,10 @@ * For information on usage and redistribution, and for a DISCLAIMER OF ALL * WARRANTIES, see the file, "LICENSE.txt," in this distribution. */ +/* This is a prototype of an active comment. It might be replaced with + a new core object type, T_LINK (te_type bitfield would have to be + extended then). */ + #include #include #include "m_pd.h" @@ -21,6 +25,10 @@ typedef struct _pddplink t_object x_ob; t_glist *x_glist; int x_isboxed; + char *x_vistext; + int x_vissize; + int x_vislength; + int x_rtextactive; t_symbol *x_dirsym; t_symbol *x_ulink; t_atom x_openargs[2]; @@ -29,6 +37,117 @@ typedef struct _pddplink } t_pddplink; static t_class *pddplink_class; +static t_class *pddplinkbox_class; + +/* Code that might be merged back to g_text.c starts here: */ + +static void pddplink_getrect(t_gobj *z, t_glist *glist, + int *xp1, int *yp1, int *xp2, int *yp2) +{ + t_pddplink *x = (t_pddplink *)z; + int width, height; + float x1, y1, x2, y2; + if (glist->gl_editor && glist->gl_editor->e_rtext) + { + if (x->x_rtextactive) + { + t_rtext *y = glist_findrtext(glist, (t_text *)x); + width = rtext_width(y); + height = rtext_height(y) - 2; + } + else + { + int font = glist_getfont(glist); + width = x->x_vislength * sys_fontwidth(font) + 2; + height = sys_fontheight(font) + 2; + } + } + else width = height = 10; + x1 = text_xpix((t_text *)x, glist); + y1 = text_ypix((t_text *)x, glist); + x2 = x1 + width; + y2 = y1 + height; + y1 += 1; + *xp1 = x1; + *yp1 = y1; + *xp2 = x2; + *yp2 = y2; +} + +static void pddplink_displace(t_gobj *z, t_glist *glist, int dx, int dy) +{ + t_text *t = (t_text *)z; + t->te_xpix += dx; + t->te_ypix += dy; + if (glist_isvisible(glist)) + { + t_rtext *y = glist_findrtext(glist, t); + rtext_displace(y, dx, dy); + } +} + +static void pddplink_select(t_gobj *z, t_glist *glist, int state) +{ + t_pddplink *x = (t_pddplink *)z; + t_rtext *y = glist_findrtext(glist, (t_text *)x); + rtext_select(y, state); + if (glist_isvisible(glist) && glist->gl_havewindow) + { + if (state) + sys_vgui(".x%lx.c itemconfigure %s -fill blue\n", + glist, rtext_gettag(y)); + else + sys_vgui(".x%lx.c itemconfigure %s -text {%s} -fill magenta\n", + glist, rtext_gettag(y), x->x_vistext); + } +} + +static void pddplink_activate(t_gobj *z, t_glist *glist, int state) +{ + t_pddplink *x = (t_pddplink *)z; + t_rtext *y = glist_findrtext(glist, (t_text *)x); + rtext_activate(y, state); + x->x_rtextactive = state; +} + +static void pddplink_vis(t_gobj *z, t_glist *glist, int vis) +{ + t_pddplink *x = (t_pddplink *)z; + if (vis) + { + if (glist->gl_havewindow) + { + t_rtext *y = glist_findrtext(glist, (t_text *)x); + rtext_draw(y); + sys_vgui(".x%lx.c itemconfigure %s -text {%s} -fill magenta\n", + glist, rtext_gettag(y), x->x_vistext); + } + } + else + { + if (glist->gl_havewindow) + { + t_rtext *y = glist_findrtext(glist, (t_text *)x); + rtext_erase(y); + } + } +} + +static int pddplink_wbclick(t_gobj *z, t_glist *glist, int xpix, int ypix, + int shift, int alt, int dbl, int doit); + +static t_widgetbehavior pddplink_widgetbehavior = +{ + pddplink_getrect, + pddplink_displace, + pddplink_select, + pddplink_activate, + 0, + pddplink_vis, + pddplink_wbclick, +}; + +/* Code that might be merged back to g_text.c ends here. */ /* FIXME need access to glob_pdobject... */ static t_pd *pddplink_pdtarget(t_pddplink *x) @@ -66,6 +185,98 @@ static void pddplink_click(t_pddplink *x, t_floatarg xpos, t_floatarg ypos, x->x_ishit = 0; } +static int pddplink_wbclick(t_gobj *z, t_glist *glist, int xpix, int ypix, + int shift, int alt, int dbl, int doit) +{ + if (doit) + pddplink_click((t_pddplink *)z, (t_floatarg)xpix, (t_floatarg)ypix, + (t_floatarg)shift, 0, (t_floatarg)alt); + return (1); +} + +static int pddplink_isoption(char *name) +{ + if (*name == '-') + { + char c = name[1]; + return ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')); + } + else return (0); +} + +static t_symbol *pddplink_nextsymbol(int ac, t_atom *av, int opt, int *skipp) +{ + int ndx; + for (ndx = 0; ndx < ac; ndx++, av++) + { + if (av->a_type == A_SYMBOL && + (!opt || pddplink_isoption(av->a_w.w_symbol->s_name))) + { + *skipp = ++ndx; + return (av->a_w.w_symbol); + } + } + return (0); +} + +static int pddplink_dooptext(char *dst, int maxsize, int ac, t_atom *av) +{ + int i, sz, sep, len; + char buf[32], *src; + for (i = 0, sz = 0, sep = 0; i < ac; i++, av++) + { + if (sep) + { + sz++; + if (sz >= maxsize) + break; + else if (dst) + { + *dst++ = ' '; + *dst = 0; + } + } + else sep = 1; + if (av->a_type == A_SYMBOL) + src = av->a_w.w_symbol->s_name; + else if (av->a_type == A_FLOAT) + { + src = buf; + sprintf(src, "%g", av->a_w.w_float); + } + else + { + sep = 0; + continue; + } + len = strlen(src); + sz += len; + if (sz >= maxsize) + break; + else if (dst) + { + strcpy(dst, src); + dst += len; + } + } + return (sz); +} + +static char *pddplink_optext(int *sizep, int ac, t_atom *av) +{ + char *result; + int sz = pddplink_dooptext(0, MAXPDSTRING, ac, av); + *sizep = sz + (sz >= MAXPDSTRING ? 4 : 1); + result = getbytes(*sizep); + pddplink_dooptext(result, sz + 1, ac, av); + if (sz >= MAXPDSTRING) + { + sz = strlen(result); + strcpy(result + sz, "..."); + } + return (result); +} + #ifdef PDDPLINK_DEBUG static void pddplink_debug(t_pddplink *x) { @@ -74,36 +285,77 @@ static void pddplink_debug(t_pddplink *x) static void pddplink_free(t_pddplink *x) { + if (x->x_vistext) + freebytes(x->x_vistext, x->x_vissize); } -static void *pddplink_new(t_symbol *s1, t_symbol *s2) +static void *pddplink_new(t_symbol *s, int ac, t_atom *av) { - 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_) + t_pddplink xgen, *x; + int skip; + xgen.x_isboxed = 0; + xgen.x_vistext = 0; + xgen.x_vissize = 0; + if (xgen.x_ulink = pddplink_nextsymbol(ac, av, 0, &skip)) { - x->x_linktype = PDDPLINK_HTML; - x->x_ulink = gensym("index.html"); + t_symbol *opt; + ac -= skip; + av += skip; + while (opt = pddplink_nextsymbol(ac, av, 1, &skip)) + { + ac -= skip; + av += skip; + if (opt == gensym("-box")) + xgen.x_isboxed = 1; + else if (opt == gensym("-text")) + { + t_symbol *nextsym = pddplink_nextsymbol(ac, av, 1, &skip); + int natoms = (nextsym ? skip - 1 : ac); + if (natoms) + xgen.x_vistext = + pddplink_optext(&xgen.x_vissize, natoms, av); + } + } } - else + x = (t_pddplink *) + pd_new(xgen.x_isboxed ? pddplinkbox_class : pddplink_class); + x->x_glist = canvas_getcurrent(); + x->x_dirsym = canvas_getdir(x->x_glist); /* FIXME */ + + x->x_isboxed = xgen.x_isboxed; + x->x_vistext = xgen.x_vistext; + x->x_vissize = xgen.x_vissize; + x->x_vislength = (x->x_vistext ? strlen(x->x_vistext) : 0); + x->x_rtextactive = 0; + if (xgen.x_ulink) { - int len = strlen(s1->s_name); - if (len > 3 && !strcmp(s1->s_name + len - 3, ".pd")) + int len = strlen(xgen.x_ulink->s_name); + if (len > 3 && !strcmp(xgen.x_ulink->s_name + len - 3, ".pd")) x->x_linktype = PDDPLINK_PD; else x->x_linktype = PDDPLINK_HTML; - x->x_ulink = s1; + x->x_ulink = xgen.x_ulink; + } + else + { + x->x_linktype = PDDPLINK_HTML; + x->x_ulink = gensym("index.html"); } 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); + else + { + /* do we need to set ((t_text *)x)->te_type = T_TEXT; ? */ + if (!x->x_vistext) + { + x->x_vislength = strlen(x->x_ulink->s_name); + x->x_vissize = x->x_vislength + 1; + x->x_vistext = getbytes(x->x_vissize); + strcpy(x->x_vistext, x->x_ulink->s_name); + } } if (x->x_linktype == PDDPLINK_HTML) sys_vgui("after 0 {::pddp::srvUse %s}\n", x->x_dirsym->s_name); @@ -115,22 +367,34 @@ 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); + A_GIMME, 0); class_addanything(pddplink_class, pddplink_anything); - class_addmethod(pddplink_class, (t_method)pddplink_click, + class_setwidget(pddplink_class, &pddplink_widgetbehavior); + + pddplinkbox_class = class_new(gensym("pddplink"), 0, + (t_method)pddplink_free, + sizeof(t_pddplink), 0, A_GIMME, 0); + class_addanything(pddplinkbox_class, pddplink_anything); + class_addmethod(pddplinkbox_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); + class_addmethod(pddplinkbox_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"); + sys_vgui( + "if {[lsearch $auto_path \"%s\"] < 0} {lappend auto_path \"%s\"}\n", + dirsym->s_name, dirsym->s_name); + sys_gui("after 0 {package require pddp}\n"); } diff --git a/pddp/pddpserver.tcl b/pddp/pddpserver.tcl deleted file mode 100644 index fe17948..0000000 --- a/pddp/pddpserver.tcl +++ /dev/null @@ -1,490 +0,0 @@ -# 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 { - Error: %1$s - Got the error: %2$s
- while trying to obtain %3$s - } -} - -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 -} -- cgit v1.2.1