From 859b2521448c487eb681dad085138a703332e85f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 30 Aug 2004 03:30:54 +0000 Subject: [PATCH] file responder: redirect if directory url does not end with /, and other changes to httpd --- Makefile | 6 +-- TODO.FACTOR.txt | 3 +- library/cross-compiler.factor | 2 + library/httpd/default-responders.factor | 23 ++++++--- library/httpd/file-responder.factor | 48 ++++++++++++------ library/httpd/http-common.factor | 52 ++++++++++++------- library/httpd/httpd.factor | 12 +++-- library/httpd/responder.factor | 53 ++++++++----------- library/init.factor | 1 + library/platform/jvm/boot-mini.factor | 1 + library/platform/jvm/boot-sumo.factor | 3 +- library/platform/jvm/files.factor | 59 ++++++++++++++++++++++ library/platform/jvm/stream.factor | 26 ---------- library/platform/native/boot-stage2.factor | 1 + library/platform/native/files.factor | 44 ++++++++++++++++ library/platform/native/stream.factor | 4 -- library/strings.factor | 3 ++ library/test/httpd/httpd.factor | 14 ++--- native/factor.h | 1 + native/file.c | 20 ++++++++ native/file.h | 1 + native/primitives.c | 1 + native/primitives.h | 2 +- native/relocate.c | 3 ++ 24 files changed, 267 insertions(+), 116 deletions(-) create mode 100644 library/platform/jvm/files.factor create mode 100644 library/platform/native/files.factor diff --git a/Makefile b/Makefile index eefe7806aa..68aeb29575 100644 --- 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 673606eb13..ef3e2092be 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -3,8 +3,6 @@ - 'default responder' for when we go to root - file responder: - directory listings - - index.html - - if a directory is requested and URL does not end with /, redirect - minimize stage2 initialization code, just move it to source files + bignums: @@ -85,6 +83,7 @@ + misc: +- don't rehash strings on every startup - 'cascading' styles - jedit ==> jedit-word, jedit takes a file name - rethink strhead/strtail&co diff --git a/library/cross-compiler.factor b/library/cross-compiler.factor index 9701b319b2..8cb1e646e9 100644 --- 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 10ff88b2f4..ad0190c29c 100644 --- 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. [ + [ + "404" "responder" set + [ drop no-such-responder ] "get" set + ] extend "404" set + [ "test" "responder" set [ test-responder ] "get" set @@ -53,12 +64,12 @@ USE: wiki-responder "quit" "responder" set [ quit-responder ] "get" set ] extend "quit" set - - [ - "file" "responder" set - [ file-responder ] "get" set - ] extend "file" set - + + [ + "file" "responder" set + [ file-responder ] "get" set + ] extend "file" set + ! [ ! "wiki" "responder" set ! [ wiki-get-responder ] "get" set diff --git a/library/httpd/file-responder.factor b/library/httpd/file-responder.factor index 55fa916320..51448fc852 100644 --- 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 "stdio" get fcopy drop ; +: serve-static ( filename mime-type -- ) + file-header print "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 ; -: file-responder ( filename -- ) - "doc-root" get [ - parse-object-name dup exists? [ +: 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 ] [ - 2drop "404 not found" httpd-error + 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 [ + serving-path dup exists? [ + serve-object + ] [ + 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 7fd590ea5f..4fdea40574 100644 --- 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 8beaad9b6a..6803b2a872 100644 --- 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 70cc47e354..1fee1ee995 100644 --- 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 ) [ @@ -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 043ea07570..4f7f022145 100644 --- 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 c068d97cde..741420eea1 100644 --- 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 f971951d84..532061a92b 100644 --- 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 index 0000000000..89f5566865 --- /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 + +: ( path -- file ) + dup "java.io.File" is not [ + [ "java.lang.String" ] "java.io.File" jnew + ] when ; + +: delete ( file -- ? ) + #! Delete a file. + [ ] "java.io.File" "delete" jinvoke ; + +: exists? ( file -- boolean ) + [ ] "java.io.File" "exists" jinvoke ; + +: directory? ( file -- boolean ) + [ ] "java.io.File" "isDirectory" jinvoke ; + +: directory ( file -- listing ) + [ ] "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. + swap + [ "java.io.File" ] "java.io.File" "renameTo" + jinvoke ; diff --git a/library/platform/jvm/stream.factor b/library/platform/jvm/stream.factor index 98a3b32e03..14682586b2 100644 --- 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 ; -: ( path -- file ) - dup "java.io.File" is not [ - [ "java.lang.String" ] "java.io.File" jnew - ] when ; - -: fdelete ( file -- ? ) - #! Delete a file. - [ ] "java.io.File" "delete" jinvoke ; - : ( file -- freader ) [ "java.lang.String" ] "java.io.FileReader" jnew ; -: exists? ( file -- boolean ) - [ ] "java.io.File" "exists" jinvoke ; - -: directory? ( file -- boolean ) - [ ] "java.io.File" "isDirectory" jinvoke ; - -: directory ( file -- listing ) - [ ] "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. - swap - [ "java.io.File" ] "java.io.File" "renameTo" - jinvoke ; - : ( 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 df0f8f8435..7051f9ca82 100644 --- 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 index 0000000000..a4d2cc4390 --- /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 074f0fd15f..97e019626b 100644 --- a/library/platform/native/stream.factor +++ b/library/platform/native/stream.factor @@ -80,10 +80,6 @@ USE: namespaces : init-stdio ( -- ) stdin stdout "stdio" set ; -: exists? ( file -- ? ) - #! This is terrible. - [ 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 63099b9b71..836c1e386a 100644 --- 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 64d12c3776..a990479911 100644 --- 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 bc5e0010c8..14d95b57a4 100644 --- a/native/factor.h +++ b/native/factor.h @@ -15,6 +15,7 @@ #include #include #include +#include #include #include #include diff --git a/native/file.c b/native/file.c index 6a5380f9ae..3c96913bc3 100644 --- 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 c24548cf35..74326d9e60 100644 --- 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 b71913d848..7d144d86e1 100644 --- 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 8f29a1d387..b1ceb28c22 100644 --- 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 c049f43f62..791b61ec7e 100644 --- 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;