externals/miXed/bin/pddp pddpboot.tcl, NONE, 1.1 pddpclient.tcl, NONE, 1.1 pddpserver.tcl, NONE, 1.1 pkgIndex.tcl, NONE, 1.1 - Pd-cvs

30 May 2005


      Update of /cvsroot/pure-data/externals/miXed/bin/pddp
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23253/bin/pddp
Added Files:
    pddpboot.tcl pddpclient.tcl pddpserver.tcl pkgIndex.tcl 
Log Message:
toxy alpha18 and pddp alpha2 (see notes.txt for toxy, pddp and shared)
--- NEW FILE: pddpclient.tcl ---
# 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: exec $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"
    }
}
--- NEW FILE: pddpboot.tcl ---
#!/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 }
}
if {[info exists ::pddp::theDir]} {
    source [file join $::pddp::theDir pddpclient.tcl]
    source [file join $::pddp::theDir pddpserver.tcl]
    if {[info exists ::pddp::theVersion]} {
    package provide pddp $::pddp::theVersion
    }
} else {
    source pddpclient.tcl]
    source pddpserver.tcl]
}
--- NEW FILE: pddpserver.tcl ---
# 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 0
    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 0}} {
    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 0}} {
    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 < 65535 } {incr thePort } {
    if {[catch {set theState(listen) \
    		[socket -server ::pddp::srvAccept $thePort]} res]} {
        if {$thePort == 0} {
    	# FIXME this is a critical error
    	set thePort 32768
        }
        } else { break }
    }
    if {$thePort == 65535} {
    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://%5B%5E/%5D+)?%7D $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 32768
    }
    } else {
    set root $env(HOME)
    set port 32768
    }
    ::pddp::srvStart $root $port
    vwait forever
}
--- NEW FILE: pkgIndex.tcl ---
proc LoadPddp { version dir } {
    namespace eval ::pddp {}
    set ::pddp::theVersion $version
    set ::pddp::theDir $dir
    source [file join $dir pddpboot.tcl]
}
set version "0.1.0.2"
package ifneeded pddp $version [list LoadPddp $version $dir]