diff --git a/library/alien/aliens.factor b/library/alien/aliens.factor index bbb29b2f0f..0fe8ae2ff6 100644 --- a/library/alien/aliens.factor +++ b/library/alien/aliens.factor @@ -27,7 +27,7 @@ M: alien = ( obj obj -- ? ) 2drop f ] ifte ; -: ALIEN: scan swons ; parsing +: ALIEN: scan-word swons ; parsing : DLL" skip-blank parse-string dlopen swons ; parsing diff --git a/library/alien/c-types.factor b/library/alien/c-types.factor index 832a99fe9b..982e96ee95 100644 --- a/library/alien/c-types.factor +++ b/library/alien/c-types.factor @@ -20,7 +20,7 @@ SYMBOL: c-types "No such C type: " swap cat2 throw f ] ?ifte ; -: size ( name -- size ) +: c-size ( name -- size ) c-type [ "width" get ] bind ; : define-c-type ( quot name -- ) diff --git a/library/alien/structs.factor b/library/alien/structs.factor index 64f4354af4..d1d144efbc 100644 --- a/library/alien/structs.factor +++ b/library/alien/structs.factor @@ -56,6 +56,7 @@ math namespaces parser strings words ; dup define-nth [ "width" set + cell "align" set [ swap ] "getter" set ] "struct-name" get define-c-type "void*" c-type "struct-name" get "*" cat2 diff --git a/library/httpd/default-responders.factor b/library/httpd/default-responders.factor index 35b8ee86b1..9d19f8f7ae 100644 --- a/library/httpd/default-responders.factor +++ b/library/httpd/default-responders.factor @@ -1,75 +1,58 @@ -! :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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: httpd-responder -USE: httpd -USE: kernel -USE: namespaces -USE: strings - -USE: test-responder -USE: inspect-responder -USE: quit-responder -USE: file-responder -USE: resource-responder -USE: cont-responder -USE: browser-responder +USING: browser-responder cont-responder file-responder kernel +namespaces prettyprint quit-responder resource-responder +test-responder ; #! Remove all existing responders, and create a blank #! responder table. global [ "httpd-responders" set ] bind - [ - "404" "responder" set - [ drop no-such-responder ] "get" set -] extend add-responder - - [ - "test" "responder" set - [ test-responder ] "get" set -] extend add-responder - +! This responder lets anybody shut down your httpd. You should +! disable it if you plan on running a production server! [ "quit" "responder" set [ quit-responder ] "get" set ] extend add-responder [ + "posttest" "responder" set + [ drop "response" get global [ . ] bind ] "post" set +] extend add-responder + +! Runs all unit tests and dumps result to the client. This uses +! a lot of server resources, so disable it on a busy server. + [ + "test" "responder" set + [ test-responder ] "get" set +] extend add-responder + +! 404 error message pages are served by this guy + [ + "404" "responder" set + [ drop no-such-responder ] "get" set +] extend add-responder + +! Serves files from a directory stored in the "doc-root" +! variable. You can set the variable in the global namespace, +! or inside the responder. + [ + ! "/var/www/" "doc-root" set "file" "responder" set [ file-responder ] "get" set [ file-responder ] "post" set [ file-responder ] "head" set ] extend add-responder +! Serves Factor source code [ "resource" "responder" set [ resource-responder ] "get" set ] extend add-responder +! Servers Factor word definitions from the image. "browser" [ f browser-responder ] install-cont-responder +! The root directory is served by... "file" set-default-responder diff --git a/library/httpd/httpd.factor b/library/httpd/httpd.factor index bdc97a4619..f7e991687d 100644 --- a/library/httpd/httpd.factor +++ b/library/httpd/httpd.factor @@ -74,3 +74,7 @@ stdio streams strings threads url-encoding ; : httpd ( port -- ) [ httpd-log-stream "log" set (httpd) ] with-scope ; + +: stop-httpd ( -- ) + #! Stop the server. + "http-server" get stream-close ; diff --git a/library/httpd/quit-responder.factor b/library/httpd/quit-responder.factor index 9644ebae78..7efb198aa5 100644 --- a/library/httpd/quit-responder.factor +++ b/library/httpd/quit-responder.factor @@ -42,5 +42,5 @@ USE: streams "quit-prohibited" get [ quit-prohibited ] [ - "http-server" get stream-close + stop-httpd ] ifte ; diff --git a/library/io/stream.factor b/library/io/stream.factor index 9bd48f39b8..36e81e1954 100644 --- a/library/io/stream.factor +++ b/library/io/stream.factor @@ -66,13 +66,29 @@ C: wrapper-stream ( stream -- stream ) ! Combine an input and output stream into one, and flush the ! stream more often. -TUPLE: talk-stream in out ; -M: talk-stream stream-flush talk-stream-out stream-flush ; -M: talk-stream stream-auto-flush talk-stream-out stream-flush ; -M: talk-stream stream-readln talk-stream-in stream-readln ; -M: talk-stream stream-read talk-stream-in stream-read ; -M: talk-stream stream-write-attr talk-stream-out stream-write-attr ; -M: talk-stream stream-close talk-stream-out stream-close ; +TUPLE: duplex-stream in out flush? ; + +M: duplex-stream stream-flush + duplex-stream-out stream-flush ; + +M: duplex-stream stream-auto-flush + dup duplex-stream-flush? [ + duplex-stream-out stream-flush + ] [ + drop + ] ifte ; + +M: duplex-stream stream-readln + duplex-stream-in stream-readln ; + +M: duplex-stream stream-read + duplex-stream-in stream-read ; + +M: duplex-stream stream-write-attr + duplex-stream-out stream-write-attr ; + +M: duplex-stream stream-close + duplex-stream-out stream-close ; ! Reading lines and counting line numbers. SYMBOL: line-number diff --git a/library/unix/files.factor b/library/unix/files.factor index 1d753f6000..a679504995 100644 --- a/library/unix/files.factor +++ b/library/unix/files.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: files -USING: alien io-internals kernel math namespaces ; +! We want the system call stat to shadow the word stat we define +USING: alien io-internals kernel math namespaces unix-internals ; : cd ( dir -- ) "void" "libc" "chdir" [ "char*" ] alien-invoke ; : stat ( path -- [ dir? mode size mtime ] ) - tuck sys-stat 0 < [ + tuck stat 0 < [ drop f ] [ [ @@ -19,13 +20,13 @@ USING: alien io-internals kernel math namespaces ; ] ifte ; : (directory) ( path -- list ) - sys-opendir [ + opendir [ [ - [ dirent-name , ] [ dup sys-readdir null>f ] while - ] make-list swap sys-closedir + [ dirent-name , ] [ dup readdir null>f ] while + ] make-list swap closedir ] [ [ ] ] ifte* ; : cwd ( -- str ) - dup 255 sys-getcwd io-error string-box-value ; + dup 255 getcwd io-error string-box-value ; diff --git a/library/unix/io.factor b/library/unix/io.factor index 2a12a46fec..61a17e22e9 100644 --- a/library/unix/io.factor +++ b/library/unix/io.factor @@ -1,8 +1,12 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: io-internals -USING: errors generic hashtables kernel lists math namespaces -sequences stdio streams strings threads vectors ; +USING: errors generic hashtables kernel lists math +sequences stdio streams strings threads unix-internals vectors ; + +! We want this bind to shadow the bind system call from +! unix-internals +USING: namespaces ; ! These let us load the code into a CFactor instance using the ! old C-based I/O. They will be removed soon. @@ -22,7 +26,7 @@ FORGET: wait-to-write : io-error ( n -- ) 0 < [ errno strerror throw ] when ; : init-handle ( fd -- ) - F_SETFL O_NONBLOCK 1 sys-fcntl io-error ; + F_SETFL O_NONBLOCK 1 fcntl io-error ; ! Common delegate of native stream readers and writers TUPLE: port handle buffer error ; @@ -55,14 +59,6 @@ GENERIC: io-task-events ( task -- events ) ! this with the hash-size call. SYMBOL: io-tasks -: init-io ( -- ) - #! Should only be called on startup. Calling this at any - #! other time can have unintended consequences. - global [ - io-tasks set - 0 1 stdio set - ] bind ; - : io-task-fd io-task-port port-handle ; : add-io-task ( callback task -- ) @@ -110,12 +106,12 @@ SYMBOL: io-tasks ] keep ; : io-multiplex ( -- ) - make-pollfds 2dup -1 sys-poll drop do-io-tasks io-multiplex ; + make-pollfds 2dup -1 poll drop do-io-tasks io-multiplex ; ! Readers : open-read ( path -- fd ) - O_RDONLY file-mode sys-open dup io-error ; + O_RDONLY file-mode open dup io-error ; TUPLE: reader line ready? ; @@ -134,7 +130,7 @@ C: reader ( handle -- reader ) "reader not ready" throw ] ifte ; -M: reader stream-close ( stream -- ) port-handle sys-close ; +M: reader stream-close ( stream -- ) port-handle close ; ! Reading lines : read-line-loop ( line buffer -- ? ) @@ -170,7 +166,7 @@ M: reader stream-close ( stream -- ) port-handle sys-close ; : read-step ( port -- ) >port< - tuck dup buffer-end swap buffer-capacity sys-read + tuck dup buffer-end swap buffer-capacity read dup 0 >= [ swap n>buffer ] [ drop postpone-error ] ifte ; : refill ( reader -- ) @@ -229,7 +225,7 @@ C: read-task ( port -- task ) : >read-task< dup read-task-count swap io-task-port ; -M: read-task do-io-task +M: read-task do-io-task ( task -- ? ) >read-task< dup refill dup eof? [ nip reader-eof t ] [ @@ -254,7 +250,7 @@ M: reader stream-read ( count stream -- string ) ! Writers : open-write ( path -- fd ) - O_WRONLY O_CREAT bitor O_TRUNC bitor file-mode sys-open + O_WRONLY O_CREAT bitor O_TRUNC bitor file-mode open dup io-error ; TUPLE: writer ; @@ -263,7 +259,7 @@ C: writer ( fd -- writer ) [ >r buffered-port r> set-delegate ] keep ; : write-step ( fd buffer -- ) - tuck dup buffer@ swap buffer-length sys-write dup 0 >= [ + tuck dup buffer@ swap buffer-length write dup 0 >= [ swap buffer-consume ] [ drop postpone-error @@ -327,7 +323,11 @@ M: writer stream-write-attr ( string style writer -- ) nip >r dup string? [ ch>string ] unless r> blocking-write ; M: writer stream-close ( stream -- ) - dup stream-flush port-handle sys-close ; + dup stream-flush port-handle close ; + +! Make a duplex stream for reading/writing a pair of fds +: ( infd outfd flush? -- ) + >r >r r> r> ; ! Copying from a reader to a writer @@ -348,3 +348,11 @@ M: writer stream-close ( stream -- ) ] [ 2drop f ] ifte ; + +: init-io ( -- ) + #! Should only be called on startup. Calling this at any + #! other time can have unintended consequences. + global [ + io-tasks set + 0 1 t stdio set + ] bind ; diff --git a/library/unix/syscalls.factor b/library/unix/syscalls.factor index 99a5f25ad3..1fb8ec21cd 100644 --- a/library/unix/syscalls.factor +++ b/library/unix/syscalls.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. -IN: io-internals +IN: unix-internals USING: alien errors kernel math namespaces ; ! Alien wrappers for various Unix libc functions. @@ -9,6 +9,7 @@ ALIAS: ulonglong off_t ALIAS: long ssize_t ALIAS: ulong size_t ALIAS: uint socklen_t +ALIAS: uint in_addr_t BEGIN-STRUCT: stat FIELD: uint dev @@ -38,10 +39,10 @@ END-STRUCT : S_IFMT OCT: 0170000 ; inline : S_ISDIR ( m -- ? ) OCT: 0170000 bitand OCT: 0040000 = ; inline -: sys-stat ( path stat -- n ) +: stat ( path stat -- n ) "int" "libc" "stat" [ "char*" "stat*" ] alien-invoke ; -: sys-opendir ( path -- dir* ) +: opendir ( path -- dir* ) "void*" "libc" "opendir" [ "char*" ] alien-invoke ; BEGIN-STRUCT: dirent @@ -52,10 +53,10 @@ BEGIN-STRUCT: dirent FIELD: uchar256 name END-STRUCT -: sys-readdir ( dir* -- dirent* ) +: readdir ( dir* -- dirent* ) "dirent*" "libc" "readdir" [ "void*" ] alien-invoke ; -: sys-closedir ( dir* -- ) +: closedir ( dir* -- ) "void" "libc" "closedir" [ "void*" ] alien-invoke ; BEGIN-STRUCT: string-box @@ -70,7 +71,7 @@ END-STRUCT : strerror ( n -- str ) "char*" "libc" "strerror" [ "int" ] alien-invoke ; -: sys-getcwd ( str len -- n ) +: getcwd ( str len -- n ) "int" "libc" "getcwd" [ "string-box*" "uint" ] alien-invoke ; : O_RDONLY HEX: 0000 ; @@ -79,27 +80,27 @@ END-STRUCT : O_CREAT HEX: 0200 ; : O_TRUNC HEX: 0400 ; -: sys-open ( path flags prot -- fd ) +: open ( path flags prot -- fd ) "int" "libc" "open" [ "char*" "int" "int" ] alien-invoke ; -: sys-close ( fd -- ) +: close ( fd -- ) "void" "libc" "close" [ "int" ] alien-invoke ; : F_SETFL 4 ; ! set file status flags : O_NONBLOCK 4 ; ! no delay -: sys-fcntl ( fd cmd key value -- n ) +: fcntl ( fd cmd key value -- n ) "int" "libc" "fcntl" [ "int" "int" "int" "int" ] alien-invoke ; -: sys-read ( fd buf nbytes -- n ) +: read ( fd buf nbytes -- n ) "ssize_t" "libc" "read" [ "int" "ulong" "size_t" ] alien-invoke ; -: sys-write ( fd buf nbytes -- n ) +: write ( fd buf nbytes -- n ) "ssize_t" "libc" "write" [ "int" "ulong" "size_t" ] alien-invoke ; : MSG_OOB HEX: 1 ; -: sys-recv ( fd buf nbytes flags -- ) +: recv ( fd buf nbytes flags -- ) "ssize_t" "libc" "read" [ "int" "ulong" "size_t" "int" ] alien-invoke ; BEGIN-STRUCT: pollfd @@ -119,25 +120,31 @@ END-STRUCT : read-events POLLIN POLLRDNORM bitor POLLRDBAND bitor ; : write-events POLLOUT POLLWRNORM bitor POLLWRBAND bitor ; -: sys-poll ( pollfds nfds timeout -- n ) +: poll ( pollfds nfds timeout -- n ) "int" "libc" "poll" [ "pollfd*" "uint" "int" ] alien-invoke ; +BEGIN-STRUCT: void** + FIELD: void* s +END-STRUCT + BEGIN-STRUCT: hostent FIELD: char* name - FIELD: void* aliases ( really char**) + FIELD: void** aliases FIELD: int addrtype FIELD: int length - FIELD: void* addr-list ( really char**) + FIELD: void** addr-list END-STRUCT -: sys-gethostbyname ( name -- hostent ) +: hostent-addr hostent-addr-list 0 swap void**-nth void**-s ; + +: gethostbyname ( name -- hostent ) "hostent*" "libc" "gethostbyname" [ "char*" ] alien-invoke ; BEGIN-STRUCT: sockaddr-in - FIELD: uchar len; - FIELD: uchar family; - FIELD: ushort port; -! FIELD: struct in_addr sin_addr; + FIELD: uchar len + FIELD: uchar family + FIELD: ushort port + FIELD: in_addr_t addr ! FIELD: char sin_zero[8]; END-STRUCT @@ -145,29 +152,29 @@ END-STRUCT : PF_INET AF_INET ; : SOCK_STREAM 1 ; -: sys-socket ( domain type protocol -- n ) +: socket ( domain type protocol -- n ) "int" "libc" "socket" [ "int" "int" "int" ] alien-invoke ; : SOL_SOCKET HEX: ffff ; ! options for socket level : SO_REUSEADDR HEX: 4 ; ! allow local address reuse : INADDR_ANY 0 ; -: sys-setsockopt ( s level optname optval optlen -- n ) +: setsockopt ( s level optname optval optlen -- n ) "int" "libc" "setsockopt" [ "int" "int" "int" "void*" "socklen_t" ] alien-invoke ; -: sys-connect ( s name namelen -- n ) +: connect ( s name namelen -- n ) "int" "libc" "connect" [ "int" "sockaddr-in" "socklen_t" ] alien-invoke ; -: sys-bind ( s sockaddr socklen -- n ) +: bind ( s sockaddr socklen -- n ) "int" "libc" "bind" [ "int" "sockaddr-in" "socklen_t" ] alien-invoke ; -: sys-listen ( s backlog -- n ) +: listen ( s backlog -- n ) "int" "libc" "listen" [ "int" "int" ] alien-invoke ; -: sys-accept ( s sockaddr socklen -- n ) +: accept ( s sockaddr socklen -- n ) "int" "libc" "accept" [ "int" "sockaddr-in" "socklen_t" ] alien-invoke ; -: sys-inet-ntoa ( sockaddr -- string ) +: inet-ntoa ( sockaddr -- string ) "char*" "libc" "inet_ntoa" [ "sockaddr-in" ] alien-invoke ; : htonl ( n -- n )