file responder: redirect if directory url does not end with /, and other changes...

diff --git a/Makefile b/Makefile
index eefe7806aae8419ef4a452b364a35e1567f3488f..68aeb295752f9095b782afa31d231212e22f905e 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,5 @@
-CC = gcc
-CFLAGS = -g -Os -mpentiumpro -Wall
+CC = gcc34
+CFLAGS = -Os -ffast-math -march=pentium4 -Wall -fomit-frame-pointer
 LIBS = -lm
 STRIP = strip
 
@@ -18,7 +18,7 @@ OBJS = native/arithmetic.o native/array.o native/bignum.o \
 
 f: $(OBJS)
        $(CC) $(LIBS) -o $@ $(OBJS)
-#      $(STRIP) $@
+       $(STRIP) $@
 
 clean:
        rm -f $(OBJS)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 673606eb1375cb5081213b5357a632dba81be4d1..ef3e2092be9a001c28f702eefe6e41c52e77f00b 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -3,8 +3,6 @@
 - 'default responder' for when we go to root\r
 - file responder:\r
   - directory listings\r
-  - index.html\r
-  - if a directory is requested and URL does not end with /, redirect\r
 - minimize stage2 initialization code, just move it to source files\r
 \r
 + bignums:\r
@@ -85,6 +83,7 @@
 \r
 + misc:\r
 \r
+- don't rehash strings on every startup\r
 - 'cascading' styles\r
 - jedit ==> jedit-word, jedit takes a file name\r
 - rethink strhead/strtail&co\r

diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor
index 9701b319b2600602e013924def335e1b1114f733..8cb1e646e960d3e0f8d000a1ea2c4d85c301d063 100644 (file)
--- a/library/cross-compiler.factor
+++ b/library/cross-compiler.factor
@@ -60,6 +60,7 @@ DEFER: sbuf-clone
 IN: io-internals
 DEFER: port?
 DEFER: open-file
+DEFER: stat
 DEFER: client-socket
 DEFER: server-socket
 DEFER: close-port
@@ -218,6 +219,7 @@ IN: cross-compiler
         getenv
         setenv
         open-file
+        stat
         garbage-collection
         save-image
         datastack

diff --git a/library/httpd/default-responders.factor b/library/httpd/default-responders.factor
index 10ff88b2f4f4896a00d25acc433452ca868da516..ad0190c29c646155a7ea039fa2085afeed8041fb 100644 (file)
--- a/library/httpd/default-responders.factor
+++ b/library/httpd/default-responders.factor
@@ -26,7 +26,10 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 IN: httpd-responder
+USE: httpd
 USE: namespaces
+USE: stack
+USE: strings
 
 USE: test-responder
 USE: inspect-responder
@@ -34,10 +37,18 @@ USE: quit-responder
 USE: file-responder
 USE: wiki-responder
 
+: no-such-responder ( -- )
+    "404 No such responder" httpd-error ;
+
 : default-responders ( -- )
     #! Remove all existing responders, and create a blank
     #! responder table.
     <namespace> [
+        <responder> [
+            "404" "responder" set
+            [ drop no-such-responder ] "get" set
+        ] extend "404" set
+
         <responder> [
             "test" "responder" set
             [ test-responder ] "get" set
@@ -53,12 +64,12 @@ USE: wiki-responder
             "quit" "responder" set
             [ quit-responder ] "get" set
         ] extend "quit" set
- 
-         <responder> [
-             "file" "responder" set
-             [ file-responder ] "get" set
-         ] extend "file" set
- 
+
+        <responder> [
+            "file" "responder" set
+            [ file-responder ] "get" set
+        ] extend "file" set
+
 !        <responder> [
 !            "wiki" "responder" set
 !            [ wiki-get-responder ] "get" set

diff --git a/library/httpd/file-responder.factor b/library/httpd/file-responder.factor
index 55fa916320d3edc7437576577f442ed07579fc79..51448fc85299cb406bfa4cd40efc32d4220ba6ea 100644 (file)
--- a/library/httpd/file-responder.factor
+++ b/library/httpd/file-responder.factor
@@ -28,10 +28,11 @@
 IN: file-responder
 USE: combinators
 USE: errors
-USE: kernel
 USE: files
 USE: httpd
 USE: httpd-responder
+USE: kernel
+USE: logging
 USE: namespaces
 USE: parser
 USE: stack
@@ -39,12 +40,8 @@ USE: stdio
 USE: streams
 USE: strings
 
-: parse-object-name ( filename -- argument filename )
-    dup [ "?" split1 swap ] [ "/" ] ifte
-    "doc-root" get swap cat2 ;
-
-: serve-script ( argument filename -- )
-    [ swap "argument" set run-file ] with-scope ;
+: serving-path ( filename -- filename )
+    f>"" "doc-root" get swap cat2 ;
 
 : file-header ( mime-type -- header )
     "200 Document follows" swap response ;
@@ -52,22 +49,43 @@ USE: strings
 : copy-and-close ( from -- )
     [ dupd "stdio" get fcopy ] [ >r fclose r> rethrow ] catch ;
 
-: serve-static ( argument filename mime-type -- )
-    file-header print <filebr> "stdio" get fcopy drop ;
+: serve-static ( filename mime-type -- )
+    file-header print <filebr> "stdio" get fcopy ;
 
-: serve-file ( argument filename -- )
+: serve-file ( filename -- )
     dup mime-type dup "application/x-factor-server-page" = [
-        drop serve-script
+        drop run-file
     ] [
         serve-static
     ] ifte ;
 
+: directory-no/ ( -- )
+    <% "request" get % CHAR: / %
+    "raw-query" get [ CHAR: ? % % ] when*
+    %> redirect ;
+
+: serve-directory ( filename -- )
+    dup "/" str-tail? dup [
+        drop dup "index.html" cat2 dup exists? [
+            serve-file
+        ] [
+            drop
+            "Foo bar" log
+            drop
+        ] ifte
+    ] [
+        2drop directory-no/
+    ] ifte ;
+
+: serve-object ( filename -- )
+    dup directory? [ serve-directory ] [ serve-file ] ifte ;
+
 : file-responder ( filename -- )
     "doc-root" get [
-        parse-object-name dup exists? [
-            serve-file
+        serving-path dup exists? [
+            serve-object
         ] [
-            2drop "404 not found" httpd-error
+            drop "404 not found" httpd-error
         ] ifte
     ] [
         drop "404 doc-root not set" httpd-error

diff --git a/library/httpd/http-common.factor b/library/httpd/http-common.factor
index 7fd590ea5f779893c2ca74706f53952e90e764c7..4fdea405748adf25aa126e9f4ce616ea2ebb5fea 100644 (file)
--- a/library/httpd/http-common.factor
+++ b/library/httpd/http-common.factor
@@ -55,6 +55,18 @@ USE: url-encoding
     dup log-error
     <% dup "text/html" response % error-body % %> print ;
 
+: serving-html ( -- )
+    "200 Document follows" "text/html" response print ;
+
+: serving-text ( -- )
+    "200 Document follows" "text/plain" response print ;
+
+: redirect ( to -- )
+    "301 Moved Permanently" "text/plain" response write
+    "Location: " write write
+    terpri terpri
+    "The resource has moved." print ;
+
 : header-line ( alist line -- alist )
     ": " split1 dup [ transp acons ] [ 2drop ] ifte ;
 
@@ -68,28 +80,34 @@ USE: url-encoding
 : content-length ( alist -- length )
     "Content-Length" swap assoc dec> ;
 
-: post-request>alist ( post-request -- alist )
-    "&" split [ "=" split1 cons ] map ;
-
-: url-decode-alist ( alist -- alist )
-    [ uncons >r url-decode r> url-decode cons ] map ;
+: query>alist ( query -- alist )
+    dup [
+        "&" split [
+            "=" split1
+            dup [ url-decode ] when swap
+            dup [ url-decode ] when swap cons
+        ] map
+    ] when ;
 
 : read-post-request ( header -- alist )
-    content-length dup [
-        read# post-request>alist url-decode-alist
-    ] when ;
+    content-length dup [ read# query>alist ] when ;
 
 : log-user-agent ( alist -- )
     "User-Agent" swap assoc* [
         unswons <% % ": " % % %> log
     ] when* ;
 
-: with-request ( method quot -- )
-    [
-        read-header "header" set
-        "header" get log-user-agent
-        swap "post" = [
-            "header" get read-post-request "response" set
-        ] when
-        call
-    ] with-scope ;
+: prepare-url ( url -- url )
+    #! This is executed in the with-request namespace.
+    "?" split1
+    dup "raw-query" set query>alist "query" set
+    dup "request" set ;
+
+: prepare-header ( -- )
+    read-header dup "header" set
+    dup log-user-agent
+    read-post-request "response" set ;
+
+: with-request ( url quot -- )
+    #! The quotation is called with the URL on the stack.
+    [ swap prepare-url swap prepare-header call ] with-scope ;

diff --git a/library/httpd/httpd.factor b/library/httpd/httpd.factor
index 8beaad9b6a8a21c697506650b45ded7345c4c063..6803b2a8728e42724469da07f5ad81c0af26fdf7 100644 (file)
--- a/library/httpd/httpd.factor
+++ b/library/httpd/httpd.factor
@@ -61,11 +61,17 @@ USE: url-encoding
 : secure-path ( path -- path )
     ".." over str-contains? [ drop f ] when ;
 
+: get-request ( url -- )
+    [ "get" swap serve-responder ] with-request ;
+
+: post-request ( url -- )
+    [ "post" swap serve-responder ] with-request ;
+
 : handle-request ( arg cmd -- )
     [
-        [ "GET"  = ] [ drop "get"  serve-responder ]
-        [ "POST" = ] [ drop "post" serve-responder ]
-        [ drop t   ] [ 2drop bad-request           ]
+        [ "GET"  = ] [ drop get-request ]
+        [ "POST" = ] [ drop post-request ]
+        [ drop t   ] [ 2drop bad-request ]
     ] cond ;
 
 : parse-request ( request -- )

diff --git a/library/httpd/responder.factor b/library/httpd/responder.factor
index 70cc47e3543f2bbd645d9f1aa2240ed4a95da84e..1fee1ee99507547d2fcc69b282f00ab743f5c685 100644 (file)
--- a/library/httpd/responder.factor
+++ b/library/httpd/responder.factor
@@ -28,6 +28,7 @@
 IN: httpd-responder
 
 USE: combinators
+USE: httpd
 USE: kernel
 USE: lists
 USE: logging
@@ -37,7 +38,17 @@ USE: stack
 USE: streams
 USE: strings
 
-USE: httpd
+! Responders are called in a new namespace with these
+! variables:
+
+! - request -- the entire URL requested, including responder
+!              name
+! - raw-query -- raw query string
+! - query -- an alist of query parameters, eg
+!            foo.bar?a=b&c=d becomes
+!            [ [ "a" | "b" ] [ "c" | "d" ] ]
+! - header -- an alist of headers from the user's client
+! - response -- an alist of the POST request response
 
 : <responder> ( -- responder )
     <namespace> [
@@ -45,56 +56,34 @@ USE: httpd
         [
             drop "GET method not implemented" httpd-error
         ] "get" set
-
         ( url -- )
         [
             drop "POST method not implemented" httpd-error
         ] "post" set
     ] extend ;
 
-: serving-html ( -- )
-    "200 Document follows" "text/html" response print ;
-
-: serving-text ( -- )
-    "200 Document follows" "text/plain" response print ;
-
-: redirect ( to -- )
-    "301 Moved Permanently" "text/plain" response write
-    "Location: " write write
-    terpri terpri
-    "The resource has moved." print ;
-
 : get-responder ( name -- responder )
-    "httpd-responders" get get* ;
+    "httpd-responders" get get* [
+        "404" "httpd-responders" get get*
+    ] unless* ;
 
 : responder-argument ( argument -- argument )
     dup f-or-"" [ drop "default-argument" get ] when ;
 
 : call-responder ( method argument responder -- )
-    pick [
-        [ responder-argument swap get call ] bind
-    ] with-request ;
-
-: no-such-responder ( name -- )
-    "404 no such responder: " swap cat2 httpd-error ;
+    [ responder-argument swap get call ] bind ;
 
 : trim-/ ( url -- url )
     #! Trim a leading /, if there is one.
     dup "/" str-head? dup [ nip ] [ drop ] ifte ;
 
-: log-responder ( argument -- )
+: log-responder ( url -- )
     "Calling responder " swap cat2 log ;
 
-: serve-responder ( argument method -- )
-    swap
-    dup log-responder
-    trim-/ "/" split1 dup [
-        over get-responder dup [
-            rot drop call-responder
-        ] [
-            2drop no-such-responder drop
-        ] ifte
+: serve-responder ( method url -- )
+    dup log-responder trim-/ "/" split1 dup [
+        swap get-responder call-responder
     ] [
-        ! Argument is just a responder name without /
+        ! Just a responder name by itself
         drop "/" swap "/" cat3 redirect drop
     ] ifte ;

diff --git a/library/init.factor b/library/init.factor
index 043ea075707d1b40cc5a926ef9dbe0c7de373172..4f7f022145fb8ac796ac80ef28b1893afc65aaf4 100644 (file)
--- a/library/init.factor
+++ b/library/init.factor
@@ -30,6 +30,7 @@ USE: combinators
 USE: compiler
 USE: continuations
 USE: errors
+USE: files
 USE: interpreter
 USE: kernel
 USE: lists

diff --git a/library/platform/jvm/boot-mini.factor b/library/platform/jvm/boot-mini.factor
index c068d97cde9e08cc370cead0ba9f6381b06acbf6..741420eea1bd0e268c5864075f730602048964db 100644 (file)
--- a/library/platform/jvm/boot-mini.factor
+++ b/library/platform/jvm/boot-mini.factor
@@ -67,6 +67,7 @@ USE: parser
 "/library/platform/jvm/regexp.factor"       run-resource ! regexp
 "/library/stream.factor"                    run-resource ! streams
 "/library/platform/jvm/stream.factor"       run-resource ! streams
+"/library/platform/jvm/files.factor"        run-resource ! files
 "/library/stdio.factor"                     run-resource ! stdio
 "/library/platform/jvm/unparser.factor"     run-resource ! unparser
 "/library/platform/jvm/parser.factor"       run-resource ! parser

diff --git a/library/platform/jvm/boot-sumo.factor b/library/platform/jvm/boot-sumo.factor
index f971951d841ca065b0a8e3cacd5bf2c31eea8fdd..532061a92b86160924f69b81a503868304217cb9 100644 (file)
--- a/library/platform/jvm/boot-sumo.factor
+++ b/library/platform/jvm/boot-sumo.factor
@@ -67,13 +67,14 @@ USE: parser
 "/library/platform/jvm/regexp.factor"       run-resource ! regexp
 "/library/stream.factor"                    run-resource ! streams
 "/library/platform/jvm/stream.factor"       run-resource ! streams
+"/library/platform/jvm/files.factor"        run-resource ! files
+"/library/files.factor"                     run-resource ! files
 "/library/stdio.factor"                     run-resource ! stdio
 "/library/platform/jvm/unparser.factor"     run-resource ! unparser
 "/library/platform/jvm/parser.factor"       run-resource ! parser
 "/library/styles.factor"                    run-resource ! styles
 "/library/platform/jvm/threads.factor"      run-resource ! threads
 "/library/logging.factor"                   run-resource ! logging
-"/library/files.factor"                     run-resource ! files
 
 !!! Math library.
 "/library/platform/jvm/real-math.factor" run-resource ! real-math

diff --git a/library/platform/jvm/files.factor b/library/platform/jvm/files.factor
new file mode 100644 (file)
index 0000000..89f5566
--- /dev/null
+++ b/library/platform/jvm/files.factor
@@ -0,0 +1,59 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: files
+USE: combinators
+USE: kernel
+USE: lists
+USE: logic
+USE: stack
+USE: strings
+
+: <file> ( path -- file )
+    dup "java.io.File" is not [
+        [ "java.lang.String" ] "java.io.File" jnew
+    ] when ;
+
+: delete ( file -- ? )
+    #! Delete a file.
+    <file> [ ] "java.io.File" "delete" jinvoke ;
+
+: exists? ( file -- boolean )
+    <file> [ ] "java.io.File" "exists" jinvoke ;
+
+: directory? ( file -- boolean )
+    <file> [ ] "java.io.File" "isDirectory" jinvoke ;
+
+: directory ( file -- listing )
+    <file> [ ] "java.io.File" "list" jinvoke array>list str-sort ;
+
+: rename ( from to -- ? )
+    ! Rename file 'from' to 'to'. These can be paths or
+    ! java.io.File instances.
+    <file> swap <file>
+    [ "java.io.File" ] "java.io.File" "renameTo"
+    jinvoke ;

diff --git a/library/platform/jvm/stream.factor b/library/platform/jvm/stream.factor
index 98a3b32e03f54875bd7c42f0af9d2fec2b8c95f6..14682586b292d0f1dc4505a9cf30ba6d1889c4ed 100644 (file)
--- a/library/platform/jvm/stream.factor
+++ b/library/platform/jvm/stream.factor
@@ -32,7 +32,6 @@ USE: kernel
 USE: lists
 USE: logic
 USE: namespaces
-USE: regexp
 USE: stack
 USE: strings
 
@@ -185,34 +184,9 @@ USE: strings
     f swap
     <byte-stream> ;
 
-: <file> ( path -- file )
-    dup "java.io.File" is not [
-        [ "java.lang.String" ] "java.io.File" jnew
-    ] when ;
-
-: fdelete ( file -- ? )
-    #! Delete a file.
-    <file> [ ] "java.io.File" "delete" jinvoke ;
-
 : <freader> ( file -- freader )
     [ "java.lang.String" ] "java.io.FileReader" jnew <breader> ;
 
-: exists? ( file -- boolean )
-    <file> [ ] "java.io.File" "exists" jinvoke ;
-
-: directory? ( file -- boolean )
-    <file> [ ] "java.io.File" "isDirectory" jinvoke ;
-
-: directory ( file -- listing )
-    <file> [ ] "java.io.File" "list" jinvoke array>list str-sort ;
-
-: frename ( from to -- ? )
-    ! Rename file 'from' to 'to'. These can be paths or
-    ! java.io.File instances.
-    <file> swap <file>
-    [ "java.io.File" ] "java.io.File" "renameTo"
-    jinvoke ;
-
 : <sreader> ( string -- reader )
     [ "java.lang.String" ] "java.io.StringReader" jnew ;
 

diff --git a/library/platform/native/boot-stage2.factor b/library/platform/native/boot-stage2.factor
index df0f8f8435ebb675a2821e46fa46f3307ffce356..7051f9ca82f5f91c6b7cce9c00657f4fa1da1031 100644 (file)
--- a/library/platform/native/boot-stage2.factor
+++ b/library/platform/native/boot-stage2.factor
@@ -98,6 +98,7 @@ USE: stdio
     "/library/random.factor"
     "/library/stdio-binary.factor"
     "/library/platform/native/prettyprint.factor"
+    "/library/platform/native/files.factor"
     "/library/files.factor"
     "/library/interpreter.factor"
     "/library/inspector.factor"

diff --git a/library/platform/native/files.factor b/library/platform/native/files.factor
new file mode 100644 (file)
index 0000000..a4d2cc4
--- /dev/null
+++ b/library/platform/native/files.factor
@@ -0,0 +1,44 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: files
+USE: combinators
+USE: io-internals
+USE: kernel
+USE: lists
+USE: logic
+USE: math
+USE: stack
+
+: exists? ( file -- ? )
+    stat >boolean ;
+
+: dir-mode
+    OCT: 40000 ;
+
+: directory? ( file -- ? )
+    stat dup [ car dir-mode bitand 0 = not ] when ;

diff --git a/library/platform/native/stream.factor b/library/platform/native/stream.factor
index 074f0fd15f49ea631ad7ffc0fed6972258e86d90..97e019626beb941d2a40c323c7e71d0f41c3e6d8 100644 (file)
--- a/library/platform/native/stream.factor
+++ b/library/platform/native/stream.factor
@@ -80,10 +80,6 @@ USE: namespaces
 : init-stdio ( -- )
     stdin stdout <fd-stream> <stdio-stream> "stdio" set ;
 
-: exists? ( file -- ? )
-    #! This is terrible.
-    [ <filebr> fclose t ] [ nip not ] catch ;
-
 : fcopy ( from to -- )
     #! Copy the contents of the fd-stream 'from' to the
     #! fd-stream 'to'.

diff --git a/library/strings.factor b/library/strings.factor
index 63099b9b713333b709ebc5f6ce85afbb3455410f..836c1e386a19611bc4e5aada60822c2467aa6439 100644 (file)
--- a/library/strings.factor
+++ b/library/strings.factor
@@ -36,6 +36,9 @@ USE: stack
 : f-or-"" ( obj -- ? )
     dup not swap "" = or ;
 
+: f>"" ( str/f -- str )
+    [ "" ] unless* ;
+
 : str-length< ( str str -- boolean )
     #! Compare string lengths.
     [ str-length ] 2apply < ;

diff --git a/library/test/httpd/httpd.factor b/library/test/httpd/httpd.factor
index 64d12c377606894a4968cefe8e0a04e9e2e49e6a..a990479911849ae3e5e723e93a92edac35bd1081 100644 (file)
--- a/library/test/httpd/httpd.factor
+++ b/library/test/httpd/httpd.factor
@@ -14,7 +14,6 @@ USE: url-encoding
 [ 5430 ]
 [ f "Content-Length: 5430" header-line content-length ] unit-test
 
-
 [ "hello world"   ] [ "hello+world"    url-decode ] unit-test
 [ "hello world"   ] [ "hello%20world"  url-decode ] unit-test
 [ " ! "           ] [ "%20%21%20"      url-decode ] unit-test
@@ -23,8 +22,6 @@ USE: url-encoding
 [ "hello%20world" ] [ "hello world"    url-encode ] unit-test
 [ "%20%21%20"     ] [ " ! "            url-encode ] unit-test
 
-! These make sure the words work, and don't leave
-! extra crap on the stakc
 [ ] [ "404 not found" ] [ httpd-error ] test-word
 
 [ "arg" ] [
@@ -60,13 +57,18 @@ USE: url-encoding
 [ f ]
 [ "foobar/../baz" secure-path ] unit-test
 
-[ ] [ "GET /index.html" parse-request ] unit-test
 [ ] [ "GET ../index.html" parse-request ] unit-test
 [ ] [ "POO" parse-request ] unit-test
 
-[ [ [ "Foo" | "Bar" ] ] ] [ "Foo=Bar" post-request>alist ] unit-test
+[ [ [ "Foo" | "Bar" ] ] ] [ "Foo=Bar" query>alist ] unit-test
+
 [ [ [ "Foo" | "Bar" ] [ "Baz" | "Quux" ] ] ]
-[ "Foo=Bar&Baz=Quux" post-request>alist ] unit-test
+[ "Foo=Bar&Baz=Quux" query>alist ] unit-test
+
+[ [ [ "Baz" | " " ] ] ]
+[ "Baz=%20" query>alist ] unit-test
+
+[ [ [ "Foo" ] ] ] [ "Foo" query>alist ] unit-test
 
 [ f "/foo/hello.html" ] [
     [

diff --git a/native/factor.h b/native/factor.h
index bc5e0010c800ae9af55c6b3ae10e974e7616bf3a..14d95b57a4a4211b699feba02f1239acc4b124bc 100644 (file)
--- a/native/factor.h
+++ b/native/factor.h
@@ -15,6 +15,7 @@
 #include <sys/param.h>
 #include <sys/types.h>
 #include <sys/socket.h>
+#include <sys/stat.h>
 #include <netinet/in.h>
 #include <arpa/inet.h>
 #include <unistd.h>

diff --git a/native/file.c b/native/file.c
index 6a5380f9aea37eafd0739b50429ae3a6a05507f8..3c96913bc3ebb325df47242cdc2628efec2e47e5 100644 (file)
--- a/native/file.c
+++ b/native/file.c
@@ -24,3 +24,23 @@ void primitive_open_file(void)
        dpush(read ? tag_object(port(PORT_READ,fd)) : F);
        dpush(write ? tag_object(port(PORT_WRITE,fd)) : F);
 }
+
+void primitive_stat(void)
+{
+       struct stat sb;
+       STRING* path = untag_string(dpop());
+       if(stat(to_c_string(path),&sb) < 0)
+               dpush(F);
+       else
+       {
+               CELL mode = tag_integer(sb.st_mode);
+               CELL size = tag_object(s48_long_long_to_bignum(sb.st_size));
+               CELL mtime = tag_integer(sb.st_mtime);
+               dpush(tag_cons(cons(
+                       mode,
+                       tag_cons(cons(
+                               size,
+                               tag_cons(cons(
+                                       mtime,F)))))));
+       }
+}

diff --git a/native/file.h b/native/file.h
index c24548cf35e299dd4511324c65f58377f542155e..74326d9e6078ab4e8a361cbb14f4717e5723bcb3 100644 (file)
--- a/native/file.h
+++ b/native/file.h
@@ -1,3 +1,4 @@
 #define FILE_MODE 0600
 
 void primitive_open_file(void);
+void primitive_stat(void);

diff --git a/native/primitives.c b/native/primitives.c
index b71913d848f8b5c1e041f79c0060109aae214eda..7d144d86e1da486576b7bf377d1e32e6af59104b 100644 (file)
--- a/native/primitives.c
+++ b/native/primitives.c
@@ -108,6 +108,7 @@ XT primitives[] = {
        primitive_getenv,
        primitive_setenv,
        primitive_open_file,
+       primitive_stat,
        primitive_gc,
        primitive_save_image,
        primitive_datastack,

diff --git a/native/primitives.h b/native/primitives.h
index 8f29a1d387ca0cd8a17700b2d2aadd076bf0692e..b1ceb28c2261587d343e76080f827e8c2783d8d9 100644 (file)
--- a/native/primitives.h
+++ b/native/primitives.h
@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 145
+#define PRIMITIVE_COUNT 146
 
 CELL primitive_to_xt(CELL primitive);

diff --git a/native/relocate.c b/native/relocate.c
index c049f43f62ad4ff7226fe5c1dfbd5c42c11bd7d3..791b61ec7eda07bd659e7ed80a694aea4df3b750 100644 (file)
--- a/native/relocate.c
+++ b/native/relocate.c
@@ -21,6 +21,9 @@ void relocate_object()
        case VECTOR_TYPE:
                fixup_vector((VECTOR*)relocating);
                break;
+       case STRING_TYPE:
+               hash_string((STRING*)relocating);
+               break;
        case SBUF_TYPE:
                fixup_sbuf((SBUF*)relocating);
                break;