From 63ba6faee2904df1123ba4c4a162272a71998b36 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 16 Feb 2008 15:35:44 -0600 Subject: [PATCH 001/140] Changes to I/O system for encodings --- core/io/encodings/encodings.factor | 105 +++++++++++++++++------- core/io/files/files.factor | 31 ++++--- core/io/streams/c/c.factor | 12 +-- core/io/streams/lines/lines.factor | 52 +----------- core/io/streams/plain/plain.factor | 19 +---- extra/io/nonblocking/nonblocking.factor | 4 +- extra/io/unix/files/files.factor | 6 +- extra/io/windows/windows.factor | 6 +- 8 files changed, 113 insertions(+), 122 deletions(-) diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 2d94e3ea80..cab625ad73 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -1,13 +1,11 @@ ! Copyright (C) 2006, 2007 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: math kernel sequences sbufs vectors io.streams.lines io.streams.plain -namespaces unicode growable strings io classes io.streams.c -continuations ; +USING: math kernel sequences sbufs vectors namespaces +growable strings io classes io.streams.c continuations +io.styles io.streams.nested ; IN: io.encodings -TUPLE: encode-error ; - -: encode-error ( -- * ) \ encode-error construct-empty throw ; +! Decoding TUPLE: decode-error ; @@ -19,7 +17,8 @@ SYMBOL: begin over push 0 begin ; : push-replacement ( buf -- buf ch state ) - CHAR: replacement-character decoded ; + ! This is the replacement character + HEX: fffd decoded ; : finish-decoding ( buf ch state -- str ) begin eq? [ decode-error ] unless drop "" like ; @@ -53,43 +52,89 @@ GENERIC: decode-step ( buf byte ch state encoding -- buf ch state ) >r swap start-decoding r> decode-read-loop ; -: ( stream decoding-class -- decoded-stream ) - construct-delegate ; +TUPLE: decoded code cr ; +: ( stream decoding-class -- decoded-stream ) + construct-empty { set-delegate set-decoded-code } decoded construct ; -: ( stream encoding-class -- encoded-stream ) - construct-delegate ; +: cr+ t swap set-line-reader-cr ; inline -GENERIC: encode-string ( string encoding -- byte-array ) -M: tuple-class encode-string construct-empty encode-string ; +: cr- f swap set-line-reader-cr ; inline -MIXIN: encoding-stream +: line-ends/eof ( stream str -- str ) f like swap cr- ; inline -M: encoding-stream stream-read1 1 swap stream-read ; +: line-ends\r ( stream str -- str ) swap cr+ ; inline -M: encoding-stream stream-read - [ delegate ] keep decode-read ; +: line-ends\n ( stream str -- str ) + over line-reader-cr over empty? and + [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline -M: encoding-stream stream-read-partial stream-read ; +: handle-readln ( stream str ch -- str ) + { + { f [ line-ends/eof ] } + { CHAR: \r [ line-ends\r ] } + { CHAR: \n [ line-ends\n ] } + } case ; -M: encoding-stream stream-read-until +: fix-read ( stream string -- string ) + over line-reader-cr [ + over cr- + "\n" ?head [ + swap stream-read1 [ add ] when* + ] [ nip ] if + ] [ nip ] if ; + +M: decoded stream-read + tuck { delegate decoded-code } get-slots decode-read fix-read ; + +M: decoded stream-read-partial tuck stream-read fix-read ; + +M: decoded stream-read-until ! Copied from { c-reader stream-read-until }!!! [ swap read-until-loop ] "" make swap over empty? over not and [ 2drop f f ] when ; -M: encoding-stream stream-write1 +: fix-read1 ( stream char -- char ) + over line-reader-cr [ + over cr- + dup CHAR: \n = [ + drop stream-read1 + ] [ nip ] if + ] [ nip ] if ; + +M: decoded stream-read1 1 over stream-read ; + +M: line-reader stream-readln ( stream -- str ) + "\r\n" over stream-read-until handle-readln ; + +! Encoding + +TUPLE: encode-error ; + +: encode-error ( -- * ) \ encode-error construct-empty throw ; + +TUPLE: encoded code ; +: ( stream encoding-class -- encoded-stream ) + construct-empty { set-delegate set-encoded-code } encoded construct ; + +GENERIC: encode-string ( string encoding -- byte-array ) +M: tuple-class encode-string construct-empty encode-string ; + +M: encoded stream-write1 >r 1string r> stream-write ; -M: encoding-stream stream-write - [ encode-string ] keep delegate stream-write ; +M: encoded stream-write + [ encoding-code encode-string ] keep delegate stream-write ; -M: encoding-stream dispose delegate dispose ; +M: encoded dispose delegate dispose ; -GENERIC: underlying-stream ( encoded-stream -- delegate ) -M: encoding-stream underlying-stream delegate ; +M: encoded stream-nl + CHAR: \n swap stream-write1 ; -GENERIC: set-underlying-stream ( new-underlying stream -- ) -M: encoding-stream set-underlying-stream set-delegate ; +M: encoded stream-format + nip stream-write ; -: set-encoding ( encoding stream -- ) ! This doesn't work now - [ underlying-stream swap construct-delegate ] keep - set-underlying-stream ; +M: encoded make-span-stream + ; + +M: encoded make-block-stream + nip ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 4b19dd6943..5a9411aadb 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -3,17 +3,17 @@ IN: io.files USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions -system combinators splitting sbufs continuations ; +system combinators splitting sbufs continuations io.encodings ; HOOK: cd io-backend ( path -- ) HOOK: cwd io-backend ( -- path ) -HOOK: io-backend ( path -- stream ) +HOOK: file-reader* io-backend ( path -- stream ) -HOOK: io-backend ( path -- stream ) +HOOK: file-writer* io-backend ( path -- stream ) -HOOK: io-backend ( path -- stream ) +HOOK: file-appender* io-backend ( path -- stream ) HOOK: delete-file io-backend ( path -- ) @@ -140,16 +140,25 @@ C: pathname M: pathname <=> [ pathname-string ] compare ; -: file-lines ( path -- seq ) lines ; +: ( path encoding -- stream ) + swap file-reader* swap ; -: file-contents ( path -- str ) - dup swap file-length [ stream-copy ] keep >string ; +: ( path encoding -- stream ) + swap file-writer* swap ; -: with-file-writer ( path quot -- ) - >r r> with-stream ; inline +: ( path encoding -- stream ) + swap file-appender* swap ; -: with-file-reader ( path quot -- ) +: file-lines ( path encoding -- seq ) lines ; + +: file-contents ( path encoding -- str ) + dupd swap file-length [ stream-copy ] keep >string ; + +: with-file-writer ( path encoding quot -- ) >r r> with-stream ; inline -: with-file-appender ( path quot -- ) +: with-file-reader ( path encoding quot -- ) + >r r> with-stream ; inline + +: with-file-appender ( path encoding quot -- ) >r r> with-stream ; inline diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 288ab212d1..9c1a099318 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -66,14 +66,14 @@ M: object init-stdio M: object io-multiplex (sleep) ; -M: object - "rb" fopen ; +M: object file-reader* + "rb" fopen ; -M: object - "wb" fopen ; +M: object file-writer* + "wb" fopen ; -M: object - "ab" fopen ; +M: object file-appender* + "ab" fopen ; : show ( msg -- ) #! A word which directly calls primitives. It is used to diff --git a/core/io/streams/lines/lines.factor b/core/io/streams/lines/lines.factor index 391c602cc3..a6a5721ad8 100755 --- a/core/io/streams/lines/lines.factor +++ b/core/io/streams/lines/lines.factor @@ -1,57 +1,9 @@ ! Copyright (C) 2004, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.lines -USING: arrays generic io kernel math namespaces sequences -vectors combinators splitting ; +USING: io.encodings.latin1 io.encodings ; TUPLE: line-reader cr ; : ( stream -- new-stream ) - line-reader construct-delegate ; - -: cr+ t swap set-line-reader-cr ; inline - -: cr- f swap set-line-reader-cr ; inline - -: line-ends/eof ( stream str -- str ) f like swap cr- ; inline - -: line-ends\r ( stream str -- str ) swap cr+ ; inline - -: line-ends\n ( stream str -- str ) - over line-reader-cr over empty? and - [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline - -: handle-readln ( stream str ch -- str ) - { - { f [ line-ends/eof ] } - { CHAR: \r [ line-ends\r ] } - { CHAR: \n [ line-ends\n ] } - } case ; - -M: line-reader stream-readln ( stream -- str ) - "\r\n" over delegate stream-read-until handle-readln ; - -: fix-read ( stream string -- string ) - over line-reader-cr [ - over cr- - "\n" ?head [ - swap stream-read1 [ add ] when* - ] [ nip ] if - ] [ nip ] if ; - -M: line-reader stream-read - tuck delegate stream-read fix-read ; - -M: line-reader stream-read-partial - tuck delegate stream-read-partial fix-read ; - -: fix-read1 ( stream char -- char ) - over line-reader-cr [ - over cr- - dup CHAR: \n = [ - drop stream-read1 - ] [ nip ] if - ] [ nip ] if ; - -M: line-reader stream-read1 ( stream -- char ) - dup delegate stream-read1 fix-read1 ; + latin1 ; diff --git a/core/io/streams/plain/plain.factor b/core/io/streams/plain/plain.factor index 70421eb1c2..e6cf9c8afa 100644 --- a/core/io/streams/plain/plain.factor +++ b/core/io/streams/plain/plain.factor @@ -1,22 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.plain -USING: generic assocs kernel math namespaces sequences -io.styles io io.streams.nested ; - -TUPLE: plain-writer ; +USING: io.encodings.latin1 io.encodings ; : ( stream -- new-stream ) - plain-writer construct-delegate ; - -M: plain-writer stream-nl - CHAR: \n swap stream-write1 ; - -M: plain-writer stream-format - nip stream-write ; - -M: plain-writer make-span-stream - ; - -M: plain-writer make-block-stream - nip ; + latin1 ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 72507f26b6..dfdd05af53 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -40,10 +40,10 @@ GENERIC: close-handle ( handle -- ) default-buffer-size get swap ; : ( handle -- stream ) - input-port ; + input-port ; : ( handle -- stream ) - output-port ; + output-port ; : handle>duplex-stream ( in-handle out-handle -- stream ) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 3bf0e3f897..7a7128d5b6 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -17,7 +17,7 @@ M: unix-io cd : open-read ( path -- fd ) O_RDONLY file-mode open dup io-error ; -M: unix-io ( path -- stream ) +M: unix-io file-reader* ( path -- stream ) open-read ; : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline @@ -25,7 +25,7 @@ M: unix-io ( path -- stream ) : open-write ( path -- fd ) write-flags file-mode open dup io-error ; -M: unix-io ( path -- stream ) +M: unix-io file-writer* ( path -- stream ) open-write ; : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline @@ -34,7 +34,7 @@ M: unix-io ( path -- stream ) append-flags file-mode open dup io-error [ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ; -M: unix-io ( path -- stream ) +M: unix-io file-appender* ( path -- stream ) open-append ; M: unix-io rename-file ( from to -- ) diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index ee3f744bb0..dc0b14f627 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -112,13 +112,13 @@ C: FileArgs [ FileArgs-lpNumberOfBytesRet ] keep FileArgs-lpOverlapped ; -M: windows-io ( path -- stream ) +M: windows-io file-reader* ( path -- stream ) open-read ; -M: windows-io ( path -- stream ) +M: windows-io file-writer* ( path -- stream ) open-write ; -M: windows-io ( path -- stream ) +M: windows-io file-appender* ( path -- stream ) open-append ; M: windows-io rename-file ( from to -- ) From 8d5f4714fad2086f5a1e3e8089a560e824c34713 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 16 Feb 2008 16:25:45 -0600 Subject: [PATCH 002/140] Core I/O changes for encodings --- core/io/encodings/ascii/ascii.factor | 13 ++++++++ core/io/encodings/binary/binary.factor | 5 ++-- core/io/encodings/encodings.factor | 7 +++-- core/io/encodings/latin1/latin1.factor | 10 +++---- core/io/files/files-docs.factor | 38 +++++++++++++++++------- core/io/files/files.factor | 22 +++++++------- core/io/io-tests.factor | 4 +-- core/io/streams/lines/lines-tests.factor | 4 +-- 8 files changed, 67 insertions(+), 36 deletions(-) create mode 100644 core/io/encodings/ascii/ascii.factor diff --git a/core/io/encodings/ascii/ascii.factor b/core/io/encodings/ascii/ascii.factor new file mode 100644 index 0000000000..d767f26cdd --- /dev/null +++ b/core/io/encodings/ascii/ascii.factor @@ -0,0 +1,13 @@ +USING: io io.encodings strings kernel ; +IN: io.encodings.ascii + +: encode-check>= ( string max -- byte-array ) + dupd [ >= ] curry all? [ >byte-array ] [ encoding-error ] if ; + +TUPLE: ascii ; + +M: ascii encode-string + drop 127 encode-check>= ; + +M: ascii decode-step + 3drop over push f f ; diff --git a/core/io/encodings/binary/binary.factor b/core/io/encodings/binary/binary.factor index c4c6237715..17c734b9c8 100644 --- a/core/io/encodings/binary/binary.factor +++ b/core/io/encodings/binary/binary.factor @@ -1,3 +1,2 @@ -USING: kernel io.encodings ; - -TUPLE: binary ; +IN: io.encodings.binary +SYMBOL: binary diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index cab625ad73..4ceae70fae 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces growable strings io classes io.streams.c continuations -io.styles io.streams.nested ; +io.styles io.streams.nested io.encodings.binary ; IN: io.encodings ! Decoding @@ -54,7 +54,10 @@ GENERIC: decode-step ( buf byte ch state encoding -- buf ch state ) TUPLE: decoded code cr ; : ( stream decoding-class -- decoded-stream ) - construct-empty { set-delegate set-decoded-code } decoded construct ; + dup binary eq? [ drop ] [ + construct-empty { set-delegate set-decoded-code } + decoded construct + ] if ; : cr+ t swap set-line-reader-cr ; inline diff --git a/core/io/encodings/latin1/latin1.factor b/core/io/encodings/latin1/latin1.factor index e6d6281eb6..d6e643fd96 100755 --- a/core/io/encodings/latin1/latin1.factor +++ b/core/io/encodings/latin1/latin1.factor @@ -1,10 +1,10 @@ -USING: io io.encodings strings kernel ; +USING: io io.encodings strings kernel io.encodings.ascii ; IN: io.encodings.latin1 TUPLE: latin1 ; -M: latin1 stream-read delegate stream-read >string ; +M: latin1 encode-string + drop 255 encode-check>= ; -M: latin1 stream-read-until delegate stream-read-until >string ; - -M: latin1 stream-read-partial delegate stream-read-partial >string ; +M: latin1 decode-step + 3drop over push f f ; diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 185fa1436b..839cd2fae0 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -6,6 +6,11 @@ ARTICLE: "file-streams" "Reading and writing files" { $subsection } { $subsection } { $subsection } +{ $subsection with-file-reader } +{ $subsection with-file-writer } +{ $subsection with-file-appender } +{ $subsection file-contents } +{ $subsection file-lines } "Pathname manipulation:" { $subsection parent-directory } { $subsection file-name } @@ -38,33 +43,44 @@ ARTICLE: "file-streams" "Reading and writing files" ABOUT: "file-streams" HELP: -{ $values { "path" "a pathname string" } { "stream" "an input stream" } } -{ $description "Outputs an input stream for reading from the specified pathname." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptors" } + { "stream" "an input stream" } } +{ $description "Outputs an input stream for reading from the specified pathname using the given encoding." } { $errors "Throws an error if the file is unreadable." } ; HELP: -{ $values { "path" "a pathname string" } { "stream" "an output stream" } } -{ $description "Outputs an output stream for writing to the specified pathname. The file's length is truncated to zero." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } } +{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The file's length is truncated to zero." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: -{ $values { "path" "a pathname string" } { "stream" "an output stream" } } -{ $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } } +{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The stream begins writing at the end of the file." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: with-file-reader -{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } } { $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." } { $errors "Throws an error if the file is unreadable." } ; HELP: with-file-writer -{ $values { "path" "a pathname string" } { "quot" "a quotation" } } -{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } } +{ $description "Opens a file for writing using the given encoding and calls the quotation using " { $link with-stream } "." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: with-file-appender -{ $values { "path" "a pathname string" } { "quot" "a quotation" } } -{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } } +{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + +HELP: file-lines +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" "an array of strings" } } +{ $description "Opens the file at the given path using the given encoding, and returns a list of the lines in that file." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + +HELP: file-contents +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } } +{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: cwd diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 5a9411aadb..daa5d6df7e 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -15,6 +15,15 @@ HOOK: file-writer* io-backend ( path -- stream ) HOOK: file-appender* io-backend ( path -- stream ) +: ( path encoding -- stream ) + swap file-reader* swap ; + +: ( path encoding -- stream ) + swap file-writer* swap ; + +: ( path encoding -- stream ) + swap file-appender* swap ; + HOOK: delete-file io-backend ( path -- ) HOOK: rename-file io-backend ( from to -- ) @@ -115,8 +124,8 @@ HOOK: copy-file io-backend ( from to -- ) M: object copy-file dup parent-directory make-directories - [ - swap [ + binary [ + swap binary [ swap stream-copy ] with-disposal ] with-disposal ; @@ -140,15 +149,6 @@ C: pathname M: pathname <=> [ pathname-string ] compare ; -: ( path encoding -- stream ) - swap file-reader* swap ; - -: ( path encoding -- stream ) - swap file-writer* swap ; - -: ( path encoding -- stream ) - swap file-appender* swap ; - : file-lines ( path encoding -- seq ) lines ; : file-contents ( path encoding -- str ) diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 23686abab5..00a8078da8 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,5 +1,5 @@ USING: arrays io io.files kernel math parser strings system -tools.test words namespaces ; +tools.test words namespaces io.encodings.ascii ; IN: temporary [ f ] [ @@ -8,7 +8,7 @@ IN: temporary ] unit-test : ( resource -- stream ) - resource-path ; + resource-path binary ascii ; [ "This is a line.\rThis is another line.\r" diff --git a/core/io/streams/lines/lines-tests.factor b/core/io/streams/lines/lines-tests.factor index 64dc7bff3b..e3a4fe886a 100755 --- a/core/io/streams/lines/lines-tests.factor +++ b/core/io/streams/lines/lines-tests.factor @@ -1,9 +1,9 @@ USING: io.streams.lines io.files io.streams.string io -tools.test kernel ; +tools.test kernel io.encodings.ascii ; IN: temporary : ( resource -- stream ) - resource-path ; + resource-path ascii ; [ { } ] [ "/core/io/test/empty-file.txt" lines ] From 62f9ed5dbd213b731263a9652389e8309e580eb9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 16 Feb 2008 22:17:41 -0600 Subject: [PATCH 003/140] putting encodings on all file readers/writers --- core/alien/c-types/c-types.factor | 5 +++- core/bootstrap/image/image.factor | 4 +-- core/io/encodings/binary/binary.factor | 3 +-- core/io/encodings/encodings.factor | 26 ++++++++++++------- core/io/encodings/utf16/utf16.factor | 6 ++--- core/io/encodings/utf8/utf8.factor | 4 +-- core/io/files/files-tests.factor | 22 ++++++++-------- core/io/io-tests.factor | 6 ++--- core/io/streams/c/c-tests.factor | 2 +- core/io/streams/c/c.factor | 3 +-- core/io/streams/lines/lines.factor | 8 +++--- core/parser/parser.factor | 4 +-- core/source-files/source-files.factor | 6 ++--- extra/benchmark/fasta/fasta.factor | 4 +-- .../benchmark/knucleotide/knucleotide.factor | 4 +-- extra/benchmark/mandel/mandel.factor | 4 +-- extra/benchmark/raytracer/raytracer.factor | 4 +-- .../reverse-complement.factor | 4 +-- extra/benchmark/sum-file/sum-file.factor | 4 +-- extra/bootstrap/image/upload/upload.factor | 4 +-- extra/bunny/model/model.factor | 4 +-- extra/cpu/8080/emulator/emulator.factor | 6 ++--- extra/cryptlib/cryptlib-tests.factor | 7 ++--- extra/crypto/hmac/hmac.factor | 6 ++--- extra/crypto/md5/md5.factor | 5 ++-- extra/crypto/sha1/sha1.factor | 4 +-- extra/editors/jedit/jedit.factor | 4 +-- extra/furnace/furnace.factor | 4 +-- extra/graphics/bitmap/bitmap.factor | 6 ++--- extra/help/cookbook/cookbook.factor | 4 +-- extra/http/client/client.factor | 4 +-- .../server/templating/templating-tests.factor | 4 +-- .../http/server/templating/templating.factor | 6 ++--- extra/icfp/2006/2006.factor | 4 +-- extra/id3/id3.factor | 10 +++---- extra/io/mmap/mmap-tests.factor | 7 ++--- extra/io/unix/unix-tests.factor | 8 +++--- extra/log-viewer/log-viewer.factor | 4 +-- extra/logging/insomniac/insomniac.factor | 5 ++-- extra/logging/server/server.factor | 4 +-- extra/mad/api/api.factor | 6 ++--- extra/msxml-to-csv/msxml-to-csv.factor | 4 +-- extra/ogg/player/player.factor | 7 ++--- .../porter-stemmer-tests.factor | 4 +-- extra/project-euler/042/042.factor | 4 +-- extra/project-euler/067/067.factor | 5 ++-- extra/project-euler/079/079.factor | 5 ++-- extra/raptor/raptor.factor | 4 +-- extra/rss/rss-tests.factor | 4 +-- extra/tar/tar.factor | 6 ++--- extra/tools/browser/browser.factor | 6 ++--- extra/tools/deploy/macosx/macosx.factor | 4 +-- extra/tools/disassembler/disassembler.factor | 6 ++--- extra/ui/freetype/freetype.factor | 2 +- extra/unicode/breaks/breaks.factor | 4 +-- extra/unicode/data/data.factor | 4 +-- extra/webapps/file/file.factor | 4 +-- extra/webapps/source/source.factor | 4 +-- extra/xml/xml.factor | 5 ++-- extra/xmode/catalog/catalog.factor | 6 ++--- extra/xmode/code2html/code2html.factor | 6 ++--- extra/yahoo/yahoo-tests.factor | 2 +- 62 files changed, 174 insertions(+), 161 deletions(-) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 7d01fb2b00..983fea0159 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: bit-arrays byte-arrays float-arrays arrays generator.registers assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations -system compiler.units ; +system compiler.units io.encodings.binary ; IN: alien.c-types DEFER: @@ -273,6 +273,9 @@ M: long-long-type box-return ( type -- ) r> add* ] when ; +: malloc-file-contents ( path -- alien ) + binary file-contents >byte-array malloc-byte-array ; + [ [ alien-cell ] [ set-alien-cell ] diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 17b56458ce..73085450a8 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -7,7 +7,7 @@ strings sbufs vectors words quotations assocs system layouts splitting growable classes tuples words.private io.binary io.files vocabs vocabs.loader source-files definitions debugger float-arrays quotations.private -sequences.private combinators ; +sequences.private combinators io.encodings.binary ; IN: bootstrap.image : my-arch ( -- arch ) @@ -416,7 +416,7 @@ M: curry ' "Writing image to " write architecture get boot-image-name resource-path dup write "..." print flush - [ (write-image) ] with-file-writer ; + binary [ (write-image) ] with-file-writer ; PRIVATE> diff --git a/core/io/encodings/binary/binary.factor b/core/io/encodings/binary/binary.factor index 17c734b9c8..8a8d09464b 100644 --- a/core/io/encodings/binary/binary.factor +++ b/core/io/encodings/binary/binary.factor @@ -1,2 +1 @@ -IN: io.encodings.binary -SYMBOL: binary +IN: io.encodings.binary SYMBOL: binary diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 4ceae70fae..cd9d4b585b 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces -growable strings io classes io.streams.c continuations +growable strings io classes continuations io.styles io.streams.nested io.encodings.binary ; IN: io.encodings @@ -13,12 +13,12 @@ TUPLE: decode-error ; SYMBOL: begin -: decoded ( buf ch -- buf ch state ) +: push-decoded ( buf ch -- buf ch state ) over push 0 begin ; : push-replacement ( buf -- buf ch state ) ! This is the replacement character - HEX: fffd decoded ; + HEX: fffd push-decoded ; : finish-decoding ( buf ch state -- str ) begin eq? [ decode-error ] unless drop "" like ; @@ -59,16 +59,16 @@ TUPLE: decoded code cr ; decoded construct ] if ; -: cr+ t swap set-line-reader-cr ; inline +: cr+ t swap set-decoded-cr ; inline -: cr- f swap set-line-reader-cr ; inline +: cr- f swap set-decoded-cr ; inline : line-ends/eof ( stream str -- str ) f like swap cr- ; inline : line-ends\r ( stream str -- str ) swap cr+ ; inline : line-ends\n ( stream str -- str ) - over line-reader-cr over empty? and + over decoded-cr over empty? and [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline : handle-readln ( stream str ch -- str ) @@ -79,7 +79,7 @@ TUPLE: decoded code cr ; } case ; : fix-read ( stream string -- string ) - over line-reader-cr [ + over decoded-cr [ over cr- "\n" ?head [ swap stream-read1 [ add ] when* @@ -91,13 +91,21 @@ M: decoded stream-read M: decoded stream-read-partial tuck stream-read fix-read ; +: read-until-loop ( stream delim -- ch ) + ! Copied from { c-reader stream-read-until }!!! + over stream-read1 dup [ + dup pick memq? [ 2nip ] [ , read-until-loop ] if + ] [ + 2nip + ] if ; + M: decoded stream-read-until ! Copied from { c-reader stream-read-until }!!! [ swap read-until-loop ] "" make swap over empty? over not and [ 2drop f f ] when ; : fix-read1 ( stream char -- char ) - over line-reader-cr [ + over decoded-cr [ over cr- dup CHAR: \n = [ drop stream-read1 @@ -106,7 +114,7 @@ M: decoded stream-read-until M: decoded stream-read1 1 over stream-read ; -M: line-reader stream-readln ( stream -- str ) +M: decoded stream-readln ( stream -- str ) "\r\n" over stream-read-until handle-readln ; ! Encoding diff --git a/core/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor index 35b6282e21..1dd317d3c0 100755 --- a/core/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -16,7 +16,7 @@ SYMBOL: ignore 8 shift bitor ; : end-multibyte ( buf byte ch -- buf ch state ) - append-nums decoded ; + append-nums push-decoded ; : begin-utf16be ( buf byte -- buf ch state ) dup -3 shift BIN: 11011 number= [ @@ -36,7 +36,7 @@ SYMBOL: ignore { double [ end-multibyte ] } { quad1 [ append-nums quad2 ] } { quad2 [ handle-quad2be ] } - { quad3 [ append-nums HEX: 10000 + decoded ] } + { quad3 [ append-nums HEX: 10000 + push-decoded ] } { ignore [ 2drop push-replacement ] } } case ; @@ -52,7 +52,7 @@ SYMBOL: ignore : handle-quad3le ( buf byte ch -- buf ch state ) swap dup -2 shift BIN: 110111 = [ - BIN: 11 bitand append-nums HEX: 10000 + decoded + BIN: 11 bitand append-nums HEX: 10000 + push-decoded ] [ 2drop push-replacement ] if ; : decode-utf16le-step ( buf byte ch state -- buf ch state ) diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 6a3a8b8ec7..7f211f92de 100644 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -23,7 +23,7 @@ SYMBOL: quad3 : begin-utf8 ( buf byte -- buf ch state ) { - { [ dup -7 shift zero? ] [ decoded ] } + { [ dup -7 shift zero? ] [ push-decoded ] } { [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] } { [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] } { [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] } @@ -31,7 +31,7 @@ SYMBOL: quad3 } cond ; : end-multibyte ( buf byte ch -- buf ch state ) - f append-nums [ decoded ] unless* ; + f append-nums [ push-decoded ] unless* ; : decode-utf8-step ( buf byte ch state -- buf ch state ) { diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index d0f9737f19..a92a52a024 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,34 +1,34 @@ IN: temporary -USING: tools.test io.files io threads kernel continuations ; +USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; [ "passwd" ] [ "/etc/passwd" file-name ] unit-test [ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test [ ] [ - "test-foo.txt" resource-path [ + "test-foo.txt" resource-path ascii [ "Hello world." print ] with-file-writer ] unit-test [ ] [ - "test-foo.txt" resource-path [ + "test-foo.txt" resource-path ascii [ "Hello appender." print - ] with-stream + ] with-file-appender ] unit-test [ ] [ - "test-bar.txt" resource-path [ + "test-bar.txt" resource-path ascii [ "Hello appender." print - ] with-stream + ] with-file-appender ] unit-test [ "Hello world.\nHello appender.\n" ] [ - "test-foo.txt" resource-path file-contents + "test-foo.txt" resource-path ascii file-contents ] unit-test [ "Hello appender.\n" ] [ - "test-bar.txt" resource-path file-contents + "test-bar.txt" resource-path ascii file-contents ] unit-test [ ] [ "test-foo.txt" resource-path delete-file ] unit-test @@ -42,7 +42,7 @@ USING: tools.test io.files io threads kernel continuations ; [ ] [ "test-blah" resource-path make-directory ] unit-test [ ] [ - "test-blah/fooz" resource-path dispose + "test-blah/fooz" resource-path ascii dispose ] unit-test [ t ] [ @@ -55,11 +55,11 @@ USING: tools.test io.files io threads kernel continuations ; [ f ] [ "test-blah" resource-path exists? ] unit-test -[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test +[ ] [ "test-quux.txt" resource-path ascii [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test [ ] [ "test-quux.txt" resource-path delete-file ] unit-test -[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test +[ ] [ "test-quux.txt" resource-path ascii [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test [ ] [ "test-quux.txt" "quux-test.txt" [ resource-path ] 2apply rename-file ] unit-test [ t ] [ "quux-test.txt" resource-path exists? ] unit-test diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 00a8078da8..74b6b5034f 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,5 +1,5 @@ USING: arrays io io.files kernel math parser strings system -tools.test words namespaces io.encodings.ascii ; +tools.test words namespaces io.encodings.ascii io.encodings.binary ; IN: temporary [ f ] [ @@ -8,7 +8,7 @@ IN: temporary ] unit-test : ( resource -- stream ) - resource-path binary ascii ; + resource-path ascii ; [ "This is a line.\rThis is another line.\r" @@ -53,7 +53,7 @@ IN: temporary ] unit-test [ ] [ - image [ + image binary [ 10 [ 65536 read drop ] times ] with-file-reader ] unit-test diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 5ace929ceb..66ea460126 100755 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -2,7 +2,7 @@ USING: tools.test io.files io io.streams.c ; IN: temporary [ "hello world" ] [ - "test.txt" resource-path [ + "test.txt" resource-path ascii [ "hello world" write ] with-file-writer diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 9c1a099318..73b8bb32b9 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private namespaces io strings sequences math generic threads.private classes -io.backend io.streams.lines io.streams.plain io.streams.duplex -io.files continuations ; +io.backend io.streams.duplex io.files continuations ; IN: io.streams.c TUPLE: c-writer handle ; diff --git a/core/io/streams/lines/lines.factor b/core/io/streams/lines/lines.factor index a6a5721ad8..84ff272d69 100755 --- a/core/io/streams/lines/lines.factor +++ b/core/io/streams/lines/lines.factor @@ -1,9 +1,7 @@ ! Copyright (C) 2004, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.lines -USING: io.encodings.latin1 io.encodings ; +! USING: io.encodings.latin1 io.encodings ; -TUPLE: line-reader cr ; - -: ( stream -- new-stream ) - latin1 ; +! : ( stream -- new-stream ) +! latin1 ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index fc29445f88..2f7beb56d7 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger -io.files io.streams.string io.streams.lines vocabs +io.files io.streams.string io.streams.lines vocabs io.encodings.utf8 source-files classes hashtables compiler.errors compiler.units ; IN: parser @@ -489,7 +489,7 @@ SYMBOL: interactive-vocabs [ [ [ parsing-file ] keep - [ ?resource-path ] keep + [ ?resource-path utf8 ] keep parse-stream ] with-compiler-errors ] [ diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index c7539ad3eb..d2566982f8 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -5,7 +5,7 @@ namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger io.files io.crc32 io.streams.string io.streams.lines vocabs -hashtables graphs compiler.units ; +hashtables graphs compiler.units io.encodings.utf8 ; IN: source-files SYMBOL: source-files @@ -17,7 +17,7 @@ uses definitions ; : (source-modified?) ( path modified checksum -- ? ) pick file-modified rot [ 0 or ] 2apply > - [ swap file-lines lines-crc32 = not ] [ 2drop f ] if ; + [ swap utf8 file-lines lines-crc32 = not ] [ 2drop f ] if ; : source-modified? ( path -- ? ) dup source-files get at [ @@ -68,7 +68,7 @@ uses definitions ; : reset-checksums ( -- ) source-files get [ swap ?resource-path dup exists? - [ file-lines swap record-checksum ] [ 2drop ] if + [ utf8 file-lines swap record-checksum ] [ 2drop ] if ] assoc-each ; M: pathname where pathname-string 1 2array ; diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 75321def2d..a68a84fc59 100644 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -1,6 +1,6 @@ ! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2 USING: math kernel io io.files locals multiline assocs sequences -sequences.private benchmark.reverse-complement hints +sequences.private benchmark.reverse-complement hints io.encodings.ascii byte-arrays float-arrays ; IN: benchmark.fasta @@ -94,7 +94,7 @@ HINTS: random fixnum ; n [ ] seed [ initial-seed ] | - out [ + out ascii [ n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta initial-seed diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index b95e182bd1..e06b81f6de 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -1,4 +1,4 @@ -USING: kernel io io.files splitting strings +USING: kernel io io.files splitting strings io.encodings.ascii hashtables sequences assocs math namespaces prettyprint math.parser combinators arrays sorting unicode.case ; @@ -57,7 +57,7 @@ IN: benchmark.knucleotide : knucleotide ( -- ) "extra/benchmark/knucleotide/knucleotide-input.txt" resource-path - [ read-input ] with-file-reader + ascii [ read-input ] with-file-reader process-input ; MAIN: knucleotide diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 230fb2f889..a60fdbf6c7 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -1,6 +1,6 @@ IN: benchmark.mandel USING: arrays io kernel math namespaces sequences strings sbufs -math.functions math.parser io.files colors.hsv ; +math.functions math.parser io.files colors.hsv io.encodings.binary ; : max-color 360 ; inline : zoom-fact 0.8 ; inline @@ -66,6 +66,6 @@ SYMBOL: cols : mandel-main ( -- ) "mandel.ppm" resource-path - [ mandel write ] with-file-writer ; + binary [ mandel write ] with-file-writer ; MAIN: mandel-main diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 8f2badc95f..9783389e80 100644 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -3,7 +3,7 @@ USING: float-arrays compiler generic io io.files kernel math math.functions math.vectors math.parser namespaces sequences -sequences.private words ; +sequences.private words io.encodings.binary ; IN: benchmark.raytracer ! parameters @@ -171,6 +171,6 @@ DEFER: create ( level c r -- scene ) : raytracer-main "raytracer.pnm" resource-path - [ run write ] with-file-writer ; + binary [ run write ] with-file-writer ; MAIN: raytracer-main diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index cc20b4b349..2ae92223d1 100644 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -1,6 +1,6 @@ USING: io io.files io.streams.duplex kernel sequences sequences.private strings vectors words memoize splitting -hints unicode.case ; +hints unicode.case io.encodings.latin1 ; IN: benchmark.reverse-complement MEMO: trans-map ( -- str ) @@ -32,7 +32,7 @@ HINTS: do-line vector string ; readln [ do-line (reverse-complement) ] [ show-seq ] if* ; : reverse-complement ( infile outfile -- ) - >r r> [ + latin1 >r latin1 r> [ 500000 (reverse-complement) ] with-stream ; diff --git a/extra/benchmark/sum-file/sum-file.factor b/extra/benchmark/sum-file/sum-file.factor index e17765d542..3db31f8887 100644 --- a/extra/benchmark/sum-file/sum-file.factor +++ b/extra/benchmark/sum-file/sum-file.factor @@ -1,11 +1,11 @@ -USING: io io.files math math.parser kernel prettyprint ; +USING: io io.files math math.parser kernel prettyprint io.encodings.ascii ; IN: benchmark.sum-file : sum-file-loop ( n -- n' ) readln [ string>number + sum-file-loop ] when* ; : sum-file ( file -- ) - [ 0 sum-file-loop ] with-file-reader . ; + ascii [ 0 sum-file-loop ] with-file-reader . ; : sum-file-main ( -- ) home "sum-file-in.txt" path+ sum-file ; diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 552e26ebf5..4b8ddb0c4b 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -2,14 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. IN: bootstrap.image.upload USING: http.client crypto.md5 splitting assocs kernel io.files -bootstrap.image sequences io namespaces io.launcher math ; +bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ; : destination "slava@factorcode.org:www/images/latest/" ; : boot-image-names images [ boot-image-name ] map ; : compute-checksums ( -- ) - "checksums.txt" [ + "checksums.txt" ascii [ boot-image-names [ dup write bl file>md5str print ] each ] with-file-writer ; diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 7c77ed98af..8d2175846c 100644 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices - math.parser io io.files kernel opengl opengl.gl opengl.glu + math.parser io io.files kernel opengl opengl.gl opengl.glu io.encodings.ascii opengl.capabilities shuffle http.client vectors splitting tools.time system combinators combinators.cleave float-arrays continuations namespaces sequences.lib ; @@ -35,7 +35,7 @@ IN: bunny.model : read-model ( stream -- model ) "Reading model" print flush [ - [ parse-model ] with-file-reader + ascii [ parse-model ] with-file-reader [ normals ] 2keep 3array ] time ; diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index 9499ff8dff..9189a41411 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -4,7 +4,7 @@ USING: kernel math sequences words arrays io io.files namespaces math.parser kernel.private assocs quotations parser parser-combinators tools.time - sequences.private compiler.units ; + sequences.private compiler.units io.encodings.binary ; IN: cpu.8080.emulator TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ; @@ -461,7 +461,7 @@ M: cpu reset ( cpu -- ) : load-rom ( filename cpu -- ) #! Load the contents of the file into ROM. #! (address 0x0000-0x1FFF). - cpu-ram swap [ + cpu-ram swap binary [ 0 swap (load-rom) ] with-file-reader ; @@ -477,7 +477,7 @@ SYMBOL: rom-root #! file path shoul dbe relative to the '/roms' resource path. rom-dir [ cpu-ram [ - swap first2 rom-dir swap path+ [ + swap first2 rom-dir swap path+ binary [ swap (load-rom) ] with-file-reader ] curry each diff --git a/extra/cryptlib/cryptlib-tests.factor b/extra/cryptlib/cryptlib-tests.factor index c404114716..aeac468ba3 100644 --- a/extra/cryptlib/cryptlib-tests.factor +++ b/extra/cryptlib/cryptlib-tests.factor @@ -1,5 +1,6 @@ USING: cryptlib.libcl cryptlib prettyprint kernel alien sequences libc math -tools.test io io.files continuations alien.c-types splitting generic.math ; +tools.test io io.files continuations alien.c-types splitting generic.math +io.encodings.binary ; "=========================================================" print "Envelope/de-envelop test..." print @@ -152,7 +153,7 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; ! envelope CRYPT_FORMAT_CRYPTLIB [ "extra/cryptlib/test/large_data.txt" resource-path - file-contents set-pop-buffer + binary file-contents set-pop-buffer envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE get-pop-buffer alien>char-string length 10000 + set-attribute envelope-handle CRYPT_ENVINFO_DATASIZE @@ -192,7 +193,7 @@ tools.test io io.files continuations alien.c-types splitting generic.math ; CRYPT_FORMAT_CRYPTLIB [ envelope-handle CRYPT_ENVINFO_PASSWORD "password" set-attribute-string "extra/cryptlib/test/large_data.txt" resource-path - file-contents set-pop-buffer + binary file-contents set-pop-buffer envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE get-pop-buffer alien>char-string length 10000 + set-attribute envelope-handle CRYPT_ENVINFO_DATASIZE diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 7c358a8c09..56d39e71dc 100644 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -1,6 +1,6 @@ USING: arrays combinators crypto.common crypto.md5 crypto.sha1 crypto.md5.private io io.binary io.files io.streams.string -kernel math math.vectors memoize sequences ; +kernel math math.vectors memoize sequences io.encodings.binary ; IN: crypto.hmac : sha1-hmac ( Ko Ki -- hmac ) @@ -32,7 +32,7 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; [ init-hmac sha1-hmac ] with-stream ; : file>sha1-hmac ( K path -- hmac ) - stream>sha1-hmac ; + binary stream>sha1-hmac ; : string>sha1-hmac ( K string -- hmac ) stream>sha1-hmac ; @@ -42,7 +42,7 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; [ init-hmac md5-hmac ] with-stream ; : file>md5-hmac ( K path -- hmac ) - stream>md5-hmac ; + binary stream>md5-hmac ; : string>md5-hmac ( K string -- hmac ) stream>md5-hmac ; diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor index fe215e32db..9ca3561574 100644 --- a/extra/crypto/md5/md5.factor +++ b/extra/crypto/md5/md5.factor @@ -2,7 +2,8 @@ USING: kernel io io.binary io.files io.streams.string math math.functions math.parser namespaces splitting strings -sequences crypto.common byte-arrays locals sequences.private ; +sequences crypto.common byte-arrays locals sequences.private +io.encodings.binary ; IN: crypto.md5 : string>md5 ( string -- byte-array ) stream>md5 ; : string>md5str ( string -- md5-string ) string>md5 hex-string ; -: file>md5 ( path -- byte-array ) stream>md5 ; +: file>md5 ( path -- byte-array ) binary stream>md5 ; : file>md5str ( path -- md5-string ) file>md5 hex-string ; diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index f6dfbcd031..8f8b3e0cdd 100644 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -1,4 +1,4 @@ -USING: arrays combinators crypto.common kernel io io.binary +USING: arrays combinators crypto.common kernel io io.encodings.binary io.files io.streams.string math.vectors strings sequences namespaces math parser sequences vectors hashtables ; @@ -123,7 +123,7 @@ SYMBOL: K : string>sha1 ( string -- sha1 ) stream>sha1 ; : string>sha1str ( string -- str ) string>sha1 hex-string ; : string>sha1-bignum ( string -- n ) string>sha1 be> ; -: file>sha1 ( file -- sha1 ) stream>sha1 ; +: file>sha1 ( file -- sha1 ) binary stream>sha1 ; : string>sha1-interleave ( string -- seq ) [ zero? ] left-trim diff --git a/extra/editors/jedit/jedit.factor b/extra/editors/jedit/jedit.factor index fd5b6c1b06..ed579dde42 100644 --- a/extra/editors/jedit/jedit.factor +++ b/extra/editors/jedit/jedit.factor @@ -3,11 +3,11 @@ USING: arrays definitions io kernel math namespaces parser prettyprint sequences strings words editors io.files io.sockets io.streams.string io.binary -math.parser ; +math.parser io.encodings.ascii ; IN: editors.jedit : jedit-server-info ( -- port auth ) - home "/.jedit/server" path+ [ + home "/.jedit/server" path+ ascii [ readln drop readln string>number readln string>number diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 9b7a8a8aa5..b8e8b6885f 100755 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -5,7 +5,7 @@ furnace.validator hashtables heaps html.elements http http.server.responders http.server.templating io.files kernel math namespaces quotations sequences splitting words strings vectors webapps.callback continuations tuples classes vocabs -html io ; +html io io.encodings.binary ; IN: furnace : code>quotation ( word/quot -- quot ) @@ -194,7 +194,7 @@ SYMBOL: model ; : send-resource ( name -- ) - template-path get swap path+ resource-path + template-path get swap path+ resource-path binary stdio get stream-copy ; : render-link ( quot name -- ) diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index 8e61766de1..ec4d6b79e1 100644 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -4,7 +4,7 @@ USING: alien arrays byte-arrays combinators graphics.viewer io io.binary io.files kernel libc math math.functions namespaces opengl opengl.gl prettyprint -sequences strings ui ui.gadgets.panes ; +sequences strings ui ui.gadgets.panes io.encodings.binary ; IN: graphics.bitmap ! Currently can only handle 24bit bitmaps. @@ -59,7 +59,7 @@ TUPLE: bitmap magic size reserved offset header-length width dup color-index-length read swap set-bitmap-color-index ; : load-bitmap ( path -- bitmap ) - [ + binary [ T{ bitmap } clone dup parse-file-header dup parse-bitmap-header @@ -69,7 +69,7 @@ TUPLE: bitmap magic size reserved offset header-length width raw-bitmap>string >byte-array over set-bitmap-array ; : save-bitmap ( bitmap path -- ) - [ + binary [ "BM" write dup bitmap-array length 14 + 40 + 4 >le write 0 4 >le write diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 5be69663f8..0b22ea2d1e 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -191,11 +191,11 @@ ARTICLE: "cookbook-io" "Input and output cookbook" } "Print the lines of a file in sorted order:" { $code - "\"lines.txt\" file-lines natural-sort [ print ] each" + "utf8 \"lines.txt\" file-lines natural-sort [ print ] each" } "Read 1024 bytes from a file:" { $code - "\"data.bin\" [ 1024 read ] with-file-reader" + "\"data.bin\" binary [ 1024 read ] with-file-reader" } "Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory:" { $code diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 679d603708..251015a30d 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting continuations assocs.lib ; +splitting continuations assocs.lib io.encodings.binary ; IN: http.client : parse-host ( url -- host port ) @@ -71,7 +71,7 @@ DEFER: http-get-stream : download-to ( url file -- ) #! Downloads the contents of a URL to a file. >r http-get-stream check-response - r> stream-copy ; + r> binary stream-copy ; : download ( url -- ) dup download-name download-to ; diff --git a/extra/http/server/templating/templating-tests.factor b/extra/http/server/templating/templating-tests.factor index d889cd848a..2c15120552 100644 --- a/extra/http/server/templating/templating-tests.factor +++ b/extra/http/server/templating/templating-tests.factor @@ -1,5 +1,5 @@ USING: io io.files io.streams.string http.server.templating kernel tools.test - sequences ; + sequences io.encodings.utf8 ; IN: temporary : test-template ( path -- ? ) @@ -8,7 +8,7 @@ IN: temporary ".fhtml" append resource-path [ run-template-file ] with-string-writer ] keep - ".html" append resource-path file-contents = ; + ".html" append resource-path utf8 file-contents = ; [ t ] [ "example" test-template ] unit-test [ t ] [ "bug" test-template ] unit-test diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index f364b86524..d15bec4fb2 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -4,7 +4,7 @@ USING: continuations sequences kernel parser namespaces io io.files io.streams.lines io.streams.string html html.elements source-files debugger combinators math quotations generic -strings splitting ; +strings splitting io.encodings.utf8 ; IN: http.server.templating @@ -82,7 +82,7 @@ DEFER: <% delimiter templating-vocab use+ dup source-file file set ! so that reload works properly [ - ?resource-path file-contents + ?resource-path utf8 file-contents [ eval-template ] [ html-error. drop ] recover ] keep ] with-file-vocabs @@ -93,4 +93,4 @@ DEFER: <% delimiter swap path+ run-template-file ; : template-convert ( infile outfile -- ) - [ run-template-file ] with-file-writer ; + utf8 [ run-template-file ] with-file-writer ; diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor index ae0e058490..1740e8a523 100755 --- a/extra/icfp/2006/2006.factor +++ b/extra/icfp/2006/2006.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences kernel.private namespaces arrays io io.files splitting io.binary math.functions vectors quotations -combinators ; +combinators io.encodings.binary ; IN: icfp.2006 SYMBOL: regs @@ -134,7 +134,7 @@ SYMBOL: open-arrays [ run-op exec-loop ] unless ; : load-platters ( path -- ) - file-contents 4 group [ be> ] map + binary file-contents 4 group [ be> ] map 0 arrays get set-nth ; : init ( path -- ) diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 4f633f5be1..02e9515451 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -3,7 +3,7 @@ USING: arrays combinators io io.binary io.files io.paths io.encodings.utf16 kernel math math.parser namespaces sequences -splitting strings assocs unicode.categories ; +splitting strings assocs unicode.categories io.encodings.binary ; IN: id3 @@ -107,20 +107,20 @@ C: extended-header read-header read-frames ; : supported-version? ( version -- ? ) - [ 3 4 ] member? ; + { 3 4 } member? ; : read-id3v2 ( -- tag/f ) read1 dup supported-version? [ (read-id3v2) ] [ drop f ] if ; : id3v2? ( -- ? ) - 3 read "ID3" = ; + 3 read "ID3" sequence= ; : read-tag ( stream -- tag/f ) id3v2? [ read-id3v2 ] [ f ] if ; : id3v2 ( filename -- tag/f ) - [ read-tag ] with-file-reader ; + binary [ read-tag ] with-file-reader ; : file? ( path -- ? ) stat 3drop not ; @@ -135,7 +135,7 @@ C: extended-header [ mp3? ] subset ; : id3? ( file -- ? ) - [ id3v2? ] with-file-reader ; + binary [ id3v2? ] with-file-reader ; : id3s ( files -- id3s ) [ id3? ] subset ; diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index 25caae036d..388deac0db 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -1,9 +1,10 @@ -USING: io io.mmap io.files kernel tools.test continuations sequences ; +USING: io io.mmap io.files kernel tools.test continuations +sequences io.encodings.ascii ; IN: temporary [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors -[ ] [ "mmap-test-file.txt" resource-path [ "12345" write ] with-file-writer ] unit-test +[ ] [ "mmap-test-file.txt" resource-path ascii [ "12345" write ] with-file-writer ] unit-test [ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test -[ "22345" ] [ "mmap-test-file.txt" resource-path file-contents ] unit-test +[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index e1c3108952..85d450dac9 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -1,6 +1,6 @@ USING: io.files io.sockets io kernel threads namespaces tools.test continuations strings byte-arrays sequences -prettyprint system ; +prettyprint system io.encodings.binary ; IN: temporary ! Unix domain stream sockets @@ -131,15 +131,15 @@ client-addr ! Invalid parameter tests [ - image [ stdio get accept ] with-file-reader + image binary [ stdio get accept ] with-file-reader ] must-fail [ - image [ stdio get receive ] with-file-reader + image binary [ stdio get receive ] with-file-reader ] must-fail [ - image [ + image binary [ B{ 1 2 } server-addr stdio get send ] with-file-reader diff --git a/extra/log-viewer/log-viewer.factor b/extra/log-viewer/log-viewer.factor index 0f139d184e..7bc63d3e34 100755 --- a/extra/log-viewer/log-viewer.factor +++ b/extra/log-viewer/log-viewer.factor @@ -1,4 +1,4 @@ -USING: kernel io io.files io.monitors ; +USING: kernel io io.files io.monitors io.encodings.utf8 ; IN: log-viewer : read-lines ( stream -- ) @@ -9,6 +9,6 @@ IN: log-viewer dup next-change 2drop over read-lines tail-file-loop ; : tail-file ( file -- ) - dup dup read-lines + dup utf8 dup read-lines swap parent-directory f tail-file-loop ; diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor index bb143879bf..0294085eda 100755 --- a/extra/logging/insomniac/insomniac.factor +++ b/extra/logging/insomniac/insomniac.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: logging.analysis logging.server logging smtp io.sockets -kernel io.files io.streams.string namespaces raptor.cron assocs ; +kernel io.files io.streams.string namespaces raptor.cron assocs +io.encodings.utf8 ; IN: logging.insomniac SYMBOL: insomniac-smtp-host @@ -11,7 +12,7 @@ SYMBOL: insomniac-recipients : ?analyze-log ( service word-names -- string/f ) >r log-path 1 log# dup exists? [ - file-lines r> [ analyze-log ] with-string-writer + utf8 file-lines r> [ analyze-log ] with-string-writer ] [ r> 2drop f ] if ; diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index 05029df1d0..e2a57fbc54 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -3,7 +3,7 @@ USING: namespaces kernel io calendar sequences io.files io.sockets continuations prettyprint assocs math.parser words debugger math combinators concurrency arrays init -math.ranges strings ; +math.ranges strings io.encodings.utf8 ; IN: logging.server : log-root ( -- string ) @@ -20,7 +20,7 @@ SYMBOL: log-files : open-log-stream ( service -- stream ) log-path dup make-directories - 1 log# ; + 1 log# utf8 ; : log-stream ( service -- stream ) log-files get [ open-log-stream ] cache ; diff --git a/extra/mad/api/api.factor b/extra/mad/api/api.factor index d803fa64e0..fdc2903d46 100644 --- a/extra/mad/api/api.factor +++ b/extra/mad/api/api.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Adam Wendt. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types byte-arrays io io.binary io.files kernel mad - namespaces prettyprint sbufs sequences tools.interpreter vars ; + namespaces prettyprint sbufs sequences tools.interpreter vars + io.encodings.binary ; IN: mad.api VARS: buffer-start buffer-length output-callback-var ; @@ -80,9 +81,6 @@ VARS: buffer-start buffer-length output-callback-var ; : make-decoder ( -- decoder ) "mad_decoder" malloc-object ; -: malloc-file-contents ( path -- alien ) - file-contents >byte-array malloc-byte-array ; - : mad-run ( -- int ) make-decoder [ mad-init ] keep MAD_DECODER_MODE_SYNC mad_decoder_run ; diff --git a/extra/msxml-to-csv/msxml-to-csv.factor b/extra/msxml-to-csv/msxml-to-csv.factor index 8a9ba9cf98..3004324511 100644 --- a/extra/msxml-to-csv/msxml-to-csv.factor +++ b/extra/msxml-to-csv/msxml-to-csv.factor @@ -1,4 +1,4 @@ -USING: io io.files sequences xml xml.utilities ; +USING: io io.files sequences xml xml.utilities io.encodings.utf8 ; IN: msxml-to-csv : print-csv ( table -- ) [ "," join print ] each ; @@ -13,6 +13,6 @@ IN: msxml-to-csv ] map ; : msxml>csv ( infile outfile -- ) - [ + utf8 [ file>xml (msxml>csv) print-csv ] with-file-writer ; diff --git a/extra/ogg/player/player.factor b/extra/ogg/player/player.factor index 518030ee4d..94a45c90e3 100644 --- a/extra/ogg/player/player.factor +++ b/extra/ogg/player/player.factor @@ -14,7 +14,8 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays sequences libc shuffle alien.c-types system openal math namespaces threads shuffle opengl arrays ui.gadgets.worlds combinators math.parser ui.gadgets ui.render opengl.gl ui - continuations io.files hints combinators.lib sequences.lib ; + continuations io.files hints combinators.lib sequences.lib + io.encodings.binary ; IN: ogg.player @@ -612,7 +613,7 @@ M: theora-gadget draw-gadget* ( gadget -- ) play-ogg ; : play-vorbis-file ( filename -- ) - play-vorbis-stream ; + binary play-vorbis-stream ; : play-theora-stream ( stream -- ) @@ -620,5 +621,5 @@ M: theora-gadget draw-gadget* ( gadget -- ) play-ogg ; : play-theora-file ( filename -- ) - play-theora-stream ; + binary play-theora-stream ; diff --git a/extra/porter-stemmer/porter-stemmer-tests.factor b/extra/porter-stemmer/porter-stemmer-tests.factor index d3e031fdc6..1e46fcd871 100644 --- a/extra/porter-stemmer/porter-stemmer-tests.factor +++ b/extra/porter-stemmer/porter-stemmer-tests.factor @@ -1,6 +1,6 @@ IN: temporary USING: arrays io kernel porter-stemmer sequences tools.test -io.files ; +io.files io.encodings.utf8 ; [ 0 ] [ "xa" consonant-seq ] unit-test [ 0 ] [ "xxaa" consonant-seq ] unit-test @@ -56,7 +56,7 @@ io.files ; [ "hell" ] [ "hell" step5 "" like ] unit-test [ "mate" ] [ "mate" step5 "" like ] unit-test -: resource-lines resource-path file-lines ; +: resource-lines resource-path utf8 file-lines ; [ { } ] [ "extra/porter-stemmer/test/voc.txt" resource-lines diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor index c66be27df7..a87722debc 100644 --- a/extra/project-euler/042/042.factor +++ b/extra/project-euler/042/042.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: ascii io.files kernel math math.functions namespaces - project-euler.common sequences sequences.lib splitting ; + project-euler.common sequences sequences.lib splitting io.encodings.ascii ; IN: project-euler.042 ! http://projecteuler.net/index.php?section=problems&id=42 @@ -31,7 +31,7 @@ IN: project-euler.042 : source-042 ( -- seq ) "extra/project-euler/042/words.txt" resource-path - file-contents [ quotable? ] subset "," split ; + ascii file-contents [ quotable? ] subset "," split ; : (triangle-upto) ( limit n -- ) 2dup nth-triangle > [ diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor index f206f59472..436ccde776 100644 --- a/extra/project-euler/067/067.factor +++ b/extra/project-euler/067/067.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files math.parser namespaces project-euler.common sequences splitting ; +USING: io.files math.parser namespaces project-euler.common +io.encodings.ascii sequences splitting ; IN: project-euler.067 ! http://projecteuler.net/index.php?section=problems&id=67 @@ -38,7 +39,7 @@ IN: project-euler.067 : source-067 ( -- seq ) "extra/project-euler/067/triangle.txt" resource-path - file-lines [ " " split [ string>number ] map ] map ; + ascii file-lines [ " " split [ string>number ] map ] map ; PRIVATE> diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor index f068db77ec..30c46de0a0 100644 --- a/extra/project-euler/079/079.factor +++ b/extra/project-euler/079/079.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs hashtables io.files kernel math math.parser namespaces sequences ; +USING: assocs hashtables io.files kernel math math.parser namespaces +io.encodings.ascii sequences ; IN: project-euler.079 ! http://projecteuler.net/index.php?section=problems&id=79 @@ -26,7 +27,7 @@ IN: project-euler.079 edges ( seq -- seq ) [ diff --git a/extra/raptor/raptor.factor b/extra/raptor/raptor.factor index d776739d89..36da6d9434 100644 --- a/extra/raptor/raptor.factor +++ b/extra/raptor/raptor.factor @@ -42,10 +42,10 @@ SYMBOL: networking-hook ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! USING: io io.files io.streams.lines io.streams.plain io.streams.duplex - listener ; + listener io.encodings.utf8 ; : tty-listener ( tty -- ) - [ ] [ ] bi + [ utf8 ] [ utf8 ] bi [ listener ] with-stream ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor index 68a40704b3..1d493d3c14 100644 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -1,9 +1,9 @@ -USING: rss io kernel io.files tools.test ; +USING: rss io kernel io.files tools.test io.encodings.utf8 ; : load-news-file ( filename -- feed ) #! Load an news syndication file and process it, returning #! it as an feed tuple. - read-feed ; + utf8 read-feed ; [ T{ feed diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index d92b4bd48b..ed083386ed 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,7 +1,7 @@ USING: combinators io io.files io.streams.duplex io.streams.string kernel math math.parser continuations namespaces pack prettyprint sequences strings system -hexdump tools.interpreter ; +hexdump tools.interpreter io.encodings.binary ; IN: tar : zero-checksum 256 ; @@ -94,7 +94,7 @@ TUPLE: unimplemented-typeflag header ; ! Normal file : typeflag-0 - tar-header-name tar-path+ + tar-header-name tar-path+ binary [ read-data-blocks ] keep dispose ; ! Hard link @@ -236,7 +236,7 @@ TUPLE: unimplemented-typeflag header ; ] when* ; : parse-tar ( path -- obj ) - [ + binary [ "tar-test" resource-path base-dir set global [ nl nl nl "Starting to parse .tar..." print flush ] bind global [ "Expanding to: " write base-dir get . flush ] bind diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 7c28983519..63f9a087f5 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -5,12 +5,12 @@ words vocabs vocabs.loader definitions parser continuations inspector debugger io io.styles io.streams.lines hashtables sorting prettyprint source-files arrays combinators strings system math.parser help.markup help.topics help.syntax -help.stylesheet memoize ; +help.stylesheet memoize io.encodings.utf8 ; IN: tools.browser MEMO: (vocab-file-contents) ( path -- lines ) ?resource-path dup exists? - [ file-lines ] [ drop f ] if ; + [ utf8 file-lines ] [ drop f ] if ; : vocab-file-contents ( vocab name -- seq ) vocab-path+ dup [ (vocab-file-contents) ] when ; @@ -18,7 +18,7 @@ MEMO: (vocab-file-contents) ( path -- lines ) : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-path+ [ ?resource-path - [ [ print ] each ] with-file-writer + utf8 [ [ print ] each ] with-file-writer ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index eb1a4af4a7..e4a0d539d1 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -46,8 +46,8 @@ IN: tools.deploy.macosx ] H{ } make-assoc print-plist ; : create-app-plist ( vocab bundle-name -- ) - dup "Contents/Info.plist" path+ - [ print-app-plist ] with-stream ; + dup "Contents/Info.plist" path+ + utf8 [ print-app-plist ] with-file-writer ; : create-app-dir ( vocab bundle-name -- vm ) dup "Frameworks" copy-bundle-dir diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 833a6e7548..57fe7b43e8 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/extra/tools/disassembler/disassembler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files io words alien kernel math.parser alien.syntax io.launcher system assocs arrays sequences namespaces qualified -system math windows.kernel32 generator.fixup ; +system math windows.kernel32 generator.fixup io.encodings.ascii ; IN: tools.disassembler : in-file "gdb-in.txt" resource-path ; @@ -15,7 +15,7 @@ M: word make-disassemble-cmd word-xt code-format - 2array make-disassemble-cmd ; M: pair make-disassemble-cmd - in-file [ + in-file ascii [ "attach " write current-process-handle number>string print "disassemble " write @@ -28,7 +28,7 @@ M: pair make-disassemble-cmd out-file +stdout+ set [ "gdb" , "-x" , in-file , "-batch" , ] { } make +arguments+ set ] { } make-assoc run-process drop - out-file file-lines ; + out-file ascii file-lines ; : tabs>spaces ( str -- str' ) { { CHAR: \t CHAR: \s } } substitute ; diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 2dade0f58e..8078ec4a33 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -73,7 +73,7 @@ M: freetype-renderer free-fonts ( world -- ) : open-face ( font style -- face ) ttf-name ttf-path - dup file-contents >byte-array malloc-byte-array + dup malloc-file-contents swap file-length (open-face) ; diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 1014d3ad7e..dfc7bf2264 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -1,7 +1,7 @@ USING: unicode.categories kernel math combinators splitting sequences math.parser io.files io assocs arrays namespaces combinators.lib assocs.lib math.ranges unicode.normalize -unicode.syntax unicode.data compiler.units alien.syntax ; +unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ; IN: unicode.breaks C-ENUM: Any L V T Extend Control CR LF graphemes ; @@ -30,7 +30,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; concat >set ; : other-extend-lines ( -- lines ) - "extra/unicode/PropList.txt" resource-path file-lines ; + "extra/unicode/PropList.txt" resource-path ascii file-lines ; VALUE: other-extend diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index c3998a6132..11be803893 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,6 +1,6 @@ USING: assocs math kernel sequences io.files hashtables quotations splitting arrays math.parser combinators.lib hash2 -byte-arrays words namespaces words compiler.units parser ; +byte-arrays words namespaces words compiler.units parser io.encodings.ascii ; IN: unicode.data << @@ -21,7 +21,7 @@ IN: unicode.data ! Loading data from UnicodeData.txt : data ( filename -- data ) - file-lines [ ";" split ] map ; + ascii file-lines [ ";" split ] map ; : load-data ( -- data ) "extra/unicode/UnicodeData.txt" resource-path data ; diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor index 552f5e0977..12627b985f 100755 --- a/extra/webapps/file/file.factor +++ b/extra/webapps/file/file.factor @@ -3,7 +3,7 @@ USING: calendar html io io.files kernel math math.parser http.server.responders http.server.templating namespaces parser sequences strings assocs hashtables debugger http.mime sorting -html.elements logging ; +html.elements logging io.encodings.binary ; IN: webapps.file @@ -37,7 +37,7 @@ SYMBOL: serve-file-hook [ dupd file-response - stdio get stream-copy + binary stdio get stream-copy ] serve-file-hook set-global : serve-static ( filename mime-type -- ) diff --git a/extra/webapps/source/source.factor b/extra/webapps/source/source.factor index 4c0701c687..dc97805b78 100755 --- a/extra/webapps/source/source.factor +++ b/extra/webapps/source/source.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.files namespaces webapps.file http.server.responders -xmode.code2html kernel html sequences ; +xmode.code2html kernel html sequences io.encodings.utf8 ; IN: webapps.source ! This responder is a potential security problem. Make sure you @@ -15,7 +15,7 @@ IN: webapps.source : source-responder ( path mime-type -- ) drop serving-html - [ dup htmlize-stream ] with-html-stream ; + [ dup utf8 htmlize-stream ] with-html-stream ; global [ ! Serve up our own source code diff --git a/extra/xml/xml.factor b/extra/xml/xml.factor index ec3e24b99d..970ff39cf1 100644 --- a/extra/xml/xml.factor +++ b/extra/xml/xml.factor @@ -3,7 +3,7 @@ USING: io io.streams.string io.files kernel math namespaces prettyprint sequences arrays generic strings vectors xml.char-classes xml.data xml.errors xml.tokenize xml.writer -xml.utilities state-parser assocs ascii ; +xml.utilities state-parser assocs ascii io.encodings.utf8 ; IN: xml ! -- Overall parser with data tree @@ -167,7 +167,8 @@ TUPLE: pull-xml scope ; read-xml ; : file>xml ( filename -- xml ) - read-xml ; + ! Autodetect encoding! + utf8 read-xml ; : xml-reprint ( string -- ) string>xml print-xml ; diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index d6402603fa..6bff786fff 100755 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -1,6 +1,6 @@ USING: xmode.loader xmode.utilities xmode.rules namespaces strings splitting assocs sequences kernel io.files xml memoize -words globs combinators ; +words globs combinators io.encodings.utf8 ; IN: xmode.catalog TUPLE: mode file file-name-glob first-line-glob ; @@ -25,7 +25,7 @@ TAGS> : load-catalog ( -- modes ) "extra/xmode/modes/catalog" resource-path - read-xml parse-modes-tag ; + file>xml parse-modes-tag ; : modes ( -- assoc ) \ modes get-global [ @@ -38,7 +38,7 @@ TAGS> MEMO: (load-mode) ( name -- rule-sets ) modes at mode-file "extra/xmode/modes/" swap append - resource-path parse-mode ; + resource-path utf8 parse-mode ; SYMBOL: rule-sets diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor index 3db70cf2e9..47e619cc00 100755 --- a/extra/xmode/code2html/code2html.factor +++ b/extra/xmode/code2html/code2html.factor @@ -1,5 +1,5 @@ USING: xmode.tokens xmode.marker xmode.catalog kernel html html.elements io - io.files sequences words ; + io.files sequences words io.encodings.utf8 ; IN: xmode.code2html : htmlize-tokens ( tokens -- ) @@ -20,7 +20,7 @@ IN: xmode.code2html : default-stylesheet ( -- ) ; : htmlize-stream ( path stream -- ) @@ -40,5 +40,5 @@ IN: xmode.code2html ; : htmlize-file ( path -- ) - dup over ".html" append + dup utf8 over ".html" append utf8 [ htmlize-stream ] with-stream ; diff --git a/extra/yahoo/yahoo-tests.factor b/extra/yahoo/yahoo-tests.factor index 22ea687a29..197fa4900b 100644 --- a/extra/yahoo/yahoo-tests.factor +++ b/extra/yahoo/yahoo-tests.factor @@ -6,6 +6,6 @@ USING: tools.test yahoo kernel io.files xml sequences ; "Official Foo Fighters" "http://www.foofighters.com/" "Official site with news, tour dates, discography, store, community, and more." -} ] [ "extra/yahoo/test-results.xml" resource-path read-xml parse-yahoo first ] unit-test +} ] [ "extra/yahoo/test-results.xml" resource-path file>xml parse-yahoo first ] unit-test [ "http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=1" ] [ "hi" 1 query ] unit-test From e918cf6de0c16d0880f34db0f53ce9b778b6b487 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 21 Feb 2008 15:22:49 -0600 Subject: [PATCH 004/140] More changes wrt encodings --- core/bootstrap/image/image.factor | 3 +- core/io/encodings/ascii/ascii.factor | 8 ++-- core/io/encodings/ascii/authors.txt | 1 + core/io/encodings/binary/binary.factor | 2 + core/io/encodings/encodings.factor | 27 +++++++------ core/io/encodings/latin1/latin1.factor | 4 +- core/io/encodings/utf16/utf16.factor | 5 +-- core/io/encodings/utf8/utf8.factor | 5 +-- core/io/files/authors.txt | 1 + core/io/files/files.factor | 11 ++--- core/io/streams/c/c.factor | 14 +++---- core/io/streams/plain/plain.factor | 17 ++++++-- core/io/streams/string/string.factor | 47 +++++++++++----------- extra/db/sqlite/test.db | Bin 0 -> 2048 bytes extra/io/buffers/buffers-docs.factor | 2 +- extra/io/launcher/launcher-docs.factor | 3 +- extra/io/launcher/launcher.factor | 7 ++-- extra/io/nonblocking/nonblocking.factor | 8 ++-- extra/io/sockets/authors.txt | 1 + extra/io/sockets/sockets-docs.factor | 6 +-- extra/io/sockets/sockets.factor | 17 ++++---- extra/io/unix/backend/backend.factor | 4 +- extra/io/unix/launcher/launcher.factor | 4 +- extra/io/unix/sockets/sockets.factor | 4 +- extra/io/unix/unix-tests.factor | 4 +- extra/irc/irc.factor | 5 ++- extra/smtp/smtp.factor | 6 +-- extra/tools/deploy/backend/backend.factor | 4 +- extra/webapps/cgi/cgi.factor | 4 +- 29 files changed, 125 insertions(+), 99 deletions(-) create mode 100644 core/io/encodings/ascii/authors.txt create mode 100644 extra/db/sqlite/test.db diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 73085450a8..610f57cb8d 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -416,7 +416,8 @@ M: curry ' "Writing image to " write architecture get boot-image-name resource-path dup write "..." print flush - binary [ (write-image) ] with-file-writer ; + ! binary + [ (write-image) ] with-stream ; PRIVATE> diff --git a/core/io/encodings/ascii/ascii.factor b/core/io/encodings/ascii/ascii.factor index d767f26cdd..410c07f1ca 100644 --- a/core/io/encodings/ascii/ascii.factor +++ b/core/io/encodings/ascii/ascii.factor @@ -1,8 +1,10 @@ -USING: io io.encodings strings kernel ; +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ; IN: io.encodings.ascii : encode-check>= ( string max -- byte-array ) - dupd [ >= ] curry all? [ >byte-array ] [ encoding-error ] if ; + dupd [ >= ] curry all? [ >byte-array ] [ encode-error ] if ; TUPLE: ascii ; @@ -10,4 +12,4 @@ M: ascii encode-string drop 127 encode-check>= ; M: ascii decode-step - 3drop over push f f ; + 3drop dup 127 >= [ encode-error ] when over push f f ; diff --git a/core/io/encodings/ascii/authors.txt b/core/io/encodings/ascii/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/core/io/encodings/ascii/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/core/io/encodings/binary/binary.factor b/core/io/encodings/binary/binary.factor index 8a8d09464b..b8bcc0f87a 100644 --- a/core/io/encodings/binary/binary.factor +++ b/core/io/encodings/binary/binary.factor @@ -1 +1,3 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. IN: io.encodings.binary SYMBOL: binary diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index cd9d4b585b..c1fd2c018c 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2006, 2007 Daniel Ehrenberg. +! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces -growable strings io classes continuations -io.styles io.streams.nested io.encodings.binary ; +growable strings io classes continuations combinators +io.styles io.streams.plain io.encodings.binary splitting +io.streams.string io.streams.duplex ; IN: io.encodings ! Decoding @@ -134,18 +135,20 @@ M: encoded stream-write1 >r 1string r> stream-write ; M: encoded stream-write - [ encoding-code encode-string ] keep delegate stream-write ; + [ encoded-code encode-string ] keep delegate stream-write ; M: encoded dispose delegate dispose ; -M: encoded stream-nl - CHAR: \n swap stream-write1 ; +INSTANCE: encoded plain-writer -M: encoded stream-format - nip stream-write ; +! Rebinding duplex streams which have not read anything yet -M: encoded make-span-stream - ; +: reencode ( stream encoding -- newstream ) + over encoded? [ >r delegate r> ] when ; -M: encoded make-block-stream - nip ; +: redecode ( stream encoding -- newstream ) + over decoded? [ >r delegate r> ] when ; + +: ( duplex-stream encoding -- duplex-stream ) + swap { duplex-stream-in duplex-stream-out } get-slots + pick reencode >r swap redecode r> ; diff --git a/core/io/encodings/latin1/latin1.factor b/core/io/encodings/latin1/latin1.factor index d6e643fd96..7e867b15af 100755 --- a/core/io/encodings/latin1/latin1.factor +++ b/core/io/encodings/latin1/latin1.factor @@ -1,4 +1,6 @@ -USING: io io.encodings strings kernel io.encodings.ascii ; +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.encodings strings kernel io.encodings.ascii sequences ; IN: io.encodings.latin1 TUPLE: latin1 ; diff --git a/core/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor index 1dd317d3c0..a241913fb5 100755 --- a/core/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Daniel Ehrenberg. +! Copyright (C) 2006, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces io.binary io.encodings combinators splitting io byte-arrays ; @@ -116,19 +116,16 @@ SYMBOL: ignore } cond ; TUPLE: utf16le ; -INSTANCE: utf16le encoding-stream M: utf16le encode-string drop encode-utf16le ; M: utf16le decode-step drop decode-utf16le-step ; TUPLE: utf16be ; -INSTANCE: utf16be encoding-stream M: utf16be encode-string drop encode-utf16be ; M: utf16be decode-step drop decode-utf16be-step ; TUPLE: utf16 encoding ; -INSTANCE: utf16 encoding-stream M: utf16 underlying-stream delegate dup delegate [ ] [ ] ?if ; ! necessary? M: utf16 set-underlying-stream delegate set-delegate ; ! necessary? diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 7f211f92de..2e7585b8a9 100644 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2006, 2007 Daniel Ehrenberg. +! Copyright (C) 2006, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors growable io continuations -namespaces io.encodings combinators strings io.streams.c ; +namespaces io.encodings combinators strings ; IN: io.encodings.utf8 ! Decoding UTF-8 @@ -78,7 +78,6 @@ SYMBOL: quad3 ! Interface for streams TUPLE: utf8 ; -INSTANCE: utf8 encoding-stream M: utf8 encode-string drop encode-utf8 ; M: utf8 decode-step drop decode-utf8-step ; diff --git a/core/io/files/authors.txt b/core/io/files/authors.txt index 1901f27a24..a44f8d7f8d 100644 --- a/core/io/files/authors.txt +++ b/core/io/files/authors.txt @@ -1 +1,2 @@ Slava Pestov +Daniel Ehrenberg diff --git a/core/io/files/files.factor b/core/io/files/files.factor index daa5d6df7e..c96cb1578c 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. IN: io.files USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions -system combinators splitting sbufs continuations io.encodings ; +system combinators splitting sbufs continuations io.encodings +io.encodings.binary ; HOOK: cd io-backend ( path -- ) @@ -16,13 +17,13 @@ HOOK: file-writer* io-backend ( path -- stream ) HOOK: file-appender* io-backend ( path -- stream ) : ( path encoding -- stream ) - swap file-reader* swap ; + swap file-reader* swap ; : ( path encoding -- stream ) - swap file-writer* swap ; + swap file-writer* swap ; : ( path encoding -- stream ) - swap file-appender* swap ; + swap file-appender* swap ; HOOK: delete-file io-backend ( path -- ) diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 73b8bb32b9..8a6430eb86 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private namespaces io +USING: kernel kernel.private namespaces io io.encodings strings sequences math generic threads.private classes -io.backend io.streams.duplex io.files continuations ; +io.backend io.streams.duplex io.files continuations +io.encodings.utf8 ; IN: io.streams.c TUPLE: c-writer handle ; @@ -49,9 +50,7 @@ M: c-reader dispose c-reader-handle fclose ; : ( in out -- stream ) - >r r> - - ; + >r r> ; M: object init-io ; @@ -60,8 +59,9 @@ M: object init-io ; : stderr-handle 38 getenv ; M: object init-stdio - stdin-handle stdout-handle stdio set-global - stderr-handle stderr set-global ; + stdin-handle stdout-handle + utf8 stdio set-global + stderr-handle utf8 stderr set-global ; M: object io-multiplex (sleep) ; diff --git a/core/io/streams/plain/plain.factor b/core/io/streams/plain/plain.factor index e6cf9c8afa..4898a58fb1 100644 --- a/core/io/streams/plain/plain.factor +++ b/core/io/streams/plain/plain.factor @@ -1,7 +1,18 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel io io.streams.nested ; IN: io.streams.plain -USING: io.encodings.latin1 io.encodings ; -: ( stream -- new-stream ) - latin1 ; +MIXIN: plain-writer + +M: plain-writer stream-nl + CHAR: \n swap stream-write1 ; + +M: plain-writer stream-format + nip stream-write ; + +M: plain-writer make-span-stream + ; + +M: plain-writer make-block-stream + nip ; diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index a45c616b9a..f74f91c5bd 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.string USING: io kernel math namespaces sequences sbufs strings -generic splitting io.streams.plain io.streams.lines growable -continuations ; +generic splitting growable continuations io.streams.plain ; M: growable dispose drop ; @@ -12,31 +11,12 @@ M: growable stream-write push-all ; M: growable stream-flush drop ; : ( -- stream ) - 512 ; + 512 ; : with-string-writer ( quot -- str ) swap [ stdio get ] compose with-stream* >string ; inline -: format-column ( seq ? -- seq ) - [ - [ 0 [ length max ] reduce ] keep - swap [ CHAR: \s pad-right ] curry map - ] unless ; - -: map-last ( seq quot -- seq ) - swap dup length - [ zero? rot [ call ] keep swap ] 2map nip ; inline - -: format-table ( table -- seq ) - flip [ format-column ] map-last - flip [ " " join ] map ; - -M: plain-writer stream-write-table - [ drop format-table [ print ] each ] with-stream* ; - -M: plain-writer make-cell-stream 2drop ; - M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ; : harden-as ( seq growble-exemplar -- newseq ) @@ -69,7 +49,28 @@ M: growable stream-read-partial stream-read ; : ( str -- stream ) - >sbuf dup reverse-here ; + >sbuf dup reverse-here ; : with-string-reader ( str quot -- ) >r r> with-stream ; inline + +INSTANCE: growable plain-writer + +: format-column ( seq ? -- seq ) + [ + [ 0 [ length max ] reduce ] keep + swap [ CHAR: \s pad-right ] curry map + ] unless ; + +: map-last ( seq quot -- seq ) + swap dup length + [ zero? rot [ call ] keep swap ] 2map nip ; inline + +: format-table ( table -- seq ) + flip [ format-column ] map-last + flip [ " " join ] map ; + +M: plain-writer stream-write-table + [ drop format-table [ print ] each ] with-stream* ; + +M: plain-writer make-cell-stream 2drop ; diff --git a/extra/db/sqlite/test.db b/extra/db/sqlite/test.db new file mode 100644 index 0000000000000000000000000000000000000000..e483c47cea528c95f10fcf66fcbb67ffa351ffd1 GIT binary patch literal 2048 zcmWFz^vNtqRY=P(%1ta$FlJz3U}R))P*7lCU|k literal 0 HcmV?d00001 diff --git a/extra/io/buffers/buffers-docs.factor b/extra/io/buffers/buffers-docs.factor index def3e475f7..cf069f17aa 100644 --- a/extra/io/buffers/buffers-docs.factor +++ b/extra/io/buffers/buffers-docs.factor @@ -30,7 +30,7 @@ $nl ABOUT: "buffers" HELP: buffer -{ $class-description "The class of I/O buffers, which resemble FIFO queues, but are optimize for holding bytes, are have underlying storage allocated at a fixed address. Buffers must be de-allocated manually." +{ $class-description "The class of I/O buffers, which resemble FIFO queues, but are optimized for holding bytes, are have underlying storage allocated at a fixed address. Buffers must be de-allocated manually." $nl "Buffers have two internal pointers:" { $list diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 3a557e9fd5..10e7f2414b 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -148,8 +148,9 @@ HELP: process-stream HELP: { $values { "desc" "a launch descriptor" } + { "encoding" "an encoding descriptor" } { "stream" "a bidirectional stream" } } -{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." } +{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } { $notes "Closing the stream will block until the process exits." } ; HELP: with-process-stream diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index dce893dcaf..11eb8466a1 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -117,12 +117,13 @@ M: process get-lapse process-lapse ; M: process timed-out kill-process ; HOOK: process-stream* io-backend ( desc -- stream process ) +! Process streams are always latin1 for now; will be updated TUPLE: process-stream process ; -: ( desc -- stream ) - >descriptor - [ process-stream* ] keep +: ( desc encoding -- stream ) + swap >descriptor + [ process-stream* >r swap r> ] keep +timeout+ swap at [ over set-timeout ] when* { set-delegate set-process-stream-process } process-stream construct ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index dfdd05af53..0ae41f08fc 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -45,10 +45,10 @@ GENERIC: close-handle ( handle -- ) : ( handle -- stream ) output-port ; -: handle>duplex-stream ( in-handle out-handle -- stream ) - - [ >r r> ] [ ] [ dispose ] - cleanup ; +: handle>duplex-stream ( in-handle out-handle encoding -- stream ) + [ swap swap ] keep + [ -rot >r swap r> ] + [ ] [ dispose ] cleanup ; : pending-error ( port -- ) dup port-error f rot set-port-error [ throw ] when* ; diff --git a/extra/io/sockets/authors.txt b/extra/io/sockets/authors.txt index 1901f27a24..a44f8d7f8d 100644 --- a/extra/io/sockets/authors.txt +++ b/extra/io/sockets/authors.txt @@ -1 +1,2 @@ Slava Pestov +Daniel Ehrenberg diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index 9136c3ca22..510d47ff2b 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -92,11 +92,11 @@ HELP: inet6 } ; HELP: -{ $values { "addrspec" "an address specifier" } { "stream" "a bidirectional stream" } } -{ $description "Opens a network connection and outputs a bidirectional stream." } +{ $values { "addrspec" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } } +{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding." } { $errors "Throws an error if the connection cannot be established." } { $examples - { $code "\"www.apple.com\" \"http\" " } + { $code "\"www.apple.com\" \"http\" utf8 " } } ; HELP: diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 1afffcc7b2..6cf75f2f60 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. IN: io.sockets USING: generic kernel io.backend namespaces continuations -sequences arrays ; +sequences arrays io.encodings ; TUPLE: local path ; @@ -28,11 +28,12 @@ TUPLE: client-stream addr ; HOOK: (client) io-backend ( addrspec -- stream ) -GENERIC: ( addrspec -- stream ) +GENERIC: client* ( addrspec -- stream ) +M: array client* [ (client) ] attempt-all ; +M: object client* (client) ; -M: array [ (client) ] attempt-all ; - -M: object (client) ; +: ( addrspec encoding -- stream ) + >r client* r> ; HOOK: io-backend ( addrspec -- server ) @@ -48,7 +49,7 @@ HOOK: resolve-host io-backend ( host serv passive? -- seq ) HOOK: host-name io-backend ( -- string ) -M: inet +M: inet client* dup inet-host swap inet-port f resolve-host dup empty? [ "Host name lookup failed" throw ] when - ; + client* ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 7d9f76c686..d6e384f255 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -181,8 +181,8 @@ M: unix-io io-multiplex ( ms -- ) mx get-global wait-for-events ; M: unix-io init-stdio ( -- ) - 0 1 handle>duplex-stream io:stdio set-global - 2 io:stderr set-global ; + 0 1 utf8 handle>duplex-stream io:stdio set-global + 2 utf8 io:stderr set-global ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port mx ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 5adf0d7453..4e5f9e0fdf 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.unix.backend io.unix.files io.nonblocking sequences kernel namespaces math system alien.c-types debugger continuations arrays assocs combinators unix.process parser-combinators memoize -promises strings threads unix ; +promises strings threads unix io.encodings.latin1 ; IN: io.unix.launcher ! Search unix first @@ -99,7 +99,7 @@ M: unix-io kill-process* ( pid -- ) M: unix-io process-stream* [ - spawn-process-stream >r handle>duplex-stream r> + spawn-process-stream >r latin1 handle>duplex-stream r> ] with-descriptor ; : find-process ( handle -- process ) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 59a9a8ac2e..84d4cc33f8 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. +! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. ! See http://factorcode.org/license.txt for BSD license. ! We need to fiddle with the exact search order here, since @@ -92,7 +92,7 @@ USE: io.sockets dup rot make-sockaddr/size bind zero? [ dup close (io-error) ] unless ; -M: unix-io ( addrspec -- stream ) +M: unix-io ( addrspec -- server ) [ SOCK_STREAM server-fd dup 10 listen zero? [ dup close (io-error) ] unless diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 85d450dac9..54d2573396 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -1,6 +1,6 @@ USING: io.files io.sockets io kernel threads namespaces tools.test continuations strings byte-arrays sequences -prettyprint system io.encodings.binary ; +prettyprint system io.encodings.binary io.encodings.ascii ; IN: temporary ! Unix domain stream sockets @@ -24,7 +24,7 @@ yield [ { "Hello world" "FOO" } ] [ [ - "unix-domain-socket-test" resource-path + "unix-domain-socket-test" resource-path ascii [ readln , "XYZ" print flush diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 44c682e671..8a39846fc4 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays calendar io io.sockets kernel match namespaces -sequences splitting strings continuations threads ascii ; +sequences splitting strings continuations threads ascii +io.encodings.utf8 ; IN: irc ! "setup" objects @@ -97,7 +98,7 @@ SYMBOL: irc-client " hostname servername :irc.factor" irc-print ; : connect* ( server port -- ) - irc-client get set-irc-client-stream ; + utf8 irc-client get set-irc-client-stream ; : connect ( server -- ) 6667 connect* ; diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 47bc16e029..14230e2c7c 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces io io.timeouts kernel logging io.sockets sequences combinators sequences.lib splitting assocs strings -math.parser random system calendar ; +math.parser random system calendar io.encodings.ascii ; IN: smtp @@ -20,7 +20,7 @@ SYMBOL: esmtp t esmtp set-global : with-smtp-connection ( quot -- ) smtp-host get smtp-port get 2dup log-smtp-connection - [ + ascii [ ! ASCII until encodings reconsidered smtp-domain [ host-name or ] change read-timeout get stdio get set-timeout call @@ -180,4 +180,4 @@ TUPLE: email from to subject body ; : send ( email -- ) { email-body email-subject email-to email-from } get-slots - send-simple-message ; \ No newline at end of file + send-simple-message ; diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 2439ef8636..bcdc0f806f 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -6,7 +6,7 @@ continuations math definitions mirrors splitting parser classes inspector layouts vocabs.loader prettyprint.config prettyprint debugger io.streams.c io.streams.duplex io.files io.backend quotations io.launcher words.private tools.deploy.config -bootstrap.image ; +bootstrap.image io.encodings.utf8 ; IN: tools.deploy.backend : (copy-lines) ( stream -- ) @@ -20,7 +20,7 @@ IN: tools.deploy.backend [ +arguments+ set +stdout+ +stderr+ set - ] H{ } make-assoc + ] H{ } make-assoc utf8 dup duplex-stream-out dispose dup copy-lines process-stream-process wait-for-process zero? [ diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor index 967036a797..255aee0fbd 100644 --- a/extra/webapps/cgi/cgi.factor +++ b/extra/webapps/cgi/cgi.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs io.files combinators arrays io.launcher io http.server.responders webapps.file -sequences strings math.parser unicode.case ; +sequences strings math.parser unicode.case io.encodings.binary ; IN: webapps.cgi SYMBOL: cgi-root @@ -50,7 +50,7 @@ SYMBOL: cgi-root : (do-cgi) ( name -- ) "200 CGI output follows" response - stdio get swap cgi-descriptor [ + stdio get swap cgi-descriptor binary [ post? [ "raw-response" get write flush ] when From 11a71f235d36a32fa87df84ec0d68213be7c59c3 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 21 Feb 2008 15:28:58 -0600 Subject: [PATCH 005/140] Moving inessential encodings to extra --- extra/db/sqlite/test.db | Bin 2048 -> 0 bytes {core => extra}/io/encodings/ascii/ascii.factor | 0 {core => extra}/io/encodings/ascii/authors.txt | 0 extra/io/encodings/ascii/summary.txt | 1 + .../latin1 => extra/io/encodings/ascii}/tags.txt | 0 {core => extra}/io/encodings/latin1/authors.txt | 0 .../io/encodings/latin1/latin1-docs.factor | 0 .../io/encodings/latin1/latin1.factor | 0 {core => extra}/io/encodings/latin1/summary.txt | 0 .../utf16 => extra/io/encodings/latin1}/tags.txt | 0 .../io/encodings/utf16/.utf16.factor.swo | Bin {core => extra}/io/encodings/utf16/authors.txt | 0 {core => extra}/io/encodings/utf16/summary.txt | 0 extra/io/encodings/utf16/tags.txt | 1 + .../io/encodings/utf16/utf16-docs.factor | 0 .../io/encodings/utf16/utf16-tests.factor | 0 {core => extra}/io/encodings/utf16/utf16.factor | 0 17 files changed, 2 insertions(+) delete mode 100644 extra/db/sqlite/test.db rename {core => extra}/io/encodings/ascii/ascii.factor (100%) rename {core => extra}/io/encodings/ascii/authors.txt (100%) create mode 100644 extra/io/encodings/ascii/summary.txt rename {core/io/encodings/latin1 => extra/io/encodings/ascii}/tags.txt (100%) rename {core => extra}/io/encodings/latin1/authors.txt (100%) rename {core => extra}/io/encodings/latin1/latin1-docs.factor (100%) rename {core => extra}/io/encodings/latin1/latin1.factor (100%) rename {core => extra}/io/encodings/latin1/summary.txt (100%) rename {core/io/encodings/utf16 => extra/io/encodings/latin1}/tags.txt (100%) rename {core => extra}/io/encodings/utf16/.utf16.factor.swo (100%) rename {core => extra}/io/encodings/utf16/authors.txt (100%) rename {core => extra}/io/encodings/utf16/summary.txt (100%) create mode 100644 extra/io/encodings/utf16/tags.txt rename {core => extra}/io/encodings/utf16/utf16-docs.factor (100%) rename {core => extra}/io/encodings/utf16/utf16-tests.factor (100%) rename {core => extra}/io/encodings/utf16/utf16.factor (100%) diff --git a/extra/db/sqlite/test.db b/extra/db/sqlite/test.db deleted file mode 100644 index e483c47cea528c95f10fcf66fcbb67ffa351ffd1..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2048 zcmWFz^vNtqRY=P(%1ta$FlJz3U}R))P*7lCU|k diff --git a/core/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor similarity index 100% rename from core/io/encodings/ascii/ascii.factor rename to extra/io/encodings/ascii/ascii.factor diff --git a/core/io/encodings/ascii/authors.txt b/extra/io/encodings/ascii/authors.txt similarity index 100% rename from core/io/encodings/ascii/authors.txt rename to extra/io/encodings/ascii/authors.txt diff --git a/extra/io/encodings/ascii/summary.txt b/extra/io/encodings/ascii/summary.txt new file mode 100644 index 0000000000..8c54de7680 --- /dev/null +++ b/extra/io/encodings/ascii/summary.txt @@ -0,0 +1 @@ +ASCII encoding for streams diff --git a/core/io/encodings/latin1/tags.txt b/extra/io/encodings/ascii/tags.txt similarity index 100% rename from core/io/encodings/latin1/tags.txt rename to extra/io/encodings/ascii/tags.txt diff --git a/core/io/encodings/latin1/authors.txt b/extra/io/encodings/latin1/authors.txt similarity index 100% rename from core/io/encodings/latin1/authors.txt rename to extra/io/encodings/latin1/authors.txt diff --git a/core/io/encodings/latin1/latin1-docs.factor b/extra/io/encodings/latin1/latin1-docs.factor similarity index 100% rename from core/io/encodings/latin1/latin1-docs.factor rename to extra/io/encodings/latin1/latin1-docs.factor diff --git a/core/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor similarity index 100% rename from core/io/encodings/latin1/latin1.factor rename to extra/io/encodings/latin1/latin1.factor diff --git a/core/io/encodings/latin1/summary.txt b/extra/io/encodings/latin1/summary.txt similarity index 100% rename from core/io/encodings/latin1/summary.txt rename to extra/io/encodings/latin1/summary.txt diff --git a/core/io/encodings/utf16/tags.txt b/extra/io/encodings/latin1/tags.txt similarity index 100% rename from core/io/encodings/utf16/tags.txt rename to extra/io/encodings/latin1/tags.txt diff --git a/core/io/encodings/utf16/.utf16.factor.swo b/extra/io/encodings/utf16/.utf16.factor.swo similarity index 100% rename from core/io/encodings/utf16/.utf16.factor.swo rename to extra/io/encodings/utf16/.utf16.factor.swo diff --git a/core/io/encodings/utf16/authors.txt b/extra/io/encodings/utf16/authors.txt similarity index 100% rename from core/io/encodings/utf16/authors.txt rename to extra/io/encodings/utf16/authors.txt diff --git a/core/io/encodings/utf16/summary.txt b/extra/io/encodings/utf16/summary.txt similarity index 100% rename from core/io/encodings/utf16/summary.txt rename to extra/io/encodings/utf16/summary.txt diff --git a/extra/io/encodings/utf16/tags.txt b/extra/io/encodings/utf16/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/io/encodings/utf16/tags.txt @@ -0,0 +1 @@ +text diff --git a/core/io/encodings/utf16/utf16-docs.factor b/extra/io/encodings/utf16/utf16-docs.factor similarity index 100% rename from core/io/encodings/utf16/utf16-docs.factor rename to extra/io/encodings/utf16/utf16-docs.factor diff --git a/core/io/encodings/utf16/utf16-tests.factor b/extra/io/encodings/utf16/utf16-tests.factor similarity index 100% rename from core/io/encodings/utf16/utf16-tests.factor rename to extra/io/encodings/utf16/utf16-tests.factor diff --git a/core/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor similarity index 100% rename from core/io/encodings/utf16/utf16.factor rename to extra/io/encodings/utf16/utf16.factor From 641c61a966c5c7ea4c8cdc54ca0fa86fb9dcb319 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 21 Feb 2008 16:11:35 -0600 Subject: [PATCH 006/140] change to decoded#stream-read1 --- core/io/encodings/encodings.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index c1fd2c018c..5cb87da36f 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -113,7 +113,7 @@ M: decoded stream-read-until ] [ nip ] if ] [ nip ] if ; -M: decoded stream-read1 1 over stream-read ; +M: decoded stream-read1 1 swap stream-read ; M: decoded stream-readln ( stream -- str ) "\r\n" over stream-read-until handle-readln ; From fb9d7b05cd67cd69322af66ae6af4203f3e7c651 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 21 Feb 2008 18:03:07 -0600 Subject: [PATCH 007/140] Making everything load --- core/io/streams/lines/authors.txt | 1 - core/io/streams/lines/lines-docs.factor | 17 ------ core/io/streams/lines/lines-tests.factor | 58 ------------------- core/io/streams/lines/lines.factor | 7 --- core/io/streams/lines/summary.txt | 1 - .../sniffer/channels}/backend/backend.factor | 0 .../sniffer/channels}/bsd/bsd.factor | 0 .../sniffer/channels}/sniffer.factor | 0 .../sniffer/io}/authors.txt | 0 .../sniffer/io}/backend/authors.txt | 0 .../sniffer/io}/backend/backend.factor | 0 .../sniffer/io}/bsd/authors.txt | 0 .../sniffer/io}/bsd/bsd.factor | 2 +- .../sniffer/io}/filter/authors.txt | 0 .../sniffer/io}/filter/backend/authors.txt | 0 .../sniffer/io}/filter/backend/backend.factor | 0 .../sniffer/io}/filter/bsd/authors.txt | 0 .../sniffer/io}/filter/bsd/bsd.factor | 0 .../sniffer/io}/filter/filter.factor | 0 .../sniffer/io}/sniffer.factor | 0 20 files changed, 1 insertion(+), 85 deletions(-) delete mode 100644 core/io/streams/lines/authors.txt delete mode 100644 core/io/streams/lines/lines-docs.factor delete mode 100755 core/io/streams/lines/lines-tests.factor delete mode 100755 core/io/streams/lines/lines.factor delete mode 100644 core/io/streams/lines/summary.txt rename {extra/channels/sniffer => unmaintained/sniffer/channels}/backend/backend.factor (100%) rename {extra/channels/sniffer => unmaintained/sniffer/channels}/bsd/bsd.factor (100%) rename {extra/channels/sniffer => unmaintained/sniffer/channels}/sniffer.factor (100%) rename {extra/io/sniffer => unmaintained/sniffer/io}/authors.txt (100%) rename {extra/io/sniffer => unmaintained/sniffer/io}/backend/authors.txt (100%) rename {extra/io/sniffer => unmaintained/sniffer/io}/backend/backend.factor (100%) rename {extra/io/sniffer => unmaintained/sniffer/io}/bsd/authors.txt (100%) rename {extra/io/sniffer => unmaintained/sniffer/io}/bsd/bsd.factor (97%) rename {extra/io/sniffer => unmaintained/sniffer/io}/filter/authors.txt (100%) rename {extra/io/sniffer => unmaintained/sniffer/io}/filter/backend/authors.txt (100%) rename {extra/io/sniffer => unmaintained/sniffer/io}/filter/backend/backend.factor (100%) rename {extra/io/sniffer => unmaintained/sniffer/io}/filter/bsd/authors.txt (100%) rename {extra/io/sniffer => unmaintained/sniffer/io}/filter/bsd/bsd.factor (100%) rename {extra/io/sniffer => unmaintained/sniffer/io}/filter/filter.factor (100%) rename {extra/io/sniffer => unmaintained/sniffer/io}/sniffer.factor (100%) diff --git a/core/io/streams/lines/authors.txt b/core/io/streams/lines/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/core/io/streams/lines/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/core/io/streams/lines/lines-docs.factor b/core/io/streams/lines/lines-docs.factor deleted file mode 100644 index 789a060ed5..0000000000 --- a/core/io/streams/lines/lines-docs.factor +++ /dev/null @@ -1,17 +0,0 @@ -USING: help.markup help.syntax io strings ; -IN: io.streams.lines - -ARTICLE: "io.streams.lines" "Line reader streams" -"Line reader streams wrap an underlying stream and provide a default implementation of " { $link stream-readln } "." -{ $subsection line-reader } -{ $subsection } ; - -ABOUT: "io.streams.lines" - -HELP: line-reader -{ $class-description "An input stream which delegates to an underlying stream while providing an implementation of the " { $link stream-readln } " word in terms of the underlying stream's " { $link stream-read-until } ". Line readers are created by calling " { $link } "." } ; - -HELP: -{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } } -{ $description "Creates a new " { $link line-reader } "." } -{ $notes "Stream constructors should call this word to wrap streams that do not natively support reading lines. Unix (" { $snippet "\\n" } "), Windows (" { $snippet "\\r\\n" } ") and MacOS (" { $snippet "\\r" } ") line endings are supported." } ; diff --git a/core/io/streams/lines/lines-tests.factor b/core/io/streams/lines/lines-tests.factor deleted file mode 100755 index e3a4fe886a..0000000000 --- a/core/io/streams/lines/lines-tests.factor +++ /dev/null @@ -1,58 +0,0 @@ -USING: io.streams.lines io.files io.streams.string io -tools.test kernel io.encodings.ascii ; -IN: temporary - -: ( resource -- stream ) - resource-path ascii ; - -[ { } ] -[ "/core/io/test/empty-file.txt" lines ] -unit-test - -: lines-test ( stream -- line1 line2 ) - [ readln readln ] with-stream ; - -[ - "This is a line." - "This is another line." -] [ - "/core/io/test/windows-eol.txt" lines-test -] unit-test - -[ - "This is a line." - "This is another line." -] [ - "/core/io/test/mac-os-eol.txt" lines-test -] unit-test - -[ - "This is a line." - "This is another line." -] [ - "/core/io/test/unix-eol.txt" lines-test -] unit-test - -[ - "1234" -] [ - "Hello world\r\n1234" - dup stream-readln drop - 4 swap stream-read -] unit-test - -[ - "1234" -] [ - "Hello world\r\n1234" - dup stream-readln drop - 4 swap stream-read-partial -] unit-test - -[ - CHAR: 1 -] [ - "Hello world\r\n1234" - dup stream-readln drop - stream-read1 -] unit-test diff --git a/core/io/streams/lines/lines.factor b/core/io/streams/lines/lines.factor deleted file mode 100755 index 84ff272d69..0000000000 --- a/core/io/streams/lines/lines.factor +++ /dev/null @@ -1,7 +0,0 @@ -! Copyright (C) 2004, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -IN: io.streams.lines -! USING: io.encodings.latin1 io.encodings ; - -! : ( stream -- new-stream ) -! latin1 ; diff --git a/core/io/streams/lines/summary.txt b/core/io/streams/lines/summary.txt deleted file mode 100644 index 8c0c096f0b..0000000000 --- a/core/io/streams/lines/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Read lines of text from a character-oriented stream diff --git a/extra/channels/sniffer/backend/backend.factor b/unmaintained/sniffer/channels/backend/backend.factor similarity index 100% rename from extra/channels/sniffer/backend/backend.factor rename to unmaintained/sniffer/channels/backend/backend.factor diff --git a/extra/channels/sniffer/bsd/bsd.factor b/unmaintained/sniffer/channels/bsd/bsd.factor similarity index 100% rename from extra/channels/sniffer/bsd/bsd.factor rename to unmaintained/sniffer/channels/bsd/bsd.factor diff --git a/extra/channels/sniffer/sniffer.factor b/unmaintained/sniffer/channels/sniffer.factor similarity index 100% rename from extra/channels/sniffer/sniffer.factor rename to unmaintained/sniffer/channels/sniffer.factor diff --git a/extra/io/sniffer/authors.txt b/unmaintained/sniffer/io/authors.txt similarity index 100% rename from extra/io/sniffer/authors.txt rename to unmaintained/sniffer/io/authors.txt diff --git a/extra/io/sniffer/backend/authors.txt b/unmaintained/sniffer/io/backend/authors.txt similarity index 100% rename from extra/io/sniffer/backend/authors.txt rename to unmaintained/sniffer/io/backend/authors.txt diff --git a/extra/io/sniffer/backend/backend.factor b/unmaintained/sniffer/io/backend/backend.factor similarity index 100% rename from extra/io/sniffer/backend/backend.factor rename to unmaintained/sniffer/io/backend/backend.factor diff --git a/extra/io/sniffer/bsd/authors.txt b/unmaintained/sniffer/io/bsd/authors.txt similarity index 100% rename from extra/io/sniffer/bsd/authors.txt rename to unmaintained/sniffer/io/bsd/authors.txt diff --git a/extra/io/sniffer/bsd/bsd.factor b/unmaintained/sniffer/io/bsd/bsd.factor similarity index 97% rename from extra/io/sniffer/bsd/bsd.factor rename to unmaintained/sniffer/io/bsd/bsd.factor index 66336425a1..2a8a8e20c0 100644 --- a/extra/io/sniffer/bsd/bsd.factor +++ b/unmaintained/sniffer/io/bsd/bsd.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Elie Chaftari, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax destructors hexdump io -io.buffers io.nonblocking io.sockets io.streams.lines +io.buffers io.nonblocking io.sockets io.unix.backend io.unix.files kernel libc locals math qualified sequences io.sniffer.backend ; QUALIFIED: unix diff --git a/extra/io/sniffer/filter/authors.txt b/unmaintained/sniffer/io/filter/authors.txt similarity index 100% rename from extra/io/sniffer/filter/authors.txt rename to unmaintained/sniffer/io/filter/authors.txt diff --git a/extra/io/sniffer/filter/backend/authors.txt b/unmaintained/sniffer/io/filter/backend/authors.txt similarity index 100% rename from extra/io/sniffer/filter/backend/authors.txt rename to unmaintained/sniffer/io/filter/backend/authors.txt diff --git a/extra/io/sniffer/filter/backend/backend.factor b/unmaintained/sniffer/io/filter/backend/backend.factor similarity index 100% rename from extra/io/sniffer/filter/backend/backend.factor rename to unmaintained/sniffer/io/filter/backend/backend.factor diff --git a/extra/io/sniffer/filter/bsd/authors.txt b/unmaintained/sniffer/io/filter/bsd/authors.txt similarity index 100% rename from extra/io/sniffer/filter/bsd/authors.txt rename to unmaintained/sniffer/io/filter/bsd/authors.txt diff --git a/extra/io/sniffer/filter/bsd/bsd.factor b/unmaintained/sniffer/io/filter/bsd/bsd.factor similarity index 100% rename from extra/io/sniffer/filter/bsd/bsd.factor rename to unmaintained/sniffer/io/filter/bsd/bsd.factor diff --git a/extra/io/sniffer/filter/filter.factor b/unmaintained/sniffer/io/filter/filter.factor similarity index 100% rename from extra/io/sniffer/filter/filter.factor rename to unmaintained/sniffer/io/filter/filter.factor diff --git a/extra/io/sniffer/sniffer.factor b/unmaintained/sniffer/io/sniffer.factor similarity index 100% rename from extra/io/sniffer/sniffer.factor rename to unmaintained/sniffer/io/sniffer.factor From 8249ce21166dfc51618dbdbc3e0bc4e0dcd5a9a2 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 21 Feb 2008 18:05:04 -0600 Subject: [PATCH 008/140] OK, now everything should load --- core/alien/c-types/c-types.factor | 2 +- core/io/encodings/encodings.factor | 5 +++-- core/io/streams/byte-array/byte-array.factor | 4 ++-- core/io/streams/c/c-docs.factor | 2 +- core/io/streams/c/c.factor | 2 +- core/io/streams/plain/plain-docs.factor | 11 ++--------- core/listener/listener.factor | 4 ++-- core/parser/parser.factor | 2 +- core/source-files/source-files.factor | 2 +- core/vocabs/loader/loader.factor | 2 +- extra/crypto/sha1/sha1.factor | 2 +- extra/db/sqlite/test.db | Bin 0 -> 2048 bytes extra/documents/documents.factor | 2 +- extra/http/server/templating/templating.factor | 2 +- extra/io/encodings/utf16/utf16.factor | 2 -- extra/io/launcher/launcher.factor | 2 +- extra/io/nonblocking/nonblocking.factor | 2 +- extra/io/unix/backend/backend.factor | 4 ++-- extra/tools/browser/browser.factor | 2 +- extra/tools/deploy/macosx/macosx.factor | 2 +- extra/ui/gadgets/labels/labels.factor | 2 +- 21 files changed, 25 insertions(+), 33 deletions(-) create mode 100644 extra/db/sqlite/test.db diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 983fea0159..a67c7f4fb9 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: bit-arrays byte-arrays float-arrays arrays generator.registers assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations -system compiler.units io.encodings.binary ; +system compiler.units io.files io.encodings.binary ; IN: alien.c-types DEFER: diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 5cb87da36f..28cf36060b 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -90,7 +90,7 @@ TUPLE: decoded code cr ; M: decoded stream-read tuck { delegate decoded-code } get-slots decode-read fix-read ; -M: decoded stream-read-partial tuck stream-read fix-read ; +M: decoded stream-read-partial stream-read ; : read-until-loop ( stream delim -- ch ) ! Copied from { c-reader stream-read-until }!!! @@ -113,7 +113,8 @@ M: decoded stream-read-until ] [ nip ] if ] [ nip ] if ; -M: decoded stream-read1 1 swap stream-read ; +M: decoded stream-read1 + 1 swap stream-read [ first ] [ f ] if* ; M: decoded stream-readln ( stream -- str ) "\r\n" over stream-read-until handle-readln ; diff --git a/core/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor index eb224650f3..afbc94bf6a 100644 --- a/core/io/streams/byte-array/byte-array.factor +++ b/core/io/streams/byte-array/byte-array.factor @@ -3,14 +3,14 @@ sequences io namespaces ; IN: io.streams.byte-array : ( encoding -- stream ) - 512 swap ; + 512 swap ; : with-byte-writer ( encoding quot -- byte-array ) >r r> [ stdio get ] compose with-stream* >byte-array ; inline : ( byte-array encoding -- stream ) - >r >byte-vector dup reverse-here r> ; + >r >byte-vector dup reverse-here r> ; : with-byte-reader ( byte-array encoding quot -- ) >r r> with-stream ; inline diff --git a/core/io/streams/c/c-docs.factor b/core/io/streams/c/c-docs.factor index de8a756f92..d95e02321c 100644 --- a/core/io/streams/c/c-docs.factor +++ b/core/io/streams/c/c-docs.factor @@ -33,7 +33,7 @@ HELP: ( out -- stream ) HELP: { $values { "in" "a C FILE* handle" } { "out" "a C FILE* handle" } { "stream" "a new stream" } } -{ $description "Creates a stream which reads and writes data by calling C standard library functions, wrapping the input portion in a " { $link line-reader } " and the output portion in a " { $link plain-writer } "." } ; +{ $description "Creates a duplex stream which reads and writes data by calling C standard library functions." } ; HELP: fopen ( path mode -- alien ) { $values { "path" "a pathname string" } { "mode" "an access mode specifier" } { "alien" "a C FILE* handle" } } diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 8a6430eb86..7481c79cb5 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -14,7 +14,7 @@ M: c-writer stream-write1 >r 1string r> stream-write ; M: c-writer stream-write - c-writer-handle fwrite ; + >r >string r> c-writer-handle fwrite ; M: c-writer stream-flush c-writer-handle fflush ; diff --git a/core/io/streams/plain/plain-docs.factor b/core/io/streams/plain/plain-docs.factor index 4d7c5cc25e..a84e5be4f7 100644 --- a/core/io/streams/plain/plain-docs.factor +++ b/core/io/streams/plain/plain-docs.factor @@ -8,17 +8,10 @@ ARTICLE: "io.streams.plain" "Plain writer streams" { $link make-span-stream } ", " { $link make-block-stream } " and " { $link make-cell-stream } "." -{ $subsection plain-writer } -{ $subsection } ; +{ $subsection plain-writer } ; ABOUT: "io.streams.plain" HELP: plain-writer -{ $class-description "An output stream which delegates to an underlying stream while providing an implementation of the extended stream output protocol in a trivial way. Plain writers are created by calling " { $link } "." } -{ $see-also "stream-protocol" } ; - -HELP: -{ $values { "stream" "an input stream" } { "new-stream" "an input stream" } } -{ $description "Creates a new " { $link plain-writer } "." } -{ $notes "Stream constructors should call this word to wrap streams that do not natively support the extended stream output protocol." } +{ $class-description "An output stream mixin providing an implementation of the extended stream output protocol in a trivial way." } { $see-also "stream-protocol" } ; diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 288cb53322..a29d7d5802 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io kernel math memory namespaces -parser sequences strings io.styles io.streams.lines +parser sequences strings io.styles io.streams.duplex vectors words generic system combinators tuples continuations debugger definitions compiler.units ; IN: listener @@ -32,7 +32,7 @@ GENERIC: stream-read-quot ( stream -- quot/f ) 3drop f ] if ; -M: line-reader stream-read-quot +M: object stream-read-quot V{ } clone read-quot-loop ; M: duplex-stream stream-read-quot diff --git a/core/parser/parser.factor b/core/parser/parser.factor index fe9d2769c9..be527f11c7 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger -io.files io.streams.string io.streams.lines vocabs io.encodings.utf8 +io.files io.streams.string vocabs io.encodings.utf8 source-files classes hashtables compiler.errors compiler.units ; IN: parser diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index d2566982f8..185e9a1715 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger -io.files io.crc32 io.streams.string io.streams.lines vocabs +io.files io.crc32 io.streams.string vocabs hashtables graphs compiler.units io.encodings.utf8 ; IN: source-files diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 2d53ed82e2..9ea38c9cff 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces sequences io.files kernel assocs words vocabs definitions parser continuations inspector debugger io io.styles -io.streams.lines hashtables sorting prettyprint source-files +hashtables sorting prettyprint source-files arrays combinators strings system math.parser compiler.errors splitting ; IN: vocabs.loader diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 8f8b3e0cdd..eaad6df622 100644 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -1,6 +1,6 @@ USING: arrays combinators crypto.common kernel io io.encodings.binary io.files io.streams.string math.vectors strings sequences -namespaces math parser sequences vectors +namespaces math parser sequences vectors io.binary hashtables ; IN: crypto.sha1 diff --git a/extra/db/sqlite/test.db b/extra/db/sqlite/test.db new file mode 100644 index 0000000000000000000000000000000000000000..e483c47cea528c95f10fcf66fcbb67ffa351ffd1 GIT binary patch literal 2048 zcmWFz^vNtqRY=P(%1ta$FlJz3U}R))P*7lCU|k literal 0 HcmV?d00001 diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index 34ecce5f8e..993e69ec14 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel math models namespaces sequences strings -splitting io.streams.lines combinators unicode.categories ; +splitting combinators unicode.categories ; IN: documents : +col ( loc n -- newloc ) >r first2 r> + 2array ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index d15bec4fb2..046541d94e 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -2,7 +2,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel parser namespaces io -io.files io.streams.lines io.streams.string html html.elements +io.files io.streams.string html html.elements source-files debugger combinators math quotations generic strings splitting io.encodings.utf8 ; diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor index a241913fb5..3e10dcba35 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/extra/io/encodings/utf16/utf16.factor @@ -126,8 +126,6 @@ M: utf16be encode-string drop encode-utf16be ; M: utf16be decode-step drop decode-utf16be-step ; TUPLE: utf16 encoding ; -M: utf16 underlying-stream delegate dup delegate [ ] [ ] ?if ; ! necessary? -M: utf16 set-underlying-stream delegate set-delegate ; ! necessary? M: utf16 encode-string >r encode-utf16le r> diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 13ae64f159..00cce32303 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.backend io.timeouts system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader -init threads continuations math ; +init threads continuations math io.encodings ; IN: io.launcher ! Non-blocking process exit notification facility diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 0ae41f08fc..a8828afff6 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.nonblocking USING: math kernel io sequences io.buffers io.timeouts generic -sbufs system io.streams.lines io.streams.plain io.streams.duplex +sbufs system io.streams.plain io.streams.duplex io.encodings io.backend continuations debugger classes byte-arrays namespaces splitting dlists assocs ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index b1f4ee949d..d3873c60fe 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien generic assocs kernel kernel.private math io.nonblocking sequences strings structs sbufs -threads unix vectors io.buffers io.backend +threads unix vectors io.buffers io.backend io.encodings io.streams.duplex math.parser continuations system libc -qualified namespaces io.timeouts ; +qualified namespaces io.timeouts io.encodings.utf8 ; QUALIFIED: io IN: io.unix.backend diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index e56703a894..24836c1201 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces splitting sequences io.files kernel assocs words vocabs vocabs.loader definitions parser continuations -inspector debugger io io.styles io.streams.lines hashtables +inspector debugger io io.styles hashtables sorting prettyprint source-files arrays combinators strings system math.parser help.markup help.topics help.syntax help.stylesheet memoize io.encodings.utf8 ; diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index e4a0d539d1..bdbb7f1aee 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.files io.launcher kernel namespaces sequences system tools.deploy.backend tools.deploy.config assocs -hashtables prettyprint io.unix.backend cocoa +hashtables prettyprint io.unix.backend cocoa io.encodings.utf8 cocoa.application cocoa.classes cocoa.plists qualified ; QUALIFIED: unix IN: tools.deploy.macosx diff --git a/extra/ui/gadgets/labels/labels.factor b/extra/ui/gadgets/labels/labels.factor index 5e5801dd02..167aa26084 100755 --- a/extra/ui/gadgets/labels/labels.factor +++ b/extra/ui/gadgets/labels/labels.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io kernel math namespaces -opengl sequences io.streams.lines strings splitting +opengl sequences strings splitting ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors models ; IN: ui.gadgets.labels From 1b80c453fdb0acfc386b46c93ca572f0c99bc10b Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 21 Feb 2008 19:09:53 -0600 Subject: [PATCH 009/140] Little changes for encodings --- core/io/encodings/encodings.factor | 6 +++--- extra/io/unix/sockets/sockets.factor | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 28cf36060b..dfd9f9a36f 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -92,17 +92,17 @@ M: decoded stream-read M: decoded stream-read-partial stream-read ; -: read-until-loop ( stream delim -- ch ) +: decoded-read-until ( stream delim -- ch ) ! Copied from { c-reader stream-read-until }!!! over stream-read1 dup [ - dup pick memq? [ 2nip ] [ , read-until-loop ] if + dup pick memq? [ 2nip ] [ , decoded-read-until ] if ] [ 2nip ] if ; M: decoded stream-read-until ! Copied from { c-reader stream-read-until }!!! - [ swap read-until-loop ] "" make + [ swap decoded-read-until ] "" make swap over empty? over not and [ 2drop f f ] when ; : fix-read1 ( stream char -- char ) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 60a49aadd2..b78abbe11b 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -48,7 +48,7 @@ M: unix-io (client) ( addrspec -- stream ) dup r> r> connect zero? err_no EINPROGRESS = or [ dup init-client-socket - dup handle>duplex-stream + dup f handle>duplex-stream dup duplex-stream-out dup wait-to-connect pending-init-error From 72e15848bf63c0efd4a909e0a2223e313b5526d3 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 22 Feb 2008 20:21:23 -0600 Subject: [PATCH 010/140] More changes for encodings --- core/bootstrap/image/image.factor | 3 +-- core/io/encodings/encodings.factor | 19 +++++++++++++++---- core/io/encodings/utf8/utf8-tests.factor | 4 ++-- core/io/io-tests.factor | 4 ++-- core/io/streams/c/c-tests.factor | 2 +- core/io/streams/string/string.factor | 10 +++++++--- extra/io/encodings/ascii/ascii.factor | 6 +++--- extra/io/encodings/latin1/latin1.factor | 2 +- extra/io/encodings/utf16/utf16-tests.factor | 4 ++-- extra/io/nonblocking/nonblocking.factor | 9 ++++----- extra/io/unix/backend/backend.factor | 2 +- extra/io/unix/launcher/launcher.factor | 2 +- extra/io/unix/sockets/sockets.factor | 2 +- extra/xmode/utilities/utilities-tests.factor | 2 +- 14 files changed, 42 insertions(+), 29 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 36cfad828e..241511c00d 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -416,8 +416,7 @@ M: curry ' "Writing image to " write architecture get boot-image-name resource-path dup write "..." print flush - ! binary - [ (write-image) ] with-stream ; + binary [ (write-image) ] with-stream ; PRIVATE> diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index dfd9f9a36f..8267ad5217 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -3,7 +3,7 @@ USING: math kernel sequences sbufs vectors namespaces growable strings io classes continuations combinators io.styles io.streams.plain io.encodings.binary splitting -io.streams.string io.streams.duplex ; +io.streams.duplex ; IN: io.encodings ! Decoding @@ -50,7 +50,7 @@ GENERIC: decode-step ( buf byte ch state encoding -- buf ch state ) ] if ; : decode-read ( length stream encoding -- string ) - >r swap start-decoding r> + >r swap >fixnum start-decoding r> decode-read-loop ; TUPLE: decoded code cr ; @@ -114,7 +114,7 @@ M: decoded stream-read-until ] [ nip ] if ; M: decoded stream-read1 - 1 swap stream-read [ first ] [ f ] if* ; + 1 swap stream-read f like [ first ] [ f ] if* ; M: decoded stream-readln ( stream -- str ) "\r\n" over stream-read-until handle-readln ; @@ -127,7 +127,10 @@ TUPLE: encode-error ; TUPLE: encoded code ; : ( stream encoding-class -- encoded-stream ) - construct-empty { set-delegate set-encoded-code } encoded construct ; + dup binary eq? [ drop ] [ + construct-empty { set-delegate set-encoded-code } + encoded construct + ] if ; GENERIC: encode-string ( string encoding -- byte-array ) M: tuple-class encode-string construct-empty encode-string ; @@ -153,3 +156,11 @@ INSTANCE: encoded plain-writer : ( duplex-stream encoding -- duplex-stream ) swap { duplex-stream-in duplex-stream-out } get-slots pick reencode >r swap redecode r> ; + +! The null encoding does nothing +! (used to wrap things as line-reader/plain-writer) +! Later this will be replaced by inheritance + +TUPLE: null-encoding ; +M: null-encoding encode-string drop ; +M: null-encoding decode-step 3drop over push f f ; diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor index 44d0870385..a6a32041be 100644 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -2,10 +2,10 @@ USING: io.encodings.utf8 tools.test sbufs kernel io io.encodings sequences strings arrays unicode ; : decode-utf8-w/stream ( array -- newarray ) - >sbuf dup reverse-here utf8 contents ; + >sbuf dup reverse-here utf8 contents ; : encode-utf8-w/stream ( array -- newarray ) - SBUF" " clone tuck utf8 stream-write >array ; + SBUF" " clone tuck utf8 stream-write >array ; [ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 74b6b5034f..394deb0e5c 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,5 +1,5 @@ USING: arrays io io.files kernel math parser strings system -tools.test words namespaces io.encodings.ascii io.encodings.binary ; +tools.test words namespaces io.encodings.latin1 io.encodings.binary ; IN: temporary [ f ] [ @@ -8,7 +8,7 @@ IN: temporary ] unit-test : ( resource -- stream ) - resource-path ascii ; + resource-path latin1 ; [ "This is a line.\rThis is another line.\r" diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 66ea460126..cc2aa9dde0 100755 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test io.files io io.streams.c ; +USING: tools.test io.files io io.streams.c io.encodings.ascii ; IN: temporary [ "hello world" ] [ diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index f74f91c5bd..e1c14e6ee3 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.string USING: io kernel math namespaces sequences sbufs strings -generic splitting growable continuations io.streams.plain ; +generic splitting growable continuations io.streams.plain +io.encodings ; M: growable dispose drop ; @@ -23,7 +24,7 @@ M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ; underlying like ; : growable-read-until ( growable n -- str ) - dupd tail-slice swap harden-as dup reverse-here ; + >fixnum dupd tail-slice swap harden-as dup reverse-here ; : find-last-sep swap [ memq? ] curry find-last drop ; @@ -49,7 +50,7 @@ M: growable stream-read-partial stream-read ; : ( str -- stream ) - >sbuf dup reverse-here ; + >sbuf dup reverse-here null-encoding ; : with-string-reader ( str quot -- ) >r r> with-stream ; inline @@ -74,3 +75,6 @@ M: plain-writer stream-write-table [ drop format-table [ print ] each ] with-stream* ; M: plain-writer make-cell-stream 2drop ; + +M: growable stream-readln ( stream -- str ) + "\r\n" over stream-read-until handle-readln ; diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor index 410c07f1ca..0878a7a624 100644 --- a/extra/io/encodings/ascii/ascii.factor +++ b/extra/io/encodings/ascii/ascii.factor @@ -3,13 +3,13 @@ USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ; IN: io.encodings.ascii -: encode-check>= ( string max -- byte-array ) - dupd [ >= ] curry all? [ >byte-array ] [ encode-error ] if ; +: encode-check<= ( string max -- byte-array ) + dupd [ <= ] curry all? [ >byte-array ] [ encode-error ] if ; TUPLE: ascii ; M: ascii encode-string - drop 127 encode-check>= ; + drop 127 encode-check<= ; M: ascii decode-step 3drop dup 127 >= [ encode-error ] when over push f f ; diff --git a/extra/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor index 7e867b15af..b914589dc9 100755 --- a/extra/io/encodings/latin1/latin1.factor +++ b/extra/io/encodings/latin1/latin1.factor @@ -6,7 +6,7 @@ IN: io.encodings.latin1 TUPLE: latin1 ; M: latin1 encode-string - drop 255 encode-check>= ; + drop 255 encode-check<= ; M: latin1 decode-step 3drop over push f f ; diff --git a/extra/io/encodings/utf16/utf16-tests.factor b/extra/io/encodings/utf16/utf16-tests.factor index 041c486915..1677c2d38d 100755 --- a/extra/io/encodings/utf16/utf16-tests.factor +++ b/extra/io/encodings/utf16/utf16-tests.factor @@ -2,10 +2,10 @@ USING: kernel tools.test io.encodings.utf16 arrays sbufs sequences io.encodings io unicode ; : decode-w/stream ( array encoding -- newarray ) - >r >sbuf dup reverse-here r> contents >array ; + >r >sbuf dup reverse-here r> contents >array ; : encode-w/stream ( array encoding -- newarray ) - >r SBUF" " clone tuck r> stream-write >array ; + >r SBUF" " clone tuck r> stream-write >array ; [ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode-w/stream ] unit-test [ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode-w/stream ] unit-test diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index a8828afff6..21bb284805 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -39,15 +39,14 @@ GENERIC: close-handle ( handle -- ) : ( handle type -- port ) default-buffer-size get swap ; -: ( handle -- stream ) +: ( handle -- input-port ) input-port ; -: ( handle -- stream ) +: ( handle -- output-port ) output-port ; -: handle>duplex-stream ( in-handle out-handle encoding -- stream ) - [ swap swap ] keep - [ -rot >r swap r> ] +: handle>duplex-stream ( in-handle out-handle -- stream ) + [ swap swap ] [ ] [ dispose ] cleanup ; : pending-error ( port -- ) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index d3873c60fe..e0921f6f02 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -182,7 +182,7 @@ M: unix-io io-multiplex ( ms -- ) mx get-global wait-for-events ; M: unix-io init-stdio ( -- ) - 0 1 utf8 handle>duplex-stream io:stdio set-global + 0 1 handle>duplex-stream io:stdio utf8 set-global 2 utf8 io:stderr set-global ; ! mx io-task for embedding an fd-based mx inside another mx diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 128adbc3dc..deff2d2642 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -99,7 +99,7 @@ M: unix-io kill-process* ( pid -- ) M: unix-io process-stream* [ - spawn-process-stream >r latin1 handle>duplex-stream r> + spawn-process-stream >r handle>duplex-stream r> ] with-descriptor ; : find-process ( handle -- process ) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index b78abbe11b..60a49aadd2 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -48,7 +48,7 @@ M: unix-io (client) ( addrspec -- stream ) dup r> r> connect zero? err_no EINPROGRESS = or [ dup init-client-socket - dup f handle>duplex-stream + dup handle>duplex-stream dup duplex-stream-out dup wait-to-connect pending-init-error diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor index 713700bf7a..820d1bcc9a 100755 --- a/extra/xmode/utilities/utilities-tests.factor +++ b/extra/xmode/utilities/utilities-tests.factor @@ -49,5 +49,5 @@ TAGS> } ] [ "extra/xmode/utilities/test.xml" - resource-path read-xml parse-company-tag + resource-path file>xml parse-company-tag ] unit-test From a4963a92171063bfacaa149510236ffc1072b793 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 22 Feb 2008 20:41:14 -0600 Subject: [PATCH 011/140] Fixing Unix/Windows init-stdio --- extra/io/unix/backend/backend.factor | 2 +- extra/io/windows/ce/backend/backend.factor | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index e0921f6f02..641b3ebd24 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -182,7 +182,7 @@ M: unix-io io-multiplex ( ms -- ) mx get-global wait-for-events ; M: unix-io init-stdio ( -- ) - 0 1 handle>duplex-stream io:stdio utf8 set-global + 0 1 handle>duplex-stream utf8 io:stdio set-global 2 utf8 io:stderr set-global ; ! mx io-task for embedding an fd-based mx inside another mx diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index e90a9f16e2..349276fe72 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -1,7 +1,7 @@ USING: io.nonblocking io.windows threads.private kernel io.backend windows.winsock windows.kernel32 windows io.streams.duplex io namespaces alien.syntax system combinators -io.buffers ; +io.buffers io.encodings io.encodings.utf8 ; IN: io.windows.ce.backend : port-errored ( port -- ) @@ -41,5 +41,5 @@ M: windows-ce-io init-stdio ( -- ) ] [ 0 _getstdfilex _fileno 1 _getstdfilex _fileno - ] if + ] if utf8 ] with-variable stdio set-global ; From 75f1fb5246a93183ba58b2ffd2c2099394a68b76 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 24 Feb 2008 01:37:05 -0600 Subject: [PATCH 012/140] Various refactorings of streams with encodings --- core/io/backend/backend.factor | 8 +++++-- core/io/encodings/encodings.factor | 5 ++--- core/io/files/files.factor | 12 +++++------ core/io/streams/c/c-docs.factor | 5 ----- core/io/streams/c/c.factor | 17 +++++++-------- extra/io/launcher/launcher.factor | 5 ++--- extra/io/nonblocking/nonblocking.factor | 17 +++++++-------- extra/io/sockets/sockets.factor | 20 +++++++++++------- extra/io/unix/backend/backend.factor | 7 ++++--- extra/io/unix/files/files.factor | 6 +++--- extra/io/unix/launcher/launcher.factor | 4 ++-- extra/io/unix/sockets/sockets.factor | 22 +++++++++----------- extra/io/windows/ce/backend/backend.factor | 11 ++++++---- extra/io/windows/ce/sockets/sockets.factor | 18 +++++++--------- extra/io/windows/nt/launcher/launcher.factor | 8 ++++--- extra/io/windows/nt/sockets/sockets.factor | 22 +++++++++----------- extra/io/windows/windows.factor | 9 +++----- 17 files changed, 96 insertions(+), 100 deletions(-) diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index c38b7355b1..2824b6a299 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,13 +1,17 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: init kernel system namespaces ; +USING: init kernel system namespaces io io.encodings io.encodings.utf8 ; IN: io.backend SYMBOL: io-backend HOOK: init-io io-backend ( -- ) -HOOK: init-stdio io-backend ( -- ) +HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ) + +: init-stdio ( -- ) + (init-stdio) utf8 stderr set-global + utf8 stdio set-global ; HOOK: io-multiplex io-backend ( ms -- ) diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 8267ad5217..670a235615 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -153,9 +153,8 @@ INSTANCE: encoded plain-writer : redecode ( stream encoding -- newstream ) over decoded? [ >r delegate r> ] when ; -: ( duplex-stream encoding -- duplex-stream ) - swap { duplex-stream-in duplex-stream-out } get-slots - pick reencode >r swap redecode r> ; +: ( stream-in stream-out encoding -- duplex-stream ) + tuck reencode >r redecode r> ; ! The null encoding does nothing ! (used to wrap things as line-reader/plain-writer) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 491cc6e81a..4a04be3bfe 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -10,20 +10,20 @@ HOOK: cd io-backend ( path -- ) HOOK: cwd io-backend ( -- path ) -HOOK: file-reader* io-backend ( path -- stream ) +HOOK: (file-reader) io-backend ( path -- stream ) -HOOK: file-writer* io-backend ( path -- stream ) +HOOK: (file-writer) io-backend ( path -- stream ) -HOOK: file-appender* io-backend ( path -- stream ) +HOOK: (file-appender) io-backend ( path -- stream ) : ( path encoding -- stream ) - swap file-reader* swap ; + swap (file-reader) swap ; : ( path encoding -- stream ) - swap file-writer* swap ; + swap (file-writer) swap ; : ( path encoding -- stream ) - swap file-appender* swap ; + swap (file-appender) swap ; HOOK: delete-file io-backend ( path -- ) diff --git a/core/io/streams/c/c-docs.factor b/core/io/streams/c/c-docs.factor index d95e02321c..5d9c7b1a53 100644 --- a/core/io/streams/c/c-docs.factor +++ b/core/io/streams/c/c-docs.factor @@ -6,7 +6,6 @@ ARTICLE: "io.streams.c" "ANSI C streams" "C streams are found in the " { $vocab-link "io.streams.c" } " vocabulary; they are " { $link "stream-protocol" } " implementations which read and write C " { $snippet "FILE*" } " handles." { $subsection } { $subsection } -{ $subsection } "Underlying primitives used to implement the above:" { $subsection fopen } { $subsection fwrite } @@ -31,10 +30,6 @@ HELP: ( out -- stream ) { $description "Creates a stream which writes data by calling C standard library functions." } { $notes "Usually C streams are only used during bootstrap, and non-blocking OS-specific I/O routines are used during normal operation." } ; -HELP: -{ $values { "in" "a C FILE* handle" } { "out" "a C FILE* handle" } { "stream" "a new stream" } } -{ $description "Creates a duplex stream which reads and writes data by calling C standard library functions." } ; - HELP: fopen ( path mode -- alien ) { $values { "path" "a pathname string" } { "mode" "an access mode specifier" } { "alien" "a C FILE* handle" } } { $description "Opens a file named by " { $snippet "path" } ". The " { $snippet "mode" } " parameter should be something like " { $snippet "\"r\"" } " or " { $snippet "\"rw\"" } "; consult the " { $snippet "fopen(3)" } " manual page for details." } diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 7481c79cb5..164d0d5f58 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -49,29 +49,26 @@ M: c-reader stream-read-until M: c-reader dispose c-reader-handle fclose ; -: ( in out -- stream ) - >r r> ; - M: object init-io ; : stdin-handle 11 getenv ; : stdout-handle 12 getenv ; : stderr-handle 38 getenv ; -M: object init-stdio - stdin-handle stdout-handle - utf8 stdio set-global - stderr-handle utf8 stderr set-global ; +M: object (init-stdio) + stdin-handle + stdout-handle + stderr-handle ; M: object io-multiplex (sleep) ; -M: object file-reader* +M: object (file-reader) "rb" fopen ; -M: object file-writer* +M: object (file-writer) "wb" fopen ; -M: object file-appender* +M: object (file-appender) "ab" fopen ; : show ( msg -- ) diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 00cce32303..fb162fb3c8 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -119,14 +119,13 @@ M: process get-lapse process-lapse ; M: process timed-out kill-process ; -HOOK: process-stream* io-backend ( desc -- stream process ) -! Process streams are always latin1 for now; will be updated +HOOK: (process-stream) io-backend ( desc -- in out process ) TUPLE: process-stream process ; : ( desc encoding -- stream ) swap >descriptor - [ process-stream* >r swap r> ] keep + [ (process-stream) >r rot r> ] keep +timeout+ swap at [ over set-timeout ] when* { set-delegate set-process-stream-process } process-stream construct ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 21bb284805..b16005b4e5 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.nonblocking USING: math kernel io sequences io.buffers io.timeouts generic -sbufs system io.streams.plain io.streams.duplex io.encodings +sbufs system io.streams.duplex io.encodings io.backend continuations debugger classes byte-arrays namespaces -splitting dlists assocs ; +splitting dlists assocs io.encodings.binary ; SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global @@ -45,9 +45,8 @@ GENERIC: close-handle ( handle -- ) : ( handle -- output-port ) output-port ; -: handle>duplex-stream ( in-handle out-handle -- stream ) - [ swap swap ] - [ ] [ dispose ] cleanup ; +: ( read-handle write-handle -- input-port output-port ) + swap [ swap ] [ dispose ] cleanup ; : pending-error ( port -- ) dup port-error f rot set-port-error [ throw ] when* ; @@ -171,11 +170,11 @@ M: port dispose [ dup port-type >r closed over set-port-type r> close-port ] if ; -TUPLE: server-port addr client ; +TUPLE: server-port addr client encoding ; -: ( handle addr -- server ) - >r f server-port r> - { set-delegate set-server-port-addr } +: ( handle addr encoding -- server ) + rot f server-port + { set-server-port-addr set-server-port-encoding set-delegate } server-port construct ; : check-server-port ( port -- ) diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 6cf75f2f60..07e4f0afca 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -IN: io.sockets USING: generic kernel io.backend namespaces continuations -sequences arrays io.encodings ; +sequences arrays io.encodings io.nonblocking ; +IN: io.sockets TUPLE: local path ; @@ -26,18 +26,24 @@ TUPLE: client-stream addr ; { set-client-stream-addr set-delegate } client-stream construct ; -HOOK: (client) io-backend ( addrspec -- stream ) +HOOK: (client) io-backend ( addrspec -- client-in client-out ) -GENERIC: client* ( addrspec -- stream ) +GENERIC: client* ( addrspec -- client-in client-out ) M: array client* [ (client) ] attempt-all ; M: object client* (client) ; : ( addrspec encoding -- stream ) - >r client* r> ; + [ >r client* r> ] keep ; -HOOK: io-backend ( addrspec -- server ) +HOOK: (server) io-backend ( addrspec -- handle ) -HOOK: accept io-backend ( server -- client ) +: ( addrspec encoding -- server ) + >r [ (server) ] keep r> ; + +HOOK: (accept) io-backend ( server -- stream-in stream-out ) + +: accept ( server -- client ) + [ (accept) ] keep server-port-encoding ; HOOK: io-backend ( addrspec -- datagram ) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 641b3ebd24..4d6e839989 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -181,9 +181,10 @@ M: port port-flush ( port -- ) M: unix-io io-multiplex ( ms -- ) mx get-global wait-for-events ; -M: unix-io init-stdio ( -- ) - 0 1 handle>duplex-stream utf8 io:stdio set-global - 2 utf8 io:stderr set-global ; +M: unix-io (init-stdio) ( -- ) + 0 + 1 + 2 ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port mx ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 7a7128d5b6..a156d3b80c 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -17,7 +17,7 @@ M: unix-io cd : open-read ( path -- fd ) O_RDONLY file-mode open dup io-error ; -M: unix-io file-reader* ( path -- stream ) +M: unix-io (file-reader) ( path -- stream ) open-read ; : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline @@ -25,7 +25,7 @@ M: unix-io file-reader* ( path -- stream ) : open-write ( path -- fd ) write-flags file-mode open dup io-error ; -M: unix-io file-writer* ( path -- stream ) +M: unix-io (file-writer) ( path -- stream ) open-write ; : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline @@ -34,7 +34,7 @@ M: unix-io file-writer* ( path -- stream ) append-flags file-mode open dup io-error [ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ; -M: unix-io file-appender* ( path -- stream ) +M: unix-io (file-appender) ( path -- stream ) open-append ; M: unix-io rename-file ( from to -- ) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index deff2d2642..8384c2fce6 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -97,9 +97,9 @@ M: unix-io kill-process* ( pid -- ) -rot 2dup second close first close ] with-fork first swap second rot ; -M: unix-io process-stream* +M: unix-io (process-stream) [ - spawn-process-stream >r handle>duplex-stream r> + spawn-process-stream >r r> ] with-descriptor ; : find-process ( handle -- process ) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 60a49aadd2..2af77e83c4 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -3,12 +3,12 @@ ! We need to fiddle with the exact search order here, since ! unix::accept shadows streams::accept. -IN: io.unix.sockets USING: alien alien.c-types generic io kernel math namespaces io.nonblocking parser threads unix sequences byte-arrays io.sockets io.binary io.unix.backend io.streams.duplex io.sockets.impl math.parser continuations libc combinators ; +IN: io.unix.sockets : pending-init-error ( port -- ) #! We close it here to avoid a resource leak; callers of @@ -48,10 +48,9 @@ M: unix-io (client) ( addrspec -- stream ) dup r> r> connect zero? err_no EINPROGRESS = or [ dup init-client-socket - dup handle>duplex-stream - dup duplex-stream-out + dup dup wait-to-connect - pending-init-error + dup pending-init-error ] [ dup close (io-error) ] if ; @@ -74,7 +73,7 @@ TUPLE: accept-task ; : do-accept ( port fd sockaddr -- ) rot [ server-port-addr parse-sockaddr - swap dup handle>duplex-stream + swap dup ] keep set-server-port-client ; M: accept-task do-io-task @@ -92,18 +91,17 @@ USE: io.sockets dup rot make-sockaddr/size bind zero? [ dup close (io-error) ] unless ; -M: unix-io ( addrspec -- server ) - [ - SOCK_STREAM server-fd - dup 10 listen zero? [ dup close (io-error) ] unless - ] keep ; +M: unix-io (server) ( addrspec -- handle ) + SOCK_STREAM server-fd + dup 10 listen zero? [ dup close (io-error) ] unless ; -M: unix-io accept ( server -- client ) +M: unix-io (accept) ( server -- client-in client-out ) #! Wait for a client connection. dup check-server-port dup wait-to-accept dup pending-error - server-port-client ; + server-port-client + { duplex-stream-in duplex-stream-out } get-slots ; ! Datagram sockets - UDP and Unix domain M: unix-io diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index 349276fe72..26135521ff 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -1,7 +1,7 @@ USING: io.nonblocking io.windows threads.private kernel io.backend windows.winsock windows.kernel32 windows io.streams.duplex io namespaces alien.syntax system combinators -io.buffers io.encodings io.encodings.utf8 ; +io.buffers io.encodings io.encodings.utf8 combinators.lib ; IN: io.windows.ce.backend : port-errored ( port -- ) @@ -31,15 +31,18 @@ LIBRARY: libc FUNCTION: void* _getstdfilex int fd ; FUNCTION: void* _fileno void* file ; -M: windows-ce-io init-stdio ( -- ) +M: windows-ce-io (init-stdio) ( -- ) #! We support Windows NT too, to make this I/O backend #! easier to debug. 512 default-buffer-size [ winnt? [ STD_INPUT_HANDLE GetStdHandle STD_OUTPUT_HANDLE GetStdHandle + STD_ERROR_HANDLE GetStdHandle ] [ 0 _getstdfilex _fileno 1 _getstdfilex _fileno - ] if utf8 - ] with-variable stdio set-global ; + 2 _getstdfilex _fileno + ] if [ f ] 3apply + rot -rot [ ] 2apply + ] with-variable ; diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index e9ca6220af..9bc583a3d8 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -31,17 +31,15 @@ M: win32-socket wince-write ( port port-handle -- ) windows.winsock:WSAConnect windows.winsock:winsock-error!=0/f ; -M: windows-ce-io (client) ( addrspec -- duplex-stream ) - do-connect dup handle>duplex-stream ; +M: windows-ce-io (client) ( addrspec -- reader writer ) + do-connect dup ; -M: windows-ce-io ( addrspec -- duplex-stream ) - [ - windows.winsock:SOCK_STREAM server-fd - dup listen-on-socket - - ] keep ; +M: windows-ce-io (server) ( addrspec -- handle ) + windows.winsock:SOCK_STREAM server-fd + dup listen-on-socket + ; -M: windows-ce-io accept ( server -- client ) +M: windows-ce-io (accept) ( server -- client ) [ dup check-server-port [ @@ -54,7 +52,7 @@ M: windows-ce-io accept ( server -- client ) [ windows.winsock:winsock-error ] when ] keep ] keep server-port-addr parse-sockaddr swap - dup handle>duplex-stream + ] with-timeout ; M: windows-ce-io ( addrspec -- datagram ) diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index cd9bb9baef..f84dcc154c 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -87,7 +87,7 @@ M: windows-nt-io fill-redirection over redirect-stdin over set-STARTUPINFO-hStdInput drop ; -M: windows-nt-io process-stream* +M: windows-nt-io (process-stream) [ [ make-CreateProcess-args @@ -103,8 +103,10 @@ M: windows-nt-io process-stream* dup CreateProcess-args-stdout-pipe pipe-out CloseHandle drop dup CreateProcess-args-stdout-pipe pipe-in - over CreateProcess-args-stdin-pipe pipe-out + over CreateProcess-args-stdin-pipe pipe-out - swap CreateProcess-args-lpProcessInformation + [ f ] 2apply + + rot CreateProcess-args-lpProcessInformation ] with-destructors ] with-descriptor ; diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index eef7476dd5..7af7df9bef 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -61,7 +61,8 @@ M: windows-nt-io (client) ( addrspec -- duplex-stream ) dup ConnectEx-args-s* INADDR_ANY roll bind-socket dup (ConnectEx) - dup ConnectEx-args-s* dup handle>duplex-stream + dup ConnectEx-args-s* + dup over set-ConnectEx-args-port dup connect-continuation @@ -91,7 +92,7 @@ TUPLE: AcceptEx-args port f over set-AcceptEx-args-lpdwBytesReceived* (make-overlapped) swap set-AcceptEx-args-lpOverlapped* ; -: (accept) ( AcceptEx -- ) +: ((accept)) ( AcceptEx -- ) \ AcceptEx-args >tuple*< AcceptEx drop winsock-error-string [ throw ] when* ; @@ -125,16 +126,15 @@ TUPLE: AcceptEx-args port [ AcceptEx-args-sAcceptSocket* add-completion ] keep - AcceptEx-args-sAcceptSocket* dup handle>duplex-stream - ; + AcceptEx-args-sAcceptSocket* ; -M: windows-nt-io accept ( server -- client ) +M: windows-nt-io (accept) ( server -- client-in client-out ) [ [ dup check-server-port \ AcceptEx-args construct-empty [ init-accept ] keep - [ (accept) ] keep + [ ((accept)) ] keep [ accept-continuation ] keep AcceptEx-args-port pending-error dup duplex-stream-in pending-error @@ -142,13 +142,11 @@ M: windows-nt-io accept ( server -- client ) ] with-timeout ] with-destructors ; -M: windows-nt-io ( addrspec -- server ) +M: windows-nt-io (server) ( addrspec -- handle ) [ - [ - SOCK_STREAM server-fd dup listen-on-socket - dup add-completion - - ] keep + SOCK_STREAM server-fd dup listen-on-socket + dup add-completion + ] with-destructors ; M: windows-nt-io ( addrspec -- datagram ) diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index dc0b14f627..b5da867c56 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -20,9 +20,6 @@ TUPLE: win32-file handle ptr ; C: win32-file -: ( in out -- stream ) - >r f r> f handle>duplex-stream ; - HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: add-completion io-backend ( port -- ) @@ -112,13 +109,13 @@ C: FileArgs [ FileArgs-lpNumberOfBytesRet ] keep FileArgs-lpOverlapped ; -M: windows-io file-reader* ( path -- stream ) +M: windows-io (file-reader) ( path -- stream ) open-read ; -M: windows-io file-writer* ( path -- stream ) +M: windows-io (file-writer) ( path -- stream ) open-write ; -M: windows-io file-appender* ( path -- stream ) +M: windows-io (file-appender) ( path -- stream ) open-append ; M: windows-io rename-file ( from to -- ) From 44f4aa4c69e44199a5bcad9c5ab3b5b9e8678061 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 24 Feb 2008 19:58:34 -0600 Subject: [PATCH 013/140] More updates for encodings --- core/io/backend/backend.factor | 8 ++++---- core/io/encodings/binary/binary-docs.factor | 2 +- core/io/encodings/encodings.factor | 10 +++++----- core/io/encodings/utf8/utf8-docs.factor | 19 ++++++------------- core/io/encodings/utf8/utf8-tests.factor | 6 +++--- core/io/files/files.factor | 8 ++++---- core/io/io-tests.factor | 4 ++-- core/io/streams/byte-array/byte-array.factor | 4 ++-- core/io/streams/string/string.factor | 2 +- extra/io/encodings/utf16/utf16-tests.factor | 8 ++++---- extra/io/launcher/launcher.factor | 2 +- extra/io/nonblocking/nonblocking.factor | 2 +- extra/io/sockets/sockets-docs.factor | 7 ++++--- extra/io/sockets/sockets.factor | 4 ++-- 14 files changed, 40 insertions(+), 46 deletions(-) diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 2824b6a299..6f41814ce9 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -10,8 +10,8 @@ HOOK: init-io io-backend ( -- ) HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ) : init-stdio ( -- ) - (init-stdio) utf8 stderr set-global - utf8 stdio set-global ; + (init-stdio) utf8 stderr set-global + utf8 stdio set-global ; HOOK: io-multiplex io-backend ( ms -- ) @@ -23,8 +23,8 @@ HOOK: normalize-pathname io-backend ( str -- newstr ) M: object normalize-pathname ; -: set-io-backend ( backend -- ) - io-backend set-global init-io init-stdio ; +: set-io-backend ( io-backend -- ) + io-backend set-global init-io init-stdio die ; [ init-io embedded? [ init-stdio ] unless ] "io.backend" add-init-hook diff --git a/core/io/encodings/binary/binary-docs.factor b/core/io/encodings/binary/binary-docs.factor index f8be5054df..823eea67be 100644 --- a/core/io/encodings/binary/binary-docs.factor +++ b/core/io/encodings/binary/binary-docs.factor @@ -2,4 +2,4 @@ USING: help.syntax help.markup ; IN: io.encodings.binary HELP: binary -{ $class-description "This is the encoding descriptor for binary I/O." } ; +{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." } ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 670a235615..79079929bb 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -54,7 +54,7 @@ GENERIC: decode-step ( buf byte ch state encoding -- buf ch state ) decode-read-loop ; TUPLE: decoded code cr ; -: ( stream decoding-class -- decoded-stream ) +: ( stream decoding-class -- decoded-stream ) dup binary eq? [ drop ] [ construct-empty { set-delegate set-decoded-code } decoded construct @@ -126,7 +126,7 @@ TUPLE: encode-error ; : encode-error ( -- * ) \ encode-error construct-empty throw ; TUPLE: encoded code ; -: ( stream encoding-class -- encoded-stream ) +: ( stream encoding-class -- encoded-stream ) dup binary eq? [ drop ] [ construct-empty { set-delegate set-encoded-code } encoded construct @@ -148,12 +148,12 @@ INSTANCE: encoded plain-writer ! Rebinding duplex streams which have not read anything yet : reencode ( stream encoding -- newstream ) - over encoded? [ >r delegate r> ] when ; + over encoded? [ >r delegate r> ] when ; : redecode ( stream encoding -- newstream ) - over decoded? [ >r delegate r> ] when ; + over decoded? [ >r delegate r> ] when ; -: ( stream-in stream-out encoding -- duplex-stream ) +: ( stream-in stream-out encoding -- duplex-stream ) tuck reencode >r redecode r> ; ! The null encoding does nothing diff --git a/core/io/encodings/utf8/utf8-docs.factor b/core/io/encodings/utf8/utf8-docs.factor index 6e1923824f..734a7f7236 100755 --- a/core/io/encodings/utf8/utf8-docs.factor +++ b/core/io/encodings/utf8/utf8-docs.factor @@ -1,18 +1,11 @@ -USING: help.markup help.syntax io.encodings strings ; +USING: help.markup help.syntax io.encodings strings io.files ; IN: io.encodings.utf8 ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data" -"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences." -{ $subsection encode-utf8 } -{ $subsection decode-utf8 } ; +"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences. The encoding descriptor for UTF-8:" +{ $subsection utf8 } ; + +HELP: utf8 +{ $class-description "This is the class of encoding tuples which denote a UTF-8 encoding. You can pass this class symbol as an encoding descriptor to words like " { $link } " and " { $link encode-string } "." } ; ABOUT: "io.encodings.utf8" - -HELP: decode-utf8 -{ $values { "seq" "a sequence of bytes" } { "str" string } } -{ $description "Decodes a sequence of bytes representing a Unicode string in UTF8 format." } -{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ; - -HELP: encode-utf8 -{ $values { "str" string } { "seq" "a sequence of bytes" } } -{ $description "Encodes a Unicode string as a sequence of bytes in UTF8 format." } ; diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor index a6a32041be..0671fe2129 100644 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -1,11 +1,11 @@ USING: io.encodings.utf8 tools.test sbufs kernel io io.encodings -sequences strings arrays unicode ; +sequences strings arrays unicode io.streams.byte-array ; : decode-utf8-w/stream ( array -- newarray ) - >sbuf dup reverse-here utf8 contents ; + utf8 contents >array ; : encode-utf8-w/stream ( array -- newarray ) - SBUF" " clone tuck utf8 stream-write >array ; + utf8 [ write ] with-byte-writer >array ; [ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index f41e04d72d..bff9d69129 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -17,13 +17,13 @@ HOOK: (file-writer) io-backend ( path -- stream ) HOOK: (file-appender) io-backend ( path -- stream ) : ( path encoding -- stream ) - swap (file-reader) swap ; + swap (file-reader) swap ; : ( path encoding -- stream ) - swap (file-writer) swap ; + swap (file-writer) swap ; : ( path encoding -- stream ) - swap (file-appender) swap ; + swap (file-appender) swap ; HOOK: delete-file io-backend ( path -- ) @@ -171,4 +171,4 @@ M: pathname <=> [ pathname-string ] compare ; [ dup make-directory ] when ; -: temp-file ( name -- path ) temp-directory swap path+ ; \ No newline at end of file +: temp-file ( name -- path ) temp-directory swap path+ ; diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 394deb0e5c..74b6b5034f 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,5 +1,5 @@ USING: arrays io io.files kernel math parser strings system -tools.test words namespaces io.encodings.latin1 io.encodings.binary ; +tools.test words namespaces io.encodings.ascii io.encodings.binary ; IN: temporary [ f ] [ @@ -8,7 +8,7 @@ IN: temporary ] unit-test : ( resource -- stream ) - resource-path latin1 ; + resource-path ascii ; [ "This is a line.\rThis is another line.\r" diff --git a/core/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor index afbc94bf6a..d5ca8eac68 100644 --- a/core/io/streams/byte-array/byte-array.factor +++ b/core/io/streams/byte-array/byte-array.factor @@ -3,14 +3,14 @@ sequences io namespaces ; IN: io.streams.byte-array : ( encoding -- stream ) - 512 swap ; + 512 swap ; : with-byte-writer ( encoding quot -- byte-array ) >r r> [ stdio get ] compose with-stream* >byte-array ; inline : ( byte-array encoding -- stream ) - >r >byte-vector dup reverse-here r> ; + >r >byte-vector dup reverse-here r> ; : with-byte-reader ( byte-array encoding quot -- ) >r r> with-stream ; inline diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index e1c14e6ee3..15fc2b704e 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -50,7 +50,7 @@ M: growable stream-read-partial stream-read ; : ( str -- stream ) - >sbuf dup reverse-here null-encoding ; + >sbuf dup reverse-here null-encoding ; : with-string-reader ( str quot -- ) >r r> with-stream ; inline diff --git a/extra/io/encodings/utf16/utf16-tests.factor b/extra/io/encodings/utf16/utf16-tests.factor index 1677c2d38d..7ee5c9574e 100755 --- a/extra/io/encodings/utf16/utf16-tests.factor +++ b/extra/io/encodings/utf16/utf16-tests.factor @@ -1,11 +1,11 @@ -USING: kernel tools.test io.encodings.utf16 arrays sbufs sequences io.encodings -io unicode ; +USING: kernel tools.test io.encodings.utf16 arrays sbufs +sequences io.encodings io unicode io.streams.byte-array ; : decode-w/stream ( array encoding -- newarray ) - >r >sbuf dup reverse-here r> contents >array ; + contents >array ; : encode-w/stream ( array encoding -- newarray ) - >r SBUF" " clone tuck r> stream-write >array ; + [ write ] with-byte-writer >array ; [ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode-w/stream ] unit-test [ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode-w/stream ] unit-test diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 9236ec2ce9..b1990df654 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -127,7 +127,7 @@ TUPLE: process-stream process ; : ( desc encoding -- stream ) swap >descriptor - [ (process-stream) >r rot r> ] keep + [ (process-stream) >r rot r> ] keep +timeout+ swap at [ over set-timeout ] when* { set-delegate set-process-stream-process } process-stream construct ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index b8007192fe..b0ce1fcc12 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -45,7 +45,7 @@ GENERIC: close-handle ( handle -- ) output-port ; : ( read-handle write-handle -- input-port output-port ) - swap [ swap ] [ dispose ] cleanup ; + swap [ swap ] [ ] [ dispose drop ] cleanup ; : pending-error ( port -- ) dup port-error f rot set-port-error [ throw ] when* ; diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index 510d47ff2b..fa38ec90ee 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -100,12 +100,12 @@ HELP: } ; HELP: -{ $values { "addrspec" "an address specifier" } { "server" "a handle" } } +{ $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } } { $description "Begins listening for network connections to a local address. Server objects responds to two words:" { $list { { $link dispose } " - stops listening on the port and frees all associated resources" } - { { $link accept } " - blocks until there is a connection" } + { { $link accept } " - blocks until there is a connection, and returns a stream of the encoding passed to the constructor" } } } { $notes @@ -119,7 +119,7 @@ HELP: HELP: accept { $values { "server" "a handle" } { "client" "a bidirectional stream" } } -{ $description "Waits for a connection to a server socket created by " { $link } ", and outputs a bidirectional stream when the connection has been established." +{ $description "Waits for a connection to a server socket created by " { $link } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." $nl "The returned client stream responds to the " { $link client-stream-addr } " word with the address of the incoming connection." } { $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ; @@ -139,6 +139,7 @@ HELP: "To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:" { $code "\"localhost\" 1234 t resolve-host" } "Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly." + "Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding" } { $errors "Throws an error if the port is already in use, or if the OS forbids access." } ; diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 07e4f0afca..8de43bfd20 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -33,7 +33,7 @@ M: array client* [ (client) ] attempt-all ; M: object client* (client) ; : ( addrspec encoding -- stream ) - [ >r client* r> ] keep ; + [ >r client* r> ] keep ; HOOK: (server) io-backend ( addrspec -- handle ) @@ -43,7 +43,7 @@ HOOK: (server) io-backend ( addrspec -- handle ) HOOK: (accept) io-backend ( server -- stream-in stream-out ) : accept ( server -- client ) - [ (accept) ] keep server-port-encoding ; + [ (accept) ] keep server-port-encoding ; HOOK: io-backend ( addrspec -- datagram ) From 08a3d0ba12b44b136d56291bf6b07195daf8a03e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 25 Feb 2008 13:54:35 -0600 Subject: [PATCH 014/140] Making things bootstrap, partial fix for client --- core/io/backend/backend.factor | 2 +- core/io/encodings/encodings-docs.factor | 13 +++++++++++++ core/io/io-tests.factor | 2 +- extra/io/server/server.factor | 2 +- extra/io/sockets/sockets.factor | 4 ++-- extra/io/unix/unix-tests.factor | 10 +++++----- 6 files changed, 23 insertions(+), 10 deletions(-) create mode 100644 core/io/encodings/encodings-docs.factor diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 6f41814ce9..1595ecd576 100755 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -24,7 +24,7 @@ HOOK: normalize-pathname io-backend ( str -- newstr ) M: object normalize-pathname ; : set-io-backend ( io-backend -- ) - io-backend set-global init-io init-stdio die ; + io-backend set-global init-io init-stdio ; [ init-io embedded? [ init-stdio ] unless ] "io.backend" add-init-hook diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor new file mode 100644 index 0000000000..bb1a991903 --- /dev/null +++ b/core/io/encodings/encodings-docs.factor @@ -0,0 +1,13 @@ +USING: help.markup help.syntax ; +IN: io.encodings + +ARTICLE: "encodings" "I/O encodings" +"Many streams deal with bytes, rather than Unicode code points, at some level. The translation between these two things is specified by an encoding. To abstract this away from the programmer, Factor provides a system where these streams are associated with an encoding which is always used when the stream is read from or written to. For most purposes, an encoding descriptor consisting of a symbol is all that is needed when initializing a stream." +"To make an encoded stream directly (something which is normally handled by the appropriate stream constructor), use the following words:" +{ $subsection } +{ $subsection } +{ $subsection } +"To encode or decode a string, use" +{ $subsection encode-string } +! { $subsection decode-string } +; diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 74b6b5034f..2ac55a33fa 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -8,7 +8,7 @@ IN: temporary ] unit-test : ( resource -- stream ) - resource-path ascii ; + resource-path binary ; [ "This is a line.\rThis is another line.\r" diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 6cc11ea6b6..2c1cac1467 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -30,7 +30,7 @@ LOG: accepted-connection NOTICE { log-service servers } "Client" spawn-vars ] 2keep accept-loop ; inline -: server-loop ( addrspec quot -- ) +: server-loop ( addrspec encoding quot -- ) >r dup servers get push r> [ accept-loop ] curry with-disposal ; inline diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 8de43bfd20..c10d7e963c 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -29,11 +29,11 @@ TUPLE: client-stream addr ; HOOK: (client) io-backend ( addrspec -- client-in client-out ) GENERIC: client* ( addrspec -- client-in client-out ) -M: array client* [ (client) ] attempt-all ; +M: array client* [ (client) 2array ] attempt-all first2 ; M: object client* (client) ; : ( addrspec encoding -- stream ) - [ >r client* r> ] keep ; + over client* rot ; HOOK: (server) io-backend ( addrspec -- handle ) diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 6e61786d9b..ede8e745c5 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -10,12 +10,12 @@ IN: temporary ] ignore-errors "unix-domain-socket-test" resource-path - [ - stdio get accept [ + ascii [ + accept [ "Hello world" print flush readln "XYZ" = "FOO" "BAR" ? print flush ] with-stream - ] with-stream + ] with-disposal "unix-domain-socket-test" resource-path delete-file ] "Test" spawn drop @@ -24,8 +24,8 @@ yield [ { "Hello world" "FOO" } ] [ [ - "unix-domain-socket-test" resource-path ascii - [ + "unix-domain-socket-test" resource-path + ascii [ readln , "XYZ" print flush readln , From 63e04a9b1767aabca8755cbdba24bda85d7514f7 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 25 Feb 2008 14:24:44 -0600 Subject: [PATCH 015/140] Fixing Unix I/O tests --- extra/io/unix/unix-tests.factor | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index ede8e745c5..7fa210d5da 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -6,10 +6,10 @@ IN: temporary ! Unix domain stream sockets [ [ - "unix-domain-socket-test" resource-path delete-file + "unix-domain-socket-test" temp-file delete-file ] ignore-errors - "unix-domain-socket-test" resource-path + "unix-domain-socket-test" temp-file ascii [ accept [ "Hello world" print flush @@ -17,14 +17,14 @@ IN: temporary ] with-stream ] with-disposal - "unix-domain-socket-test" resource-path delete-file + "unix-domain-socket-test" temp-file delete-file ] "Test" spawn drop yield [ { "Hello world" "FOO" } ] [ [ - "unix-domain-socket-test" resource-path + "unix-domain-socket-test" temp-file ascii [ readln , "XYZ" print flush @@ -35,7 +35,7 @@ yield ! Unix domain datagram sockets [ - "unix-domain-datagram-test" resource-path delete-file + "unix-domain-datagram-test" temp-file delete-file ] ignore-errors : server-addr "unix-domain-datagram-test" temp-file ; @@ -67,17 +67,18 @@ yield "Done" print - "unix-domain-datagram-test" resource-path delete-file + "unix-domain-datagram-test" temp-file delete-file ] with-scope ] "Test" spawn drop yield [ - "unix-domain-datagram-test-2" resource-path delete-file + "unix-domain-datagram-test-2" temp-file delete-file ] ignore-errors client-addr +"Four" print "d" set [ ] [ @@ -109,7 +110,7 @@ client-addr ! Test error behavior [ - "unix-domain-datagram-test-3" resource-path delete-file + "unix-domain-datagram-test-3" temp-file delete-file ] ignore-errors "unix-domain-datagram-test-2" temp-file delete-file From 6260cd3e5afdbca83f7433b836de9ed4142a0e5c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Feb 2008 14:53:18 -0600 Subject: [PATCH 016/140] Working on new HTTP server --- extra/assocs/lib/lib.factor | 9 +- extra/furnace/furnace.factor | 11 ++ extra/http/client/client-tests.factor | 26 ++- extra/http/client/client.factor | 120 ++++++------- extra/http/http-tests.factor | 99 ++++++++++- extra/http/http.factor | 241 ++++++++++++++++++++++++-- extra/http/server/server-tests.factor | 68 ++++---- extra/http/server/server.factor | 156 ++++++++++++----- 8 files changed, 566 insertions(+), 164 deletions(-) mode change 100644 => 100755 extra/http/http-tests.factor diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 182f04a367..88095759e6 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -16,13 +16,16 @@ IN: assocs.lib : at-default ( key assoc -- value/key ) dupd at [ nip ] when* ; +: replace-at ( assoc value key -- assoc ) + >r >r dup r> 1vector r> rot set-at ; + : insert-at ( value key assoc -- ) [ ?push ] change-at ; -: peek-at* ( key assoc -- obj ? ) - at* dup [ >r peek r> ] when ; +: peek-at* ( assoc key -- obj ? ) + swap at* dup [ >r peek r> ] when ; -: peek-at ( key assoc -- obj ) +: peek-at ( assoc key -- obj ) peek-at* drop ; : >multi-assoc ( assoc -- new-assoc ) diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 11ff697049..f10094f07b 100755 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -35,6 +35,17 @@ SYMBOL: current-action SYMBOL: validators-errored SYMBOL: validation-errors +: build-url ( str query-params -- newstr ) + [ + over % + dup assoc-empty? [ + 2drop + ] [ + CHAR: ? rot member? "&" "?" ? % + assoc>query % + ] if + ] "" make ; + : action-link ( query action -- url ) [ "/responder/" % diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index d2fb719acd..5e407657a8 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -1,14 +1,26 @@ -USING: http.client tools.test ; +USING: http.client http.client.private http tools.test +tuple-syntax namespaces ; [ "localhost" 80 ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test -[ "localhost:8888" "/foo" ] [ "http://localhost:8888/foo" parse-url ] unit-test -[ "localhost:8888" "/" ] [ "http://localhost:8888" parse-url ] unit-test -[ 404 ] [ "HTTP/1.1 404 File not found" parse-response ] unit-test -[ 404 ] [ "404 File not found" parse-response ] unit-test -[ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test -[ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test +[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test +[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test [ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test [ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test [ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test [ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test + +[ + TUPLE{ request + method: "GET" + host: "www.apple.com" + path: "/index.html" + port: 80 + } +] [ + [ + "http://www.apple.com/index.html" + + request-with-url + ] with-scope +] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 99ba045019..8b74b6dc72 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,64 +2,73 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting continuations assocs.lib calendar ; +splitting continuations assocs.lib calendar vectors hashtables +accessors ; IN: http.client -: parse-host ( url -- host port ) - #! Extract the host name and port number from an HTTP URL. - ":" split1 [ string>number ] [ 80 ] if* ; - -SYMBOL: domain - -: parse-url ( url -- host resource ) - dup "https://" head? [ - "ssl not yet supported: " swap append throw - ] when "http://" ?head drop +: parse-url ( url -- resource host port ) + "http://" ?head [ "Only http:// supported" throw ] unless "/" split1 [ "/" swap append ] [ "/" ] if* - >r dup empty? [ drop domain get ] [ dup domain set ] if r> ; + swap parse-host ; -: parse-response ( line -- code ) - "HTTP/" ?head [ " " split1 nip ] when - " " split1 drop string>number [ - "Premature end of stream" throw - ] unless* ; +r >>path r> dup [ query>assoc ] when >>query ; -: crlf "\r\n" write ; +! This is all pretty complex because it needs to handle +! HTTP redirects, which might be absolute or relative +: request-with-url ( url request -- request ) + clone dup "request" set + swap parse-url >r >r store-path r> >>host r> >>port ; -: http-request ( host resource method -- ) - write bl write " HTTP/1.0" write crlf - "Host: " write write crlf ; +DEFER: (http-request) -: get-request ( host resource -- ) - "GET" http-request crlf ; +: absolute-redirect ( url -- request ) + "request" get request-with-url ; -DEFER: http-get-stream +: relative-redirect ( path -- request ) + "request" get swap store-path ; -: do-redirect ( code headers stream -- code headers stream ) - #! Should this support Location: headers that are - #! relative URLs? - pick 100 /i 3 = [ - dispose "location" swap peek-at nip http-get-stream - ] when ; +: do-redirect ( response -- response stream ) + dup response-code 300 399 between? [ + header>> "location" peek-at + dup "http://" head? [ + absolute-redirect + ] [ + relative-redirect + ] if "GET" >>method (http-request) + ] [ + stdio get + ] if ; -: default-timeout 1 minutes over set-timeout ; +: (http-request) ( request -- response stream ) + dup host>> over port>> stdio set + write-request flush read-response + do-redirect ; -: http-get-stream ( url -- code headers stream ) - #! Opens a stream for reading from an HTTP URL. - parse-url over parse-host [ - [ [ get-request read-response ] with-stream* ] keep - default-timeout - ] [ ] [ dispose ] cleanup do-redirect ; +PRIVATE> + +: http-request ( url request -- response stream ) + [ + request-with-url + [ + (http-request) + 1 minutes over set-timeout + ] [ ] [ stdio get dispose ] cleanup + ] with-scope ; + +: ( -- request ) + request construct-empty + "GET" >>method ; + +: http-get-stream ( url -- response stream ) + http-request ; : success? ( code -- ? ) 200 = ; -: check-response ( code headers stream -- stream ) - nip swap success? +: check-response ( response stream -- stream ) + swap code>> success? [ dispose "HTTP download failed" throw ] unless ; : http-get ( url -- string ) @@ -70,23 +79,18 @@ DEFER: http-get-stream : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - >r http-get-stream check-response - r> stream-copy ; + swap http-get-stream check-response + [ swap stream-copy ] with-disposal ; : download ( url -- ) dup download-name download-to ; -: post-request ( content-type content host resource -- ) - #! Note: It is up to the caller to url encode the content if - #! it is required according to the content-type. - "POST" http-request [ - "Content-Length: " write length number>string write crlf - "Content-Type: " write url-encode write crlf - crlf - ] keep write ; +: ( content-type content -- request ) + request construct-empty + "POST" >>method + swap >>post-data + swap >>post-data-type ; -: http-post ( content-type content url -- code headers string ) - #! Make a POST request. The content is URL encoded for you. - parse-url over parse-host [ - post-request flush read-response stdio get contents - ] with-stream ; +: http-post ( content-type content url -- response string ) + #! The content is URL encoded for you. + -rot url-encode http-request contents ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor old mode 100644 new mode 100755 index 5146502644..9fa593053c --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,4 +1,5 @@ -USING: http tools.test ; +USING: http tools.test multiline tuple-syntax +io.streams.string kernel arrays splitting sequences ; IN: temporary [ "hello%20world" ] [ "hello world" url-encode ] unit-test @@ -16,3 +17,99 @@ IN: temporary [ "%20%21%20" ] [ " ! " url-encode ] unit-test [ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test + +STRING: read-request-test-1 +GET http://foo/bar HTTP/1.1 +Some-Header: 1 +Some-Header: 2 +Content-Length: 4 + +blah +; + +[ + TUPLE{ request + method: "GET" + path: "bar" + query: f + version: "1.1" + header: H{ { "some-header" V{ "1" "2" } } { "content-length" V{ "4" } } } + post-data: "blah" + } +] [ + read-request-test-1 [ + read-request + ] with-string-reader +] unit-test + +STRING: read-request-test-1' +GET bar HTTP/1.1 +content-length: 4 +some-header: 1 +some-header: 2 + +blah +; + +read-request-test-1' 1array [ + read-request-test-1 + [ read-request ] with-string-reader + [ write-request ] with-string-writer + ! normalize crlf + string-lines "\n" join +] unit-test + +STRING: read-request-test-2 +HEAD http://foo/bar HTTP/1.0 +Host: www.sex.com +; + +[ + TUPLE{ request + method: "HEAD" + path: "bar" + query: f + version: "1.0" + header: H{ { "host" V{ "www.sex.com" } } } + host: "www.sex.com" + } +] [ + read-request-test-2 [ + read-request + ] with-string-reader +] unit-test + +STRING: read-response-test-1 +HTTP/1.0 404 not found +Content-Type: text/html + +blah +; + +[ + TUPLE{ response + version: "1.0" + code: 404 + message: "not found" + header: H{ { "content-type" V{ "text/html" } } } + } +] [ + read-response-test-1 + [ read-response ] with-string-reader +] unit-test + + +STRING: read-response-test-1' +HTTP/1.0 404 not found +content-type: text/html + + +; + +read-response-test-1' 1array [ + read-response-test-1 + [ read-response ] with-string-reader + [ write-response ] with-string-writer + ! normalize crlf + string-lines "\n" join +] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 5c4dae94c7..4c2834b7ca 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,19 +1,34 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables io kernel math namespaces math.parser assocs -sequences strings splitting ascii io.encodings.utf8 assocs.lib -namespaces unicode.case ; +USING: hashtables io io.streams.string kernel math namespaces +math.parser assocs sequences strings splitting ascii +io.encodings.utf8 assocs.lib namespaces unicode.case combinators +vectors sorting new-slots accessors calendar ; IN: http +: http-port 80 ; inline + +: crlf "\r\n" write ; + : header-line ( line -- ) ": " split1 dup [ swap >lower insert ] [ 2drop ] if ; -: (read-header) ( -- ) +: read-header-line ( -- ) readln dup - empty? [ drop ] [ header-line (read-header) ] if ; + empty? [ drop ] [ header-line read-header-line ] if ; -: read-header ( -- hash ) - [ (read-header) ] H{ } make-assoc ; +: read-header ( -- multi-assoc ) + [ read-header-line ] H{ } make-assoc ; + +: write-header ( multi-assoc -- ) + >alist sort-keys + [ + swap write ": " write { + { [ dup number? ] [ number>string ] } + { [ dup timestamp? ] [ timestamp>http-string ] } + { [ dup string? ] [ ] } + } cond write crlf + ] multi-assoc-each crlf ; : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without @@ -23,7 +38,7 @@ IN: http over digit? or swap "/_-." member? or ; foldable -: push-utf8 ( string -- ) +: push-utf8 ( ch -- ) 1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; : url-encode ( str -- str ) @@ -58,17 +73,205 @@ IN: http : url-decode ( str -- str ) [ 0 swap url-decode-iter ] "" make decode-utf8 ; -: hash>query ( hash -- str ) +: query>assoc ( query -- assoc ) + dup [ + "&" split [ + "=" split1 [ dup [ url-decode ] when ] 2apply + ] H{ } map>assoc + ] when ; + +: assoc>query ( hash -- str ) [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map "&" join ; -: build-url ( str query-params -- newstr ) +TUPLE: request +host +port +method +path +query +version +header +post-data +post-data-type ; + +: + request construct-empty + "1.0" >>version + http-port >>port ; + +: url>path ( url -- path ) + url-decode "http://" ?head + [ "/" split1 "" or nip ] [ "/" ?head drop ] if ; + +: read-method ( request -- request ) + " " read-until [ "Bad request: method" throw ] unless + >>method ; + +: read-query ( request -- request ) + " " read-until + [ "Bad request: query params" throw ] unless + query>assoc >>query ; + +: read-url ( request -- request ) + " ?" read-until { + { CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] } + { CHAR: ? [ url>path >>path read-query ] } + [ "Bad request: URL" throw ] + } case ; + +: parse-version ( string -- version ) + "HTTP/" ?head [ "Bad version" throw ] unless + dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ; + +: read-request-version ( request -- request ) + readln [ CHAR: \s = ] left-trim + parse-version + >>version ; + +: read-request-header ( request -- request ) + read-header >>header ; + +SYMBOL: max-post-request + +1024 256 * max-post-request set-global + +: content-length ( header -- n ) + "content-length" peek-at string>number dup [ + dup max-post-request get > [ + "content-length > max-post-request" throw + ] when + ] when ; + +: read-post-data ( request -- request ) + dup header>> content-length [ read >>post-data ] when* ; + +: parse-host ( string -- host port ) + "." ?tail drop ":" split1 + [ string>number ] [ http-port ] if* ; + +: extract-host ( request -- request ) + dup header>> "host" peek-at parse-host >r >>host r> >>port ; + +: extract-post-data-type ( request -- request ) + dup header>> "content-type" peek-at >>post-data-type ; + +: read-request ( -- request ) + + read-method + read-url + read-request-version + read-request-header + read-post-data + extract-host + extract-post-data-type ; + +: write-method ( request -- request ) + dup method>> write bl ; + +: write-url ( request -- request ) + dup path>> url-encode write + dup query>> dup assoc-empty? [ drop ] [ + "?" write + assoc>query write + ] if ; + +: write-request-url ( request -- request ) + write-url bl ; + +: write-version ( request -- request ) + "HTTP/" write dup request-version write crlf ; + +: write-request-header ( request -- request ) + dup header>> >hashtable + over host>> [ "host" replace-at ] when* + over post-data>> [ length "content-length" replace-at ] when* + over post-data-type>> [ "content-type" replace-at ] when* + write-header ; + +: write-post-data ( request -- request ) + dup post-data>> [ write ] when* ; + +: write-request ( request -- ) + write-method + write-url + write-version + write-request-header + write-post-data + flush + drop ; + +: request-url ( request -- url ) [ - over % - dup assoc-empty? [ - 2drop - ] [ - CHAR: ? rot member? "&" "?" ? % - hash>query % - ] if - ] "" make ; + dup host>> [ + "http://" write + dup host>> url-encode write + ":" write + dup port>> number>string write + ] when + "/" write + write-url + drop + ] with-string-writer ; + +TUPLE: response +version +code +message +header ; + +: + response construct-empty + "1.0" >>version + H{ } clone >>header ; + +: read-response-version + " " read-until + [ "Bad response: version" throw ] unless + parse-version + >>version ; + +: read-response-code + " " read-until [ "Bad response: code" throw ] unless + string>number [ "Bad response: code" throw ] unless* + >>code ; + +: read-response-message + readln >>message ; + +: read-response-header + read-header >>header ; + +: read-response ( -- response ) + + read-response-version + read-response-code + read-response-message + read-response-header ; + +: write-response-version ( response -- response ) + "HTTP/" write + dup version>> write bl ; + +: write-response-code ( response -- response ) + dup code>> number>string write bl ; + +: write-response-message ( response -- response ) + dup message>> write crlf ; + +: write-response-header ( response -- response ) + dup header>> write-header ; + +: write-response ( respose -- ) + write-response-version + write-response-code + write-response-message + write-response-header + flush + drop ; + +: set-response-header ( response value key -- response ) + pick header>> -rot replace-at drop ; + +: set-content-type ( response content-type -- response ) + "content-type" set-response-header ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 18edd94f12..a67d21a640 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,39 +1,45 @@ -USING: webapps.file http.server.responders http -http.server namespaces io tools.test strings io.server -logging ; +USING: http.server tools.test kernel namespaces accessors +new-slots assocs.lib io http math sequences ; IN: temporary -[ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test +TUPLE: mock-responder ; -[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test +: ( path -- responder ) + mock-responder construct-delegate ; -[ "index.html" ] -[ "http://www.jedit.org/index.html" url>path ] unit-test +M: mock-responder do-responder + 2nip + path>> on + [ "Hello world" print ] + "text/plain" ; -[ "foo/bar" ] -[ "http://www.jedit.org/foo/bar" url>path ] unit-test +: check-dispatch ( tag path -- ? ) + over off + swap default-host get call-responder + write-response call get ; -[ "" ] -[ "http://www.jedit.org/" url>path ] unit-test +[ + "" + "foo" add-responder + "bar" add-responder + "baz/" + "123" add-responder + "default" >>default + add-responder + default-host set -[ "" ] -[ "http://www.jedit.org" url>path ] unit-test + [ t ] [ "foo" "foo" check-dispatch ] unit-test + [ f ] [ "foo" "bar" check-dispatch ] unit-test + [ t ] [ "bar" "bar" check-dispatch ] unit-test + [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test + [ t ] [ "123" "baz/123" check-dispatch ] unit-test -[ "foobar" ] -[ "foobar" secure-path ] unit-test - -[ f ] -[ "foobar/../baz" secure-path ] unit-test - -[ ] [ f [ "GET ../index.html" parse-request ] with-logging ] unit-test -[ ] [ f [ "POO" parse-request ] with-logging ] unit-test - -[ H{ { "Foo" "Bar" } } ] [ "Foo=Bar" query>hash ] unit-test - -[ H{ { "Foo" "Bar" } { "Baz" "Quux" } } ] -[ "Foo=Bar&Baz=Quux" query>hash ] unit-test - -[ H{ { "Baz" " " } } ] -[ "Baz=%20" query>hash ] unit-test - -[ H{ { "Foo" f } } ] [ "Foo" query>hash ] unit-test + [ t ] [ + + "baz" >>path + "baz" default-host get call-responder + dup code>> 300 399 between? >r + header>> "location" peek-at "baz/" tail? r> and + nip + ] unit-test +] with-scope diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index a2f5c3474b..e06ae6a95c 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,65 +1,131 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io io.timeouts strings splitting -threads http http.server.responders sequences prettyprint -io.server logging calendar ; - +threads http sequences prettyprint io.server logging calendar +new-slots html.elements accessors math.parser combinators.lib ; IN: http.server -: (url>path) ( uri -- path ) - url-decode "http://" ?head [ - "/" split1 dup "" ? nip - ] when ; +TUPLE: responder path directory ; -: url>path ( uri -- path ) - "?" split1 dup [ - >r (url>path) "?" r> 3append - ] [ - drop (url>path) - ] if ; +: ( path -- responder ) + "/" ?tail responder construct-boa ; -: secure-path ( path -- path ) - ".." over subseq? [ drop f ] when ; +GENERIC: do-responder ( request path responder -- quot response ) -: request-method ( cmd -- method ) - H{ - { "GET" "get" } - { "POST" "post" } - { "HEAD" "head" } - } at "bad" or ; +TUPLE: trivial-responder quot response ; -: (handle-request) ( arg cmd -- method path host ) - request-method dup "method" set swap - prepare-url prepare-header host ; +: ( quot response -- responder ) + trivial-responder construct-boa + "" over set-delegate ; -: handle-request ( arg cmd -- ) - [ (handle-request) serve-responder ] with-scope ; +M: trivial-responder do-responder + 2nip dup quot>> swap response>> ; -: parse-request ( request -- ) - " " split1 dup [ - " HTTP" split1 drop url>path secure-path dup [ - swap handle-request - ] [ - 2drop bad-request - ] if - ] [ - 2drop bad-request - ] if ; +: trivial-response-body ( code message -- ) + + +

swap number>string write bl write

+ + ; -\ parse-request NOTICE add-input-logging +: ( code message -- quot response ) + [ [ trivial-response-body ] 2curry ] 2keep + "text/html" set-content-type + swap >>message + swap >>code ; + +: <404> ( -- quot response ) + 404 "Not Found" ; + +: ( to code message -- quot response ) + + rot "location" set-response-header ; + +: ( to -- quot response ) + 301 "Moved Permanently" ; + +: ( to -- quot response ) + 307 "Temporary Redirect" ; + +: ( content-type -- response ) + + 200 >>code + swap set-content-type ; + +TUPLE: dispatcher responders default ; + +: responder-matches? ( path responder -- ? ) + path>> head? ; + +TUPLE: no-/-responder ; + +M: no-/-responder do-responder + 2drop + dup path>> "/" append >>path + request-url ; + +: ( -- responder ) + "" no-/-responder construct-delegate ; + + no-/-responder set-global + +: find-responder ( path dispatcher -- path responder ) + >r "/" ?head drop r> + [ responders>> [ dupd responder-matches? ] find nip ] keep + default>> or [ path>> ?head drop ] keep ; + +: no-trailing-/ ( path responder -- path responder ) + over empty? over directory>> and + [ drop no-/-responder get-global ] when ; + +: call-responder ( request path responder -- quot response ) + no-trailing-/ do-responder ; + +SYMBOL: 404-responder + +<404> 404-responder set-global + +M: dispatcher do-responder + find-responder call-responder ; + +: ( path -- dispatcher ) + + dispatcher construct-delegate + 404-responder get-global >>default + V{ } clone >>responders ; + +: add-responder ( dispatcher responder -- dispatcher ) + over responders>> push ; + +SYMBOL: virtual-hosts +SYMBOL: default-host + +virtual-hosts global [ drop H{ } clone ] cache drop +default-host global [ drop 404-responder ] cache drop + +: find-virtual-host ( host -- responder ) + virtual-hosts get at [ default-host get ] unless* ; + +: handle-request ( request -- ) + [ + dup path>> over host>> find-virtual-host + call-responder + write-response + ] keep method>> "HEAD" = [ drop ] [ call ] if ; + +: default-timeout 1 minutes stdio get set-timeout ; + +LOG: httpd-hit NOTICE + +: log-request ( request -- ) + { method>> host>> path>> } map-exec-with httpd-hit ; : httpd ( port -- ) internet-server "http.server" [ - 1 minutes stdio get set-timeout - readln [ parse-request ] when* + default-timeout + read-request dup log-request handle-request ] with-server ; : httpd-main ( -- ) 8888 httpd ; MAIN: httpd-main - -! Load default webapps -USE: webapps.file -USE: webapps.callback -USE: webapps.continuation -USE: webapps.cgi From 278509336d39dd9e2d0e73df70fa15b4e36b1e8a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 25 Feb 2008 15:10:14 -0600 Subject: [PATCH 017/140] Making with-server take encodings properly --- extra/benchmark/sockets/sockets.factor | 4 ++-- extra/concurrency/distributed/distributed.factor | 4 ++-- extra/http/server/server.factor | 4 ++-- extra/io/server/server.factor | 8 ++++---- extra/tty-server/tty-server.factor | 6 +++--- 5 files changed, 13 insertions(+), 13 deletions(-) diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 6b1908afb1..b6b20630a1 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,9 +1,9 @@ -USING: io.sockets io.server io kernel math threads +USING: io.sockets io.server io kernel math threads io.encodings.ascii debugger tools.time prettyprint concurrency.combinators ; IN: benchmark.sockets : simple-server ( -- ) - 7777 local-server "benchmark.sockets" [ + 7777 local-server "benchmark.sockets" ascii [ read1 CHAR: x = [ stop-server ] [ diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index 2c54a872f7..029be9772c 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: serialize sequences concurrency.messaging threads io io.server qualified arrays -namespaces kernel ; +namespaces kernel io.encodings.binary ; QUALIFIED: io.sockets IN: concurrency.distributed @@ -15,7 +15,7 @@ SYMBOL: local-node ( -- addrspec ) [ local-node set-global "concurrency.distributed" - [ handle-node-client ] with-server + binary [ handle-node-client ] with-server ] 2curry f spawn drop ; : start-node ( port -- ) diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index a2f5c3474b..bd0abc4f9b 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io io.timeouts strings splitting threads http http.server.responders sequences prettyprint -io.server logging calendar ; +io.server logging calendar io.encodings.latin1 ; IN: http.server @@ -49,7 +49,7 @@ IN: http.server \ parse-request NOTICE add-input-logging : httpd ( port -- ) - internet-server "http.server" [ + internet-server "http.server" latin1 [ 1 minutes stdio get set-timeout readln [ parse-request ] when* ] with-server ; diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 2c1cac1467..c2fa9bafae 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -44,12 +44,12 @@ PRIVATE> : internet-server ( port -- seq ) f swap t resolve-host ; -: with-server ( seq service quot -- ) +: with-server ( seq service encoding quot -- ) V{ } clone [ - servers [ - [ server-loop ] curry with-logging + swap servers [ + [ server-loop ] 2curry with-logging ] with-variable - ] 3curry parallel-each ; inline + ] 3curry curry parallel-each ; inline : stop-server ( -- ) servers get [ dispose ] each ; diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor index f71265e6f0..2936c39070 100644 --- a/extra/tty-server/tty-server.factor +++ b/extra/tty-server/tty-server.factor @@ -1,11 +1,11 @@ -USING: listener io.server ; +USING: listener io.server io.encodings.utf8 ; IN: tty-server : tty-server ( port -- ) local-server "tty-server" - [ listener ] with-server ; + utf8 [ listener ] with-server ; : default-tty-server 9999 tty-server ; -MAIN: default-tty-server \ No newline at end of file +MAIN: default-tty-server From a2aa718cd4ac97a7856cce886adf482cff7c66c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Feb 2008 15:40:40 -0600 Subject: [PATCH 018/140] Remove obsolete vocab --- extra/http/server/responders/authors.txt | 1 - .../http/server/responders/responders.factor | 225 ------------------ 2 files changed, 226 deletions(-) delete mode 100755 extra/http/server/responders/authors.txt delete mode 100755 extra/http/server/responders/responders.factor diff --git a/extra/http/server/responders/authors.txt b/extra/http/server/responders/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/http/server/responders/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor deleted file mode 100755 index e4e0e257c4..0000000000 --- a/extra/http/server/responders/responders.factor +++ /dev/null @@ -1,225 +0,0 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs hashtables html html.elements splitting -http io kernel math math.parser namespaces parser sequences -strings io.server vectors assocs.lib logging ; - -IN: http.server.responders - -! Variables -SYMBOL: vhosts -SYMBOL: responders - -: >header ( value key -- multi-hash ) - H{ } clone [ insert-at ] keep ; - -: print-header ( alist -- ) - [ swap write ": " write print ] multi-assoc-each nl ; - -: response ( msg -- ) "HTTP/1.0 " write print ; - -: error-body ( error -- ) -

write

; - -: error-head ( error -- ) - response - H{ { "Content-Type" V{ "text/html" } } } print-header nl ; - -: httpd-error ( error -- ) - #! This must be run from handle-request - dup error-head - "head" "method" get = [ drop ] [ error-body ] if ; - -\ httpd-error ERROR add-error-logging - -: bad-request ( -- ) - [ - ! Make httpd-error print a body - "get" "method" set - "400 Bad request" httpd-error - ] with-scope ; - -: serving-content ( mime -- ) - "200 Document follows" response - "Content-Type" >header print-header ; - -: serving-html "text/html" serving-content ; - -: serve-html ( quot -- ) - serving-html with-html-stream ; - -: serving-text "text/plain" serving-content ; - -: redirect ( to response -- ) - response "Location" >header print-header ; - -: permanent-redirect ( to -- ) - "301 Moved Permanently" redirect ; - -: temporary-redirect ( to -- ) - "307 Temporary Redirect" redirect ; - -: directory-no/ ( -- ) - [ - "request" get % CHAR: / , - "raw-query" get [ CHAR: ? , % ] when* - ] "" make permanent-redirect ; - -: query>hash ( query -- hash ) - dup [ - "&" split [ - "=" split1 [ dup [ url-decode ] when ] 2apply 2array - ] map - ] when >hashtable ; - -SYMBOL: max-post-request - -1024 256 * max-post-request set-global - -: content-length ( header -- n ) - "Content-Length" swap at string>number dup [ - dup max-post-request get > [ - "Content-Length > max-post-request" throw - ] when - ] when ; - -: read-post-request ( header -- str hash ) - content-length [ read dup query>hash ] [ f f ] if* ; - -LOG: log-headers DEBUG - -: interesting-headers ( assoc -- string ) - [ - [ - drop { - "user-agent" - "referer" - "x-forwarded-for" - "host" - } member? - ] assoc-subset [ - ": " swap 3append % "\n" % - ] multi-assoc-each - ] "" make ; - -: prepare-url ( url -- url ) - #! This is executed in the with-request namespace. - "?" split1 - dup "raw-query" set query>hash "query" set - dup "request" set ; - -: prepare-header ( -- ) - read-header - dup "header" set - dup interesting-headers log-headers - read-post-request "response" set "raw-response" set ; - -! Responders are called in a new namespace with these -! variables: - -! - method -- one of get, post, or head. -! - request -- the entire URL requested, including responder -! name -! - responder-url -- the component of the URL for the responder -! - raw-query -- raw query string -! - query -- a hashtable of query parameters, eg -! foo.bar?a=b&c=d becomes -! H{ { "a" "b" } { "c" "d" } } -! - header -- a hashtable of headers from the user's client -! - response -- a hashtable of the POST request response -! - raw-response -- raw POST request response - -: query-param ( key -- value ) "query" get at ; - -: header-param ( key -- value ) - "header" get peek-at ; - -: host ( -- string ) - #! The host the current responder was called from. - "Host" header-param ":" split1 drop ; - -: add-responder ( responder -- ) - #! Add a responder object to the list. - "responder" over at responders get set-at ; - -: make-responder ( quot -- ) - #! quot has stack effect ( url -- ) - [ - [ - drop "GET method not implemented" httpd-error - ] "get" set - [ - drop "POST method not implemented" httpd-error - ] "post" set - [ - drop "HEAD method not implemented" httpd-error - ] "head" set - [ - drop bad-request - ] "bad" set - - call - ] H{ } make-assoc add-responder ; - -: add-simple-responder ( name quot -- ) - [ - [ drop ] swap append dup "get" set "post" set - "responder" set - ] make-responder ; - -: vhost ( name -- vhost ) - vhosts get at [ "default" vhost ] unless* ; - -: responder ( name -- responder ) - responders get at [ "404" responder ] unless* ; - -: set-default-responder ( name -- ) - responder "default" responders get set-at ; - -: call-responder ( method argument responder -- ) - over "argument" set [ swap get with-scope ] bind ; - -: serve-default-responder ( method url -- ) - "/" "responder-url" set - "default" responder call-responder ; - -: trim-/ ( url -- url ) - #! Trim a leading /, if there is one. - "/" ?head drop ; - -: serve-explicit-responder ( method url -- ) - "/" split1 - "/responder/" pick "/" 3append "responder-url" set - dup [ - swap responder call-responder - ] [ - ! Just a responder name by itself - drop "request" get "/" append permanent-redirect 2drop - ] if ; - -: serve-responder ( method path host -- ) - #! Responder paths come in two forms: - #! /foo/bar... - default responder used - #! /responder/foo/bar - responder foo, argument bar - vhost [ - trim-/ "responder/" ?head [ - serve-explicit-responder - ] [ - serve-default-responder - ] if - ] bind ; - -\ serve-responder DEBUG add-input-logging - -: no-such-responder ( -- ) - "404 No such responder" httpd-error ; - -! create a responders hash if it doesn't already exist -global [ - responders [ H{ } assoc-like ] change - - ! 404 error message pages are served by this guy - "404" [ no-such-responder ] add-simple-responder - - H{ } clone "default" associate vhosts set -] bind From 500e0fbc9bd82f3d52552ef2a3912183e49cd4dc Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 26 Feb 2008 01:20:27 -0600 Subject: [PATCH 019/140] Fixing send --- extra/concurrency/distributed/distributed.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor index 029be9772c..f09c441d26 100755 --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -28,7 +28,7 @@ C: remote-process M: remote-process send ( message thread -- ) { remote-process-id remote-process-node } get-slots - io.sockets: [ 2array serialize ] with-stream ; + binary io.sockets: [ 2array serialize ] with-stream ; M: thread (serialize) ( obj -- ) thread-id local-node get-global From 52f04dcfa462d2d4930cd32294349c6d4d153ef4 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 26 Feb 2008 01:24:40 -0600 Subject: [PATCH 020/140] Fix unit tests --- core/words/words-docs.factor | 4 ++-- extra/io/server/server-tests.factor | 2 +- extra/io/unix/unix-tests.factor | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index f1cc678d17..4903f8933b 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -1,5 +1,5 @@ -USING: definitions help.markup help.syntax kernel -kernel.private parser words.private vocabs classes quotations +USING: definitions help.markup help.syntax kernel parser +kernel.private words.private vocabs classes quotations strings effects compiler.units ; IN: words diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor index 24b4c231d1..6c3c177513 100755 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -1,4 +1,4 @@ IN: temporary USING: tools.test io.server io.server.private ; -{ 1 0 } [ [ ] server-loop ] must-infer-as +{ 2 0 } [ [ ] server-loop ] must-infer-as diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 998168ddaa..ca5d0f29fd 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -134,7 +134,7 @@ datagram-client delete-file [ image binary [ - B{ 1 2 } server-addr + B{ 1 2 } datagram-server stdio get send ] with-file-reader ] must-fail From d0e0a12cb08cfbe87de087c3814e613fffcbf091 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 26 Feb 2008 01:30:05 -0600 Subject: [PATCH 021/140] fixing SMTP for encodings (is ASCII appropriate?) --- extra/smtp/server/server.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index c28ec7745a..92b605e91c 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -1,5 +1,8 @@ ! Copyright (C) 2007 Elie CHAFTARI ! See http://factorcode.org/license.txt for BSD license. +USING: combinators kernel prettyprint io io.timeouts io.server +sequences namespaces io.sockets continuations calendar io.encodings.ascii ; +IN: smtp.server ! Mock SMTP server for testing purposes. @@ -27,10 +30,6 @@ ! bye ! Connection closed by foreign host. -USING: combinators kernel prettyprint io io.timeouts io.server -sequences namespaces io.sockets continuations calendar ; -IN: smtp.server - SYMBOL: data-mode : process ( -- ) @@ -64,7 +63,7 @@ SYMBOL: data-mode : smtp-server ( port -- ) "Starting SMTP server on port " write dup . flush - "127.0.0.1" swap [ + "127.0.0.1" swap ascii [ accept [ 1 minutes stdio get set-timeout "220 hello\r\n" write flush From 51ccd3417e389bc0a69fb6cff2a63eca7634b065 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 26 Feb 2008 09:59:40 -0600 Subject: [PATCH 022/140] Yes, ascii is appropriate --- extra/smtp/smtp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 99a708d2de..33ced2f1c2 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -20,7 +20,7 @@ SYMBOL: esmtp t esmtp set-global : with-smtp-connection ( quot -- ) smtp-host get smtp-port get 2dup log-smtp-connection - ascii [ ! ASCII until encodings reconsidered + ascii [ smtp-domain [ host-name or ] change read-timeout get stdio get set-timeout call From a7ee1d2642a39929f79a8d54d27fc1a36e66f85b Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 26 Feb 2008 19:32:33 -0600 Subject: [PATCH 023/140] Assuring that \r\n is included as blank in unicode.categories --- extra/unicode/categories/categories.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/unicode/categories/categories.factor b/extra/unicode/categories/categories.factor index e5f157463d..4ba96fb9c4 100644 --- a/extra/unicode/categories/categories.factor +++ b/extra/unicode/categories/categories.factor @@ -1,7 +1,7 @@ USING: unicode.syntax ; IN: unicode.categories -CATEGORY: blank Zs Zl Zp ; +CATEGORY: blank Zs Zl Zp \r\n ; CATEGORY: letter Ll ; CATEGORY: LETTER Lu ; CATEGORY: Letter Lu Ll Lt Lm Lo ; From 2f7247334e943ec49374e0670820e2d198b25f94 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Feb 2008 16:37:04 -0600 Subject: [PATCH 024/140] fix with-directory and write unit test --- core/io/files/files-tests.factor | 2 ++ core/io/files/files.factor | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 92e148a854..f804d7c5ac 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -121,3 +121,5 @@ USING: tools.test io.files io threads kernel continuations ; [ ] [ "copy-destination" temp-file delete-tree ] unit-test [ ] [ "copy-tree-test" temp-file delete-tree ] unit-test + +[ t ] [ cwd "core" resource-path [ ] with-directory cwd = ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 85f0621443..55eee65bbf 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -70,7 +70,7 @@ HOOK: cd io-backend ( path -- ) HOOK: cwd io-backend ( -- path ) : with-directory ( path quot -- ) - swap cd cwd [ cd ] curry [ ] cleanup ; inline + cwd [ cd ] curry rot cd [ ] cleanup ; inline ! Creating directories HOOK: make-directory io-backend ( path -- ) @@ -209,4 +209,4 @@ HOOK: io-backend ( path -- stream ) { [ winnt? ] [ "USERPROFILE" os-env ] } { [ wince? ] [ "" resource-path ] } { [ unix? ] [ "HOME" os-env ] } - } cond ; \ No newline at end of file + } cond ; From 2753b2442af438446b971115f94220a99184c0ea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Feb 2008 16:37:27 -0600 Subject: [PATCH 025/140] fix io.files.temporary for windows --- extra/io/files/temporary/backend/backend.factor | 2 +- extra/io/files/temporary/temporary.factor | 10 +++------- extra/io/windows/files/temporary/temporary.factor | 6 ++++-- 3 files changed, 8 insertions(+), 10 deletions(-) diff --git a/extra/io/files/temporary/backend/backend.factor b/extra/io/files/temporary/backend/backend.factor index 0fe4068621..5c6900b3d2 100644 --- a/extra/io/files/temporary/backend/backend.factor +++ b/extra/io/files/temporary/backend/backend.factor @@ -1,5 +1,5 @@ USING: io.backend ; IN: io.files.temporary.backend -HOOK: (temporary-file) io-backend ( path prefix suffix -- stream path ) +HOOK: (temporary-file) io-backend ( path -- stream path ) HOOK: temporary-path io-backend ( -- path ) diff --git a/extra/io/files/temporary/temporary.factor b/extra/io/files/temporary/temporary.factor index d46ddff8c6..5c5e72e83f 100644 --- a/extra/io/files/temporary/temporary.factor +++ b/extra/io/files/temporary/temporary.factor @@ -2,18 +2,14 @@ USING: kernel math math.bitfields combinators.lib math.parser random sequences sequences.lib continuations namespaces io.files io.backend io.nonblocking io arrays io.files.temporary.backend system combinators vocabs.loader ; -USE: tools.walker IN: io.files.temporary -: random-letter ( -- ch ) - 26 random { CHAR: a CHAR: A } random + ; +: random-letter ( -- ch ) 26 random { CHAR: a CHAR: A } random + ; : random-ch ( -- ch ) - { t f } random - [ 10 random CHAR: 0 + ] [ random-letter ] if ; + { t f } random [ 10 random CHAR: 0 + ] [ random-letter ] if ; -: random-name ( n -- string ) - [ drop random-ch ] "" map-as ; +: random-name ( n -- string ) [ drop random-ch ] "" map-as ; : ( prefix suffix -- path duplex-stream ) temporary-path -rot diff --git a/extra/io/windows/files/temporary/temporary.factor b/extra/io/windows/files/temporary/temporary.factor index d96ff49e15..426cab367b 100644 --- a/extra/io/windows/files/temporary/temporary.factor +++ b/extra/io/windows/files/temporary/temporary.factor @@ -1,8 +1,10 @@ -USING: kernel system ; +USING: io.files.temporary.backend io.nonblocking io.windows +kernel system windows.kernel32 ; + IN: io.windows.files.temporary M: windows-io (temporary-file) ( path -- stream ) - GENERIC_WRITE CREATE_NEW 0 open-file 0 ; + GENERIC_WRITE CREATE_NEW 0 open-file 0 ; M: windows-io temporary-path ( -- path ) "TEMP" os-env ; From cc3f226cd39823e6cb548b77fc6d2b4d3eada1a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 Feb 2008 00:57:38 -0600 Subject: [PATCH 026/140] New HTTPD work in progress --- extra/http/basic-authentication/authors.txt | 1 - .../basic-authentication-docs.factor | 69 ----- .../basic-authentication-tests.factor | 66 ----- .../basic-authentication.factor | 65 ----- extra/http/basic-authentication/summary.txt | 1 - extra/http/basic-authentication/tags.txt | 1 - extra/http/client/client-tests.factor | 2 + extra/http/client/client.factor | 11 +- extra/http/http-tests.factor | 33 ++- extra/http/http.factor | 239 ++++++++++++++---- extra/http/mime/mime.factor | 1 + .../server/authentication/basic/basic.factor | 50 ++++ extra/http/server/callbacks/callbacks.factor | 170 +++++++++++++ extra/http/server/cgi/cgi.factor | 65 +++++ extra/http/server/server-tests.factor | 38 +-- extra/http/server/server.factor | 133 +++++----- extra/http/server/sessions/authors.txt | 1 + .../server/sessions/sessions-tests.factor | 32 +++ extra/http/server/sessions/sessions.factor | 112 ++++++++ extra/http/server/static/static.factor | 95 +++++++ .../http/server/templating/templating.factor | 17 +- extra/webapps/cgi/authors.txt | 1 - extra/webapps/cgi/cgi.factor | 75 ------ extra/webapps/file/authors.txt | 1 - extra/webapps/file/file.factor | 136 ---------- extra/webapps/source/authors.txt | 1 - extra/webapps/source/source.factor | 35 --- .../code2html/responder/responder.factor | 15 ++ 28 files changed, 864 insertions(+), 602 deletions(-) delete mode 100644 extra/http/basic-authentication/authors.txt delete mode 100644 extra/http/basic-authentication/basic-authentication-docs.factor delete mode 100644 extra/http/basic-authentication/basic-authentication-tests.factor delete mode 100644 extra/http/basic-authentication/basic-authentication.factor delete mode 100644 extra/http/basic-authentication/summary.txt delete mode 100644 extra/http/basic-authentication/tags.txt mode change 100644 => 100755 extra/http/mime/mime.factor create mode 100755 extra/http/server/authentication/basic/basic.factor create mode 100755 extra/http/server/callbacks/callbacks.factor create mode 100755 extra/http/server/cgi/cgi.factor create mode 100755 extra/http/server/sessions/authors.txt create mode 100755 extra/http/server/sessions/sessions-tests.factor create mode 100755 extra/http/server/sessions/sessions.factor create mode 100755 extra/http/server/static/static.factor delete mode 100755 extra/webapps/cgi/authors.txt delete mode 100755 extra/webapps/cgi/cgi.factor delete mode 100755 extra/webapps/file/authors.txt delete mode 100755 extra/webapps/file/file.factor delete mode 100755 extra/webapps/source/authors.txt delete mode 100755 extra/webapps/source/source.factor create mode 100755 extra/xmode/code2html/responder/responder.factor diff --git a/extra/http/basic-authentication/authors.txt b/extra/http/basic-authentication/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/extra/http/basic-authentication/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/http/basic-authentication/basic-authentication-docs.factor b/extra/http/basic-authentication/basic-authentication-docs.factor deleted file mode 100644 index 68d6e6bf1d..0000000000 --- a/extra/http/basic-authentication/basic-authentication-docs.factor +++ /dev/null @@ -1,69 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax crypto.sha2 ; -IN: http.basic-authentication - -HELP: realms -{ $description - "A hashtable mapping a basic authentication realm (a string) " - "to either a quotation or a hashtable. The quotation has " - "stack effect ( username sha-256-string -- bool ). It " - "is expected to perform the user authentication when called." $nl - "If the realm maps to a hashtable then the hashtable should be a " - "mapping of usernames to sha-256 hashed passwords." $nl - "If the 'realms' variable does not exist in the current scope then " - "authentication will always fail." } -{ $see-also add-realm with-basic-authentication } ; - -HELP: add-realm -{ $values - { "data" "a quotation or a hashtable" } { "name" "a string" } } -{ $description - "Adds the authentication data to the " { $link realms } ". 'data' can be " - "a quotation with stack effect ( username sha-256-string -- bool ) or " - "a hashtable mapping username strings to sha-256-string passwords." } -{ $examples - { $code "H{ { \"admin\" \"...\" } { \"user\" \"...\" } } \"my-realm\" add-realm" } - { $code "[ \"...\" = swap \"admin\" = and ] \"my-realm\" add-realm" } -} -{ $see-also with-basic-authentication realms } ; - -HELP: with-basic-authentication -{ $values - { "realm" "a string" } { "quot" "a quotation with stack effect ( -- )" } } -{ $description - "Checks if the HTTP request has the correct authorisation headers " - "for basic authentication within the named realm. If the headers " - "are not present then a '401' HTTP response results from the " - "request, otherwise the quotation is called." } -{ $examples -{ $code "\"my-realm\" [\n serving-html \"Success!\" write\n] with-basic-authentication" } } -{ $see-also add-realm realms } - ; - -ARTICLE: { "http-authentication" "basic-authentication" } "Basic Authentication" -"The Basic Authentication system provides a simple browser based " -"authentication method to web applications. When the browser requests " -"a resource protected with basic authentication the server responds with " -"a '401' response code which means the user is unauthorized." -$nl -"When the browser receives this it prompts the user for a username and " -"password. This is sent back to the server in a special HTTP header. The " -"server then checks this against its authentication information and either " -"accepts or rejects the users request." -$nl -"Authentication is split up into " { $link realms } ". Each realm can have " -"a different database of username and password information. A responder can " -"require basic authentication by using the " { $link with-basic-authentication } " word." -$nl -"Username and password information can be maintained using " { $link realms } " and " { $link add-realm } "." -$nl -"All passwords on the server should be stored as sha-256 strings generated with the " { $link string>sha-256-string } " word." -$nl -"Note that Basic Authentication itself is insecure in that it " -"sends the username and password as clear text (although it is " -"base64 encoded this is not much help). To prevent eavesdropping " -"it is best to use Basic Authentication with SSL." ; - -IN: http.basic-authentication -ABOUT: { "http-authentication" "basic-authentication" } diff --git a/extra/http/basic-authentication/basic-authentication-tests.factor b/extra/http/basic-authentication/basic-authentication-tests.factor deleted file mode 100644 index 318123b0b4..0000000000 --- a/extra/http/basic-authentication/basic-authentication-tests.factor +++ /dev/null @@ -1,66 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel crypto.sha2 http.basic-authentication tools.test - namespaces base64 sequences ; - -{ t } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "admin:passwordx" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ t } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "admin:xpassword" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - f realms set - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test diff --git a/extra/http/basic-authentication/basic-authentication.factor b/extra/http/basic-authentication/basic-authentication.factor deleted file mode 100644 index dfe04dc4b5..0000000000 --- a/extra/http/basic-authentication/basic-authentication.factor +++ /dev/null @@ -1,65 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel base64 http.server crypto.sha2 namespaces assocs - quotations hashtables combinators splitting sequences - http.server.responders io html.elements ; -IN: http.basic-authentication - -! 'realms' is a hashtable mapping a realm (a string) to -! either a quotation or a hashtable. The quotation -! has stack effect ( username sha-256-string -- bool ). -! It should perform the user authentication. 'sha-256-string' -! is the plain text password provided by the user passed through -! 'string>sha-256-string'. If 'realms' maps to a hashtable then -! it is a mapping of usernames to sha-256 hashed passwords. -! -! 'realms' can be set on a per vhost basis in the vhosts -! table. -! -! If there are no realms then authentication fails. -SYMBOL: realms - -: add-realm ( data name -- ) - #! Add the named realm to the realms table. - #! 'data' should be a hashtable or a quotation. - realms get [ H{ } clone dup realms set ] unless* - set-at ; - -: user-authorized? ( username password realm -- bool ) - realms get dup [ - at { - { [ dup quotation? ] [ call ] } - { [ dup hashtable? ] [ swapd at = ] } - { [ t ] [ 3drop f ] } - } cond - ] [ - 3drop drop f - ] if ; - -: authorization-ok? ( realm header -- bool ) - #! Given the realm and the 'Authorization' header, - #! authenticate the user. - dup [ - " " split dup first "Basic" = [ - second base64> ":" split first2 string>sha-256-string rot - user-authorized? - ] [ - 2drop f - ] if - ] [ - 2drop f - ] if ; - -: authentication-error ( realm -- ) - "401 Unauthorized" response - "Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate print-header - - "Username or Password is invalid" write - ; - -: with-basic-authentication ( realm quot -- ) - #! Check if the user is authenticated in the given realm - #! to run the specified quotation. If not, use Basic - #! Authentication to ask for authorization details. - over "authorization" header-param authorization-ok? - [ nip call ] [ drop authentication-error ] if ; diff --git a/extra/http/basic-authentication/summary.txt b/extra/http/basic-authentication/summary.txt deleted file mode 100644 index 60cef7e630..0000000000 --- a/extra/http/basic-authentication/summary.txt +++ /dev/null @@ -1 +0,0 @@ -HTTP Basic Authentication implementation diff --git a/extra/http/basic-authentication/tags.txt b/extra/http/basic-authentication/tags.txt deleted file mode 100644 index c0772185a0..0000000000 --- a/extra/http/basic-authentication/tags.txt +++ /dev/null @@ -1 +0,0 @@ -web diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 5e407657a8..4fca1697a5 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -16,6 +16,8 @@ tuple-syntax namespaces ; host: "www.apple.com" path: "/index.html" port: 80 + version: "1.1" + cookies: V{ } } ] [ [ diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 8b74b6dc72..1c408e44e3 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files io.timeouts strings -splitting continuations assocs.lib calendar vectors hashtables +splitting continuations calendar vectors hashtables accessors ; IN: http.client @@ -32,7 +32,7 @@ DEFER: (http-request) : do-redirect ( response -- response stream ) dup response-code 300 399 between? [ - header>> "location" peek-at + header>> "location" swap at dup "http://" head? [ absolute-redirect ] [ @@ -44,7 +44,7 @@ DEFER: (http-request) : (http-request) ( request -- response stream ) dup host>> over port>> stdio set - write-request flush read-response + dup "r" set-global write-request flush read-response do-redirect ; PRIVATE> @@ -59,8 +59,7 @@ PRIVATE> ] with-scope ; : ( -- request ) - request construct-empty - "GET" >>method ; + "GET" >>method ; : http-get-stream ( url -- response stream ) http-request ; @@ -86,7 +85,7 @@ PRIVATE> dup download-name download-to ; : ( content-type content -- request ) - request construct-empty + "POST" >>method swap >>post-data swap >>post-data-type ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 9fa593053c..681ebd97e2 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -29,12 +29,14 @@ blah [ TUPLE{ request + port: 80 method: "GET" path: "bar" - query: f + query: H{ } version: "1.1" - header: H{ { "some-header" V{ "1" "2" } } { "content-length" V{ "4" } } } + header: H{ { "some-header" "1; 2" } { "content-length" "4" } } post-data: "blah" + cookies: V{ } } ] [ read-request-test-1 [ @@ -45,8 +47,7 @@ blah STRING: read-request-test-1' GET bar HTTP/1.1 content-length: 4 -some-header: 1 -some-header: 2 +some-header: 1; 2 blah ; @@ -60,18 +61,20 @@ read-request-test-1' 1array [ ] unit-test STRING: read-request-test-2 -HEAD http://foo/bar HTTP/1.0 +HEAD http://foo/bar HTTP/1.1 Host: www.sex.com ; [ TUPLE{ request + port: 80 method: "HEAD" path: "bar" - query: f - version: "1.0" - header: H{ { "host" V{ "www.sex.com" } } } + query: H{ } + version: "1.1" + header: H{ { "host" "www.sex.com" } } host: "www.sex.com" + cookies: V{ } } ] [ read-request-test-2 [ @@ -80,7 +83,7 @@ Host: www.sex.com ] unit-test STRING: read-response-test-1 -HTTP/1.0 404 not found +HTTP/1.1 404 not found Content-Type: text/html blah @@ -88,10 +91,11 @@ blah [ TUPLE{ response - version: "1.0" + version: "1.1" code: 404 message: "not found" - header: H{ { "content-type" V{ "text/html" } } } + header: H{ { "content-type" "text/html" } } + cookies: V{ } } ] [ read-response-test-1 @@ -100,7 +104,7 @@ blah STRING: read-response-test-1' -HTTP/1.0 404 not found +HTTP/1.1 404 not found content-type: text/html @@ -113,3 +117,8 @@ read-response-test-1' 1array [ ! normalize crlf string-lines "\n" join ] unit-test + +[ t ] [ + "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT" + dup parse-cookies unparse-cookies = +] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 4c2834b7ca..8686d87052 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -2,34 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: hashtables io io.streams.string kernel math namespaces math.parser assocs sequences strings splitting ascii -io.encodings.utf8 assocs.lib namespaces unicode.case combinators -vectors sorting new-slots accessors calendar ; +io.encodings.utf8 namespaces unicode.case combinators +vectors sorting new-slots accessors calendar calendar.format +quotations arrays ; IN: http : http-port 80 ; inline -: crlf "\r\n" write ; - -: header-line ( line -- ) - ": " split1 dup [ swap >lower insert ] [ 2drop ] if ; - -: read-header-line ( -- ) - readln dup - empty? [ drop ] [ header-line read-header-line ] if ; - -: read-header ( -- multi-assoc ) - [ read-header-line ] H{ } make-assoc ; - -: write-header ( multi-assoc -- ) - >alist sort-keys - [ - swap write ": " write { - { [ dup number? ] [ number>string ] } - { [ dup timestamp? ] [ timestamp>http-string ] } - { [ dup string? ] [ ] } - } cond write crlf - ] multi-assoc-each crlf ; - : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without #! URL-encoding? @@ -73,6 +52,54 @@ IN: http : url-decode ( str -- str ) [ 0 swap url-decode-iter ] "" make decode-utf8 ; +: crlf "\r\n" write ; + +: add-header ( value key assoc -- ) + [ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ; + +: header-line ( line -- ) + dup first blank? [ + [ blank? ] left-trim + "last-header" get + "header" get + add-header + ] [ + ": " split1 dup [ + swap >lower dup "last-header" set + "header" get add-header + ] [ + 2drop + ] if + ] if ; + +: read-header-line ( -- ) + readln dup + empty? [ drop ] [ header-line read-header-line ] if ; + +: read-header ( -- assoc ) + H{ } clone [ + "header" [ read-header-line ] with-variable + ] keep ; + +: header-value>string ( value -- string ) + { + { [ dup number? ] [ number>string ] } + { [ dup timestamp? ] [ timestamp>http-string ] } + { [ dup string? ] [ ] } + { [ dup sequence? ] [ [ header-value>string ] map "; " join ] } + } cond ; + +: check-header-string ( str -- str ) + #! http://en.wikipedia.org/wiki/HTTP_Header_Injection + dup [ "\r\n" member? ] contains? + [ "Header injection attack" throw ] when ; + +: write-header ( assoc -- ) + >alist sort-keys [ + swap url-encode write ": " write + header-value>string check-header-string write crlf + ] assoc-each crlf ; + : query>assoc ( query -- assoc ) dup [ "&" split [ @@ -84,6 +111,50 @@ IN: http [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map "&" join ; +TUPLE: cookie name value path domain expires http-only ; + +: ( value name -- cookie ) + cookie construct-empty + swap >>name swap >>value ; + +: parse-cookies ( string -- seq ) + [ + f swap + + ";" split [ + [ blank? ] trim "=" split1 swap >lower { + { "expires" [ >>expires ] } + { "domain" [ >>domain ] } + { "path" [ >>path ] } + { "httponly" [ drop t >>http-only ] } + { "" [ drop ] } + [ dup , nip ] + } case + ] each + + drop + ] { } make ; + +: (unparse-cookie) ( key value -- ) + { + { [ dup f eq? ] [ 2drop ] } + { [ dup t eq? ] [ drop , ] } + { [ t ] [ "=" swap 3append , ] } + } cond ; + +: unparse-cookie ( cookie -- strings ) + [ + dup name>> >lower over value>> (unparse-cookie) + "path" over path>> (unparse-cookie) + "domain" over domain>> (unparse-cookie) + "expires" over expires>> (unparse-cookie) + "httponly" over http-only>> (unparse-cookie) + drop + ] { } make ; + +: unparse-cookies ( cookies -- string ) + [ unparse-cookie ] map concat "; " join ; + TUPLE: request host port @@ -93,12 +164,21 @@ query version header post-data -post-data-type ; +post-data-type +cookies ; : request construct-empty - "1.0" >>version - http-port >>port ; + "1.1" >>version + http-port >>port + H{ } clone >>query + V{ } clone >>cookies ; + +: query-param ( request key -- value ) + swap query>> at ; + +: set-query-param ( request value key -- request ) + pick query>> set-at ; : url>path ( url -- path ) url-decode "http://" ?head @@ -132,12 +212,15 @@ post-data-type ; : read-request-header ( request -- request ) read-header >>header ; +: header ( request/response key -- value ) + swap header>> at ; + SYMBOL: max-post-request 1024 256 * max-post-request set-global : content-length ( header -- n ) - "content-length" peek-at string>number dup [ + "content-length" swap at string>number dup [ dup max-post-request get > [ "content-length > max-post-request" throw ] when @@ -151,10 +234,13 @@ SYMBOL: max-post-request [ string>number ] [ http-port ] if* ; : extract-host ( request -- request ) - dup header>> "host" peek-at parse-host >r >>host r> >>port ; + dup "host" header parse-host >r >>host r> >>port ; : extract-post-data-type ( request -- request ) - dup header>> "content-type" peek-at >>post-data-type ; + dup "content-type" header >>post-data-type ; + +: extract-cookies ( request -- request ) + dup "cookie" header [ parse-cookies >>cookies ] when* ; : read-request ( -- request ) @@ -164,7 +250,8 @@ SYMBOL: max-post-request read-request-header read-post-data extract-host - extract-post-data-type ; + extract-post-data-type + extract-cookies ; : write-method ( request -- request ) dup method>> write bl ; @@ -184,9 +271,10 @@ SYMBOL: max-post-request : write-request-header ( request -- request ) dup header>> >hashtable - over host>> [ "host" replace-at ] when* - over post-data>> [ length "content-length" replace-at ] when* - over post-data-type>> [ "content-type" replace-at ] when* + over host>> [ "host" pick set-at ] when* + over post-data>> [ length "content-length" pick set-at ] when* + over post-data-type>> [ "content-type" pick set-at ] when* + over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when* write-header ; : write-post-data ( request -- request ) @@ -194,7 +282,7 @@ SYMBOL: max-post-request : write-request ( request -- ) write-method - write-url + write-request-url write-version write-request-header write-post-data @@ -209,30 +297,42 @@ SYMBOL: max-post-request ":" write dup port>> number>string write ] when - "/" write + dup path>> "/" head? [ "/" write ] unless write-url drop ] with-string-writer ; +: set-header ( request/response value key -- request/response ) + pick header>> set-at ; + +GENERIC: write-response ( response -- ) + +GENERIC: write-full-response ( request response -- ) + TUPLE: response version code message -header ; +header +cookies +body ; : response construct-empty - "1.0" >>version - H{ } clone >>header ; + "1.1" >>version + H{ } clone >>header + "close" "connection" set-header + now timestamp>http-string "date" set-header + V{ } clone >>cookies ; : read-response-version - " " read-until + " \t" read-until [ "Bad response: version" throw ] unless parse-version >>version ; : read-response-code - " " read-until [ "Bad response: code" throw ] unless + " \t" read-until [ "Bad response: code" throw ] unless string>number [ "Bad response: code" throw ] unless* >>code ; @@ -240,7 +340,8 @@ header ; readln >>message ; : read-response-header - read-header >>header ; + read-header >>header + dup "set-cookie" header [ parse-cookies >>cookies ] when* ; : read-response ( -- response ) @@ -260,9 +361,20 @@ header ; dup message>> write crlf ; : write-response-header ( response -- response ) - dup header>> write-header ; + dup header>> clone + over cookies>> f like + [ unparse-cookies "set-cookie" pick set-at ] when* + write-header ; -: write-response ( respose -- ) +: write-response-body ( response -- response ) + dup body>> { + { [ dup not ] [ drop ] } + { [ dup string? ] [ write ] } + { [ dup callable? ] [ call ] } + { [ t ] [ stdio get stream-copy ] } + } cond ; + +M: response write-response ( respose -- ) write-response-version write-response-code write-response-message @@ -270,8 +382,39 @@ header ; flush drop ; -: set-response-header ( response value key -- response ) - pick header>> -rot replace-at drop ; +M: response write-full-response ( request response -- ) + dup write-response + swap method>> "HEAD" = [ write-response-body ] unless ; -: set-content-type ( response content-type -- response ) - "content-type" set-response-header ; +: set-content-type ( request/response content-type -- request/response ) + "content-type" set-header ; + +: get-cookie ( request/response name -- cookie/f ) + >r cookies>> r> [ swap name>> = ] curry find nip ; + +: delete-cookie ( request/response name -- ) + over cookies>> >r get-cookie r> delete ; + +: put-cookie ( request/response cookie -- request/response ) + [ dupd name>> get-cookie [ dupd delete-cookie ] when* ] keep + over cookies>> push ; + +TUPLE: raw-response +version +code +message +body ; + +: ( -- response ) + raw-response construct-empty + "1.1" >>version ; + +M: raw-response write-response ( respose -- ) + write-response-version + write-response-code + write-response-message + write-response-body + drop ; + +M: raw-response write-full-response ( response -- ) + write-response nip ; diff --git a/extra/http/mime/mime.factor b/extra/http/mime/mime.factor old mode 100644 new mode 100755 index 3365127d87..f9097ecce3 --- a/extra/http/mime/mime.factor +++ b/extra/http/mime/mime.factor @@ -30,5 +30,6 @@ H{ { "pdf" "application/pdf" } { "factor" "text/plain" } + { "cgi" "application/x-cgi-script" } { "fhtml" "application/x-factor-server-page" } } "mime-types" set-global diff --git a/extra/http/server/authentication/basic/basic.factor b/extra/http/server/authentication/basic/basic.factor new file mode 100755 index 0000000000..b6dbed4b62 --- /dev/null +++ b/extra/http/server/authentication/basic/basic.factor @@ -0,0 +1,50 @@ +! Copyright (c) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.authentication.basic +USING: accessors new-slots quotations assocs kernel splitting +base64 crypto.sha2 html.elements io combinators http.server +http sequences ; + +! 'users' is a quotation or an assoc. The quotation +! has stack effect ( sha-256-string username -- ? ). +! It should perform the user authentication. 'sha-256-string' +! is the plain text password provided by the user passed through +! 'string>sha-256-string'. If 'users' is an assoc then +! it is a mapping of usernames to sha-256 hashed passwords. +TUPLE: realm responder name users ; + +C: realm + +: user-authorized? ( password username realm -- ? ) + users>> { + { [ dup callable? ] [ call ] } + { [ dup assoc? ] [ at = ] } + } cond ; + +: authorization-ok? ( realm header -- bool ) + #! Given the realm and the 'Authorization' header, + #! authenticate the user. + dup [ + " " split1 swap "Basic" = [ + base64> ":" split1 string>sha-256-string + spin user-authorized? + ] [ + 2drop f + ] if + ] [ + 2drop f + ] if ; + +: <401> ( realm -- response ) + 401 "Unauthorized" + "Basic realm=\"" rot name>> "\"" 3append + "WWW-Authenticate" set-header + [ + + "Username or Password is invalid" write + + ] >>body ; + +M: realm call-responder ( request path realm -- response ) + pick "authorization" header dupd authorization-ok? + [ responder>> call-responder ] [ 2nip <401> ] if ; diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor new file mode 100755 index 0000000000..a000a76040 --- /dev/null +++ b/extra/http/server/callbacks/callbacks.factor @@ -0,0 +1,170 @@ +! Copyright (C) 2004 Chris Double. +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: html http http.server io kernel math namespaces +continuations calendar sequences assocs new-slots hashtables +accessors arrays alarms quotations combinators ; +IN: http.server.callbacks + +SYMBOL: responder + +TUPLE: callback-responder responder callbacks ; + +: ( responder -- responder' ) + #! A continuation responder is a special type of session + #! manager. However it works entirely differently from + #! the URL and cookie session managers. + H{ } clone callback-responder construct-boa ; + +TUPLE: callback cont quot expires alarm responder ; + +: timeout 20 minutes ; + +: timeout-callback ( callback -- ) + dup alarm>> cancel-alarm + dup responder>> callbacks>> delete-at ; + +: touch-callback ( callback -- ) + dup expires>> [ + dup alarm>> [ cancel-alarm ] when* + dup [ timeout-callback ] curry timeout later >>alarm + ] when drop ; + +: ( cont quot expires? -- callback ) + [ f responder get callback construct-boa ] keep + [ dup touch-callback ] when ; + +: invoke-callback ( request exit-cont callback -- response ) + [ quot>> 3array ] keep cont>> continue-with ; + +: register-callback ( cont quot expires? -- id ) + + responder get callbacks>> generate-key + [ responder get callbacks>> set-at ] keep ; + +SYMBOL: exit-continuation + +: exit-with exit-continuation get continue-with ; + +: forward-to-url ( url -- * ) + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + exit-with ; + +: cont-id "factorcontid" ; + +: id>url ( id -- url ) + request get clone + swap cont-id associate >>query + request-url ; + +: forward-to-id ( id -- * ) + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + id>url forward-to-url ; + +: restore-request ( pair -- ) + first3 >r exit-continuation set request set r> call ; + +: resume-page ( request page responder callback -- * ) + dup touch-callback + >r 2drop exit-continuation get + r> invoke-callback ; + +SYMBOL: post-refresh-get? + +: redirect-to-here ( -- ) + #! Force a redirect to the client browser so that the browser + #! goes to the current point in the code. This forces an URL + #! change on the browser so that refreshing that URL will + #! immediately run from this code point. This prevents the + #! "this request will issue a POST" warning from the browser + #! and prevents re-running the previous POST logic. This is + #! known as the 'post-refresh-get' pattern. + post-refresh-get? get [ + [ + [ ] t register-callback forward-to-id + ] callcc1 restore-request + ] [ + post-refresh-get? on + ] if ; + +SYMBOL: current-show + +: store-current-show ( -- ) + #! Store the current continuation in the variable 'current-show' + #! so it can be returned to later by 'quot-id'. Note that it + #! recalls itself when the continuation is called to ensure that + #! it resets its value back to the most recent show call. + [ current-show set f ] callcc1 + [ restore-request store-current-show ] when* ; + +: show-final ( quot -- * ) + [ + >r store-current-show redirect-to-here r> call exit-with + ] with-scope ; inline + +M: callback-responder call-responder + [ + [ + exit-continuation set + dup responder set + pick request set + pick cont-id query-param over callbacks>> at [ + resume-page + ] [ + responder>> call-responder + "Continuation responder pages must use show-final" throw + ] if* + ] with-scope + ] callcc1 >r 3drop r> ; + +: show-page ( quot -- ) + [ + >r store-current-show redirect-to-here r> + [ + [ ] register-callback + call + exit-with + ] callcc1 restore-request + ] with-scope ; inline + +: quot-id ( quot -- id ) + current-show get swap t register-callback ; + +: quot-url ( quot -- url ) + quot-id id>url ; + +! SYMBOL: current-show +! +! : store-current-show ( -- ) +! #! Store the current continuation in the variable 'current-show' +! #! so it can be returned to later by href callbacks. Note that it +! #! recalls itself when the continuation is called to ensure that +! #! it resets its value back to the most recent show call. +! [ ( 0 -- ) +! [ ( 0 1 -- ) +! current-show set ( 0 -- ) +! continue +! ] callcc1 +! nip +! store-current-show +! ] callcc0 ; +! + +! +! : show-final ( quot -- * ) +! store-current-show +! redirect-to-here +! call +! exit-with ; inline +! +! : show-page ( quot -- request ) +! store-current-show redirect-to-here +! [ +! register-continuation +! call +! exit-with +! ] callcc1 restore-request ; inline diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor new file mode 100755 index 0000000000..9950a9a4a4 --- /dev/null +++ b/extra/http/server/cgi/cgi.factor @@ -0,0 +1,65 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel assocs io.files combinators +arrays io.launcher io http.server.static http.server +http accessors sequences strings math.parser ; +IN: http.server.cgi + +: post? request get method>> "POST" = ; + +: cgi-variables ( script-path -- assoc ) + #! This needs some work. + [ + "CGI/1.0" "GATEWAY_INTERFACE" set + "HTTP/" request get version>> append "SERVER_PROTOCOL" set + "Factor" "SERVER_SOFTWARE" set + + dup "PATH_TRANSLATED" set + "SCRIPT_FILENAME" set + + request get path>> "SCRIPT_NAME" set + + request get host>> "SERVER_NAME" set + request get port>> number>string "SERVER_PORT" set + "" "PATH_INFO" set + "" "REMOTE_HOST" set + "" "REMOTE_ADDR" set + "" "AUTH_TYPE" set + "" "REMOTE_USER" set + "" "REMOTE_IDENT" set + + request get method>> "REQUEST_METHOD" set + request get query>> assoc>query "QUERY_STRING" set + request get "cookie" header "HTTP_COOKIE" set + + request get "user-agent" header "HTTP_USER_AGENT" set + request get "accept" header "HTTP_ACCEPT" set + + post? [ + request get post-data-type>> "CONTENT_TYPE" set + request get post-data>> length number>string "CONTENT_LENGTH" set + ] when + ] H{ } make-assoc ; + +: cgi-descriptor ( name -- desc ) + [ + dup 1array +arguments+ set + cgi-variables +environment+ set + ] H{ } make-assoc ; + +: serve-cgi ( name -- response ) + + 200 >>code + "CGI output follows" >>message + swap [ + stdio get swap cgi-descriptor [ + post? [ + request get post-data>> write flush + ] when + stdio get swap (stream-copy) + ] with-stream + ] curry >>body ; + +: enable-cgi ( responder -- responder ) + [ serve-cgi ] "application/x-cgi-script" + pick special>> set-at ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index a67d21a640..8616071580 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,45 +1,53 @@ USING: http.server tools.test kernel namespaces accessors -new-slots assocs.lib io http math sequences ; +new-slots io http math sequences assocs ; IN: temporary -TUPLE: mock-responder ; +TUPLE: mock-responder path ; -: ( path -- responder ) - mock-responder construct-delegate ; +C: mock-responder -M: mock-responder do-responder +M: mock-responder call-responder 2nip path>> on - [ "Hello world" print ] "text/plain" ; : check-dispatch ( tag path -- ? ) over off swap default-host get call-responder - write-response call get ; + write-response get ; [ - "" - "foo" add-responder - "bar" add-responder - "baz/" - "123" add-responder + + "foo" "foo" add-responder + "bar" "bar" add-responder + + "123" "123" add-responder "default" >>default - add-responder + "baz" add-responder default-host set + [ "foo" ] [ + "foo" default-host get find-responder path>> nip + ] unit-test + + [ "bar" ] [ + "bar" default-host get find-responder path>> nip + ] unit-test + [ t ] [ "foo" "foo" check-dispatch ] unit-test [ f ] [ "foo" "bar" check-dispatch ] unit-test [ t ] [ "bar" "bar" check-dispatch ] unit-test [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test + [ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test + [ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test [ t ] [ "123" "baz/123" check-dispatch ] unit-test + [ t ] [ "123" "baz///123" check-dispatch ] unit-test [ t ] [ "baz" >>path "baz" default-host get call-responder dup code>> 300 399 between? >r - header>> "location" peek-at "baz/" tail? r> and - nip + header>> "location" swap at "baz/" tail? r> and ] unit-test ] with-scope diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index e06ae6a95c..3780b2110d 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,24 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar -new-slots html.elements accessors math.parser combinators.lib ; +new-slots html.elements accessors math.parser combinators.lib +vocabs.loader debugger html continuations random ; IN: http.server -TUPLE: responder path directory ; +GENERIC: call-responder ( request path responder -- response ) -: ( path -- responder ) - "/" ?tail responder construct-boa ; +TUPLE: trivial-responder response ; -GENERIC: do-responder ( request path responder -- quot response ) +C: trivial-responder -TUPLE: trivial-responder quot response ; - -: ( quot response -- responder ) - trivial-responder construct-boa - "" over set-delegate ; - -M: trivial-responder do-responder - 2nip dup quot>> swap response>> ; +M: trivial-responder call-responder 2nip response>> call ; : trivial-response-body ( code message -- ) @@ -28,23 +21,30 @@ M: trivial-responder do-responder ; -: ( code message -- quot response ) - [ [ trivial-response-body ] 2curry ] 2keep +: ( code message -- response ) + + 2over [ trivial-response-body ] 2curry >>body "text/html" set-content-type swap >>message swap >>code ; -: <404> ( -- quot response ) +: <404> ( -- response ) 404 "Not Found" ; -: ( to code message -- quot response ) - - rot "location" set-response-header ; +SYMBOL: 404-responder -: ( to -- quot response ) +[ <404> ] 404-responder set-global + +: ( to code message -- response ) + + swap "location" set-header ; + +\ DEBUG add-input-logging + +: ( to -- response ) 301 "Moved Permanently" ; -: ( to -- quot response ) +: ( to -- response ) 307 "Temporary Redirect" ; : ( content-type -- response ) @@ -52,66 +52,58 @@ M: trivial-responder do-responder 200 >>code swap set-content-type ; -TUPLE: dispatcher responders default ; +TUPLE: dispatcher default responders ; -: responder-matches? ( path responder -- ? ) - path>> head? ; +: get-responder ( name dispatcher -- responder ) + tuck responders>> at [ ] [ default>> ] ?if ; -TUPLE: no-/-responder ; +: find-responder ( path dispatcher -- path responder ) + >r [ CHAR: / = ] left-trim "/" split1 + swap [ CHAR: / = ] right-trim r> get-responder ; -M: no-/-responder do-responder - 2drop +: redirect-with-/ ( request -- response ) dup path>> "/" append >>path request-url ; -: ( -- responder ) - "" no-/-responder construct-delegate ; +M: dispatcher call-responder + over [ + find-responder call-responder + ] [ + 2drop redirect-with-/ + ] if ; - no-/-responder set-global +: ( -- dispatcher ) + 404-responder get-global H{ } clone + dispatcher construct-boa ; -: find-responder ( path dispatcher -- path responder ) - >r "/" ?head drop r> - [ responders>> [ dupd responder-matches? ] find nip ] keep - default>> or [ path>> ?head drop ] keep ; - -: no-trailing-/ ( path responder -- path responder ) - over empty? over directory>> and - [ drop no-/-responder get-global ] when ; - -: call-responder ( request path responder -- quot response ) - no-trailing-/ do-responder ; - -SYMBOL: 404-responder - -<404> 404-responder set-global - -M: dispatcher do-responder - find-responder call-responder ; - -: ( path -- dispatcher ) - - dispatcher construct-delegate - 404-responder get-global >>default - V{ } clone >>responders ; - -: add-responder ( dispatcher responder -- dispatcher ) - over responders>> push ; +: add-responder ( dispatcher responder path -- dispatcher ) + pick responders>> set-at ; SYMBOL: virtual-hosts SYMBOL: default-host virtual-hosts global [ drop H{ } clone ] cache drop -default-host global [ drop 404-responder ] cache drop +default-host global [ drop 404-responder get-global ] cache drop : find-virtual-host ( host -- responder ) virtual-hosts get at [ default-host get ] unless* ; +: <500> ( error -- response ) + 500 "Internal server error" + swap [ + "Internal server error" [ + [ print-error nl :c ] with-html-stream + ] simple-page + ] curry >>body ; + : handle-request ( request -- ) [ - dup path>> over host>> find-virtual-host - call-responder - write-response - ] keep method>> "HEAD" = [ drop ] [ call ] if ; + dup dup path>> over host>> + find-virtual-host call-responder + ] [ <500> ] recover + dup write-response + swap method>> "HEAD" = + [ drop ] [ write-response-body ] if ; : default-timeout 1 minutes stdio get set-timeout ; @@ -120,12 +112,21 @@ LOG: httpd-hit NOTICE : log-request ( request -- ) { method>> host>> path>> } map-exec-with httpd-hit ; +SYMBOL: development-mode + +: (httpd) ( -- ) + default-timeout + development-mode get-global + [ global [ refresh-all ] bind ] when + read-request dup log-request handle-request ; + : httpd ( port -- ) - internet-server "http.server" [ - default-timeout - read-request dup log-request handle-request - ] with-server ; + internet-server "http.server" [ (httpd) ] with-server ; : httpd-main ( -- ) 8888 httpd ; MAIN: httpd-main + +: generate-key ( assoc -- str ) + 4 big-random >hex dup pick key? + [ drop generate-key ] [ nip ] if ; diff --git a/extra/http/server/sessions/authors.txt b/extra/http/server/sessions/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/http/server/sessions/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor new file mode 100755 index 0000000000..988ae41609 --- /dev/null +++ b/extra/http/server/sessions/sessions-tests.factor @@ -0,0 +1,32 @@ +IN: temporary +USING: tools.test http.server.sessions math namespaces +kernel accessors ; + +"1234" f [ + [ ] [ 3 "x" sset ] unit-test + + [ 9 ] [ "x" sget sq ] unit-test + + [ ] [ "x" [ 1- ] schange ] unit-test + + [ 4 ] [ "x" sget sq ] unit-test +] with-session + +[ t ] [ f url-sessions? ] unit-test +[ t ] [ f cookie-sessions? ] unit-test + +[ ] [ + f + [ 0 "x" sset ] >>init + "manager" set +] unit-test + +[ { 5 0 } ] [ + [ + "manager" get new-session + dup "manager" get get-session [ 5 "a" sset ] with-session + dup "manager" get get-session [ "a" sget , ] with-session + dup "manager" get get-session [ "x" sget , ] with-session + "manager" get get-session delete-session + ] { } make +] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor new file mode 100755 index 0000000000..7d6ca5a637 --- /dev/null +++ b/extra/http/server/sessions/sessions.factor @@ -0,0 +1,112 @@ +! Copyright (C) 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs calendar kernel math.parser namespaces random +boxes alarms new-slots accessors http http.server +quotations hashtables sequences ; +IN: http.server.sessions + +! ! ! ! ! ! +! WARNING: this session manager is vulnerable to XSRF attacks +! ! ! ! ! ! + +TUPLE: session-manager responder init sessions ; + +: ( responder class -- responder' ) + >r [ ] H{ } clone session-manager construct-boa r> + construct-delegate ; inline + +TUPLE: session id manager namespace alarm ; + +: ( id manager -- session ) + H{ } clone \ session construct-boa ; + +: timeout ( -- dt ) 20 minutes ; + +: cancel-timeout ( session -- ) + alarm>> ?box [ cancel-alarm ] [ drop ] if ; + +: delete-session ( session -- ) + dup cancel-timeout + dup manager>> sessions>> delete-at ; + +: touch-session ( session -- ) + dup cancel-timeout + dup [ delete-session ] curry timeout later + swap session-alarm >box ; + +: session ( -- assoc ) \ session get namespace>> ; + +: sget ( key -- value ) session at ; + +: sset ( value key -- ) session set-at ; + +: schange ( key quot -- ) session swap change-at ; inline + +: with-session ( session quot -- ) + >r \ session r> with-variable ; inline + +: new-session ( responder -- id ) + [ sessions>> generate-key dup ] keep + [ dup touch-session ] keep + [ init>> with-session ] 2keep + >r over r> sessions>> set-at ; + +: get-session ( id responder -- session ) + sessions>> tuck at* [ + nip dup touch-session + ] [ + 2drop f + ] if ; + +: call-responder/session ( request path responder session -- response ) + [ responder>> call-responder ] with-session ; + +: sessions ( -- manager/f ) + \ session get dup [ manager>> ] when ; + +GENERIC: session-link* ( url query sessions -- string ) + +M: object session-link* 2drop url-encode ; + +: session-link ( url query -- string ) sessions session-link* ; + +TUPLE: url-sessions ; + +: ( responder -- responder' ) + url-sessions ; + +: sess-id "factorsessid" ; + +M: url-sessions call-responder ( request path responder -- response ) + pick sess-id query-param over get-session [ + call-responder/session + ] [ + new-session nip sess-id set-query-param + request-url + ] if* ; + +M: url-sessions session-link* + drop + \ session get id>> sess-id associate union assoc>query + >r url-encode r> + dup assoc-empty? [ drop ] [ "?" swap 3append ] if ; + +TUPLE: cookie-sessions ; + +: ( responder -- responder' ) + cookie-sessions ; + +: get-session-cookie ( request -- cookie ) + sess-id get-cookie ; + +: ( id -- cookie ) + sess-id ; + +M: cookie-sessions call-responder ( request path responder -- response ) + pick get-session-cookie value>> over get-session [ + call-responder/session + ] [ + dup new-session + [ over get-session call-responder/session ] keep + put-cookie + ] if* ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor new file mode 100755 index 0000000000..e1a7a3cae9 --- /dev/null +++ b/extra/http/server/static/static.factor @@ -0,0 +1,95 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar html io io.files kernel math math.parser http +http.server namespaces parser sequences strings assocs +hashtables debugger http.mime sorting html.elements logging +calendar.format new-slots accessors ; +IN: http.server.static + +SYMBOL: responder + +! special maps mime types to quots with effect ( path -- ) +TUPLE: file-responder root hook special ; + +: unix-time>timestamp ( n -- timestamp ) + >r unix-1970 r> seconds time+ ; + +: file-http-date ( filename -- string ) + file-modified unix-time>timestamp timestamp>http-string ; + +: last-modified-matches? ( filename -- ? ) + file-http-date dup [ + request get "if-modified-since" header = + ] when ; + +: <304> ( -- response ) + 304 "Not modified" ; + +: ( root hook -- responder ) + H{ } clone file-responder construct-boa ; + +: ( root -- responder ) + [ + + over file-length "content-length" set-header + over file-http-date "last-modified" set-header + swap [ stdio get stream-copy ] curry >>body + ] ; + +: serve-static ( filename mime-type -- response ) + over last-modified-matches? + [ 2drop <304> ] [ responder get hook>> call ] if ; + +: serving-path ( filename -- filename ) + "" or responder get root>> swap path+ ; + +: serve-file ( filename -- response ) + dup mime-type + dup responder get special>> at + [ call ] [ serve-static ] ?if ; + +\ serve-file NOTICE add-input-logging + +: file. ( name dirp -- ) + [ "/" append ] when + dup write ; + +: directory. ( path -- ) + dup file-name [ +

dup file-name write

+
    + directory sort-keys + [
  • file.
    • ] assoc-each +
+ ] simple-html-document ; + +: list-directory ( directory -- response ) + "text/html" + swap [ directory. ] curry >>body ; + +: find-index ( filename -- path ) + { "index.html" "index.fhtml" } + [ dupd path+ exists? ] find nip + dup [ path+ ] [ nip ] if ; + +: serve-directory ( filename -- response ) + dup "/" tail? [ + dup find-index + [ serve-file ] [ list-directory ] ?if + ] [ + drop request get redirect-with-/ + ] if ; + +: serve-object ( filename -- response ) + serving-path dup exists? [ + dup directory? [ serve-directory ] [ serve-file ] if + ] [ + drop <404> + ] if ; + +M: file-responder call-responder ( request path responder -- response ) + [ + responder set + swap request set + serve-object + ] with-scope ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index 3b0dcb8e5e..b298faca74 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -4,7 +4,8 @@ USING: continuations sequences kernel parser namespaces io io.files io.streams.lines io.streams.string html html.elements source-files debugger combinators math quotations generic -strings splitting ; +strings splitting accessors http.server.static http.server +assocs ; IN: http.server.templating @@ -82,10 +83,10 @@ DEFER: <% delimiter templating-vocab use+ ! so that reload works properly dup source-file file set - dup ?resource-path file-contents + ?resource-path file-contents [ eval-template ] [ html-error. drop ] recover ] with-file-vocabs - ] assert-depth drop ; + ] curry assert-depth ; : run-relative-template-file ( filename -- ) file get source-file-path parent-directory @@ -93,3 +94,13 @@ DEFER: <% delimiter : template-convert ( infile outfile -- ) [ run-template-file ] with-file-writer ; + +! file responder integration +: serve-fhtml ( filename -- response ) + "text/html" + swap [ run-template-file ] curry >>body ; + +: enable-fhtml ( responder -- responder ) + [ serve-fhtml ] + "application/x-factor-server-page" + pick special>> set-at ; diff --git a/extra/webapps/cgi/authors.txt b/extra/webapps/cgi/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/webapps/cgi/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor deleted file mode 100755 index 5dba9dae00..0000000000 --- a/extra/webapps/cgi/cgi.factor +++ /dev/null @@ -1,75 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel assocs io.files combinators -arrays io.launcher io http.server.responders webapps.file -sequences strings math.parser unicode.case ; -IN: webapps.cgi - -SYMBOL: cgi-root - -: post? "method" get "post" = ; - -: cgi-variables ( script-path -- assoc ) - #! This needs some work. - [ - "CGI/1.0" "GATEWAY_INTERFACE" set - "HTTP/1.0" "SERVER_PROTOCOL" set - "Factor" "SERVER_SOFTWARE" set - - dup "PATH_TRANSLATED" set - "SCRIPT_FILENAME" set - - "request" get "SCRIPT_NAME" set - - host "SERVER_NAME" set - "" "SERVER_PORT" set - "" "PATH_INFO" set - "" "REMOTE_HOST" set - "" "REMOTE_ADDR" set - "" "AUTH_TYPE" set - "" "REMOTE_USER" set - "" "REMOTE_IDENT" set - - "method" get >upper "REQUEST_METHOD" set - "raw-query" get "QUERY_STRING" set - "cookie" header-param "HTTP_COOKIE" set - - "user-agent" header-param "HTTP_USER_AGENT" set - "accept" header-param "HTTP_ACCEPT" set - - post? [ - "content-type" header-param "CONTENT_TYPE" set - "raw-response" get length number>string "CONTENT_LENGTH" set - ] when - ] H{ } make-assoc ; - -: cgi-descriptor ( name -- desc ) - [ - cgi-root get swap path+ dup 1array +arguments+ set - cgi-variables +environment+ set - ] H{ } make-assoc ; - -: (do-cgi) ( name -- ) - "200 CGI output follows" response - stdio get swap cgi-descriptor [ - post? [ - "raw-response" get write flush - ] when - stdio get swap (stream-copy) - ] with-stream ; - -: serve-regular-file ( -- ) - cgi-root get doc-root [ file-responder ] with-variable ; - -: do-cgi ( name -- ) - { - { [ dup ".cgi" tail? not ] [ drop serve-regular-file ] } - { [ dup empty? ] [ "403 forbidden" httpd-error ] } - { [ cgi-root get not ] [ "404 cgi-root not set" httpd-error ] } - { [ ".." over subseq? ] [ "403 forbidden" httpd-error ] } - { [ t ] [ (do-cgi) ] } - } cond ; - -global [ - "cgi" [ "argument" get do-cgi ] add-simple-responder -] bind diff --git a/extra/webapps/file/authors.txt b/extra/webapps/file/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/webapps/file/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor deleted file mode 100755 index 411c70c76a..0000000000 --- a/extra/webapps/file/file.factor +++ /dev/null @@ -1,136 +0,0 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: calendar html io io.files kernel math math.parser -http.server.responders http.server.templating namespaces parser -sequences strings assocs hashtables debugger http.mime sorting -html.elements logging calendar.format ; -IN: webapps.file - -SYMBOL: doc-root - -: serving-path ( filename -- filename ) - "" or doc-root get swap path+ ; - -: unix-time>timestamp ( n -- timestamp ) - >r unix-1970 r> seconds time+ ; - -: file-http-date ( filename -- string ) - file-modified unix-time>timestamp timestamp>http-string ; - -: file-response ( filename mime-type -- ) - "200 OK" response - [ - "Content-Type" set - dup file-length number>string "Content-Length" set - file-http-date "Last-Modified" set - now timestamp>http-string "Date" set - ] H{ } make-assoc print-header ; - -: last-modified-matches? ( filename -- bool ) - file-http-date dup [ - "if-modified-since" header-param = - ] when ; - -: not-modified-response ( -- ) - "304 Not Modified" response - now timestamp>http-string "Date" associate print-header ; - -! You can override how files are served in a custom responder -SYMBOL: serve-file-hook - -[ - dupd - file-response - stdio get stream-copy -] serve-file-hook set-global - -: serve-static ( filename mime-type -- ) - over last-modified-matches? [ - 2drop not-modified-response - ] [ - "method" get "head" = [ - file-response - ] [ - serve-file-hook get call - ] if - ] if ; - -SYMBOL: page - -: run-page ( filename -- ) - dup - [ [ dup page set run-template-file ] with-scope ] try - drop ; - -\ run-page DEBUG add-input-logging - -: include-page ( filename -- ) - serving-path run-page ; - -: serve-fhtml ( filename -- ) - serving-html - "method" get "head" = [ drop ] [ run-page ] if ; - -: serve-file ( filename -- ) - dup mime-type dup "application/x-factor-server-page" = - [ drop serve-fhtml ] [ serve-static ] if ; - -\ serve-file NOTICE add-input-logging - -: file. ( name dirp -- ) - [ "/" append ] when - dup write ; - -: directory. ( path request -- ) - dup [ -

write

-
    - directory sort-keys - [
  • file.
    • ] assoc-each -
- ] simple-html-document ; - -: list-directory ( directory -- ) - serving-html - "method" get "head" = [ - drop - ] [ - "request" get directory. - ] if ; - -: find-index ( filename -- path ) - { "index.html" "index.fhtml" } - [ dupd path+ exists? ] find nip - dup [ path+ ] [ nip ] if ; - -: serve-directory ( filename -- ) - dup "/" tail? [ - dup find-index - [ serve-file ] [ list-directory ] ?if - ] [ - drop directory-no/ - ] if ; - -: serve-object ( filename -- ) - serving-path dup exists? [ - dup directory? [ serve-directory ] [ serve-file ] if - ] [ - drop "404 not found" httpd-error - ] if ; - -: file-responder ( -- ) - doc-root get [ - "argument" get serve-object - ] [ - "404 doc-root not set" httpd-error - ] if ; - -global [ - ! Serves files from a directory stored in the doc-root - ! variable. You can set the variable in the global - ! namespace, or inside the responder. - "file" [ file-responder ] add-simple-responder - - ! The root directory is served by... - "file" set-default-responder -] bind \ No newline at end of file diff --git a/extra/webapps/source/authors.txt b/extra/webapps/source/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/webapps/source/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/webapps/source/source.factor b/extra/webapps/source/source.factor deleted file mode 100755 index 98fb5b8873..0000000000 --- a/extra/webapps/source/source.factor +++ /dev/null @@ -1,35 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: io.files namespaces webapps.file http.server.responders -xmode.code2html kernel html sequences ; -IN: webapps.source - -! This responder is a potential security problem. Make sure you -! don't have sensitive files stored under vm/, core/, extra/ -! or misc/. - -: check-source-path ( path -- ? ) - { "vm/" "core/" "extra/" "misc/" } - [ head? ] with contains? ; - -: source-responder ( path mime-type -- ) - drop - serving-html - [ - dup file-name swap htmlize-stream - ] with-html-stream ; - -global [ - ! Serve up our own source code - "source" [ - "argument" get check-source-path [ - [ - "" resource-path doc-root set - [ source-responder ] serve-file-hook set - file-responder - ] with-scope - ] [ - "403 forbidden" httpd-error - ] if - ] add-simple-responder -] bind diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor new file mode 100755 index 0000000000..d14ffd93b3 --- /dev/null +++ b/extra/xmode/code2html/responder/responder.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.files namespaces http.server http.server.static http +xmode.code2html kernel html sequences accessors ; +IN: xmode.code2html.responder + +: ( root -- responder ) + [ + drop + "text/html" + over file-http-date "last-modified" set-header + swap [ + dup file-name swap htmlize-stream + ] curry >>body + ] ; From 24b4fb0df9da74f086a572fc987aab658d78c58b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 Feb 2008 10:37:39 -0600 Subject: [PATCH 027/140] Use if-box in http.server --- extra/http/server/sessions/sessions.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 7d6ca5a637..4db256ca72 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -23,7 +23,7 @@ TUPLE: session id manager namespace alarm ; : timeout ( -- dt ) 20 minutes ; : cancel-timeout ( session -- ) - alarm>> ?box [ cancel-alarm ] [ drop ] if ; + alarm>> [ cancel-alarm ] if-box? ; : delete-session ( session -- ) dup cancel-timeout From 869cfd54630a7259dfdab9d17e50aaefec6b36d8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Feb 2008 15:38:20 -0600 Subject: [PATCH 028/140] fix sqlite -- wasn't settin gthe bound? flag --- extra/db/sqlite/sqlite.factor | 3 ++- extra/db/tuples/tuples-tests.factor | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index b980e99718..d873e98a95 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -64,7 +64,8 @@ M: sqlite-statement bind-tuple ( tuple statement -- ) [ sql-spec-type ] tri 3array ] with map ] keep - [ set-statement-bind-params ] keep bind-statement* ; + [ set-statement-bind-params ] keep + t over set-statement-bound? bind-statement* ; : last-insert-id ( -- id ) db get db-handle sqlite3_last_insert_rowid diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index c9e6d302e0..ade18286b4 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -81,7 +81,7 @@ person "PERSON" 1 "billy" 10 3.14 the-person1 set 2 "johnny" 10 3.14 the-person2 set -test-sqlite +! test-sqlite ! test-postgresql TUPLE: paste n summary author channel mode contents timestamp annotations ; From 93a8cbcac3fb462ade75625c8347c01c9b20f2a9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Feb 2008 15:41:54 -0600 Subject: [PATCH 029/140] fix a hack. oops --- extra/db/sqlite/sqlite.factor | 6 +++--- extra/db/tuples/tuples-tests.factor | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index d873e98a95..c03496530b 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -53,7 +53,8 @@ M: sqlite-result-set dispose ( result-set -- ) M: sqlite-statement bind-statement* ( statement -- ) dup statement-bound? [ dup reset-statement ] when - [ statement-bind-params ] [ statement-handle ] bi sqlite-bind ; + [ statement-bind-params ] [ statement-handle ] bi + sqlite-bind ; M: sqlite-statement bind-tuple ( tuple statement -- ) [ @@ -64,8 +65,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- ) [ sql-spec-type ] tri 3array ] with map ] keep - [ set-statement-bind-params ] keep - t over set-statement-bound? bind-statement* ; + bind-statement ; : last-insert-id ( -- id ) db get db-handle sqlite3_last_insert_rowid diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index ade18286b4..c9e6d302e0 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -81,7 +81,7 @@ person "PERSON" 1 "billy" 10 3.14 the-person1 set 2 "johnny" 10 3.14 the-person2 set -! test-sqlite +test-sqlite ! test-postgresql TUPLE: paste n summary author channel mode contents timestamp annotations ; From b7f9aac2106499deeb65db76d9977e3ac87200b8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Feb 2008 17:10:22 -0600 Subject: [PATCH 030/140] fix with-unique-file --- extra/io/files/unique/unique.factor | 2 +- extra/io/unix/unix.factor | 2 +- extra/io/windows/files/unique/unique.factor | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index 3a1c3c46b8..b39a14c7f5 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -29,7 +29,7 @@ PRIVATE> ] 3curry unique-retries retry ; : with-unique-file ( quot -- path ) - >r f f make-unique-file r> with-stream ; inline + >r f f make-unique-file r> rot [ with-stream ] dip ; inline : with-temporary-file ( quot -- ) with-unique-file delete-file ; inline diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 11cdc0aa3b..b7111c5eac 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,5 +1,5 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts -io.unix.launcher io.unix.mmap io.backend io.files.unique +io.unix.launcher io.unix.mmap io.backend io.unix.files.unique combinators namespaces system vocabs.loader sequences ; "io.unix." os append require diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor index 01e654751e..5f11bf6142 100644 --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -1,4 +1,4 @@ -USING: kernel system ; +USING: kernel system io.files.unqiue io.files.unique.backend ; IN: io.windows.files.unique M: windows-io (make-unique-file) ( path -- stream ) From ac6c91d5a626e7a47d9e23833131350d38e5f8e5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Feb 2008 17:44:53 -0600 Subject: [PATCH 031/140] fix bootstrap --- extra/io/files/unique/unique.factor | 5 +++++ extra/io/unix/unix.factor | 2 +- extra/io/windows/files/unique/unique.factor | 2 +- extra/io/windows/windows.factor | 8 ++++---- 4 files changed, 11 insertions(+), 6 deletions(-) diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index b39a14c7f5..1e77cd6814 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -46,3 +46,8 @@ PRIVATE> : with-temporary-directory ( quot -- ) with-unique-directory delete-tree ; inline + +{ + { [ unix? ] [ "io.unix.files.unique" ] } + { [ windows? ] [ "io.windows.files.unique" ] } +} cond require diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index b7111c5eac..64e2cc3c3d 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,5 +1,5 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts -io.unix.launcher io.unix.mmap io.backend io.unix.files.unique +io.unix.launcher io.unix.mmap io.backend combinators namespaces system vocabs.loader sequences ; "io.unix." os append require diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor index 5f11bf6142..ae06090488 100644 --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -1,4 +1,4 @@ -USING: kernel system io.files.unqiue io.files.unique.backend ; +USING: kernel system io.files.unique.backend ; IN: io.windows.files.unique M: windows-io (make-unique-file) ( path -- stream ) diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 06dbaf89f7..38b7d4829c 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.backend io.buffers io.files io.nonblocking io.sockets io.binary -io.sockets.impl io.windows.files.unique windows.errors -strings io.streams.duplex kernel math namespaces sequences -windows windows.kernel32 windows.shell32 windows.types -windows.winsock splitting continuations math.bitfields ; +io.sockets.impl windows.errors strings io.streams.duplex +kernel math namespaces sequences windows windows.kernel32 +windows.shell32 windows.types windows.winsock splitting +continuations math.bitfields ; IN: io.windows TUPLE: windows-nt-io ; From adf5cfda5904f5f655016f1ea77bc287203d3ed8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Feb 2008 18:04:09 -0600 Subject: [PATCH 032/140] clean up retry --- extra/combinators/lib/lib.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 08336fd32e..f65b94dc11 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -170,4 +170,4 @@ MACRO: construct-slots ( assoc tuple-class -- tuple ) >r keep r> rot [ call ] [ 2drop f ] if ; inline : retry ( quot n -- ) - swap [ drop ] swap compose attempt-all ; inline + [ drop ] rot compose attempt-all ; inline From 4f40f10b88fac030bd3a7cc9773589251c1c4e04 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Feb 2008 18:04:20 -0600 Subject: [PATCH 033/140] fix stack effect --- extra/io/files/unique/backend/backend.factor | 2 +- extra/io/files/unique/unique.factor | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/io/files/unique/backend/backend.factor b/extra/io/files/unique/backend/backend.factor index 228b6881f9..b26557688b 100644 --- a/extra/io/files/unique/backend/backend.factor +++ b/extra/io/files/unique/backend/backend.factor @@ -1,5 +1,5 @@ USING: io.backend ; IN: io.files.unique.backend -HOOK: (make-unique-file) io-backend ( prefix suffix -- stream path ) +HOOK: (make-unique-file) io-backend ( path -- stream ) HOOK: temporary-path io-backend ( -- path ) diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index 1e77cd6814..8c0666161e 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -22,11 +22,12 @@ IN: io.files.unique PRIVATE> : make-unique-file ( prefix suffix -- path stream ) +break temporary-path -rot [ unique-length random-name swap 3append path+ dup (make-unique-file) - ] 3curry unique-retries retry ; + ] 3curry unique-retries retry break ; : with-unique-file ( quot -- path ) >r f f make-unique-file r> rot [ with-stream ] dip ; inline From a318a80b991e2a44ecff2f1d4a942114d2eb83da Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Feb 2008 18:04:44 -0600 Subject: [PATCH 034/140] fix using --- extra/io/windows/files/unique/unique.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor index ae06090488..dd0341162b 100644 --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -1,4 +1,5 @@ -USING: kernel system io.files.unique.backend ; +USING: kernel system io.files.unique.backend +windows.kernel32 io.windows io.nonblocking ; IN: io.windows.files.unique M: windows-io (make-unique-file) ( path -- stream ) From 2dffb31e53b18270cc5d5c686f9f997a3c8c0d7c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Feb 2008 18:05:38 -0600 Subject: [PATCH 035/140] remove debug info --- extra/io/files/unique/unique.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index 8c0666161e..1e77cd6814 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -22,12 +22,11 @@ IN: io.files.unique PRIVATE> : make-unique-file ( prefix suffix -- path stream ) -break temporary-path -rot [ unique-length random-name swap 3append path+ dup (make-unique-file) - ] 3curry unique-retries retry break ; + ] 3curry unique-retries retry ; : with-unique-file ( quot -- path ) >r f f make-unique-file r> rot [ with-stream ] dip ; inline From 316a8ad1ae6e07bcf4f766b72a3591135e308d9c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Feb 2008 18:20:45 -0600 Subject: [PATCH 036/140] fix io.files.unique --- extra/io/windows/files/unique/unique.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor index dd0341162b..0823c3f0f3 100644 --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -3,7 +3,7 @@ windows.kernel32 io.windows io.nonblocking ; IN: io.windows.files.unique M: windows-io (make-unique-file) ( path -- stream ) - GENERIC_WRITE CREATE_NEW 0 open-file 0 ; + GENERIC_WRITE CREATE_NEW 0 open-file 0 ; M: windows-io temporary-path ( -- path ) "TEMP" os-env ; From 373a88a77ad3214f7ab6ae21f3912fe373bbf5be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 Feb 2008 19:10:30 -0600 Subject: [PATCH 037/140] Fix UI hang, add if-box combinator --- core/boxes/boxes.factor | 3 + core/vocabs/loader/loader.factor | 10 +- extra/alarms/alarms.factor | 3 +- extra/concurrency/flags/flags-tests.factor | 46 +++ extra/concurrency/flags/flags.factor | 10 +- extra/help/help.factor | 10 +- extra/http.good/authors.txt | 1 + .../basic-authentication/authors.txt | 1 + .../basic-authentication-docs.factor | 69 +++++ .../basic-authentication-tests.factor | 66 +++++ .../basic-authentication.factor | 65 ++++ .../basic-authentication/summary.txt | 1 + extra/http.good/basic-authentication/tags.txt | 1 + extra/http.good/client/authors.txt | 1 + extra/http.good/client/client-tests.factor | 26 ++ extra/http.good/client/client.factor | 96 ++++++ extra/http.good/client/summary.txt | 1 + extra/http.good/client/tags.txt | 2 + extra/http.good/http-tests.factor | 115 ++++++++ extra/http.good/http.factor | 277 ++++++++++++++++++ extra/http.good/mime/authors.txt | 1 + extra/http.good/mime/mime.factor | 34 +++ extra/http.good/server/authors.txt | 1 + extra/http.good/server/server-tests.factor | 45 +++ extra/http.good/server/server.factor | 131 +++++++++ extra/http.good/server/summary.txt | 1 + extra/http.good/server/tags.txt | 3 + extra/http.good/server/templating/authors.txt | 2 + .../server/templating/templating-tests.factor | 17 ++ .../server/templating/templating.factor | 96 ++++++ .../server/templating/test/bug.fhtml | 5 + .../http.good/server/templating/test/bug.html | 2 + .../server/templating/test/example.fhtml | 8 + .../server/templating/test/example.html | 9 + .../server/templating/test/stack.fhtml | 1 + .../server/templating/test/stack.html | 2 + extra/http.good/summary.txt | 1 + extra/http.good/tags.txt | 2 + extra/io/monitors/monitors.factor | 2 +- extra/ui/windows/windows.factor | 10 +- extra/vocabs/monitor/monitor.factor | 6 +- 41 files changed, 1158 insertions(+), 25 deletions(-) create mode 100755 extra/concurrency/flags/flags-tests.factor mode change 100644 => 100755 extra/concurrency/flags/flags.factor create mode 100644 extra/http.good/authors.txt create mode 100644 extra/http.good/basic-authentication/authors.txt create mode 100644 extra/http.good/basic-authentication/basic-authentication-docs.factor create mode 100644 extra/http.good/basic-authentication/basic-authentication-tests.factor create mode 100644 extra/http.good/basic-authentication/basic-authentication.factor create mode 100644 extra/http.good/basic-authentication/summary.txt create mode 100644 extra/http.good/basic-authentication/tags.txt create mode 100644 extra/http.good/client/authors.txt create mode 100755 extra/http.good/client/client-tests.factor create mode 100755 extra/http.good/client/client.factor create mode 100644 extra/http.good/client/summary.txt create mode 100644 extra/http.good/client/tags.txt create mode 100755 extra/http.good/http-tests.factor create mode 100755 extra/http.good/http.factor create mode 100755 extra/http.good/mime/authors.txt create mode 100644 extra/http.good/mime/mime.factor create mode 100755 extra/http.good/server/authors.txt create mode 100755 extra/http.good/server/server-tests.factor create mode 100755 extra/http.good/server/server.factor create mode 100644 extra/http.good/server/summary.txt create mode 100644 extra/http.good/server/tags.txt create mode 100644 extra/http.good/server/templating/authors.txt create mode 100644 extra/http.good/server/templating/templating-tests.factor create mode 100755 extra/http.good/server/templating/templating.factor create mode 100644 extra/http.good/server/templating/test/bug.fhtml create mode 100644 extra/http.good/server/templating/test/bug.html create mode 100644 extra/http.good/server/templating/test/example.fhtml create mode 100644 extra/http.good/server/templating/test/example.html create mode 100644 extra/http.good/server/templating/test/stack.fhtml create mode 100644 extra/http.good/server/templating/test/stack.html create mode 100644 extra/http.good/summary.txt create mode 100644 extra/http.good/tags.txt diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor index 8197e57969..a989e091bb 100755 --- a/core/boxes/boxes.factor +++ b/core/boxes/boxes.factor @@ -19,3 +19,6 @@ TUPLE: box value full? ; : ?box ( box -- value/f ? ) dup box-full? [ box> t ] [ drop f f ] if ; + +: if-box? ( box quot -- ) + >r ?box r> [ drop ] if ; inline diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 8bdd9b902f..57743ce9e1 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -4,7 +4,7 @@ USING: namespaces sequences io.files kernel assocs words vocabs definitions parser continuations inspector debugger io io.styles io.streams.lines hashtables sorting prettyprint source-files arrays combinators strings system math.parser compiler.errors -splitting ; +splitting init ; IN: vocabs.loader SYMBOL: vocab-roots @@ -175,7 +175,13 @@ SYMBOL: failures : refresh ( prefix -- ) to-refresh do-refresh ; -: refresh-all ( -- ) "" refresh ; +SYMBOL: sources-changed? + +[ t sources-changed? set-global ] "vocabs.loader" add-init-hook + +: refresh-all ( -- ) + sources-changed? get-global + [ "" refresh f sources-changed? set-global ] when ; GENERIC: (load-vocab) ( name -- vocab ) diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index a50e1817e1..d008b7b462 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -87,5 +87,4 @@ PRIVATE> from-now f add-alarm ; : cancel-alarm ( alarm -- ) - alarm-entry ?box - [ alarms get-global heap-delete ] [ drop ] if ; + alarm-entry [ alarms get-global heap-delete ] if-box? ; diff --git a/extra/concurrency/flags/flags-tests.factor b/extra/concurrency/flags/flags-tests.factor new file mode 100755 index 0000000000..44934b59c4 --- /dev/null +++ b/extra/concurrency/flags/flags-tests.factor @@ -0,0 +1,46 @@ +IN: temporary +USING: tools.test concurrency.flags kernel threads locals ; + +:: flag-test-1 ( -- ) + [let | f [ ] | + [ f raise-flag ] "Flag test" spawn drop + f lower-flag + f flag-value? + ] ; + +[ f ] [ flag-test-1 ] unit-test + +:: flag-test-2 ( -- ) + [let | f [ ] | + [ 1000 sleep f raise-flag ] "Flag test" spawn drop + f lower-flag + f flag-value? + ] ; + +[ f ] [ flag-test-2 ] unit-test + +:: flag-test-3 ( -- ) + [let | f [ ] | + f raise-flag + f flag-value? + ] ; + +[ t ] [ flag-test-3 ] unit-test + +:: flag-test-4 ( -- ) + [let | f [ ] | + [ f raise-flag ] "Flag test" spawn drop + f wait-for-flag + f flag-value? + ] ; + +[ t ] [ flag-test-4 ] unit-test + +:: flag-test-5 ( -- ) + [let | f [ ] | + [ 1000 sleep f raise-flag ] "Flag test" spawn drop + f wait-for-flag + f flag-value? + ] ; + +[ t ] [ flag-test-5 ] unit-test diff --git a/extra/concurrency/flags/flags.factor b/extra/concurrency/flags/flags.factor old mode 100644 new mode 100755 index 888b617b85..d598bf0b59 --- a/extra/concurrency/flags/flags.factor +++ b/extra/concurrency/flags/flags.factor @@ -9,8 +9,8 @@ TUPLE: flag value? thread ; : raise-flag ( flag -- ) dup flag-value? [ - dup flag-thread ?box - [ resume ] [ drop t over set-flag-value? ] if + t over set-flag-value? + dup flag-thread [ resume ] if-box? ] unless drop ; : wait-for-flag ( flag -- ) @@ -19,8 +19,4 @@ TUPLE: flag value? thread ; ] if ; : lower-flag ( flag -- ) - dup flag-value? [ - f swap set-flag-value? - ] [ - wait-for-flag - ] if ; + dup wait-for-flag f swap set-flag-value? ; diff --git a/extra/help/help.factor b/extra/help/help.factor index 490374a384..9332e6aff8 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -132,13 +132,13 @@ M: word set-article-parent swap "help-parent" set-word-prop ; nl "Debugger commands:" print nl - ":help - documentation for this error" print - ":s - data stack at exception time" print - ":r - retain stack at exception time" print - ":c - call stack at exception time" print + ":s - data stack at error time" print + ":r - retain stack at error time" print + ":c - call stack at error time" print ":edit - jump to source location (parse errors only)" print - ":get ( var -- value ) accesses variables at time of the error" print ; + ":get ( var -- value ) accesses variables at time of the error" print + ":vars - list all variables at error time"; : :help ( -- ) error get delegates [ error-help ] map [ ] subset diff --git a/extra/http.good/authors.txt b/extra/http.good/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/http.good/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/http.good/basic-authentication/authors.txt b/extra/http.good/basic-authentication/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/http.good/basic-authentication/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/http.good/basic-authentication/basic-authentication-docs.factor b/extra/http.good/basic-authentication/basic-authentication-docs.factor new file mode 100644 index 0000000000..68d6e6bf1d --- /dev/null +++ b/extra/http.good/basic-authentication/basic-authentication-docs.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax crypto.sha2 ; +IN: http.basic-authentication + +HELP: realms +{ $description + "A hashtable mapping a basic authentication realm (a string) " + "to either a quotation or a hashtable. The quotation has " + "stack effect ( username sha-256-string -- bool ). It " + "is expected to perform the user authentication when called." $nl + "If the realm maps to a hashtable then the hashtable should be a " + "mapping of usernames to sha-256 hashed passwords." $nl + "If the 'realms' variable does not exist in the current scope then " + "authentication will always fail." } +{ $see-also add-realm with-basic-authentication } ; + +HELP: add-realm +{ $values + { "data" "a quotation or a hashtable" } { "name" "a string" } } +{ $description + "Adds the authentication data to the " { $link realms } ". 'data' can be " + "a quotation with stack effect ( username sha-256-string -- bool ) or " + "a hashtable mapping username strings to sha-256-string passwords." } +{ $examples + { $code "H{ { \"admin\" \"...\" } { \"user\" \"...\" } } \"my-realm\" add-realm" } + { $code "[ \"...\" = swap \"admin\" = and ] \"my-realm\" add-realm" } +} +{ $see-also with-basic-authentication realms } ; + +HELP: with-basic-authentication +{ $values + { "realm" "a string" } { "quot" "a quotation with stack effect ( -- )" } } +{ $description + "Checks if the HTTP request has the correct authorisation headers " + "for basic authentication within the named realm. If the headers " + "are not present then a '401' HTTP response results from the " + "request, otherwise the quotation is called." } +{ $examples +{ $code "\"my-realm\" [\n serving-html \"Success!\" write\n] with-basic-authentication" } } +{ $see-also add-realm realms } + ; + +ARTICLE: { "http-authentication" "basic-authentication" } "Basic Authentication" +"The Basic Authentication system provides a simple browser based " +"authentication method to web applications. When the browser requests " +"a resource protected with basic authentication the server responds with " +"a '401' response code which means the user is unauthorized." +$nl +"When the browser receives this it prompts the user for a username and " +"password. This is sent back to the server in a special HTTP header. The " +"server then checks this against its authentication information and either " +"accepts or rejects the users request." +$nl +"Authentication is split up into " { $link realms } ". Each realm can have " +"a different database of username and password information. A responder can " +"require basic authentication by using the " { $link with-basic-authentication } " word." +$nl +"Username and password information can be maintained using " { $link realms } " and " { $link add-realm } "." +$nl +"All passwords on the server should be stored as sha-256 strings generated with the " { $link string>sha-256-string } " word." +$nl +"Note that Basic Authentication itself is insecure in that it " +"sends the username and password as clear text (although it is " +"base64 encoded this is not much help). To prevent eavesdropping " +"it is best to use Basic Authentication with SSL." ; + +IN: http.basic-authentication +ABOUT: { "http-authentication" "basic-authentication" } diff --git a/extra/http.good/basic-authentication/basic-authentication-tests.factor b/extra/http.good/basic-authentication/basic-authentication-tests.factor new file mode 100644 index 0000000000..318123b0b4 --- /dev/null +++ b/extra/http.good/basic-authentication/basic-authentication-tests.factor @@ -0,0 +1,66 @@ +! Copyright (c) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel crypto.sha2 http.basic-authentication tools.test + namespaces base64 sequences ; + +{ t } [ + [ + H{ } clone realms set + H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm + "test-realm" "Basic " "admin:password" >base64 append authorization-ok? + ] with-scope +] unit-test + +{ f } [ + [ + H{ } clone realms set + H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm + "test-realm" "Basic " "admin:passwordx" >base64 append authorization-ok? + ] with-scope +] unit-test + +{ f } [ + [ + H{ } clone realms set + H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm + "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? + ] with-scope +] unit-test + +{ t } [ + [ + H{ } clone realms set + [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm + "test-realm" "Basic " "admin:password" >base64 append authorization-ok? + ] with-scope +] unit-test + +{ f } [ + [ + H{ } clone realms set + [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm + "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? + ] with-scope +] unit-test + +{ f } [ + [ + H{ } clone realms set + [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm + "test-realm" "Basic " "admin:xpassword" >base64 append authorization-ok? + ] with-scope +] unit-test + +{ f } [ + [ + f realms set + "test-realm" "Basic " "admin:password" >base64 append authorization-ok? + ] with-scope +] unit-test + +{ f } [ + [ + H{ } clone realms set + "test-realm" "Basic " "admin:password" >base64 append authorization-ok? + ] with-scope +] unit-test diff --git a/extra/http.good/basic-authentication/basic-authentication.factor b/extra/http.good/basic-authentication/basic-authentication.factor new file mode 100644 index 0000000000..e15ba9db16 --- /dev/null +++ b/extra/http.good/basic-authentication/basic-authentication.factor @@ -0,0 +1,65 @@ +! Copyright (c) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel base64 http.server crypto.sha2 namespaces assocs + quotations hashtables combinators splitting sequences + http.server.responders io html.elements ; +IN: http.basic-authentication + +! 'realms' is a hashtable mapping a realm (a string) to +! either a quotation or a hashtable. The quotation +! has stack effect ( username sha-256-string -- bool ). +! It should perform the user authentication. 'sha-256-string' +! is the plain text password provided by the user passed through +! 'string>sha-256-string'. If 'realms' maps to a hashtable then +! it is a mapping of usernames to sha-256 hashed passwords. +! +! 'realms' can be set on a per vhost basis in the vhosts +! table. +! +! If there are no realms then authentication fails. +SYMBOL: realms + +: add-realm ( data name -- ) + #! Add the named realm to the realms table. + #! 'data' should be a hashtable or a quotation. + realms get [ H{ } clone dup realms set ] unless* + set-at ; + +: user-authorized? ( username password realm -- bool ) + realms get dup [ + at { + { [ dup quotation? ] [ call ] } + { [ dup hashtable? ] [ swapd at = ] } + { [ t ] [ 3drop f ] } + } cond + ] [ + 3drop drop f + ] if ; + +: authorization-ok? ( realm header -- bool ) + #! Given the realm and the 'Authorization' header, + #! authenticate the user. + dup [ + " " split dup first "Basic" = [ + second base64> ":" split first2 string>sha-256-string rot + user-authorized? + ] [ + 2drop f + ] if + ] [ + 2drop f + ] if ; + +: authentication-error ( realm -- ) + "401 Unauthorized" response + "Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate print-header + + "Username or Password is invalid" write + ; + +: with-basic-authentication ( realm quot -- ) + #! Check if the user is authenticated in the given realm + #! to run the specified quotation. If not, use Basic + #! Authentication to ask for authorization details. + over "Authorization" header-param authorization-ok? + [ nip call ] [ drop authentication-error ] if ; diff --git a/extra/http.good/basic-authentication/summary.txt b/extra/http.good/basic-authentication/summary.txt new file mode 100644 index 0000000000..60cef7e630 --- /dev/null +++ b/extra/http.good/basic-authentication/summary.txt @@ -0,0 +1 @@ +HTTP Basic Authentication implementation diff --git a/extra/http.good/basic-authentication/tags.txt b/extra/http.good/basic-authentication/tags.txt new file mode 100644 index 0000000000..c0772185a0 --- /dev/null +++ b/extra/http.good/basic-authentication/tags.txt @@ -0,0 +1 @@ +web diff --git a/extra/http.good/client/authors.txt b/extra/http.good/client/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/http.good/client/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/http.good/client/client-tests.factor b/extra/http.good/client/client-tests.factor new file mode 100755 index 0000000000..5e407657a8 --- /dev/null +++ b/extra/http.good/client/client-tests.factor @@ -0,0 +1,26 @@ +USING: http.client http.client.private http tools.test +tuple-syntax namespaces ; +[ "localhost" 80 ] [ "localhost" parse-host ] unit-test +[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test +[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test +[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test + +[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test +[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test +[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test +[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test + +[ + TUPLE{ request + method: "GET" + host: "www.apple.com" + path: "/index.html" + port: 80 + } +] [ + [ + "http://www.apple.com/index.html" + + request-with-url + ] with-scope +] unit-test diff --git a/extra/http.good/client/client.factor b/extra/http.good/client/client.factor new file mode 100755 index 0000000000..8b74b6dc72 --- /dev/null +++ b/extra/http.good/client/client.factor @@ -0,0 +1,96 @@ +! Copyright (C) 2005, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs http kernel math math.parser namespaces sequences +io io.sockets io.streams.string io.files io.timeouts strings +splitting continuations assocs.lib calendar vectors hashtables +accessors ; +IN: http.client + +: parse-url ( url -- resource host port ) + "http://" ?head [ "Only http:// supported" throw ] unless + "/" split1 [ "/" swap append ] [ "/" ] if* + swap parse-host ; + +r >>path r> dup [ query>assoc ] when >>query ; + +! This is all pretty complex because it needs to handle +! HTTP redirects, which might be absolute or relative +: request-with-url ( url request -- request ) + clone dup "request" set + swap parse-url >r >r store-path r> >>host r> >>port ; + +DEFER: (http-request) + +: absolute-redirect ( url -- request ) + "request" get request-with-url ; + +: relative-redirect ( path -- request ) + "request" get swap store-path ; + +: do-redirect ( response -- response stream ) + dup response-code 300 399 between? [ + header>> "location" peek-at + dup "http://" head? [ + absolute-redirect + ] [ + relative-redirect + ] if "GET" >>method (http-request) + ] [ + stdio get + ] if ; + +: (http-request) ( request -- response stream ) + dup host>> over port>> stdio set + write-request flush read-response + do-redirect ; + +PRIVATE> + +: http-request ( url request -- response stream ) + [ + request-with-url + [ + (http-request) + 1 minutes over set-timeout + ] [ ] [ stdio get dispose ] cleanup + ] with-scope ; + +: ( -- request ) + request construct-empty + "GET" >>method ; + +: http-get-stream ( url -- response stream ) + http-request ; + +: success? ( code -- ? ) 200 = ; + +: check-response ( response stream -- stream ) + swap code>> success? + [ dispose "HTTP download failed" throw ] unless ; + +: http-get ( url -- string ) + http-get-stream check-response contents ; + +: download-name ( url -- name ) + file-name "?" split1 drop "/" ?tail drop ; + +: download-to ( url file -- ) + #! Downloads the contents of a URL to a file. + swap http-get-stream check-response + [ swap stream-copy ] with-disposal ; + +: download ( url -- ) + dup download-name download-to ; + +: ( content-type content -- request ) + request construct-empty + "POST" >>method + swap >>post-data + swap >>post-data-type ; + +: http-post ( content-type content url -- response string ) + #! The content is URL encoded for you. + -rot url-encode http-request contents ; diff --git a/extra/http.good/client/summary.txt b/extra/http.good/client/summary.txt new file mode 100644 index 0000000000..5609c916c4 --- /dev/null +++ b/extra/http.good/client/summary.txt @@ -0,0 +1 @@ +HTTP client diff --git a/extra/http.good/client/tags.txt b/extra/http.good/client/tags.txt new file mode 100644 index 0000000000..93e65ae758 --- /dev/null +++ b/extra/http.good/client/tags.txt @@ -0,0 +1,2 @@ +web +network diff --git a/extra/http.good/http-tests.factor b/extra/http.good/http-tests.factor new file mode 100755 index 0000000000..9fa593053c --- /dev/null +++ b/extra/http.good/http-tests.factor @@ -0,0 +1,115 @@ +USING: http tools.test multiline tuple-syntax +io.streams.string kernel arrays splitting sequences ; +IN: temporary + +[ "hello%20world" ] [ "hello world" url-encode ] unit-test +[ "hello world" ] [ "hello%20world" url-decode ] unit-test +[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test +[ "" ] [ "%XX%XX%XX" url-decode ] unit-test +[ "" ] [ "%XX%XX%X" url-decode ] 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 +[ "hello world" ] [ "hello world%" url-decode ] unit-test +[ "hello world" ] [ "hello world%x" url-decode ] unit-test +[ "hello%20world" ] [ "hello world" url-encode ] unit-test +[ "%20%21%20" ] [ " ! " url-encode ] unit-test + +[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test + +STRING: read-request-test-1 +GET http://foo/bar HTTP/1.1 +Some-Header: 1 +Some-Header: 2 +Content-Length: 4 + +blah +; + +[ + TUPLE{ request + method: "GET" + path: "bar" + query: f + version: "1.1" + header: H{ { "some-header" V{ "1" "2" } } { "content-length" V{ "4" } } } + post-data: "blah" + } +] [ + read-request-test-1 [ + read-request + ] with-string-reader +] unit-test + +STRING: read-request-test-1' +GET bar HTTP/1.1 +content-length: 4 +some-header: 1 +some-header: 2 + +blah +; + +read-request-test-1' 1array [ + read-request-test-1 + [ read-request ] with-string-reader + [ write-request ] with-string-writer + ! normalize crlf + string-lines "\n" join +] unit-test + +STRING: read-request-test-2 +HEAD http://foo/bar HTTP/1.0 +Host: www.sex.com +; + +[ + TUPLE{ request + method: "HEAD" + path: "bar" + query: f + version: "1.0" + header: H{ { "host" V{ "www.sex.com" } } } + host: "www.sex.com" + } +] [ + read-request-test-2 [ + read-request + ] with-string-reader +] unit-test + +STRING: read-response-test-1 +HTTP/1.0 404 not found +Content-Type: text/html + +blah +; + +[ + TUPLE{ response + version: "1.0" + code: 404 + message: "not found" + header: H{ { "content-type" V{ "text/html" } } } + } +] [ + read-response-test-1 + [ read-response ] with-string-reader +] unit-test + + +STRING: read-response-test-1' +HTTP/1.0 404 not found +content-type: text/html + + +; + +read-response-test-1' 1array [ + read-response-test-1 + [ read-response ] with-string-reader + [ write-response ] with-string-writer + ! normalize crlf + string-lines "\n" join +] unit-test diff --git a/extra/http.good/http.factor b/extra/http.good/http.factor new file mode 100755 index 0000000000..4c2834b7ca --- /dev/null +++ b/extra/http.good/http.factor @@ -0,0 +1,277 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: hashtables io io.streams.string kernel math namespaces +math.parser assocs sequences strings splitting ascii +io.encodings.utf8 assocs.lib namespaces unicode.case combinators +vectors sorting new-slots accessors calendar ; +IN: http + +: http-port 80 ; inline + +: crlf "\r\n" write ; + +: header-line ( line -- ) + ": " split1 dup [ swap >lower insert ] [ 2drop ] if ; + +: read-header-line ( -- ) + readln dup + empty? [ drop ] [ header-line read-header-line ] if ; + +: read-header ( -- multi-assoc ) + [ read-header-line ] H{ } make-assoc ; + +: write-header ( multi-assoc -- ) + >alist sort-keys + [ + swap write ": " write { + { [ dup number? ] [ number>string ] } + { [ dup timestamp? ] [ timestamp>http-string ] } + { [ dup string? ] [ ] } + } cond write crlf + ] multi-assoc-each crlf ; + +: url-quotable? ( ch -- ? ) + #! In a URL, can this character be used without + #! URL-encoding? + dup letter? + over LETTER? or + over digit? or + swap "/_-." member? or ; foldable + +: push-utf8 ( ch -- ) + 1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; + +: url-encode ( str -- str ) + [ [ + dup url-quotable? [ , ] [ push-utf8 ] if + ] each ] "" make ; + +: url-decode-hex ( index str -- ) + 2dup length 2 - >= [ + 2drop + ] [ + >r 1+ dup 2 + r> subseq hex> [ , ] when* + ] if ; + +: url-decode-% ( index str -- index str ) + 2dup url-decode-hex >r 3 + r> ; + +: url-decode-+-or-other ( index str ch -- index str ) + dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ; + +: url-decode-iter ( index str -- ) + 2dup length >= [ + 2drop + ] [ + 2dup nth dup CHAR: % = [ + drop url-decode-% + ] [ + url-decode-+-or-other + ] if url-decode-iter + ] if ; + +: url-decode ( str -- str ) + [ 0 swap url-decode-iter ] "" make decode-utf8 ; + +: query>assoc ( query -- assoc ) + dup [ + "&" split [ + "=" split1 [ dup [ url-decode ] when ] 2apply + ] H{ } map>assoc + ] when ; + +: assoc>query ( hash -- str ) + [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map + "&" join ; + +TUPLE: request +host +port +method +path +query +version +header +post-data +post-data-type ; + +: + request construct-empty + "1.0" >>version + http-port >>port ; + +: url>path ( url -- path ) + url-decode "http://" ?head + [ "/" split1 "" or nip ] [ "/" ?head drop ] if ; + +: read-method ( request -- request ) + " " read-until [ "Bad request: method" throw ] unless + >>method ; + +: read-query ( request -- request ) + " " read-until + [ "Bad request: query params" throw ] unless + query>assoc >>query ; + +: read-url ( request -- request ) + " ?" read-until { + { CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] } + { CHAR: ? [ url>path >>path read-query ] } + [ "Bad request: URL" throw ] + } case ; + +: parse-version ( string -- version ) + "HTTP/" ?head [ "Bad version" throw ] unless + dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ; + +: read-request-version ( request -- request ) + readln [ CHAR: \s = ] left-trim + parse-version + >>version ; + +: read-request-header ( request -- request ) + read-header >>header ; + +SYMBOL: max-post-request + +1024 256 * max-post-request set-global + +: content-length ( header -- n ) + "content-length" peek-at string>number dup [ + dup max-post-request get > [ + "content-length > max-post-request" throw + ] when + ] when ; + +: read-post-data ( request -- request ) + dup header>> content-length [ read >>post-data ] when* ; + +: parse-host ( string -- host port ) + "." ?tail drop ":" split1 + [ string>number ] [ http-port ] if* ; + +: extract-host ( request -- request ) + dup header>> "host" peek-at parse-host >r >>host r> >>port ; + +: extract-post-data-type ( request -- request ) + dup header>> "content-type" peek-at >>post-data-type ; + +: read-request ( -- request ) + + read-method + read-url + read-request-version + read-request-header + read-post-data + extract-host + extract-post-data-type ; + +: write-method ( request -- request ) + dup method>> write bl ; + +: write-url ( request -- request ) + dup path>> url-encode write + dup query>> dup assoc-empty? [ drop ] [ + "?" write + assoc>query write + ] if ; + +: write-request-url ( request -- request ) + write-url bl ; + +: write-version ( request -- request ) + "HTTP/" write dup request-version write crlf ; + +: write-request-header ( request -- request ) + dup header>> >hashtable + over host>> [ "host" replace-at ] when* + over post-data>> [ length "content-length" replace-at ] when* + over post-data-type>> [ "content-type" replace-at ] when* + write-header ; + +: write-post-data ( request -- request ) + dup post-data>> [ write ] when* ; + +: write-request ( request -- ) + write-method + write-url + write-version + write-request-header + write-post-data + flush + drop ; + +: request-url ( request -- url ) + [ + dup host>> [ + "http://" write + dup host>> url-encode write + ":" write + dup port>> number>string write + ] when + "/" write + write-url + drop + ] with-string-writer ; + +TUPLE: response +version +code +message +header ; + +: + response construct-empty + "1.0" >>version + H{ } clone >>header ; + +: read-response-version + " " read-until + [ "Bad response: version" throw ] unless + parse-version + >>version ; + +: read-response-code + " " read-until [ "Bad response: code" throw ] unless + string>number [ "Bad response: code" throw ] unless* + >>code ; + +: read-response-message + readln >>message ; + +: read-response-header + read-header >>header ; + +: read-response ( -- response ) + + read-response-version + read-response-code + read-response-message + read-response-header ; + +: write-response-version ( response -- response ) + "HTTP/" write + dup version>> write bl ; + +: write-response-code ( response -- response ) + dup code>> number>string write bl ; + +: write-response-message ( response -- response ) + dup message>> write crlf ; + +: write-response-header ( response -- response ) + dup header>> write-header ; + +: write-response ( respose -- ) + write-response-version + write-response-code + write-response-message + write-response-header + flush + drop ; + +: set-response-header ( response value key -- response ) + pick header>> -rot replace-at drop ; + +: set-content-type ( response content-type -- response ) + "content-type" set-response-header ; diff --git a/extra/http.good/mime/authors.txt b/extra/http.good/mime/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/http.good/mime/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/http.good/mime/mime.factor b/extra/http.good/mime/mime.factor new file mode 100644 index 0000000000..3365127d87 --- /dev/null +++ b/extra/http.good/mime/mime.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io assocs kernel sequences math namespaces splitting ; + +IN: http.mime + +: file-extension ( filename -- extension ) + "." split dup length 1 <= [ drop f ] [ peek ] if ; + +: mime-type ( filename -- mime-type ) + file-extension "mime-types" get at "application/octet-stream" or ; + +H{ + { "html" "text/html" } + { "txt" "text/plain" } + { "xml" "text/xml" } + { "css" "text/css" } + + { "gif" "image/gif" } + { "png" "image/png" } + { "jpg" "image/jpeg" } + { "jpeg" "image/jpeg" } + + { "jar" "application/octet-stream" } + { "zip" "application/octet-stream" } + { "tgz" "application/octet-stream" } + { "tar.gz" "application/octet-stream" } + { "gz" "application/octet-stream" } + + { "pdf" "application/pdf" } + + { "factor" "text/plain" } + { "fhtml" "application/x-factor-server-page" } +} "mime-types" set-global diff --git a/extra/http.good/server/authors.txt b/extra/http.good/server/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/http.good/server/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/http.good/server/server-tests.factor b/extra/http.good/server/server-tests.factor new file mode 100755 index 0000000000..a67d21a640 --- /dev/null +++ b/extra/http.good/server/server-tests.factor @@ -0,0 +1,45 @@ +USING: http.server tools.test kernel namespaces accessors +new-slots assocs.lib io http math sequences ; +IN: temporary + +TUPLE: mock-responder ; + +: ( path -- responder ) + mock-responder construct-delegate ; + +M: mock-responder do-responder + 2nip + path>> on + [ "Hello world" print ] + "text/plain" ; + +: check-dispatch ( tag path -- ? ) + over off + swap default-host get call-responder + write-response call get ; + +[ + "" + "foo" add-responder + "bar" add-responder + "baz/" + "123" add-responder + "default" >>default + add-responder + default-host set + + [ t ] [ "foo" "foo" check-dispatch ] unit-test + [ f ] [ "foo" "bar" check-dispatch ] unit-test + [ t ] [ "bar" "bar" check-dispatch ] unit-test + [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test + [ t ] [ "123" "baz/123" check-dispatch ] unit-test + + [ t ] [ + + "baz" >>path + "baz" default-host get call-responder + dup code>> 300 399 between? >r + header>> "location" peek-at "baz/" tail? r> and + nip + ] unit-test +] with-scope diff --git a/extra/http.good/server/server.factor b/extra/http.good/server/server.factor new file mode 100755 index 0000000000..e06ae6a95c --- /dev/null +++ b/extra/http.good/server/server.factor @@ -0,0 +1,131 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs kernel namespaces io io.timeouts strings splitting +threads http sequences prettyprint io.server logging calendar +new-slots html.elements accessors math.parser combinators.lib ; +IN: http.server + +TUPLE: responder path directory ; + +: ( path -- responder ) + "/" ?tail responder construct-boa ; + +GENERIC: do-responder ( request path responder -- quot response ) + +TUPLE: trivial-responder quot response ; + +: ( quot response -- responder ) + trivial-responder construct-boa + "" over set-delegate ; + +M: trivial-responder do-responder + 2nip dup quot>> swap response>> ; + +: trivial-response-body ( code message -- ) + + +

swap number>string write bl write

+ + ; + +: ( code message -- quot response ) + [ [ trivial-response-body ] 2curry ] 2keep + "text/html" set-content-type + swap >>message + swap >>code ; + +: <404> ( -- quot response ) + 404 "Not Found" ; + +: ( to code message -- quot response ) + + rot "location" set-response-header ; + +: ( to -- quot response ) + 301 "Moved Permanently" ; + +: ( to -- quot response ) + 307 "Temporary Redirect" ; + +: ( content-type -- response ) + + 200 >>code + swap set-content-type ; + +TUPLE: dispatcher responders default ; + +: responder-matches? ( path responder -- ? ) + path>> head? ; + +TUPLE: no-/-responder ; + +M: no-/-responder do-responder + 2drop + dup path>> "/" append >>path + request-url ; + +: ( -- responder ) + "" no-/-responder construct-delegate ; + + no-/-responder set-global + +: find-responder ( path dispatcher -- path responder ) + >r "/" ?head drop r> + [ responders>> [ dupd responder-matches? ] find nip ] keep + default>> or [ path>> ?head drop ] keep ; + +: no-trailing-/ ( path responder -- path responder ) + over empty? over directory>> and + [ drop no-/-responder get-global ] when ; + +: call-responder ( request path responder -- quot response ) + no-trailing-/ do-responder ; + +SYMBOL: 404-responder + +<404> 404-responder set-global + +M: dispatcher do-responder + find-responder call-responder ; + +: ( path -- dispatcher ) + + dispatcher construct-delegate + 404-responder get-global >>default + V{ } clone >>responders ; + +: add-responder ( dispatcher responder -- dispatcher ) + over responders>> push ; + +SYMBOL: virtual-hosts +SYMBOL: default-host + +virtual-hosts global [ drop H{ } clone ] cache drop +default-host global [ drop 404-responder ] cache drop + +: find-virtual-host ( host -- responder ) + virtual-hosts get at [ default-host get ] unless* ; + +: handle-request ( request -- ) + [ + dup path>> over host>> find-virtual-host + call-responder + write-response + ] keep method>> "HEAD" = [ drop ] [ call ] if ; + +: default-timeout 1 minutes stdio get set-timeout ; + +LOG: httpd-hit NOTICE + +: log-request ( request -- ) + { method>> host>> path>> } map-exec-with httpd-hit ; + +: httpd ( port -- ) + internet-server "http.server" [ + default-timeout + read-request dup log-request handle-request + ] with-server ; + +: httpd-main ( -- ) 8888 httpd ; + +MAIN: httpd-main diff --git a/extra/http.good/server/summary.txt b/extra/http.good/server/summary.txt new file mode 100644 index 0000000000..e6d2ca62e9 --- /dev/null +++ b/extra/http.good/server/summary.txt @@ -0,0 +1 @@ +HTTP server diff --git a/extra/http.good/server/tags.txt b/extra/http.good/server/tags.txt new file mode 100644 index 0000000000..b0881a9ec0 --- /dev/null +++ b/extra/http.good/server/tags.txt @@ -0,0 +1,3 @@ +enterprise +network +web diff --git a/extra/http.good/server/templating/authors.txt b/extra/http.good/server/templating/authors.txt new file mode 100644 index 0000000000..b47eafb62a --- /dev/null +++ b/extra/http.good/server/templating/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Matthew Willis diff --git a/extra/http.good/server/templating/templating-tests.factor b/extra/http.good/server/templating/templating-tests.factor new file mode 100644 index 0000000000..d889cd848a --- /dev/null +++ b/extra/http.good/server/templating/templating-tests.factor @@ -0,0 +1,17 @@ +USING: io io.files io.streams.string http.server.templating kernel tools.test + sequences ; +IN: temporary + +: test-template ( path -- ? ) + "extra/http/server/templating/test/" swap append + [ + ".fhtml" append resource-path + [ run-template-file ] with-string-writer + ] keep + ".html" append resource-path file-contents = ; + +[ t ] [ "example" test-template ] unit-test +[ t ] [ "bug" test-template ] unit-test +[ t ] [ "stack" test-template ] unit-test + +[ ] [ "<%\n%>" parse-template drop ] unit-test diff --git a/extra/http.good/server/templating/templating.factor b/extra/http.good/server/templating/templating.factor new file mode 100755 index 0000000000..f364b86524 --- /dev/null +++ b/extra/http.good/server/templating/templating.factor @@ -0,0 +1,96 @@ +! Copyright (C) 2005 Alex Chapman +! Copyright (C) 2006, 2007 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: continuations sequences kernel parser namespaces io +io.files io.streams.lines io.streams.string html html.elements +source-files debugger combinators math quotations generic +strings splitting ; + +IN: http.server.templating + +: templating-vocab ( -- vocab-name ) "http.server.templating" ; + +! See apps/http-server/test/ or libs/furnace/ for template usage +! examples + +! We use a custom lexer so that %> ends a token even if not +! followed by whitespace +TUPLE: template-lexer ; + +: ( lines -- lexer ) + template-lexer construct-delegate ; + +M: template-lexer skip-word + [ + { + { [ 2dup nth CHAR: " = ] [ drop 1+ ] } + { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] } + { [ t ] [ f skip ] } + } cond + ] change-column ; + +DEFER: <% delimiter + +: check-<% ( lexer -- col ) + "<%" over lexer-line-text rot lexer-column start* ; + +: found-<% ( accum lexer col -- accum ) + [ + over lexer-line-text + >r >r lexer-column r> r> subseq parsed + \ write-html parsed + ] 2keep 2 + swap set-lexer-column ; + +: still-looking ( accum lexer -- accum ) + [ + dup lexer-line-text swap lexer-column tail + parsed \ print-html parsed + ] keep next-line ; + +: parse-%> ( accum lexer -- accum ) + dup still-parsing? [ + dup check-<% + [ found-<% ] [ [ still-looking ] keep parse-%> ] if* + ] [ + drop + ] if ; + +: %> lexer get parse-%> ; parsing + +: parse-template-lines ( lines -- quot ) + [ + V{ } clone lexer get parse-%> f (parse-until) + ] with-parser ; + +: parse-template ( string -- quot ) + [ + use [ clone ] change + templating-vocab use+ + string-lines parse-template-lines + ] with-scope ; + +: eval-template ( string -- ) parse-template call ; + +: html-error. ( error -- ) + 
 error.
; + +: run-template-file ( filename -- ) + [ + [ + "quiet" on + parser-notes off + templating-vocab use+ + dup source-file file set ! so that reload works properly + [ + ?resource-path file-contents + [ eval-template ] [ html-error. drop ] recover + ] keep + ] with-file-vocabs + ] assert-depth drop ; + +: run-relative-template-file ( filename -- ) + file get source-file-path parent-directory + swap path+ run-template-file ; + +: template-convert ( infile outfile -- ) + [ run-template-file ] with-file-writer ; diff --git a/extra/http.good/server/templating/test/bug.fhtml b/extra/http.good/server/templating/test/bug.fhtml new file mode 100644 index 0000000000..cb66599079 --- /dev/null +++ b/extra/http.good/server/templating/test/bug.fhtml @@ -0,0 +1,5 @@ +<% + USING: prettyprint ; + ! Hello world + 5 pprint +%> diff --git a/extra/http.good/server/templating/test/bug.html b/extra/http.good/server/templating/test/bug.html new file mode 100644 index 0000000000..51d7b8d169 --- /dev/null +++ b/extra/http.good/server/templating/test/bug.html @@ -0,0 +1,2 @@ +5 + diff --git a/extra/http.good/server/templating/test/example.fhtml b/extra/http.good/server/templating/test/example.fhtml new file mode 100644 index 0000000000..211f44af9a --- /dev/null +++ b/extra/http.good/server/templating/test/example.fhtml @@ -0,0 +1,8 @@ +<% USING: math ; %> + + + Simple Embedded Factor Example + + <% 5 [ %>

I like repetition

<% ] times %> + + diff --git a/extra/http.good/server/templating/test/example.html b/extra/http.good/server/templating/test/example.html new file mode 100644 index 0000000000..9bf4a08209 --- /dev/null +++ b/extra/http.good/server/templating/test/example.html @@ -0,0 +1,9 @@ + + + + Simple Embedded Factor Example + +

I like repetition

I like repetition

I like repetition

I like repetition

I like repetition

+ + + diff --git a/extra/http.good/server/templating/test/stack.fhtml b/extra/http.good/server/templating/test/stack.fhtml new file mode 100644 index 0000000000..399711a209 --- /dev/null +++ b/extra/http.good/server/templating/test/stack.fhtml @@ -0,0 +1 @@ +The stack: <% USING: prettyprint ; .s %> diff --git a/extra/http.good/server/templating/test/stack.html b/extra/http.good/server/templating/test/stack.html new file mode 100644 index 0000000000..ee923a6421 --- /dev/null +++ b/extra/http.good/server/templating/test/stack.html @@ -0,0 +1,2 @@ +The stack: + diff --git a/extra/http.good/summary.txt b/extra/http.good/summary.txt new file mode 100644 index 0000000000..8791a6f1c4 --- /dev/null +++ b/extra/http.good/summary.txt @@ -0,0 +1 @@ +Common code shared by HTTP client and server diff --git a/extra/http.good/tags.txt b/extra/http.good/tags.txt new file mode 100644 index 0000000000..93e65ae758 --- /dev/null +++ b/extra/http.good/tags.txt @@ -0,0 +1,2 @@ +web +network diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 34065203f8..1678c2de41 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -49,7 +49,7 @@ M: simple-monitor set-timeout set-simple-monitor-timeout ; >r r> construct-delegate ; inline : notify-callback ( simple-monitor -- ) - simple-monitor-callback ?box [ resume ] [ drop ] if ; + simple-monitor-callback [ resume ] if-box? ; M: simple-monitor timed-out notify-callback ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index b5ab63c4c8..9d6e95c07a 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -358,7 +358,6 @@ M: windows-ui-backend (close-window) { [ t ] [ dup TranslateMessage drop dup DispatchMessage drop - yield event-loop ] } } cond ; @@ -454,12 +453,11 @@ M: windows-ui-backend raise-window* ( world -- ) win-hWnd SetFocus drop ] when* ; -M: windows-ui-backend set-title ( string world -- ) - world-handle [ nip win-hWnd WM_SETTEXT 0 ] 2keep +M: windows-ui-backend set-title ( string handle -- ) dup win-title [ free ] when* - >r malloc-u16-string dup r> - set-win-title alien-address - SendMessage drop ; + >r malloc-u16-string r> + 2dup set-win-title + win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ; M: windows-ui-backend ui [ diff --git a/extra/vocabs/monitor/monitor.factor b/extra/vocabs/monitor/monitor.factor index 32a104687e..78e2339764 100755 --- a/extra/vocabs/monitor/monitor.factor +++ b/extra/vocabs/monitor/monitor.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: threads io.files io.monitors init kernel -tools.browser namespaces continuations ; +tools.browser namespaces continuations vocabs.loader ; IN: vocabs.monitor ! Use file system change monitoring to flush the tags/authors @@ -9,7 +9,9 @@ IN: vocabs.monitor SYMBOL: vocab-monitor : monitor-thread ( -- ) - vocab-monitor get-global next-change 2drop reset-cache ; + vocab-monitor get-global + next-change 2drop + t sources-changed? set-global reset-cache ; : start-monitor-thread #! Silently ignore errors during monitor creation since From 85ab4c3b5d7aaa4927d6a9961da61e168886a114 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 29 Feb 2008 19:11:26 -0600 Subject: [PATCH 038/140] Oops --- extra/http.good/authors.txt | 1 - .../basic-authentication/authors.txt | 1 - .../basic-authentication-docs.factor | 69 ----- .../basic-authentication-tests.factor | 66 ----- .../basic-authentication.factor | 65 ---- .../basic-authentication/summary.txt | 1 - extra/http.good/basic-authentication/tags.txt | 1 - extra/http.good/client/authors.txt | 1 - extra/http.good/client/client-tests.factor | 26 -- extra/http.good/client/client.factor | 96 ------ extra/http.good/client/summary.txt | 1 - extra/http.good/client/tags.txt | 2 - extra/http.good/http-tests.factor | 115 -------- extra/http.good/http.factor | 277 ------------------ extra/http.good/mime/authors.txt | 1 - extra/http.good/mime/mime.factor | 34 --- extra/http.good/server/authors.txt | 1 - extra/http.good/server/server-tests.factor | 45 --- extra/http.good/server/server.factor | 131 --------- extra/http.good/server/summary.txt | 1 - extra/http.good/server/tags.txt | 3 - extra/http.good/server/templating/authors.txt | 2 - .../server/templating/templating-tests.factor | 17 -- .../server/templating/templating.factor | 96 ------ .../server/templating/test/bug.fhtml | 5 - .../http.good/server/templating/test/bug.html | 2 - .../server/templating/test/example.fhtml | 8 - .../server/templating/test/example.html | 9 - .../server/templating/test/stack.fhtml | 1 - .../server/templating/test/stack.html | 2 - extra/http.good/summary.txt | 1 - extra/http.good/tags.txt | 2 - 32 files changed, 1083 deletions(-) delete mode 100644 extra/http.good/authors.txt delete mode 100644 extra/http.good/basic-authentication/authors.txt delete mode 100644 extra/http.good/basic-authentication/basic-authentication-docs.factor delete mode 100644 extra/http.good/basic-authentication/basic-authentication-tests.factor delete mode 100644 extra/http.good/basic-authentication/basic-authentication.factor delete mode 100644 extra/http.good/basic-authentication/summary.txt delete mode 100644 extra/http.good/basic-authentication/tags.txt delete mode 100644 extra/http.good/client/authors.txt delete mode 100755 extra/http.good/client/client-tests.factor delete mode 100755 extra/http.good/client/client.factor delete mode 100644 extra/http.good/client/summary.txt delete mode 100644 extra/http.good/client/tags.txt delete mode 100755 extra/http.good/http-tests.factor delete mode 100755 extra/http.good/http.factor delete mode 100755 extra/http.good/mime/authors.txt delete mode 100644 extra/http.good/mime/mime.factor delete mode 100755 extra/http.good/server/authors.txt delete mode 100755 extra/http.good/server/server-tests.factor delete mode 100755 extra/http.good/server/server.factor delete mode 100644 extra/http.good/server/summary.txt delete mode 100644 extra/http.good/server/tags.txt delete mode 100644 extra/http.good/server/templating/authors.txt delete mode 100644 extra/http.good/server/templating/templating-tests.factor delete mode 100755 extra/http.good/server/templating/templating.factor delete mode 100644 extra/http.good/server/templating/test/bug.fhtml delete mode 100644 extra/http.good/server/templating/test/bug.html delete mode 100644 extra/http.good/server/templating/test/example.fhtml delete mode 100644 extra/http.good/server/templating/test/example.html delete mode 100644 extra/http.good/server/templating/test/stack.fhtml delete mode 100644 extra/http.good/server/templating/test/stack.html delete mode 100644 extra/http.good/summary.txt delete mode 100644 extra/http.good/tags.txt diff --git a/extra/http.good/authors.txt b/extra/http.good/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/extra/http.good/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/http.good/basic-authentication/authors.txt b/extra/http.good/basic-authentication/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/extra/http.good/basic-authentication/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/http.good/basic-authentication/basic-authentication-docs.factor b/extra/http.good/basic-authentication/basic-authentication-docs.factor deleted file mode 100644 index 68d6e6bf1d..0000000000 --- a/extra/http.good/basic-authentication/basic-authentication-docs.factor +++ /dev/null @@ -1,69 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax crypto.sha2 ; -IN: http.basic-authentication - -HELP: realms -{ $description - "A hashtable mapping a basic authentication realm (a string) " - "to either a quotation or a hashtable. The quotation has " - "stack effect ( username sha-256-string -- bool ). It " - "is expected to perform the user authentication when called." $nl - "If the realm maps to a hashtable then the hashtable should be a " - "mapping of usernames to sha-256 hashed passwords." $nl - "If the 'realms' variable does not exist in the current scope then " - "authentication will always fail." } -{ $see-also add-realm with-basic-authentication } ; - -HELP: add-realm -{ $values - { "data" "a quotation or a hashtable" } { "name" "a string" } } -{ $description - "Adds the authentication data to the " { $link realms } ". 'data' can be " - "a quotation with stack effect ( username sha-256-string -- bool ) or " - "a hashtable mapping username strings to sha-256-string passwords." } -{ $examples - { $code "H{ { \"admin\" \"...\" } { \"user\" \"...\" } } \"my-realm\" add-realm" } - { $code "[ \"...\" = swap \"admin\" = and ] \"my-realm\" add-realm" } -} -{ $see-also with-basic-authentication realms } ; - -HELP: with-basic-authentication -{ $values - { "realm" "a string" } { "quot" "a quotation with stack effect ( -- )" } } -{ $description - "Checks if the HTTP request has the correct authorisation headers " - "for basic authentication within the named realm. If the headers " - "are not present then a '401' HTTP response results from the " - "request, otherwise the quotation is called." } -{ $examples -{ $code "\"my-realm\" [\n serving-html \"Success!\" write\n] with-basic-authentication" } } -{ $see-also add-realm realms } - ; - -ARTICLE: { "http-authentication" "basic-authentication" } "Basic Authentication" -"The Basic Authentication system provides a simple browser based " -"authentication method to web applications. When the browser requests " -"a resource protected with basic authentication the server responds with " -"a '401' response code which means the user is unauthorized." -$nl -"When the browser receives this it prompts the user for a username and " -"password. This is sent back to the server in a special HTTP header. The " -"server then checks this against its authentication information and either " -"accepts or rejects the users request." -$nl -"Authentication is split up into " { $link realms } ". Each realm can have " -"a different database of username and password information. A responder can " -"require basic authentication by using the " { $link with-basic-authentication } " word." -$nl -"Username and password information can be maintained using " { $link realms } " and " { $link add-realm } "." -$nl -"All passwords on the server should be stored as sha-256 strings generated with the " { $link string>sha-256-string } " word." -$nl -"Note that Basic Authentication itself is insecure in that it " -"sends the username and password as clear text (although it is " -"base64 encoded this is not much help). To prevent eavesdropping " -"it is best to use Basic Authentication with SSL." ; - -IN: http.basic-authentication -ABOUT: { "http-authentication" "basic-authentication" } diff --git a/extra/http.good/basic-authentication/basic-authentication-tests.factor b/extra/http.good/basic-authentication/basic-authentication-tests.factor deleted file mode 100644 index 318123b0b4..0000000000 --- a/extra/http.good/basic-authentication/basic-authentication-tests.factor +++ /dev/null @@ -1,66 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel crypto.sha2 http.basic-authentication tools.test - namespaces base64 sequences ; - -{ t } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "admin:passwordx" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ t } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "admin:xpassword" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - f realms set - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test diff --git a/extra/http.good/basic-authentication/basic-authentication.factor b/extra/http.good/basic-authentication/basic-authentication.factor deleted file mode 100644 index e15ba9db16..0000000000 --- a/extra/http.good/basic-authentication/basic-authentication.factor +++ /dev/null @@ -1,65 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel base64 http.server crypto.sha2 namespaces assocs - quotations hashtables combinators splitting sequences - http.server.responders io html.elements ; -IN: http.basic-authentication - -! 'realms' is a hashtable mapping a realm (a string) to -! either a quotation or a hashtable. The quotation -! has stack effect ( username sha-256-string -- bool ). -! It should perform the user authentication. 'sha-256-string' -! is the plain text password provided by the user passed through -! 'string>sha-256-string'. If 'realms' maps to a hashtable then -! it is a mapping of usernames to sha-256 hashed passwords. -! -! 'realms' can be set on a per vhost basis in the vhosts -! table. -! -! If there are no realms then authentication fails. -SYMBOL: realms - -: add-realm ( data name -- ) - #! Add the named realm to the realms table. - #! 'data' should be a hashtable or a quotation. - realms get [ H{ } clone dup realms set ] unless* - set-at ; - -: user-authorized? ( username password realm -- bool ) - realms get dup [ - at { - { [ dup quotation? ] [ call ] } - { [ dup hashtable? ] [ swapd at = ] } - { [ t ] [ 3drop f ] } - } cond - ] [ - 3drop drop f - ] if ; - -: authorization-ok? ( realm header -- bool ) - #! Given the realm and the 'Authorization' header, - #! authenticate the user. - dup [ - " " split dup first "Basic" = [ - second base64> ":" split first2 string>sha-256-string rot - user-authorized? - ] [ - 2drop f - ] if - ] [ - 2drop f - ] if ; - -: authentication-error ( realm -- ) - "401 Unauthorized" response - "Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate print-header - - "Username or Password is invalid" write - ; - -: with-basic-authentication ( realm quot -- ) - #! Check if the user is authenticated in the given realm - #! to run the specified quotation. If not, use Basic - #! Authentication to ask for authorization details. - over "Authorization" header-param authorization-ok? - [ nip call ] [ drop authentication-error ] if ; diff --git a/extra/http.good/basic-authentication/summary.txt b/extra/http.good/basic-authentication/summary.txt deleted file mode 100644 index 60cef7e630..0000000000 --- a/extra/http.good/basic-authentication/summary.txt +++ /dev/null @@ -1 +0,0 @@ -HTTP Basic Authentication implementation diff --git a/extra/http.good/basic-authentication/tags.txt b/extra/http.good/basic-authentication/tags.txt deleted file mode 100644 index c0772185a0..0000000000 --- a/extra/http.good/basic-authentication/tags.txt +++ /dev/null @@ -1 +0,0 @@ -web diff --git a/extra/http.good/client/authors.txt b/extra/http.good/client/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/extra/http.good/client/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/http.good/client/client-tests.factor b/extra/http.good/client/client-tests.factor deleted file mode 100755 index 5e407657a8..0000000000 --- a/extra/http.good/client/client-tests.factor +++ /dev/null @@ -1,26 +0,0 @@ -USING: http.client http.client.private http tools.test -tuple-syntax namespaces ; -[ "localhost" 80 ] [ "localhost" parse-host ] unit-test -[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test -[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test -[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test - -[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test -[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test -[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test -[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test - -[ - TUPLE{ request - method: "GET" - host: "www.apple.com" - path: "/index.html" - port: 80 - } -] [ - [ - "http://www.apple.com/index.html" - - request-with-url - ] with-scope -] unit-test diff --git a/extra/http.good/client/client.factor b/extra/http.good/client/client.factor deleted file mode 100755 index 8b74b6dc72..0000000000 --- a/extra/http.good/client/client.factor +++ /dev/null @@ -1,96 +0,0 @@ -! Copyright (C) 2005, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs http kernel math math.parser namespaces sequences -io io.sockets io.streams.string io.files io.timeouts strings -splitting continuations assocs.lib calendar vectors hashtables -accessors ; -IN: http.client - -: parse-url ( url -- resource host port ) - "http://" ?head [ "Only http:// supported" throw ] unless - "/" split1 [ "/" swap append ] [ "/" ] if* - swap parse-host ; - -r >>path r> dup [ query>assoc ] when >>query ; - -! This is all pretty complex because it needs to handle -! HTTP redirects, which might be absolute or relative -: request-with-url ( url request -- request ) - clone dup "request" set - swap parse-url >r >r store-path r> >>host r> >>port ; - -DEFER: (http-request) - -: absolute-redirect ( url -- request ) - "request" get request-with-url ; - -: relative-redirect ( path -- request ) - "request" get swap store-path ; - -: do-redirect ( response -- response stream ) - dup response-code 300 399 between? [ - header>> "location" peek-at - dup "http://" head? [ - absolute-redirect - ] [ - relative-redirect - ] if "GET" >>method (http-request) - ] [ - stdio get - ] if ; - -: (http-request) ( request -- response stream ) - dup host>> over port>> stdio set - write-request flush read-response - do-redirect ; - -PRIVATE> - -: http-request ( url request -- response stream ) - [ - request-with-url - [ - (http-request) - 1 minutes over set-timeout - ] [ ] [ stdio get dispose ] cleanup - ] with-scope ; - -: ( -- request ) - request construct-empty - "GET" >>method ; - -: http-get-stream ( url -- response stream ) - http-request ; - -: success? ( code -- ? ) 200 = ; - -: check-response ( response stream -- stream ) - swap code>> success? - [ dispose "HTTP download failed" throw ] unless ; - -: http-get ( url -- string ) - http-get-stream check-response contents ; - -: download-name ( url -- name ) - file-name "?" split1 drop "/" ?tail drop ; - -: download-to ( url file -- ) - #! Downloads the contents of a URL to a file. - swap http-get-stream check-response - [ swap stream-copy ] with-disposal ; - -: download ( url -- ) - dup download-name download-to ; - -: ( content-type content -- request ) - request construct-empty - "POST" >>method - swap >>post-data - swap >>post-data-type ; - -: http-post ( content-type content url -- response string ) - #! The content is URL encoded for you. - -rot url-encode http-request contents ; diff --git a/extra/http.good/client/summary.txt b/extra/http.good/client/summary.txt deleted file mode 100644 index 5609c916c4..0000000000 --- a/extra/http.good/client/summary.txt +++ /dev/null @@ -1 +0,0 @@ -HTTP client diff --git a/extra/http.good/client/tags.txt b/extra/http.good/client/tags.txt deleted file mode 100644 index 93e65ae758..0000000000 --- a/extra/http.good/client/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -web -network diff --git a/extra/http.good/http-tests.factor b/extra/http.good/http-tests.factor deleted file mode 100755 index 9fa593053c..0000000000 --- a/extra/http.good/http-tests.factor +++ /dev/null @@ -1,115 +0,0 @@ -USING: http tools.test multiline tuple-syntax -io.streams.string kernel arrays splitting sequences ; -IN: temporary - -[ "hello%20world" ] [ "hello world" url-encode ] unit-test -[ "hello world" ] [ "hello%20world" url-decode ] unit-test -[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test -[ "" ] [ "%XX%XX%XX" url-decode ] unit-test -[ "" ] [ "%XX%XX%X" url-decode ] 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 -[ "hello world" ] [ "hello world%" url-decode ] unit-test -[ "hello world" ] [ "hello world%x" url-decode ] unit-test -[ "hello%20world" ] [ "hello world" url-encode ] unit-test -[ "%20%21%20" ] [ " ! " url-encode ] unit-test - -[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test - -STRING: read-request-test-1 -GET http://foo/bar HTTP/1.1 -Some-Header: 1 -Some-Header: 2 -Content-Length: 4 - -blah -; - -[ - TUPLE{ request - method: "GET" - path: "bar" - query: f - version: "1.1" - header: H{ { "some-header" V{ "1" "2" } } { "content-length" V{ "4" } } } - post-data: "blah" - } -] [ - read-request-test-1 [ - read-request - ] with-string-reader -] unit-test - -STRING: read-request-test-1' -GET bar HTTP/1.1 -content-length: 4 -some-header: 1 -some-header: 2 - -blah -; - -read-request-test-1' 1array [ - read-request-test-1 - [ read-request ] with-string-reader - [ write-request ] with-string-writer - ! normalize crlf - string-lines "\n" join -] unit-test - -STRING: read-request-test-2 -HEAD http://foo/bar HTTP/1.0 -Host: www.sex.com -; - -[ - TUPLE{ request - method: "HEAD" - path: "bar" - query: f - version: "1.0" - header: H{ { "host" V{ "www.sex.com" } } } - host: "www.sex.com" - } -] [ - read-request-test-2 [ - read-request - ] with-string-reader -] unit-test - -STRING: read-response-test-1 -HTTP/1.0 404 not found -Content-Type: text/html - -blah -; - -[ - TUPLE{ response - version: "1.0" - code: 404 - message: "not found" - header: H{ { "content-type" V{ "text/html" } } } - } -] [ - read-response-test-1 - [ read-response ] with-string-reader -] unit-test - - -STRING: read-response-test-1' -HTTP/1.0 404 not found -content-type: text/html - - -; - -read-response-test-1' 1array [ - read-response-test-1 - [ read-response ] with-string-reader - [ write-response ] with-string-writer - ! normalize crlf - string-lines "\n" join -] unit-test diff --git a/extra/http.good/http.factor b/extra/http.good/http.factor deleted file mode 100755 index 4c2834b7ca..0000000000 --- a/extra/http.good/http.factor +++ /dev/null @@ -1,277 +0,0 @@ -! Copyright (C) 2003, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: hashtables io io.streams.string kernel math namespaces -math.parser assocs sequences strings splitting ascii -io.encodings.utf8 assocs.lib namespaces unicode.case combinators -vectors sorting new-slots accessors calendar ; -IN: http - -: http-port 80 ; inline - -: crlf "\r\n" write ; - -: header-line ( line -- ) - ": " split1 dup [ swap >lower insert ] [ 2drop ] if ; - -: read-header-line ( -- ) - readln dup - empty? [ drop ] [ header-line read-header-line ] if ; - -: read-header ( -- multi-assoc ) - [ read-header-line ] H{ } make-assoc ; - -: write-header ( multi-assoc -- ) - >alist sort-keys - [ - swap write ": " write { - { [ dup number? ] [ number>string ] } - { [ dup timestamp? ] [ timestamp>http-string ] } - { [ dup string? ] [ ] } - } cond write crlf - ] multi-assoc-each crlf ; - -: url-quotable? ( ch -- ? ) - #! In a URL, can this character be used without - #! URL-encoding? - dup letter? - over LETTER? or - over digit? or - swap "/_-." member? or ; foldable - -: push-utf8 ( ch -- ) - 1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; - -: url-encode ( str -- str ) - [ [ - dup url-quotable? [ , ] [ push-utf8 ] if - ] each ] "" make ; - -: url-decode-hex ( index str -- ) - 2dup length 2 - >= [ - 2drop - ] [ - >r 1+ dup 2 + r> subseq hex> [ , ] when* - ] if ; - -: url-decode-% ( index str -- index str ) - 2dup url-decode-hex >r 3 + r> ; - -: url-decode-+-or-other ( index str ch -- index str ) - dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ; - -: url-decode-iter ( index str -- ) - 2dup length >= [ - 2drop - ] [ - 2dup nth dup CHAR: % = [ - drop url-decode-% - ] [ - url-decode-+-or-other - ] if url-decode-iter - ] if ; - -: url-decode ( str -- str ) - [ 0 swap url-decode-iter ] "" make decode-utf8 ; - -: query>assoc ( query -- assoc ) - dup [ - "&" split [ - "=" split1 [ dup [ url-decode ] when ] 2apply - ] H{ } map>assoc - ] when ; - -: assoc>query ( hash -- str ) - [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map - "&" join ; - -TUPLE: request -host -port -method -path -query -version -header -post-data -post-data-type ; - -: - request construct-empty - "1.0" >>version - http-port >>port ; - -: url>path ( url -- path ) - url-decode "http://" ?head - [ "/" split1 "" or nip ] [ "/" ?head drop ] if ; - -: read-method ( request -- request ) - " " read-until [ "Bad request: method" throw ] unless - >>method ; - -: read-query ( request -- request ) - " " read-until - [ "Bad request: query params" throw ] unless - query>assoc >>query ; - -: read-url ( request -- request ) - " ?" read-until { - { CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] } - { CHAR: ? [ url>path >>path read-query ] } - [ "Bad request: URL" throw ] - } case ; - -: parse-version ( string -- version ) - "HTTP/" ?head [ "Bad version" throw ] unless - dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ; - -: read-request-version ( request -- request ) - readln [ CHAR: \s = ] left-trim - parse-version - >>version ; - -: read-request-header ( request -- request ) - read-header >>header ; - -SYMBOL: max-post-request - -1024 256 * max-post-request set-global - -: content-length ( header -- n ) - "content-length" peek-at string>number dup [ - dup max-post-request get > [ - "content-length > max-post-request" throw - ] when - ] when ; - -: read-post-data ( request -- request ) - dup header>> content-length [ read >>post-data ] when* ; - -: parse-host ( string -- host port ) - "." ?tail drop ":" split1 - [ string>number ] [ http-port ] if* ; - -: extract-host ( request -- request ) - dup header>> "host" peek-at parse-host >r >>host r> >>port ; - -: extract-post-data-type ( request -- request ) - dup header>> "content-type" peek-at >>post-data-type ; - -: read-request ( -- request ) - - read-method - read-url - read-request-version - read-request-header - read-post-data - extract-host - extract-post-data-type ; - -: write-method ( request -- request ) - dup method>> write bl ; - -: write-url ( request -- request ) - dup path>> url-encode write - dup query>> dup assoc-empty? [ drop ] [ - "?" write - assoc>query write - ] if ; - -: write-request-url ( request -- request ) - write-url bl ; - -: write-version ( request -- request ) - "HTTP/" write dup request-version write crlf ; - -: write-request-header ( request -- request ) - dup header>> >hashtable - over host>> [ "host" replace-at ] when* - over post-data>> [ length "content-length" replace-at ] when* - over post-data-type>> [ "content-type" replace-at ] when* - write-header ; - -: write-post-data ( request -- request ) - dup post-data>> [ write ] when* ; - -: write-request ( request -- ) - write-method - write-url - write-version - write-request-header - write-post-data - flush - drop ; - -: request-url ( request -- url ) - [ - dup host>> [ - "http://" write - dup host>> url-encode write - ":" write - dup port>> number>string write - ] when - "/" write - write-url - drop - ] with-string-writer ; - -TUPLE: response -version -code -message -header ; - -: - response construct-empty - "1.0" >>version - H{ } clone >>header ; - -: read-response-version - " " read-until - [ "Bad response: version" throw ] unless - parse-version - >>version ; - -: read-response-code - " " read-until [ "Bad response: code" throw ] unless - string>number [ "Bad response: code" throw ] unless* - >>code ; - -: read-response-message - readln >>message ; - -: read-response-header - read-header >>header ; - -: read-response ( -- response ) - - read-response-version - read-response-code - read-response-message - read-response-header ; - -: write-response-version ( response -- response ) - "HTTP/" write - dup version>> write bl ; - -: write-response-code ( response -- response ) - dup code>> number>string write bl ; - -: write-response-message ( response -- response ) - dup message>> write crlf ; - -: write-response-header ( response -- response ) - dup header>> write-header ; - -: write-response ( respose -- ) - write-response-version - write-response-code - write-response-message - write-response-header - flush - drop ; - -: set-response-header ( response value key -- response ) - pick header>> -rot replace-at drop ; - -: set-content-type ( response content-type -- response ) - "content-type" set-response-header ; diff --git a/extra/http.good/mime/authors.txt b/extra/http.good/mime/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/http.good/mime/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/http.good/mime/mime.factor b/extra/http.good/mime/mime.factor deleted file mode 100644 index 3365127d87..0000000000 --- a/extra/http.good/mime/mime.factor +++ /dev/null @@ -1,34 +0,0 @@ -! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: io assocs kernel sequences math namespaces splitting ; - -IN: http.mime - -: file-extension ( filename -- extension ) - "." split dup length 1 <= [ drop f ] [ peek ] if ; - -: mime-type ( filename -- mime-type ) - file-extension "mime-types" get at "application/octet-stream" or ; - -H{ - { "html" "text/html" } - { "txt" "text/plain" } - { "xml" "text/xml" } - { "css" "text/css" } - - { "gif" "image/gif" } - { "png" "image/png" } - { "jpg" "image/jpeg" } - { "jpeg" "image/jpeg" } - - { "jar" "application/octet-stream" } - { "zip" "application/octet-stream" } - { "tgz" "application/octet-stream" } - { "tar.gz" "application/octet-stream" } - { "gz" "application/octet-stream" } - - { "pdf" "application/pdf" } - - { "factor" "text/plain" } - { "fhtml" "application/x-factor-server-page" } -} "mime-types" set-global diff --git a/extra/http.good/server/authors.txt b/extra/http.good/server/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/http.good/server/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/http.good/server/server-tests.factor b/extra/http.good/server/server-tests.factor deleted file mode 100755 index a67d21a640..0000000000 --- a/extra/http.good/server/server-tests.factor +++ /dev/null @@ -1,45 +0,0 @@ -USING: http.server tools.test kernel namespaces accessors -new-slots assocs.lib io http math sequences ; -IN: temporary - -TUPLE: mock-responder ; - -: ( path -- responder ) - mock-responder construct-delegate ; - -M: mock-responder do-responder - 2nip - path>> on - [ "Hello world" print ] - "text/plain" ; - -: check-dispatch ( tag path -- ? ) - over off - swap default-host get call-responder - write-response call get ; - -[ - "" - "foo" add-responder - "bar" add-responder - "baz/" - "123" add-responder - "default" >>default - add-responder - default-host set - - [ t ] [ "foo" "foo" check-dispatch ] unit-test - [ f ] [ "foo" "bar" check-dispatch ] unit-test - [ t ] [ "bar" "bar" check-dispatch ] unit-test - [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test - [ t ] [ "123" "baz/123" check-dispatch ] unit-test - - [ t ] [ - - "baz" >>path - "baz" default-host get call-responder - dup code>> 300 399 between? >r - header>> "location" peek-at "baz/" tail? r> and - nip - ] unit-test -] with-scope diff --git a/extra/http.good/server/server.factor b/extra/http.good/server/server.factor deleted file mode 100755 index e06ae6a95c..0000000000 --- a/extra/http.good/server/server.factor +++ /dev/null @@ -1,131 +0,0 @@ -! Copyright (C) 2003, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel namespaces io io.timeouts strings splitting -threads http sequences prettyprint io.server logging calendar -new-slots html.elements accessors math.parser combinators.lib ; -IN: http.server - -TUPLE: responder path directory ; - -: ( path -- responder ) - "/" ?tail responder construct-boa ; - -GENERIC: do-responder ( request path responder -- quot response ) - -TUPLE: trivial-responder quot response ; - -: ( quot response -- responder ) - trivial-responder construct-boa - "" over set-delegate ; - -M: trivial-responder do-responder - 2nip dup quot>> swap response>> ; - -: trivial-response-body ( code message -- ) - - -

swap number>string write bl write

- - ; - -: ( code message -- quot response ) - [ [ trivial-response-body ] 2curry ] 2keep - "text/html" set-content-type - swap >>message - swap >>code ; - -: <404> ( -- quot response ) - 404 "Not Found" ; - -: ( to code message -- quot response ) - - rot "location" set-response-header ; - -: ( to -- quot response ) - 301 "Moved Permanently" ; - -: ( to -- quot response ) - 307 "Temporary Redirect" ; - -: ( content-type -- response ) - - 200 >>code - swap set-content-type ; - -TUPLE: dispatcher responders default ; - -: responder-matches? ( path responder -- ? ) - path>> head? ; - -TUPLE: no-/-responder ; - -M: no-/-responder do-responder - 2drop - dup path>> "/" append >>path - request-url ; - -: ( -- responder ) - "" no-/-responder construct-delegate ; - - no-/-responder set-global - -: find-responder ( path dispatcher -- path responder ) - >r "/" ?head drop r> - [ responders>> [ dupd responder-matches? ] find nip ] keep - default>> or [ path>> ?head drop ] keep ; - -: no-trailing-/ ( path responder -- path responder ) - over empty? over directory>> and - [ drop no-/-responder get-global ] when ; - -: call-responder ( request path responder -- quot response ) - no-trailing-/ do-responder ; - -SYMBOL: 404-responder - -<404> 404-responder set-global - -M: dispatcher do-responder - find-responder call-responder ; - -: ( path -- dispatcher ) - - dispatcher construct-delegate - 404-responder get-global >>default - V{ } clone >>responders ; - -: add-responder ( dispatcher responder -- dispatcher ) - over responders>> push ; - -SYMBOL: virtual-hosts -SYMBOL: default-host - -virtual-hosts global [ drop H{ } clone ] cache drop -default-host global [ drop 404-responder ] cache drop - -: find-virtual-host ( host -- responder ) - virtual-hosts get at [ default-host get ] unless* ; - -: handle-request ( request -- ) - [ - dup path>> over host>> find-virtual-host - call-responder - write-response - ] keep method>> "HEAD" = [ drop ] [ call ] if ; - -: default-timeout 1 minutes stdio get set-timeout ; - -LOG: httpd-hit NOTICE - -: log-request ( request -- ) - { method>> host>> path>> } map-exec-with httpd-hit ; - -: httpd ( port -- ) - internet-server "http.server" [ - default-timeout - read-request dup log-request handle-request - ] with-server ; - -: httpd-main ( -- ) 8888 httpd ; - -MAIN: httpd-main diff --git a/extra/http.good/server/summary.txt b/extra/http.good/server/summary.txt deleted file mode 100644 index e6d2ca62e9..0000000000 --- a/extra/http.good/server/summary.txt +++ /dev/null @@ -1 +0,0 @@ -HTTP server diff --git a/extra/http.good/server/tags.txt b/extra/http.good/server/tags.txt deleted file mode 100644 index b0881a9ec0..0000000000 --- a/extra/http.good/server/tags.txt +++ /dev/null @@ -1,3 +0,0 @@ -enterprise -network -web diff --git a/extra/http.good/server/templating/authors.txt b/extra/http.good/server/templating/authors.txt deleted file mode 100644 index b47eafb62a..0000000000 --- a/extra/http.good/server/templating/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Slava Pestov -Matthew Willis diff --git a/extra/http.good/server/templating/templating-tests.factor b/extra/http.good/server/templating/templating-tests.factor deleted file mode 100644 index d889cd848a..0000000000 --- a/extra/http.good/server/templating/templating-tests.factor +++ /dev/null @@ -1,17 +0,0 @@ -USING: io io.files io.streams.string http.server.templating kernel tools.test - sequences ; -IN: temporary - -: test-template ( path -- ? ) - "extra/http/server/templating/test/" swap append - [ - ".fhtml" append resource-path - [ run-template-file ] with-string-writer - ] keep - ".html" append resource-path file-contents = ; - -[ t ] [ "example" test-template ] unit-test -[ t ] [ "bug" test-template ] unit-test -[ t ] [ "stack" test-template ] unit-test - -[ ] [ "<%\n%>" parse-template drop ] unit-test diff --git a/extra/http.good/server/templating/templating.factor b/extra/http.good/server/templating/templating.factor deleted file mode 100755 index f364b86524..0000000000 --- a/extra/http.good/server/templating/templating.factor +++ /dev/null @@ -1,96 +0,0 @@ -! Copyright (C) 2005 Alex Chapman -! Copyright (C) 2006, 2007 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: continuations sequences kernel parser namespaces io -io.files io.streams.lines io.streams.string html html.elements -source-files debugger combinators math quotations generic -strings splitting ; - -IN: http.server.templating - -: templating-vocab ( -- vocab-name ) "http.server.templating" ; - -! See apps/http-server/test/ or libs/furnace/ for template usage -! examples - -! We use a custom lexer so that %> ends a token even if not -! followed by whitespace -TUPLE: template-lexer ; - -: ( lines -- lexer ) - template-lexer construct-delegate ; - -M: template-lexer skip-word - [ - { - { [ 2dup nth CHAR: " = ] [ drop 1+ ] } - { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] } - { [ t ] [ f skip ] } - } cond - ] change-column ; - -DEFER: <% delimiter - -: check-<% ( lexer -- col ) - "<%" over lexer-line-text rot lexer-column start* ; - -: found-<% ( accum lexer col -- accum ) - [ - over lexer-line-text - >r >r lexer-column r> r> subseq parsed - \ write-html parsed - ] 2keep 2 + swap set-lexer-column ; - -: still-looking ( accum lexer -- accum ) - [ - dup lexer-line-text swap lexer-column tail - parsed \ print-html parsed - ] keep next-line ; - -: parse-%> ( accum lexer -- accum ) - dup still-parsing? [ - dup check-<% - [ found-<% ] [ [ still-looking ] keep parse-%> ] if* - ] [ - drop - ] if ; - -: %> lexer get parse-%> ; parsing - -: parse-template-lines ( lines -- quot ) - [ - V{ } clone lexer get parse-%> f (parse-until) - ] with-parser ; - -: parse-template ( string -- quot ) - [ - use [ clone ] change - templating-vocab use+ - string-lines parse-template-lines - ] with-scope ; - -: eval-template ( string -- ) parse-template call ; - -: html-error. ( error -- ) - 
 error.
; - -: run-template-file ( filename -- ) - [ - [ - "quiet" on - parser-notes off - templating-vocab use+ - dup source-file file set ! so that reload works properly - [ - ?resource-path file-contents - [ eval-template ] [ html-error. drop ] recover - ] keep - ] with-file-vocabs - ] assert-depth drop ; - -: run-relative-template-file ( filename -- ) - file get source-file-path parent-directory - swap path+ run-template-file ; - -: template-convert ( infile outfile -- ) - [ run-template-file ] with-file-writer ; diff --git a/extra/http.good/server/templating/test/bug.fhtml b/extra/http.good/server/templating/test/bug.fhtml deleted file mode 100644 index cb66599079..0000000000 --- a/extra/http.good/server/templating/test/bug.fhtml +++ /dev/null @@ -1,5 +0,0 @@ -<% - USING: prettyprint ; - ! Hello world - 5 pprint -%> diff --git a/extra/http.good/server/templating/test/bug.html b/extra/http.good/server/templating/test/bug.html deleted file mode 100644 index 51d7b8d169..0000000000 --- a/extra/http.good/server/templating/test/bug.html +++ /dev/null @@ -1,2 +0,0 @@ -5 - diff --git a/extra/http.good/server/templating/test/example.fhtml b/extra/http.good/server/templating/test/example.fhtml deleted file mode 100644 index 211f44af9a..0000000000 --- a/extra/http.good/server/templating/test/example.fhtml +++ /dev/null @@ -1,8 +0,0 @@ -<% USING: math ; %> - - - Simple Embedded Factor Example - - <% 5 [ %>

I like repetition

<% ] times %> - - diff --git a/extra/http.good/server/templating/test/example.html b/extra/http.good/server/templating/test/example.html deleted file mode 100644 index 9bf4a08209..0000000000 --- a/extra/http.good/server/templating/test/example.html +++ /dev/null @@ -1,9 +0,0 @@ - - - - Simple Embedded Factor Example - -

I like repetition

I like repetition

I like repetition

I like repetition

I like repetition

- - - diff --git a/extra/http.good/server/templating/test/stack.fhtml b/extra/http.good/server/templating/test/stack.fhtml deleted file mode 100644 index 399711a209..0000000000 --- a/extra/http.good/server/templating/test/stack.fhtml +++ /dev/null @@ -1 +0,0 @@ -The stack: <% USING: prettyprint ; .s %> diff --git a/extra/http.good/server/templating/test/stack.html b/extra/http.good/server/templating/test/stack.html deleted file mode 100644 index ee923a6421..0000000000 --- a/extra/http.good/server/templating/test/stack.html +++ /dev/null @@ -1,2 +0,0 @@ -The stack: - diff --git a/extra/http.good/summary.txt b/extra/http.good/summary.txt deleted file mode 100644 index 8791a6f1c4..0000000000 --- a/extra/http.good/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Common code shared by HTTP client and server diff --git a/extra/http.good/tags.txt b/extra/http.good/tags.txt deleted file mode 100644 index 93e65ae758..0000000000 --- a/extra/http.good/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -web -network From 4994a0e435849b268cea80863a62fbed14b3b602 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 Feb 2008 23:17:15 -0600 Subject: [PATCH 039/140] fix with-directory. i thought i did this already.. --- core/io/files/files-tests.factor | 2 ++ core/io/files/files.factor | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 92e148a854..850a30380b 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -121,3 +121,5 @@ USING: tools.test io.files io threads kernel continuations ; [ ] [ "copy-destination" temp-file delete-tree ] unit-test [ ] [ "copy-tree-test" temp-file delete-tree ] unit-test + +[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index e20437fa85..28f23b0de5 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -84,7 +84,7 @@ HOOK: cd io-backend ( path -- ) HOOK: cwd io-backend ( -- path ) : with-directory ( path quot -- ) - swap cd cwd [ cd ] curry [ ] cleanup ; inline + cwd [ cd ] curry rot cd [ ] cleanup ; inline ! Creating directories HOOK: make-directory io-backend ( path -- ) @@ -223,4 +223,4 @@ HOOK: io-backend ( path -- stream ) { [ winnt? ] [ "USERPROFILE" os-env ] } { [ wince? ] [ "" resource-path ] } { [ unix? ] [ "HOME" os-env ] } - } cond ; \ No newline at end of file + } cond ; From 59872525fd2aa828bd9519d7a04686bbc5d92619 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 1 Mar 2008 01:19:00 -0600 Subject: [PATCH 040/140] Fix 'box empty' error --- extra/ui/windows/windows.factor | 137 +++++++++++++++++++++----------- 1 file changed, 89 insertions(+), 48 deletions(-) diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 9d6e95c07a..6cba5cfdf8 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -235,6 +235,35 @@ M: windows-ui-backend (close-window) : handle-wm-kill-focus ( hWnd uMsg wParam lParam -- ) 3drop window [ unfocus-world ] when* ; +: message>button ( uMsg -- button down? ) + { + { [ dup WM_LBUTTONDOWN = ] [ drop 1 t ] } + { [ dup WM_LBUTTONUP = ] [ drop 1 f ] } + { [ dup WM_MBUTTONDOWN = ] [ drop 2 t ] } + { [ dup WM_MBUTTONUP = ] [ drop 2 f ] } + { [ dup WM_RBUTTONDOWN = ] [ drop 3 t ] } + { [ dup WM_RBUTTONUP = ] [ drop 3 f ] } + + { [ dup WM_NCLBUTTONDOWN = ] [ drop 1 t ] } + { [ dup WM_NCLBUTTONUP = ] [ drop 1 f ] } + { [ dup WM_NCMBUTTONDOWN = ] [ drop 2 t ] } + { [ dup WM_NCMBUTTONUP = ] [ drop 2 f ] } + { [ dup WM_NCRBUTTONDOWN = ] [ drop 3 t ] } + { [ dup WM_NCRBUTTONUP = ] [ drop 3 f ] } + } cond ; + +! If the user clicks in the window border ("non-client area") +! Windows sends us an NC[LMR]BUTTONDOWN message; but if the +! mouse is subsequently released outside the NC area, we receive +! a [LMR]BUTTONUP message and Factor can get confused. So we +! ignore BUTTONUP's that are a result of an NC*BUTTONDOWN. +SYMBOL: nc-buttons + +: handle-wm-ncbutton ( hWnd uMsg wParam lParam -- ) + 2drop nip + message>button nc-buttons get + swap [ push ] [ delete ] if ; + : >lo-hi ( WORD -- array ) [ lo-word ] keep hi-word 2array ; : mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ; @@ -244,16 +273,8 @@ M: windows-ui-backend (close-window) get-RECT-top-left 2array v- ; : mouse-event>gesture ( uMsg -- button ) - key-modifiers swap - { - { [ dup WM_LBUTTONDOWN = ] [ drop 1 ] } - { [ dup WM_LBUTTONUP = ] [ drop 1 ] } - { [ dup WM_MBUTTONDOWN = ] [ drop 2 ] } - { [ dup WM_MBUTTONUP = ] [ drop 2 ] } - { [ dup WM_RBUTTONDOWN = ] [ drop 3 ] } - { [ dup WM_RBUTTONUP = ] [ drop 3 ] } - { [ t ] [ "bad button" throw ] } - } cond ; + key-modifiers swap message>button + [ ] [ ] if ; : mouse-buttons ( -- seq ) WM_LBUTTONDOWN WM_RBUTTONDOWN 2array ; @@ -276,12 +297,16 @@ M: windows-ui-backend (close-window) mouse-captured off ; : handle-wm-buttondown ( hWnd uMsg wParam lParam -- ) - >r over capture-mouse? [ pick set-capture ] when r> + >r >r dup capture-mouse? [ over set-capture ] when r> r> prepare-mouse send-button-down ; : handle-wm-buttonup ( hWnd uMsg wParam lParam -- ) mouse-captured get [ release-capture ] when - prepare-mouse send-button-up ; + pick message>button drop dup nc-buttons get member? [ + nc-buttons get delete 4drop + ] [ + drop prepare-mouse send-button-up + ] if ; : make-TRACKMOUSEEVENT ( hWnd -- alien ) "TRACKMOUSEEVENT" [ set-TRACKMOUSEEVENT-hwndTrack ] keep @@ -307,44 +332,58 @@ M: windows-ui-backend (close-window) #! message sent if mouse leaves main application 4drop forget-rollover ; +SYMBOL: wm-handlers + +H{ } clone wm-handlers set-global + +: add-wm-handler ( quot wm -- ) + dup array? + [ [ execute add-wm-handler ] with each ] + [ wm-handlers get-global set-at ] if ; + +[ handle-wm-close 0 ] WM_CLOSE add-wm-handler +[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler + +[ handle-wm-size 0 ] WM_SIZE add-wm-handler +[ handle-wm-move 0 ] WM_MOVE add-wm-handler + +[ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler +[ 4dup handle-wm-char DefWindowProc ] { WM_CHAR WM_SYSCHAR } add-wm-handler +[ 4dup handle-wm-keyup DefWindowProc ] { WM_KEYUP WM_SYSKEYUP } add-wm-handler + +[ handle-wm-syscommand ] WM_SYSCOMMAND add-wm-handler +[ handle-wm-set-focus 0 ] WM_SETFOCUS add-wm-handler +[ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler + +[ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler +[ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler +[ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler +[ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler +[ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler +[ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler + +[ 4dup handle-wm-ncbutton DefWindowProc ] +{ WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN +WM_NCLBUTTONUP WM_NCMBUTTONUP WM_NCRBUTTONUP } +add-wm-handler + +[ nc-buttons get-global delete-all DefWindowProc ] +{ WM_EXITSIZEMOVE WM_EXITMENULOOP } add-wm-handler + +[ handle-wm-mousemove 0 ] WM_MOUSEMOVE add-wm-handler +[ handle-wm-mousewheel 0 ] WM_MOUSEWHEEL add-wm-handler +[ handle-wm-cancelmode 0 ] WM_CANCELMODE add-wm-handler +[ handle-wm-mouseleave 0 ] WM_MOUSELEAVE add-wm-handler + +SYMBOL: trace-messages? + ! return 0 if you handle the message, else just let DefWindowProc return its val : ui-wndproc ( -- object ) "uint" { "void*" "uint" "long" "long" } "stdcall" [ [ - pick ! global [ dup windows-message-name . ] bind - { - { [ dup WM_CLOSE = ] [ drop handle-wm-close 0 ] } - { [ dup WM_PAINT = ] - [ drop 4dup handle-wm-paint DefWindowProc ] } - { [ dup WM_SIZE = ] [ drop handle-wm-size 0 ] } - { [ dup WM_MOVE = ] [ drop handle-wm-move 0 ] } - - ! Keyboard events - { [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ] - [ drop 4dup handle-wm-keydown DefWindowProc ] } - { [ dup WM_CHAR = over WM_SYSCHAR = or ] - [ drop 4dup handle-wm-char DefWindowProc ] } - { [ dup WM_KEYUP = over WM_SYSKEYUP = or ] - [ drop 4dup handle-wm-keyup DefWindowProc ] } - - { [ dup WM_SYSCOMMAND = ] [ drop handle-wm-syscommand ] } - { [ dup WM_SETFOCUS = ] [ drop handle-wm-set-focus 0 ] } - { [ dup WM_KILLFOCUS = ] [ drop handle-wm-kill-focus 0 ] } - - ! Mouse events - { [ dup WM_LBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] } - { [ dup WM_MBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] } - { [ dup WM_RBUTTONDOWN = ] [ drop handle-wm-buttondown 0 ] } - { [ dup WM_LBUTTONUP = ] [ drop handle-wm-buttonup 0 ] } - { [ dup WM_MBUTTONUP = ] [ drop handle-wm-buttonup 0 ] } - { [ dup WM_RBUTTONUP = ] [ drop handle-wm-buttonup 0 ] } - { [ dup WM_MOUSEMOVE = ] [ drop handle-wm-mousemove 0 ] } - { [ dup WM_MOUSEWHEEL = ] [ drop handle-wm-mousewheel 0 ] } - { [ dup WM_CANCELMODE = ] [ drop handle-wm-cancelmode 0 ] } - { [ dup WM_MOUSELEAVE = ] [ drop handle-wm-mouseleave 0 ] } - - { [ t ] [ drop DefWindowProc ] } - } cond + pick + trace-messages? get-global [ dup windows-message-name . ] when + wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if ] ui-try ] alien-callback ; @@ -409,7 +448,8 @@ M: windows-ui-backend (close-window) SetFocus drop ; : init-win32-ui ( -- ) - "MSG" msg-obj set + V{ } clone nc-buttons set-global + "MSG" msg-obj set-global "Factor-window" malloc-u16-string class-name-ptr set-global register-wndclassex drop GetDoubleClickTime double-click-timeout set-global ; @@ -453,7 +493,8 @@ M: windows-ui-backend raise-window* ( world -- ) win-hWnd SetFocus drop ] when* ; -M: windows-ui-backend set-title ( string handle -- ) +M: windows-ui-backend set-title ( string world -- ) + world-handle dup win-title [ free ] when* >r malloc-u16-string r> 2dup set-win-title From 5352ea14ff8402eab23d498562f100b4fc39b6c5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 1 Mar 2008 01:46:01 -0600 Subject: [PATCH 041/140] Fix another race... --- extra/ui/cocoa/tools/tools.factor | 0 extra/ui/tools/listener/listener.factor | 22 ++++++++++++---------- extra/ui/tools/tools-docs.factor | 2 +- extra/ui/tools/tools.factor | 2 +- extra/ui/tools/workspace/workspace.factor | 11 +++++++---- 5 files changed, 21 insertions(+), 16 deletions(-) mode change 100644 => 100755 extra/ui/cocoa/tools/tools.factor diff --git a/extra/ui/cocoa/tools/tools.factor b/extra/ui/cocoa/tools/tools.factor old mode 100644 new mode 100755 diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index c4c366bb7d..75401b3861 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -45,21 +45,20 @@ M: listener-gadget tool-scroller listener-gadget-input interactor-flag wait-for-flag ; : workspace-busy? ( workspace -- ? ) - workspace-listener - dup wait-for-listener - listener-gadget-input interactor-busy? ; - -: get-listener ( -- listener ) - [ workspace-busy? not ] get-workspace* workspace-listener ; + workspace-listener listener-gadget-input interactor-busy? ; : listener-input ( string -- ) - get-listener listener-gadget-input set-editor-string ; + get-workspace + workspace-listener + listener-gadget-input set-editor-string ; : (call-listener) ( quot listener -- ) listener-gadget-input interactor-call ; : call-listener ( quot -- ) - get-listener (call-listener) ; + [ workspace-busy? not ] get-workspace* workspace-listener + [ dup wait-for-listener (call-listener) ] 2curry + "Listener call" spawn drop ; M: listener-command invoke-command ( target command -- ) command-quot call-listener ; @@ -68,7 +67,8 @@ M: listener-operation invoke-command ( target command -- ) [ operation-hook call ] keep operation-quot call-listener ; : eval-listener ( string -- ) - get-listener + get-workspace + workspace-listener listener-gadget-input [ set-editor-string ] keep evaluate-input ; @@ -96,7 +96,9 @@ M: listener-operation invoke-command ( target command -- ) [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ; : insert-word ( word -- ) - get-listener [ word-completion-string ] keep + get-workspace + workspace-listener + [ word-completion-string ] keep listener-gadget-input user-input ; : quot-action ( interactor -- lines ) diff --git a/extra/ui/tools/tools-docs.factor b/extra/ui/tools/tools-docs.factor index 0d68be1730..57ad16bf70 100755 --- a/extra/ui/tools/tools-docs.factor +++ b/extra/ui/tools/tools-docs.factor @@ -111,7 +111,7 @@ ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts" { $command-map workspace "scrolling" } { $command-map workspace "workflow" } { $heading "Implementation" } -"Workspaces are instances of " { $link workspace-window } "." ; +"Workspaces are instances of " { $link workspace } "." ; ARTICLE: "ui-tools" "UI development tools" "The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.." diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index b3b24cf749..062bcf9416 100755 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -82,7 +82,7 @@ workspace "workflow" f { } define-command-map [ - "Factor workspace" open-status-window + dup "Factor workspace" open-status-window ] workspace-window-hook set-global : inspect-continuation ( traceback -- ) diff --git a/extra/ui/tools/workspace/workspace.factor b/extra/ui/tools/workspace/workspace.factor index de21bf3187..d79fa92f54 100755 --- a/extra/ui/tools/workspace/workspace.factor +++ b/extra/ui/tools/workspace/workspace.factor @@ -14,9 +14,12 @@ TUPLE: workspace book listener popup ; SYMBOL: workspace-window-hook -: workspace-window ( -- workspace ) +: workspace-window* ( -- workspace ) workspace-window-hook get call ; +: workspace-window ( -- ) + workspace-window* drop ; + GENERIC: call-tool* ( arg tool -- ) GENERIC: tool-scroller ( tool -- scroller ) @@ -33,9 +36,9 @@ M: gadget tool-scroller drop f ; : select-tool ( workspace class -- ) swap show-tool drop ; : get-workspace* ( quot -- workspace ) - [ dup workspace? [ over call ] [ drop f ] if ] find-window - [ nip dup raise-window gadget-child ] - [ workspace-window get-workspace* ] if* ; inline + [ >r dup workspace? r> [ drop f ] if ] curry find-window + [ dup raise-window gadget-child ] + [ workspace-window* ] if* ; inline : get-workspace ( -- workspace ) [ drop t ] get-workspace* ; From fea927b343291554eacdcaff3bb8a96620bc3560 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 1 Mar 2008 01:57:34 -0600 Subject: [PATCH 042/140] Fix R/W locks --- extra/concurrency/locks/locks-docs.factor | 2 +- extra/concurrency/locks/locks-tests.factor | 35 ++++++++++++++++++++++ extra/concurrency/locks/locks.factor | 35 ++++++++++++++++------ 3 files changed, 62 insertions(+), 10 deletions(-) diff --git a/extra/concurrency/locks/locks-docs.factor b/extra/concurrency/locks/locks-docs.factor index 86db5914c9..3a89af5ba0 100755 --- a/extra/concurrency/locks/locks-docs.factor +++ b/extra/concurrency/locks/locks-docs.factor @@ -46,7 +46,7 @@ $nl $nl "Read/write locks allow any number of threads to hold the read lock simulateneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks." $nl -"Read/write locks are reentrant. A thread holding a read lock may acquire a write lock recursively, and a thread holding a write lock may acquire a write lock or a read lock recursively, however a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held." +"Read/write locks are reentrant. A thread holding a write lock may acquire a read lock or a write lock without blocking. However a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held." { $subsection rw-lock } { $subsection } { $subsection with-read-lock } diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor index 92f1a9f103..806fad6c32 100755 --- a/extra/concurrency/locks/locks-tests.factor +++ b/extra/concurrency/locks/locks-tests.factor @@ -176,3 +176,38 @@ threads sequences calendar ; [ lock-timeout-test ] [ linked-error-thread thread-name "Lock timeout-er" = ] must-fail-with + +:: read/write-test ( -- ) + [let | l [ ] | + [ + l [ 1 seconds sleep ] with-lock + ] "Lock holder" spawn drop + + [ + l 1/10 seconds [ ] with-lock-timeout + ] "Lock timeout-er" spawn-linked drop + + receive + ] ; + +[ + dup [ + 1 seconds [ ] with-write-lock-timeout + ] with-read-lock +] must-fail + +[ + dup [ + dup [ + 1 seconds [ ] with-write-lock-timeout + ] with-read-lock + ] with-write-lock +] must-fail + +[ ] [ + dup [ + dup [ + 1 seconds [ ] with-read-lock-timeout + ] with-read-lock + ] with-write-lock +] unit-test diff --git a/extra/concurrency/locks/locks.factor b/extra/concurrency/locks/locks.factor index ea442612b1..43f22c00da 100755 --- a/extra/concurrency/locks/locks.factor +++ b/extra/concurrency/locks/locks.factor @@ -55,17 +55,23 @@ TUPLE: rw-lock readers writers reader# writer ; r rw-lock-readers r> "read lock" wait ] when drop - dup rw-lock-reader# 1+ swap set-rw-lock-reader# ; + add-reader ; : notify-writer ( lock -- ) rw-lock-writers notify-1 ; +: remove-reader ( lock -- ) + dup rw-lock-reader# 1- swap set-rw-lock-reader# ; + : release-read-lock ( lock -- ) - dup rw-lock-reader# 1- dup pick set-rw-lock-reader# - zero? [ notify-writer ] [ drop ] if ; + dup remove-reader + dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ; : acquire-write-lock ( lock timeout -- ) over rw-lock-writer pick rw-lock-reader# 0 > or @@ -77,23 +83,34 @@ TUPLE: rw-lock readers writers reader# writer ; dup rw-lock-readers dlist-empty? [ notify-writer ] [ rw-lock-readers notify-all ] if ; -: do-reentrant-rw-lock ( lock timeout quot quot' -- ) - >r pick rw-lock-writer self eq? [ 2nip call ] r> if ; inline +: reentrant-read-lock-ok? ( lock -- ? ) + #! If we already have a write lock, then we can grab a read + #! lock too. + rw-lock-writer self eq? ; + +: reentrant-write-lock-ok? ( lock -- ? ) + #! The only case where we have a writer and > 1 reader is + #! write -> read re-entrancy, and in this case we prohibit + #! a further write -> read -> write re-entrancy. + dup rw-lock-writer self eq? + swap rw-lock-reader# zero? and ; PRIVATE> : with-read-lock-timeout ( lock timeout quot -- ) - [ + pick reentrant-read-lock-ok? [ + [ drop add-reader ] [ remove-reader ] do-lock + ] [ [ acquire-read-lock ] [ release-read-lock ] do-lock - ] do-reentrant-rw-lock ; inline + ] if ; inline : with-read-lock ( lock quot -- ) f swap with-read-lock-timeout ; inline : with-write-lock-timeout ( lock timeout quot -- ) - [ + pick reentrant-write-lock-ok? [ 2nip call ] [ [ acquire-write-lock ] [ release-write-lock ] do-lock - ] do-reentrant-rw-lock ; inline + ] if ; inline : with-write-lock ( lock quot -- ) f swap with-write-lock-timeout ; inline From c5f5e0a61a9a33d5bbd8a0191d7c8c4405073dfb Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 1 Mar 2008 02:58:29 -0600 Subject: [PATCH 043/140] io.files: rename the *-to words to *-into --- core/io/files/files-docs.factor | 28 ++++++++++++++-------------- core/io/files/files.factor | 22 +++++++++++----------- 2 files changed, 25 insertions(+), 25 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index b8cf747106..9dc178ee57 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -57,8 +57,8 @@ ARTICLE: "delete-move-copy" "Deleting, moving, copying files" "The operations for moving and copying files come in three flavors:" { $list { "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." } - { "A word named " { $snippet { $emphasis "operation" } "-to" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." } - { "A word named " { $snippet { $emphasis "operation" } "s-to" } " which takes a sequence of source paths and destination directory." } + { "A word named " { $snippet { $emphasis "operation" } "-into" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." } + { "A word named " { $snippet { $emphasis "operation" } "s-into" } " which takes a sequence of source paths and destination directory." } } "Since both of the above lists apply to copying files, that this means that there are a total of six variations on copying a file." $nl @@ -68,16 +68,16 @@ $nl { $subsection delete-tree } "Moving files:" { $subsection move-file } -{ $subsection move-file-to } -{ $subsection move-files-to } +{ $subsection move-file-into } +{ $subsection move-files-into } "Copying files:" { $subsection copy-file } -{ $subsection copy-file-to } -{ $subsection copy-files-to } +{ $subsection copy-file-into } +{ $subsection copy-files-into } "Copying directory trees recursively:" { $subsection copy-tree } -{ $subsection copy-tree-to } -{ $subsection copy-trees-to } +{ $subsection copy-tree-into } +{ $subsection copy-trees-into } "On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ; ARTICLE: "io.files" "Basic file operations" @@ -267,12 +267,12 @@ HELP: move-file { $description "Moves or renames a file." } { $errors "Throws an error if the file does not exist or if the move operation fails." } ; -HELP: move-file-to +HELP: move-file-into { $values { "from" "a pathname string" } { "to" "a directory pathname string" } } { $description "Moves a file to another directory without renaming it." } { $errors "Throws an error if the file does not exist or if the move operation fails." } ; -HELP: move-files-to +HELP: move-files-into { $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } { $description "Moves a set of files to another directory." } { $errors "Throws an error if the file does not exist or if the move operation fails." } ; @@ -283,12 +283,12 @@ HELP: copy-file { $notes "This operation attempts to preserve the original file's attributes, however not all attributes may be preserved." } { $errors "Throws an error if the file does not exist or if the copy operation fails." } ; -HELP: copy-file-to +HELP: copy-file-into { $values { "from" "a pathname string" } { "to" "a directory pathname string" } } { $description "Copies a file to another directory." } { $errors "Throws an error if the file does not exist or if the copy operation fails." } ; -HELP: copy-files-to +HELP: copy-files-into { $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } { $description "Copies a set of files to another directory." } { $errors "Throws an error if the file does not exist or if the copy operation fails." } ; @@ -299,12 +299,12 @@ HELP: copy-tree { $notes "This operation attempts to preserve original file attributes, however not all attributes may be preserved." } { $errors "Throws an error if the copy operation fails." } ; -HELP: copy-tree-to +HELP: copy-tree-into { $values { "from" "a pathname string" } { "to" "a directory pathname string" } } { $description "Copies a directory tree to another directory, recursively." } { $errors "Throws an error if the copy operation fails." } ; -HELP: copy-trees-to +HELP: copy-trees-into { $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } { $description "Copies a set of directory trees to another directory, recursively." } { $errors "Throws an error if the copy operation fails." } ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 28f23b0de5..b51d767069 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -137,37 +137,37 @@ HOOK: delete-directory io-backend ( path -- ) ! Moving and renaming files HOOK: move-file io-backend ( from to -- ) -: move-file-to ( from to -- ) +: move-file-into ( from to -- ) to-directory move-file ; -: move-files-to ( files to -- ) - [ move-file-to ] curry each ; +: move-files-into ( files to -- ) + [ move-file-into ] curry each ; ! Copying files HOOK: copy-file io-backend ( from to -- ) -: copy-file-to ( from to -- ) +: copy-file-into ( from to -- ) to-directory copy-file ; -: copy-files-to ( files to -- ) - [ copy-file-to ] curry each ; +: copy-files-into ( files to -- ) + [ copy-file-into ] curry each ; -DEFER: copy-tree-to +DEFER: copy-tree-into : copy-tree ( from to -- ) over directory? [ >r dup directory swap r> [ - >r swap first path+ r> copy-tree-to + >r swap first path+ r> copy-tree-into ] 2curry each ] [ copy-file ] if ; -: copy-tree-to ( from to -- ) +: copy-tree-into ( from to -- ) to-directory copy-tree ; -: copy-trees-to ( files to -- ) - [ copy-tree-to ] curry each ; +: copy-trees-into ( files to -- ) + [ copy-tree-into ] curry each ; ! Special paths : resource-path ( path -- newpath ) From b1a9ba88068f68434d0a210f8872618c05fbe341 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 1 Mar 2008 03:01:51 -0600 Subject: [PATCH 044/140] builder.release: refactor and cleanup --- extra/builder/release/release.factor | 95 +++++++++++----------------- 1 file changed, 37 insertions(+), 58 deletions(-) diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index c65241d922..849d1a54a3 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -1,12 +1,17 @@ -USING: kernel namespaces sequences combinators io.files io.launcher +USING: kernel system namespaces sequences splitting combinators + io.files io.launcher bake combinators.cleave builder.common builder.util ; IN: builder.release ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: releases ( -- path ) builds "/releases" append dup make-directory ; +: releases ( -- path ) + builds "releases" path+ + dup exists? not + [ dup make-directory ] + when ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -34,8 +39,6 @@ IN: builder.release ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -USING: system sequences splitting ; - : cpu- ( -- cpu ) cpu "." split "-" join ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -57,70 +60,46 @@ USING: system sequences splitting ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: move-file ( source destination -- ) - swap { "mv" , , } bake run-process drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: linux-release ( -- ) - - "factor" cd - - { "rm" "-rf" "Factor.app" } run-process drop - - { "rm" "-rf" common-files } to-strings run-process drop - - ".." cd - - { "tar" "-cvzf" archive-name "factor" } to-strings run-process drop - - archive-name releases move-file ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: windows-release ( -- ) - - "factor" cd - - { "rm" "-rf" "Factor.app" } run-process drop - - { "rm" "-rf" common-files } to-strings run-process drop - - ".." cd - - { "zip" "-r" archive-name "factor" } to-strings run-process drop - - archive-name releases move-file ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: macosx-release ( -- ) - - "factor" cd - - { "rm" "-rf" common-files } to-strings run-process drop - - ".." cd +: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ; +: macosx-archive-cmd ( -- cmd ) { "hdiutil" "create" "-srcfolder" "factor" "-fs" "HFS+" "-volname" "factor" - archive-name } - to-strings run-process drop + archive-name } ; - archive-name releases move-file ; +: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: archive-cmd ( -- cmd ) + { + { [ windows? ] [ windows-archive-cmd ] } + { [ macosx? ] [ macosx-archive-cmd ] } + { [ unix? ] [ unix-archive-cmd ] } + } + cond ; + +: make-archive ( -- ) archive-cmd to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: remove-common-files ( -- ) + { "rm" "-rf" common-files } to-strings try-process ; + +: remove-factor-app ( -- ) + macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ; + : release ( -- ) - os - { - { "linux" [ linux-release ] } - { "winnt" [ windows-release ] } - { "macosx" [ macosx-release ] } - } - case ; + "factor" + [ + remove-factor-app + remove-common-files + ] + with-directory + make-archive + archive-name releases move-file-into ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From c3fd171547dfc70edde49072d811f7a61ba53037 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 1 Mar 2008 04:14:37 -0600 Subject: [PATCH 045/140] bootstrap.image.upload: destination is configurable fix cwd dependency --- extra/bootstrap/image/upload/upload.factor | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 1fa8ee4f41..110547d963 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -4,7 +4,12 @@ IN: bootstrap.image.upload USING: http.client crypto.md5 splitting assocs kernel io.files bootstrap.image sequences io namespaces io.launcher math ; -: destination "slava@factorcode.org:www/images/latest/" ; +SYMBOL: upload-images-destination + +: destination ( -- dest ) + upload-images-destination get + "slava@/var/www/factorcode.org/w/images/latest/" + or ; : checksums "checksums.txt" temp-file ; @@ -23,6 +28,8 @@ bootstrap.image sequences io namespaces io.launcher math ; ] { } make try-process ; : new-images ( -- ) - make-images compute-checksums upload-images ; + "" resource-path + [ make-images compute-checksums upload-images ] + with-directory ; MAIN: new-images From 29ef99663939d7b661ce04f48d2fcc22a9f67019 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 1 Mar 2008 07:11:44 -0600 Subject: [PATCH 046/140] Move time related items from unix to unix.time --- extra/calendar/unix/unix.factor | 4 +++- extra/io/unix/files/files.factor | 4 ++-- extra/unix/time/time.factor | 32 ++++++++++++++++++++++++++++++++ extra/unix/unix.factor | 26 -------------------------- 4 files changed, 37 insertions(+), 29 deletions(-) create mode 100644 extra/unix/time/time.factor diff --git a/extra/calendar/unix/unix.factor b/extra/calendar/unix/unix.factor index 4e1833af06..30e22c487b 100644 --- a/extra/calendar/unix/unix.factor +++ b/extra/calendar/unix/unix.factor @@ -1,5 +1,7 @@ + USING: alien alien.c-types arrays calendar.backend -kernel structs math unix namespaces ; + kernel structs math unix.time namespaces ; + IN: calendar.unix TUPLE: unix-calendar ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index a5a4e64c03..db3cf674c7 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io - unix unix.stat kernel math continuations math.bitfields byte-arrays - alien combinators combinators.cleave calendar ; + unix unix.stat unix.time kernel math continuations math.bitfields + byte-arrays alien combinators combinators.cleave calendar ; IN: io.unix.files diff --git a/extra/unix/time/time.factor b/extra/unix/time/time.factor new file mode 100644 index 0000000000..460631d9ea --- /dev/null +++ b/extra/unix/time/time.factor @@ -0,0 +1,32 @@ + +USING: kernel alien.syntax alien.c-types math ; + +IN: unix.time + +TYPEDEF: uint time_t + +C-STRUCT: tm + { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?) + { "int" "min" } ! Minutes: 0-59 + { "int" "hour" } ! Hours since midnight: 0-23 + { "int" "mday" } ! Day of the month: 1-31 + { "int" "mon" } ! Months *since* january: 0-11 + { "int" "year" } ! Years since 1900 + { "int" "wday" } ! Days since Sunday (0-6) + { "int" "yday" } ! Days since Jan. 1: 0-365 + { "int" "isdst" } ! +1 Daylight Savings Time, 0 No DST, + { "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?) + { "char*" "zone" } ; + +C-STRUCT: timespec + { "time_t" "sec" } + { "long" "nsec" } ; + +: make-timespec ( ms -- timespec ) + 1000 /mod 1000000 * + "timespec" + [ set-timespec-nsec ] keep + [ set-timespec-sec ] keep ; + +FUNCTION: time_t time ( time_t* t ) ; +FUNCTION: tm* localtime ( time_t* clock ) ; \ No newline at end of file diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index f83120a96f..9cc8552f98 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -8,32 +8,8 @@ IN: unix TYPEDEF: uint in_addr_t TYPEDEF: uint socklen_t -TYPEDEF: uint time_t TYPEDEF: ulong size_t -C-STRUCT: tm - { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?) - { "int" "min" } ! Minutes: 0-59 - { "int" "hour" } ! Hours since midnight: 0-23 - { "int" "mday" } ! Day of the month: 1-31 - { "int" "mon" } ! Months *since* january: 0-11 - { "int" "year" } ! Years since 1900 - { "int" "wday" } ! Days since Sunday (0-6) - { "int" "yday" } ! Days since Jan. 1: 0-365 - { "int" "isdst" } ! +1 Daylight Savings Time, 0 No DST, - { "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?) - { "char*" "zone" } ; - -C-STRUCT: timespec - { "time_t" "sec" } - { "long" "nsec" } ; - -: make-timespec ( ms -- timespec ) - 1000 /mod 1000000 * - "timespec" - [ set-timespec-nsec ] keep - [ set-timespec-sec ] keep ; - : PROT_NONE 0 ; inline : PROT_READ 1 ; inline : PROT_WRITE 2 ; inline @@ -89,7 +65,6 @@ FUNCTION: ushort htons ( ushort n ) ; FUNCTION: int ioctl ( int fd, ulong request, char* argp ) ; FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ; FUNCTION: int listen ( int s, int backlog ) ; -FUNCTION: tm* localtime ( time_t* clock ) ; FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ; FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_t offset ) ; FUNCTION: int munmap ( void* addr, size_t len ) ; @@ -117,7 +92,6 @@ FUNCTION: int setuid ( uid_t uid ) ; FUNCTION: int socket ( int domain, int type, int protocol ) ; FUNCTION: char* strerror ( int errno ) ; FUNCTION: int system ( char* command ) ; -FUNCTION: time_t time ( time_t* t ) ; FUNCTION: int unlink ( char* path ) ; FUNCTION: int utimes ( char* path, timeval[2] times ) ; From e5c567c7395599d00ecb7bf63886823fbc81cf74 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 1 Mar 2008 07:13:22 -0600 Subject: [PATCH 047/140] builder: refactoring --- extra/builder/builder.factor | 94 ++++++++++++++++++------------------ 1 file changed, 46 insertions(+), 48 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 2b51f8603e..0d5f4292b7 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -39,29 +39,27 @@ IN: builder : record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ; -: make-clean ( -- desc ) { "make" "clean" } ; +: do-make-clean ( -- desc ) { "make" "clean" } try-process ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ; +! : target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ; : make-vm ( -- desc ) - { "make" target } to-strings >>arguments - "../compile-log" >>stdout - +stdout+ >>stderr + { "make" } >>arguments + "../compile-log" >>stdout + +stdout+ >>stderr >desc ; +: do-make-vm ( -- ) + make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : copy-image ( -- ) - "../../factor/" my-boot-image-name append - "../" my-boot-image-name append - copy-file - - "../../factor/" my-boot-image-name append - my-boot-image-name - copy-file ; + builds "factor" path+ my-boot-image-name path+ ".." copy-file-into + builds "factor" path+ my-boot-image-name path+ "." copy-file-into ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -77,6 +75,9 @@ IN: builder 20 minutes >>timeout >desc ; +: do-bootstrap ( -- ) + bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ; + : builder-test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } to-strings ; @@ -89,6 +90,9 @@ IN: builder 45 minutes >>timeout >desc ; +: do-builder-test ( -- ) + builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: build-status @@ -101,52 +105,46 @@ SYMBOL: build-status enter-build-dir - "report" [ + "report" + [ + "Build machine: " write host-name print + "CPU: " write cpu print + "OS: " write os print + "Build directory: " write cwd print nl - "Build machine: " write host-name print - "CPU: " write cpu print - "OS: " write os print - "Build directory: " write cwd print nl + git-clone [ "git clone failed" print ] run-or-bail - git-clone [ "git clone failed" print ] run-or-bail + "factor" + [ + record-git-id + do-make-clean + do-make-vm + copy-image + do-bootstrap + do-builder-test + ] + with-directory - "factor" cd + "test-log" delete-file - record-git-id + "Boot time: " write "boot-time" eval-file milli-seconds>time print + "Load time: " write "load-time" eval-file milli-seconds>time print + "Test time: " write "test-time" eval-file milli-seconds>time print nl - make-clean run-process drop + "Did not pass load-everything: " print "load-everything-vocabs" cat + "Did not pass test-all: " print "test-all-vocabs" cat - make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail + "Benchmarks: " print "benchmarks" eval-file benchmarks. - copy-image + nl - bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail + show-benchmark-deltas - builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail + "benchmarks" ".." copy-file-into - "../test-log" delete-file - - "Boot time: " write "../boot-time" eval-file milli-seconds>time print - "Load time: " write "../load-time" eval-file milli-seconds>time print - "Test time: " write "../test-time" eval-file milli-seconds>time print nl - - "Did not pass load-everything: " print "../load-everything-vocabs" cat - "Did not pass test-all: " print "../test-all-vocabs" cat - - "Benchmarks: " print - "../benchmarks" [ stdio get contents eval ] with-file-reader benchmarks. - - nl - - show-benchmark-deltas - - "../benchmarks" "../../benchmarks" copy-file - - ".." cd - - maybe-release - - ] with-file-writer + maybe-release + ] + with-file-writer build-status on ; From 7b8a3a7bf54c60b7e0e879b74a6a455dda7a490b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 1 Mar 2008 14:23:41 -0600 Subject: [PATCH 048/140] Change socket benchmark --- extra/benchmark/fib6/fib6.factor | 14 ++++++++ extra/benchmark/sockets/sockets.factor | 50 ++++++++++++++++++-------- 2 files changed, 50 insertions(+), 14 deletions(-) create mode 100755 extra/benchmark/fib6/fib6.factor diff --git a/extra/benchmark/fib6/fib6.factor b/extra/benchmark/fib6/fib6.factor new file mode 100755 index 0000000000..cc42028df6 --- /dev/null +++ b/extra/benchmark/fib6/fib6.factor @@ -0,0 +1,14 @@ +IN: benchmark.fib6 +USING: math kernel alien ; + +: fib + "int" { "int" } "cdecl" [ + dup 1 <= [ drop 1 ] [ + 1- dup fib swap 1- fib + + ] if + ] alien-callback + "int" { "int" } "cdecl" alien-indirect ; + +: fib-main 25 fib drop ; + +MAIN: fib-main diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 6b1908afb1..c739bb787c 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,32 +1,54 @@ -USING: io.sockets io.server io kernel math threads -debugger tools.time prettyprint concurrency.combinators ; +USING: io.sockets io kernel math threads +debugger tools.time prettyprint concurrency.count-downs +namespaces arrays continuations ; IN: benchmark.sockets +SYMBOL: counter + +: number-of-requests 1 ; + +: server-addr "127.0.0.1" 7777 ; + +: server-loop ( server -- ) + dup accept [ + [ + read1 CHAR: x = [ + "server" get dispose + ] [ + number-of-requests + [ read1 write1 flush ] times + counter get count-down + ] if + ] with-stream + ] curry "Client handler" spawn drop server-loop ; + : simple-server ( -- ) - 7777 local-server "benchmark.sockets" [ - read1 CHAR: x = [ - stop-server - ] [ - 20 [ read1 write1 flush ] times - ] if - ] with-server ; + [ + server-addr dup "server" set [ + server-loop + ] with-disposal + ] ignore-errors ; : simple-client ( -- ) - "localhost" 7777 [ + server-addr [ CHAR: b write1 flush - 20 [ CHAR: a dup write1 flush read1 assert= ] times + number-of-requests + [ CHAR: a dup write1 flush read1 assert= ] times + counter get count-down ] with-stream ; : stop-server ( -- ) - "localhost" 7777 [ + server-addr [ CHAR: x write1 ] with-stream ; : clients ( n -- ) dup pprint " clients: " write [ - [ simple-server ] in-thread + dup 2 * counter set + [ simple-server ] "Simple server" spawn drop yield yield - [ drop simple-client ] parallel-each + [ [ simple-client ] "Simple client" spawn drop ] times + counter get await stop-server yield yield ] time ; From 52d52fa314d955781046810b5f03310d494cbb45 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 1 Mar 2008 15:19:51 -0600 Subject: [PATCH 049/140] io.unix.kqueue: fix using --- extra/io/unix/kqueue/kqueue.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index 7b67a9d468..60e3754ec6 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel io.nonblocking io.unix.backend -sequences assocs unix unix.kqueue unix.process math namespaces +sequences assocs unix unix.time unix.kqueue unix.process math namespaces combinators threads vectors io.launcher io.unix.launcher ; IN: io.unix.kqueue From bec4691d6be394c588c75d90990f84bee9351fbc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 1 Mar 2008 15:52:34 -0600 Subject: [PATCH 050/140] Fix for word renamings --- core/io/files/files-tests.factor | 4 ++-- extra/tools/deploy/windows/windows.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 850a30380b..92cc548d89 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -101,7 +101,7 @@ USING: tools.test io.files io threads kernel continuations ; [ ] [ "copy-tree-test" temp-file - "copy-destination" temp-file copy-tree-to + "copy-destination" temp-file copy-tree-into ] unit-test [ "Foobar" ] [ @@ -109,7 +109,7 @@ USING: tools.test io.files io threads kernel continuations ; ] unit-test [ ] [ - "copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-to + "copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-into ] unit-test [ "Foobar" ] [ diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index fb9e0f815a..6a2ce448af 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -10,12 +10,12 @@ IN: tools.deploy.windows vm over copy-file ; : copy-fonts ( bundle-name -- ) - "fonts/" resource-path swap copy-tree-to ; + "fonts/" resource-path swap copy-tree-into ; : copy-dlls ( bundle-name -- ) { "freetype6.dll" "zlib1.dll" "factor.dll" } [ resource-path ] map - swap copy-files-to ; + swap copy-files-into ; : create-exe-dir ( vocab bundle-name -- vm ) dup copy-dlls From e98cd1fd593a4628eb0cd17a2a7838fd0274fee6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 1 Mar 2008 17:00:45 -0500 Subject: [PATCH 051/140] New convention for unit tests --- core/alien/alien-tests.factor | 2 +- core/alien/c-types/c-types-tests.factor | 2 +- core/alien/compiler/compiler-tests.factor | 2 +- core/alien/structs/structs-tests.factor | 2 +- core/arrays/arrays-tests.factor | 2 +- core/assocs/assocs-tests.factor | 2 +- core/bit-arrays/bit-arrays-tests.factor | 2 +- core/bit-vectors/bit-vectors-tests.factor | 2 +- core/bootstrap/image/image-tests.factor | 2 +- core/boxes/boxes-tests.factor | 2 +- core/byte-arrays/byte-arrays-tests.factor | 2 +- core/byte-vectors/byte-vectors-tests.factor | 2 +- core/classes/classes-tests.factor | 16 +-- core/combinators/combinators-tests.factor | 2 +- core/command-line/command-line-tests.factor | 2 +- core/compiler/tests/curry.factor | 2 +- core/compiler/tests/float.factor | 2 +- core/compiler/tests/intrinsics.factor | 2 +- core/compiler/tests/simple.factor | 2 +- core/compiler/tests/stack-trace.factor | 2 +- core/compiler/tests/templates-early.factor | 2 +- core/compiler/tests/templates.factor | 2 +- core/compiler/tests/tuples.factor | 2 +- core/continuations/continuations-tests.factor | 2 +- core/cpu/arm/assembler/assembler-tests.factor | 2 +- core/cpu/x86/assembler/assembler-tests.factor | 2 +- core/debugger/debugger-tests.factor | 2 +- core/definitions/definitions-tests.factor | 2 +- core/dlists/dlists-tests.factor | 2 +- core/effects/effects-tests.factor | 2 +- core/float-arrays/float-arrays-tests.factor | 2 +- core/float-vectors/float-vectors-tests.factor | 2 +- core/generic/generic-tests.factor | 12 +- core/growable/growable-tests.factor | 2 +- core/hashtables/hashtables-tests.factor | 2 +- core/heaps/heaps-tests.factor | 2 +- core/inference/class/class-tests.factor | 2 +- core/inference/inference-tests.factor | 2 +- core/inference/state/state-tests.factor | 2 +- .../transforms/transforms-tests.factor | 2 +- core/init/init-tests.factor | 2 +- core/inspector/inspector-tests.factor | 2 +- core/io/backend/backend-tests.factor | 2 +- core/io/binary/binary-tests.factor | 2 +- core/io/files/files-tests.factor | 2 +- core/io/io-tests.factor | 4 +- core/io/streams/c/c-tests.factor | 2 +- core/io/streams/duplex/duplex-tests.factor | 2 +- core/io/streams/lines/lines-tests.factor | 2 +- core/io/streams/nested/nested-tests.factor | 2 +- core/io/streams/string/string-tests.factor | 2 +- core/io/test/no-trailing-eol.factor | 2 +- core/kernel/kernel-tests.factor | 2 +- core/listener/listener-tests.factor | 4 +- core/math/bitfields/bitfields-tests.factor | 2 +- core/math/floats/floats-tests.factor | 2 +- core/math/integers/integers-tests.factor | 2 +- core/math/intervals/intervals-tests.factor | 2 +- core/math/math-tests.factor | 2 +- core/math/parser/parser-tests.factor | 2 +- core/memory/memory-tests.factor | 2 +- core/mirrors/mirrors-tests.factor | 2 +- core/namespaces/namespaces-tests.factor | 2 +- core/optimizer/control/control-tests.factor | 2 +- core/optimizer/def-use/def-use-tests.factor | 2 +- core/optimizer/optimizer-tests.factor | 2 +- core/parser/parser-tests.factor | 112 +++++++++--------- core/prettyprint/prettyprint-tests.factor | 34 +++--- core/quotations/quotations-tests.factor | 2 +- core/sbufs/sbufs-tests.factor | 2 +- core/sequences/sequences-tests.factor | 2 +- core/sorting/sorting-tests.factor | 2 +- core/splitting/splitting-tests.factor | 2 +- core/strings/strings-tests.factor | 2 +- core/system/system-tests.factor | 2 +- core/threads/threads-tests.factor | 2 +- core/tuples/tuples-tests.factor | 22 ++-- core/vectors/vectors-tests.factor | 2 +- core/vocabs/loader/loader-tests.factor | 4 +- core/vocabs/vocabs-tests.factor | 2 +- core/words/words-tests.factor | 52 ++++---- extra/ascii/ascii-tests.factor | 2 +- .../reverse-complement-tests.factor | 2 +- extra/calendar/format/format-tests.factor | 2 +- extra/channels/channels-tests.factor | 2 +- extra/channels/remote/remote-tests.factor | 2 +- extra/cocoa/cocoa-tests.factor | 2 +- extra/combinators/lib/lib-tests.factor | 2 +- .../combinators/combinators-tests.factor | 2 +- .../count-downs/count-downs-tests.factor | 2 +- .../exchangers/exchangers-tests.factor | 2 +- extra/concurrency/flags/flags-tests.factor | 2 +- .../concurrency/futures/futures-tests.factor | 2 +- extra/concurrency/locks/locks-tests.factor | 2 +- .../mailboxes/mailboxes-tests.factor | 2 +- .../messaging/messaging-tests.factor | 2 +- .../promises/promises-tests.factor | 2 +- extra/coroutines/coroutines-tests.factor | 2 +- extra/crypto/hmac/hmac-tests.factor | 2 +- extra/crypto/timing/timing-tests.factor | 2 +- extra/crypto/xor/xor-tests.factor | 2 +- extra/db/postgresql/postgresql-tests.factor | 4 +- extra/db/sqlite/sqlite-tests.factor | 2 +- extra/db/tuples/tuples-tests.factor | 2 +- extra/delegate/delegate-tests.factor | 2 +- extra/destructors/destructors-tests.factor | 2 +- extra/documents/documents-tests.factor | 2 +- extra/farkup/farkup-tests.factor | 2 +- extra/fjsc/fjsc-tests.factor | 2 +- extra/fry/fry-tests.factor | 2 +- extra/furnace/furnace-tests.factor | 2 +- .../furnace/validator/validator-tests.factor | 2 +- extra/globs/globs-tests.factor | 2 +- extra/help/crossref/crossref-tests.factor | 12 +- .../help/definitions/definitions-tests.factor | 16 +-- extra/help/markup/markup-tests.factor | 2 +- extra/help/syntax/syntax-tests.factor | 14 +-- extra/help/topics/topics-tests.factor | 2 +- extra/hexdump/hexdump-tests.factor | 2 +- extra/html/elements/elements-tests.factor | 2 +- extra/html/html-tests.factor | 2 +- extra/html/parser/parser-tests.factor | 2 +- extra/html/parser/utils/utils-tests.factor | 2 +- extra/http/http-tests.factor | 2 +- extra/http/server/server-tests.factor | 2 +- .../server/templating/templating-tests.factor | 2 +- extra/io/buffers/buffers-tests.factor | 2 +- extra/io/launcher/launcher-tests.factor | 2 +- extra/io/mmap/mmap-tests.factor | 2 +- extra/io/server/server-tests.factor | 2 +- extra/io/sockets/impl/impl-tests.factor | 2 +- extra/io/unix/files/files-tests.factor | 2 +- extra/io/unix/launcher/launcher-tests.factor | 2 +- extra/io/unix/unix-tests.factor | 2 +- extra/io/windows/nt/nt-tests.factor | 2 +- extra/jamshred/tunnel/tunnel-tests.factor | 2 +- extra/koszul/koszul-tests.factor | 2 +- .../lazy-lists/examples/examples-tests.factor | 2 +- extra/lazy-lists/lazy-lists-tests.factor | 2 +- extra/levenshtein/levenshtein-tests.factor | 2 +- extra/lint/lint-tests.factor | 2 +- extra/locals/locals-tests.factor | 2 +- extra/macros/macros-tests.factor | 2 +- extra/match/match-tests.factor | 2 +- extra/math/analysis/analysis-tests.factor | 2 +- .../combinatorics/combinatorics-tests.factor | 2 +- extra/math/complex/complex-tests.factor | 2 +- extra/math/erato/erato-tests.factor | 2 +- extra/math/functions/functions-tests.factor | 2 +- .../elimination/elimination-tests.factor | 2 +- extra/math/matrices/matrices-tests.factor | 2 +- .../miller-rabin/miller-rabin-tests.factor | 2 +- .../numerical-integration-tests.factor | 2 +- .../math/polynomials/polynomials-tests.factor | 2 +- .../math/quaternions/quaternions-tests.factor | 2 +- extra/math/ranges/ranges-tests.factor | 2 +- extra/math/ratios/ratios-tests.factor | 2 +- extra/math/statistics/statistics-tests.factor | 2 +- extra/math/text/english/english-tests.factor | 2 +- extra/math/vectors/vectors-tests.factor | 2 +- extra/models/models-tests.factor | 2 +- extra/money/money-tests.factor | 2 +- .../multi-methods/multi-methods-tests.factor | 2 +- .../parser-combinators-tests.factor | 2 +- .../partial-continuations-tests.factor | 2 +- extra/peg/ebnf/ebnf-tests.factor | 2 +- extra/peg/peg-tests.factor | 2 +- extra/peg/pl0/pl0-tests.factor | 2 +- extra/peg/search/search-tests.factor | 2 +- .../porter-stemmer-tests.factor | 2 +- extra/random/random-tests.factor | 2 +- extra/sequences/lib/lib-tests.factor | 2 +- extra/serialize/serialize-tests.factor | 2 +- extra/smtp/smtp-tests.factor | 2 +- extra/taxes/taxes-tests.factor | 2 +- .../annotations/annotations-tests.factor | 4 +- extra/tools/browser/browser-tests.factor | 2 +- extra/tools/crossref/crossref-tests.factor | 2 +- extra/tools/deploy/deploy-tests.factor | 2 +- extra/tools/memory/memory-tests.factor | 2 +- extra/tools/profiler/profiler-tests.factor | 2 +- extra/tools/test/test-docs.factor | 2 +- extra/tools/test/test.factor | 9 +- extra/tools/test/tools.factor | 2 +- extra/tools/walker/walker-tests.factor | 2 +- extra/trees/avl/avl-tests.factor | 2 +- extra/trees/splay/splay-tests.factor | 2 +- extra/trees/trees-tests.factor | 2 +- extra/tuple-syntax/tuple-syntax-tests.factor | 2 +- extra/tuples/lib/lib-tests.factor | 2 +- extra/ui/commands/commands-tests.factor | 2 +- extra/ui/gadgets/books/books-tests.factor | 2 +- extra/ui/gadgets/buttons/buttons-tests.factor | 2 +- extra/ui/gadgets/frames/frames-tests.factor | 2 +- extra/ui/gadgets/gadgets-tests.factor | 2 +- extra/ui/gadgets/grids/grids-tests.factor | 2 +- .../ui/gadgets/labelled/labelled-tests.factor | 2 +- extra/ui/gadgets/lists/lists-tests.factor | 2 +- extra/ui/gadgets/packs/packs-tests.factor | 2 +- extra/ui/gadgets/panes/panes-tests.factor | 2 +- .../presentations/presentations-tests.factor | 2 +- .../gadgets/scrollers/scrollers-tests.factor | 2 +- extra/ui/gadgets/slots/slots-tests.factor | 2 +- extra/ui/gadgets/tracks/tracks-tests.factor | 2 +- extra/ui/gadgets/worlds/worlds-tests.factor | 2 +- extra/ui/operations/operations-tests.factor | 2 +- extra/ui/tools/browser/browser-tests.factor | 2 +- .../tools/interactor/interactor-tests.factor | 2 +- extra/ui/tools/listener/listener-tests.factor | 2 +- extra/ui/tools/search/search-tests.factor | 2 +- extra/ui/tools/tools-tests.factor | 2 +- extra/ui/tools/walker/walker-tests.factor | 2 +- .../ui/tools/workspace/workspace-tests.factor | 2 +- extra/ui/traverse/traverse-tests.factor | 2 +- extra/units/imperial/imperial-tests.factor | 2 +- extra/units/si/si-tests.factor | 2 +- extra/units/units-tests.factor | 2 +- extra/xml/tests/arithmetic.factor | 2 +- extra/xml/tests/soap.factor | 2 +- extra/xml/tests/templating.factor | 1 + extra/xml/tests/test.factor | 2 +- extra/xmode/catalog/catalog-tests.factor | 2 +- .../keyword-map/keyword-map-tests.factor | 2 +- extra/xmode/marker/marker-tests.factor | 2 +- extra/xmode/rules/rules-tests.factor | 2 +- extra/xmode/utilities/utilities-tests.factor | 2 +- 226 files changed, 367 insertions(+), 373 deletions(-) diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index 74c94c8edf..72feca27cd 100755 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: alien.tests USING: alien alien.accessors byte-arrays arrays kernel kernel.private namespaces tools.test sequences libc math system prettyprint ; diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor index 719068e031..843b0a826b 100755 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: alien.c-types.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc ; diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index 876310cc5d..7e2e23726b 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: alien.compiler.tests USING: alien alien.c-types alien.syntax compiler kernel namespaces namespaces tools.test sequences inference words arrays parser quotations continuations inference.backend effects diff --git a/core/alien/structs/structs-tests.factor b/core/alien/structs/structs-tests.factor index b934cd56a3..a33a86d4b5 100644 --- a/core/alien/structs/structs-tests.factor +++ b/core/alien/structs/structs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: alien.structs.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc words vocabs namespaces ; diff --git a/core/arrays/arrays-tests.factor b/core/arrays/arrays-tests.factor index e07f192197..a7801c7d74 100755 --- a/core/arrays/arrays-tests.factor +++ b/core/arrays/arrays-tests.factor @@ -1,6 +1,6 @@ USING: arrays kernel sequences sequences.private growable tools.test vectors layouts system math vectors.private ; -IN: temporary +IN: arrays.tests [ -2 { "a" "b" "c" } nth ] must-fail [ 10 { "a" "b" "c" } nth ] must-fail diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index 8fabee06ef..a0a60e875a 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: assocs.tests USING: kernel math namespaces tools.test vectors sequences sequences.private hashtables io prettyprint assocs continuations ; diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index 5f89b90608..5774b86e45 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -1,6 +1,6 @@ USING: sequences arrays bit-arrays kernel tools.test math random ; -IN: temporary +IN: bit-arrays.tests [ 100 ] [ 100 length ] unit-test diff --git a/core/bit-vectors/bit-vectors-tests.factor b/core/bit-vectors/bit-vectors-tests.factor index 5838c1eb8d..dff9a8db37 100755 --- a/core/bit-vectors/bit-vectors-tests.factor +++ b/core/bit-vectors/bit-vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: bit-vectors.tests USING: tools.test bit-vectors vectors sequences kernel math ; [ 0 ] [ 123 length ] unit-test diff --git a/core/bootstrap/image/image-tests.factor b/core/bootstrap/image/image-tests.factor index 8c618a8f30..ae5c66a45c 100755 --- a/core/bootstrap/image/image-tests.factor +++ b/core/bootstrap/image/image-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: bootstrap.image.tests USING: bootstrap.image bootstrap.image.private tools.test ; \ ' must-infer diff --git a/core/boxes/boxes-tests.factor b/core/boxes/boxes-tests.factor index 66ee5247ec..76a6cfd8b1 100755 --- a/core/boxes/boxes-tests.factor +++ b/core/boxes/boxes-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: boxes.tests USING: boxes namespaces tools.test ; [ ] [ "b" set ] unit-test diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor index b5b01c201b..07b82f6111 100755 --- a/core/byte-arrays/byte-arrays-tests.factor +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: byte-arrays.tests USING: tools.test byte-arrays ; [ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test diff --git a/core/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor index 2d9ca1f205..d457d6805e 100755 --- a/core/byte-vectors/byte-vectors-tests.factor +++ b/core/byte-vectors/byte-vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: byte-vectors.tests USING: tools.test byte-vectors vectors sequences kernel ; [ 0 ] [ 123 length ] unit-test diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 103c4eed09..38ca796384 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes io.streams.string classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units ; -IN: temporary +IN: classes.tests H{ } "s" set @@ -62,7 +62,7 @@ UNION: bah fixnum alien ; [ bah ] [ \ bah? "predicating" word-prop ] unit-test ! Test generic see and parsing -[ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ] +[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ] [ [ \ bah see ] with-string-writer ] unit-test ! Test redefinition of classes @@ -78,7 +78,7 @@ M: union-1 generic-update-test drop "union-1" ; [ union-1 ] [ fixnum float class-or ] unit-test -"IN: temporary USE: math USE: arrays UNION: union-1 rational array ;" eval +"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval [ t ] [ bignum union-1 class< ] unit-test [ f ] [ union-1 number class< ] unit-test @@ -86,7 +86,7 @@ M: union-1 generic-update-test drop "union-1" ; [ object ] [ fixnum float class-or ] unit-test -"IN: temporary USE: math PREDICATE: integer union-1 even? ;" eval +"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval [ f ] [ union-1 union-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test @@ -126,7 +126,7 @@ INSTANCE: integer mx1 [ t ] [ mx1 integer class< ] unit-test [ t ] [ mx1 number class< ] unit-test -"IN: temporary USE: arrays INSTANCE: array mx1" eval +"IN: classes.tests USE: arrays INSTANCE: array mx1" eval [ t ] [ array mx1 class< ] unit-test [ f ] [ mx1 number class< ] unit-test @@ -157,7 +157,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ; [ t ] [ quotation redefine-bug-2 class< ] unit-test [ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test -[ ] [ "IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test +[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test [ t ] [ bignum redefine-bug-1 class< ] unit-test [ f ] [ fixnum redefine-bug-2 class< ] unit-test @@ -185,7 +185,7 @@ DEFER: mixin-forget-test-g [ ] [ { "USING: sequences ;" - "IN: temporary" + "IN: classes.tests" "MIXIN: mixin-forget-test" "INSTANCE: sequence mixin-forget-test" "GENERIC: mixin-forget-test-g ( x -- y )" @@ -200,7 +200,7 @@ DEFER: mixin-forget-test-g [ ] [ { "USING: hashtables ;" - "IN: temporary" + "IN: classes.tests" "MIXIN: mixin-forget-test" "INSTANCE: hashtable mixin-forget-test" "GENERIC: mixin-forget-test-g ( x -- y )" diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index ce8e180867..8abc53e43f 100755 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: combinators.tests USING: alien strings kernel math tools.test io prettyprint namespaces combinators words ; diff --git a/core/command-line/command-line-tests.factor b/core/command-line/command-line-tests.factor index c4221b0d06..226765bafe 100644 --- a/core/command-line/command-line-tests.factor +++ b/core/command-line/command-line-tests.factor @@ -1,5 +1,5 @@ USING: namespaces tools.test kernel command-line ; -IN: temporary +IN: command-line.tests [ [ f ] [ "-no-user-init" cli-arg ] unit-test diff --git a/core/compiler/tests/curry.factor b/core/compiler/tests/curry.factor index 982b3cfb75..d2e7115f8f 100755 --- a/core/compiler/tests/curry.factor +++ b/core/compiler/tests/curry.factor @@ -1,6 +1,6 @@ USING: tools.test quotations math kernel sequences assocs namespaces compiler.units ; -IN: temporary +IN: compiler.tests [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test [ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test diff --git a/core/compiler/tests/float.factor b/core/compiler/tests/float.factor index 11470f7102..0d457a8310 100755 --- a/core/compiler/tests/float.factor +++ b/core/compiler/tests/float.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: compiler.tests USING: compiler.units kernel kernel.private memory math math.private tools.test math.floats.private ; diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index d1e6f7abf4..dd9a453cfc 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: compiler.tests USING: arrays compiler.units kernel kernel.private math math.constants math.private sequences strings tools.test words continuations sequences.private hashtables.private byte-arrays diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 7f23e28bec..13b7de6987 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -1,7 +1,7 @@ USING: compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings alien arrays memory ; -IN: temporary +IN: compiler.tests ! Test empty word [ ] [ [ ] compile-call ] unit-test diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor index 137d86b489..f54ac62204 100755 --- a/core/compiler/tests/stack-trace.factor +++ b/core/compiler/tests/stack-trace.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: compiler.tests USING: compiler tools.test namespaces sequences kernel.private kernel math continuations continuations.private words splitting sorting ; diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor index 13d834a489..bdbc985078 100755 --- a/core/compiler/tests/templates-early.factor +++ b/core/compiler/tests/templates-early.factor @@ -1,5 +1,5 @@ ! Testing templates machinery without compiling anything -IN: temporary +IN: compiler.tests USING: compiler generator generator.registers generator.registers.private tools.test namespaces sequences words kernel math effects definitions compiler.units ; diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor index 4be700f221..1c19730ec0 100755 --- a/core/compiler/tests/templates.factor +++ b/core/compiler/tests/templates.factor @@ -4,7 +4,7 @@ hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io combinators ; -IN: temporary +IN: compiler.tests ! Oops! [ 5000 ] [ [ 5000 ] compile-call ] unit-test diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor index 7acd599cb8..5843575eeb 100755 --- a/core/compiler/tests/tuples.factor +++ b/core/compiler/tests/tuples.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: compiler.tests USING: kernel tools.test compiler.units ; TUPLE: color red green blue ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index b7d580afe5..d5ede60086 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -1,7 +1,7 @@ USING: kernel math namespaces io tools.test sequences vectors continuations debugger parser memory arrays words kernel.private ; -IN: temporary +IN: continuations.tests : (callcc1-test) swap 1- tuck swap ?push diff --git a/core/cpu/arm/assembler/assembler-tests.factor b/core/cpu/arm/assembler/assembler-tests.factor index 219015fae9..a30ab9f797 100644 --- a/core/cpu/arm/assembler/assembler-tests.factor +++ b/core/cpu/arm/assembler/assembler-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: cpu.arm.assembler.tests USING: assembler-arm math test namespaces sequences kernel quotations ; diff --git a/core/cpu/x86/assembler/assembler-tests.factor b/core/cpu/x86/assembler/assembler-tests.factor index 256bc57578..caa00bd618 100644 --- a/core/cpu/x86/assembler/assembler-tests.factor +++ b/core/cpu/x86/assembler/assembler-tests.factor @@ -1,5 +1,5 @@ USING: cpu.x86.assembler kernel tools.test namespaces ; -IN: temporary +IN: cpu.x86.assembler.tests [ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test [ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test diff --git a/core/debugger/debugger-tests.factor b/core/debugger/debugger-tests.factor index 31c3e8a762..afa4aa1c28 100755 --- a/core/debugger/debugger-tests.factor +++ b/core/debugger/debugger-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: debugger.tests USING: debugger kernel continuations tools.test ; [ ] [ [ drop ] [ error. ] recover ] unit-test diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index f0b0888052..4e8fb255dd 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: definitions.tests USING: tools.test generic kernel definitions sequences compiler.units ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index 203c975bb2..cd651bff2f 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -1,7 +1,7 @@ USING: dlists dlists.private kernel tools.test random assocs hashtables sequences namespaces sorting debugger io prettyprint math ; -IN: temporary +IN: dlists.tests [ t ] [ dlist-empty? ] unit-test diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index 46037ba0d4..234f567f25 100644 --- a/core/effects/effects-tests.factor +++ b/core/effects/effects-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: effects.tests USING: effects tools.test ; [ t ] [ 1 1 2 2 effect<= ] unit-test diff --git a/core/float-arrays/float-arrays-tests.factor b/core/float-arrays/float-arrays-tests.factor index 0e0ab3feb6..0918eecd84 100755 --- a/core/float-arrays/float-arrays-tests.factor +++ b/core/float-arrays/float-arrays-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: float-arrays.tests USING: float-arrays tools.test ; [ F{ 1.0 1.0 1.0 } ] [ 3 1.0 ] unit-test diff --git a/core/float-vectors/float-vectors-tests.factor b/core/float-vectors/float-vectors-tests.factor index 68b8195eb7..383dd4bcf2 100755 --- a/core/float-vectors/float-vectors-tests.factor +++ b/core/float-vectors/float-vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: float-vectors.tests USING: tools.test float-vectors vectors sequences kernel ; [ 0 ] [ 123 length ] unit-test diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index e3fdbc7b46..2dc699f87b 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -3,7 +3,7 @@ generic.math assocs hashtables io kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes continuations layouts classes.union sorting compiler.units ; -IN: temporary +IN: generic.tests GENERIC: foobar ( x -- y ) M: object foobar drop "Hello world" ; @@ -87,11 +87,11 @@ M: number union-containment drop 2 ; [ 2 ] [ 1.0 union-containment ] unit-test ! Testing recovery from bad method definitions -"IN: temporary GENERIC: unhappy ( x -- x )" eval +"IN: generic.tests GENERIC: unhappy ( x -- x )" eval [ - "IN: temporary M: dictionary unhappy ;" eval + "IN: generic.tests M: dictionary unhappy ;" eval ] must-fail -[ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test +[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test GENERIC# complex-combination 1 ( a b -- c ) M: string complex-combination drop ; @@ -192,12 +192,12 @@ SYMBOL: redefinition-test-generic TUPLE: redefinition-test-tuple ; -"IN: temporary M: redefinition-test-tuple redefinition-test-generic ;" eval +"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval [ t ] [ [ redefinition-test-generic , - "IN: temporary TUPLE: redefinition-test-tuple ;" eval + "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval redefinition-test-generic , ] { } make all-equal? ] unit-test diff --git a/core/growable/growable-tests.factor b/core/growable/growable-tests.factor index a220ccc45e..7ba67fe97b 100755 --- a/core/growable/growable-tests.factor +++ b/core/growable/growable-tests.factor @@ -1,6 +1,6 @@ USING: math sequences classes growable tools.test kernel layouts ; -IN: temporary +IN: growable.tests ! erg found this one [ fixnum ] [ diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 31486372f2..a62b306378 100755 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: hashtables.tests USING: kernel math namespaces tools.test vectors sequences sequences.private hashtables io prettyprint assocs continuations ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index f199ba8837..61e09d894e 100755 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -3,7 +3,7 @@ USING: arrays kernel math namespaces tools.test heaps heaps.private math.parser random assocs sequences sorting ; -IN: temporary +IN: heaps.tests [ heap-pop ] must-fail [ heap-pop ] must-fail diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 10eae1eb99..df90ac2291 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: inference.class.tests USING: arrays math.private kernel math compiler inference inference.dataflow optimizer tools.test kernel.private generic sequences words inference.class quotations alien diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 1fe4b7ae1e..3c12e388c4 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -6,7 +6,7 @@ continuations generic.standard sorting assocs definitions prettyprint io inspector tuples classes.union classes.predicate debugger threads.private io.streams.string io.timeouts io.thread sequences.private ; -IN: temporary +IN: inference.tests { 0 2 } [ 2 "Hello" ] must-infer-as { 1 2 } [ dup ] must-infer-as diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor index 02a3c4fde0..84d72bdd9b 100644 --- a/core/inference/state/state-tests.factor +++ b/core/inference/state/state-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: inference.state.tests USING: tools.test inference.state words ; SYMBOL: a diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index 0e5c3e231e..88aac780c1 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: inference.transforms.tests USING: sequences inference.transforms tools.test math kernel quotations inference ; diff --git a/core/init/init-tests.factor b/core/init/init-tests.factor index aa7cd0ea58..ce68a1d7ab 100644 --- a/core/init/init-tests.factor +++ b/core/init/init-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: init.tests USING: init namespaces sequences math tools.test kernel ; [ t ] [ diff --git a/core/inspector/inspector-tests.factor b/core/inspector/inspector-tests.factor index fce0cc0c86..72c1a9a6bf 100644 --- a/core/inspector/inspector-tests.factor +++ b/core/inspector/inspector-tests.factor @@ -1,6 +1,6 @@ USING: kernel tools.test math namespaces prettyprint sequences inspector io.streams.string ; -IN: temporary +IN: inspector.tests [ 1 2 3 ] describe f describe diff --git a/core/io/backend/backend-tests.factor b/core/io/backend/backend-tests.factor index e295cc34dc..04f34068eb 100644 --- a/core/io/backend/backend-tests.factor +++ b/core/io/backend/backend-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.backend.tests USING: tools.test io.backend kernel ; [ ] [ "a" normalize-pathname drop ] unit-test diff --git a/core/io/binary/binary-tests.factor b/core/io/binary/binary-tests.factor index 69e733b55a..f6d103b0d1 100755 --- a/core/io/binary/binary-tests.factor +++ b/core/io/binary/binary-tests.factor @@ -1,5 +1,5 @@ USING: io.binary tools.test ; -IN: temporary +IN: io.binary.tests [ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test [ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 850a30380b..4903f86e4b 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.files.tests USING: tools.test io.files io threads kernel continuations ; [ "passwd" ] [ "/etc/passwd" file-name ] unit-test diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 23686abab5..e3c249ec5d 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,10 +1,10 @@ USING: arrays io io.files kernel math parser strings system tools.test words namespaces ; -IN: temporary +IN: io.tests [ f ] [ "resource:/core/io/test/no-trailing-eol.factor" run-file - "foo" "temporary" lookup + "foo" "io.tests" lookup ] unit-test : ( resource -- stream ) diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 16b78c2192..3da9f27646 100755 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -1,5 +1,5 @@ USING: tools.test io.files io io.streams.c ; -IN: temporary +IN: io.streams.c.tests [ "hello world" ] [ "test.txt" temp-file [ diff --git a/core/io/streams/duplex/duplex-tests.factor b/core/io/streams/duplex/duplex-tests.factor index 44542e05ce..65bad3de41 100755 --- a/core/io/streams/duplex/duplex-tests.factor +++ b/core/io/streams/duplex/duplex-tests.factor @@ -1,5 +1,5 @@ USING: io.streams.duplex io kernel continuations tools.test ; -IN: temporary +IN: io.streams.duplex.tests ! Test duplex stream close behavior TUPLE: closing-stream closed? ; diff --git a/core/io/streams/lines/lines-tests.factor b/core/io/streams/lines/lines-tests.factor index 64dc7bff3b..e8ecc65526 100755 --- a/core/io/streams/lines/lines-tests.factor +++ b/core/io/streams/lines/lines-tests.factor @@ -1,6 +1,6 @@ USING: io.streams.lines io.files io.streams.string io tools.test kernel ; -IN: temporary +IN: io.streams.lines.tests : ( resource -- stream ) resource-path ; diff --git a/core/io/streams/nested/nested-tests.factor b/core/io/streams/nested/nested-tests.factor index 7b26beb9c6..402cb19c3b 100644 --- a/core/io/streams/nested/nested-tests.factor +++ b/core/io/streams/nested/nested-tests.factor @@ -1,3 +1,3 @@ USING: io io.streams.string io.streams.nested kernel math namespaces io.styles tools.test ; -IN: temporary +IN: io.streams.nested.tests diff --git a/core/io/streams/string/string-tests.factor b/core/io/streams/string/string-tests.factor index 4bd31fe7d8..ca117534da 100644 --- a/core/io/streams/string/string-tests.factor +++ b/core/io/streams/string/string-tests.factor @@ -1,5 +1,5 @@ USING: io.streams.string io kernel arrays namespaces tools.test ; -IN: temporary +IN: io.streams.string.tests [ "line 1" CHAR: l ] [ diff --git a/core/io/test/no-trailing-eol.factor b/core/io/test/no-trailing-eol.factor index aa4d8b82d1..959f145bf5 100644 --- a/core/io/test/no-trailing-eol.factor +++ b/core/io/test/no-trailing-eol.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.tests USE: math : foo 2 2 + ; FORGET: foo \ No newline at end of file diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 2972cb2d5d..3c40984d7a 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -1,7 +1,7 @@ USING: arrays byte-arrays kernel kernel.private math memory namespaces sequences tools.test math.private quotations continuations prettyprint io.streams.string debugger assocs ; -IN: temporary +IN: kernel.tests [ 0 ] [ f size ] unit-test [ t ] [ [ \ = \ = ] all-equal? ] unit-test diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor index 4570b1162a..71ea6e66c6 100755 --- a/core/listener/listener-tests.factor +++ b/core/listener/listener-tests.factor @@ -1,7 +1,7 @@ USING: io io.streams.string io.streams.duplex listener tools.test parser math namespaces continuations vocabs kernel compiler.units ; -IN: temporary +IN: listener.tests : hello "Hi" print ; parsing @@ -45,6 +45,6 @@ IN: temporary ] unit-test [ ] [ - "IN: temporary : hello\n\"world\" ;" parse-interactive + "IN: listener.tests : hello\n\"world\" ;" parse-interactive drop ] unit-test diff --git a/core/math/bitfields/bitfields-tests.factor b/core/math/bitfields/bitfields-tests.factor index a10c0566f8..6dfc51f440 100755 --- a/core/math/bitfields/bitfields-tests.factor +++ b/core/math/bitfields/bitfields-tests.factor @@ -1,5 +1,5 @@ USING: math math.bitfields tools.test kernel words ; -IN: temporary +IN: math.bitfields.tests [ 0 ] [ { } bitfield ] unit-test [ 256 ] [ 1 { 8 } bitfield ] unit-test diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor index 54a90ef233..095392ed81 100755 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -1,5 +1,5 @@ USING: kernel math math.constants tools.test sequences ; -IN: temporary +IN: math.floats.tests [ t ] [ 0.0 float? ] unit-test [ t ] [ 3.1415 number? ] unit-test diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 194edb8f7e..eebc45511a 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -1,6 +1,6 @@ USING: kernel math namespaces prettyprint math.private continuations tools.test sequences ; -IN: temporary +IN: math.integers.tests [ "-8" ] [ -8 unparse ] unit-test diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor index 2c6ac2ecb0..8e2f47f72b 100755 --- a/core/math/intervals/intervals-tests.factor +++ b/core/math/intervals/intervals-tests.factor @@ -1,6 +1,6 @@ USING: math.intervals kernel sequences words math arrays prettyprint tools.test random vocabs ; -IN: temporary +IN: math.intervals.tests [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test diff --git a/core/math/math-tests.factor b/core/math/math-tests.factor index c650f7384c..fcd3b929ea 100644 --- a/core/math/math-tests.factor +++ b/core/math/math-tests.factor @@ -1,5 +1,5 @@ USING: kernel math namespaces tools.test ; -IN: temporary +IN: math.tests [ ] [ 5 [ ] times ] unit-test [ ] [ 0 [ ] times ] unit-test diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 226e47090a..baa6634a9f 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -1,5 +1,5 @@ USING: kernel math math.parser sequences tools.test ; -IN: temporary +IN: math.parser.tests [ f ] [ f string>number ] diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index d0dfd2c0be..8808b30c59 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -1,6 +1,6 @@ USING: generic kernel kernel.private math memory prettyprint sequences tools.test words namespaces layouts classes ; -IN: temporary +IN: memory.tests TUPLE: testing x y z ; diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor index 994bb8ef84..863c4baa42 100644 --- a/core/mirrors/mirrors-tests.factor +++ b/core/mirrors/mirrors-tests.factor @@ -1,5 +1,5 @@ USING: mirrors tools.test assocs kernel arrays ; -IN: temporary +IN: mirrors.tests TUPLE: foo bar baz ; diff --git a/core/namespaces/namespaces-tests.factor b/core/namespaces/namespaces-tests.factor index 07e9d80c9e..8dc065c04a 100644 --- a/core/namespaces/namespaces-tests.factor +++ b/core/namespaces/namespaces-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: namespaces.tests USING: kernel namespaces tools.test words ; H{ } clone "test-namespace" set diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor index b5b52e0e0e..d7638fa66d 100755 --- a/core/optimizer/control/control-tests.factor +++ b/core/optimizer/control/control-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: optimizer.control.tests USING: tools.test optimizer.control combinators kernel sequences inference.dataflow math inference classes strings optimizer ; diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor index 815c564109..d5e8e2d75d 100755 --- a/core/optimizer/def-use/def-use-tests.factor +++ b/core/optimizer/def-use/def-use-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: optimizer.def-use.tests USING: inference inference.dataflow optimizer optimizer.def-use namespaces assocs kernel sequences math tools.test words ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index c63787ad52..5116d66715 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -3,7 +3,7 @@ kernel.private math optimizer prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations optimizer.backend classes inference.dataflow tuples.private continuations growable optimizer.inlining namespaces hints ; -IN: temporary +IN: optimizer.tests [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index d95e8258be..bfea532242 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -2,7 +2,7 @@ USING: arrays math parser tools.test kernel generic words io.streams.string namespaces classes effects source-files assocs sequences strings io.files definitions continuations sorting tuples compiler.units debugger ; -IN: temporary +IN: parser.tests [ [ 1 [ 2 [ 3 ] 4 ] 5 ] @@ -23,7 +23,7 @@ IN: temporary [ "hello world" ] [ - "IN: temporary : hello \"hello world\" ;" + "IN: parser.tests : hello \"hello world\" ;" eval "USE: temporary hello" eval ] unit-test @@ -51,7 +51,7 @@ IN: temporary : effect-parsing-test ( a b -- c ) + ; [ t ] [ - "effect-parsing-test" "temporary" lookup + "effect-parsing-test" "parser.tests" lookup \ effect-parsing-test eq? ] unit-test @@ -64,24 +64,24 @@ IN: temporary [ \ baz "declared-effect" word-prop effect-terminated? ] unit-test - [ ] [ "IN: temporary USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test + [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test [ t ] [ - "effect-parsing-test" "temporary" lookup + "effect-parsing-test" "parser.tests" lookup \ effect-parsing-test eq? ] unit-test [ T{ effect f { "a" "b" } { "d" } f } ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test - [ ] [ "IN: temporary : effect-parsing-test ;" eval ] unit-test + [ ] [ "IN: parser.tests : effect-parsing-test ;" eval ] unit-test [ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test ! Funny bug - [ 2 ] [ "IN: temporary : \0. 2 ; \0." eval ] unit-test + [ 2 ] [ "IN: parser.tests : \0. 2 ; \0." eval ] unit-test - [ "IN: temporary : missing-- ( a b ) ;" eval ] must-fail + [ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail ! These should throw errors [ "HEX: zzz" eval ] must-fail @@ -102,71 +102,71 @@ IN: temporary ] unit-test DEFER: foo - "IN: temporary USING: math prettyprint ; : foo 2 2 + . ; parsing" eval + "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ; parsing" eval [ ] [ "USE: temporary foo" eval ] unit-test - "IN: temporary USING: math prettyprint ; : foo 2 2 + . ;" eval + "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ;" eval [ t ] [ "USE: temporary \\ foo" eval - "foo" "temporary" lookup eq? + "foo" "parser.tests" lookup eq? ] unit-test ! Test smudging [ 1 ] [ - "IN: temporary : smudge-me ;" "foo" + "IN: parser.tests : smudge-me ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size ] unit-test - [ t ] [ "smudge-me" "temporary" lookup >boolean ] unit-test + [ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test [ ] [ - "IN: temporary : smudge-me-more ;" "foo" + "IN: parser.tests : smudge-me-more ;" "foo" parse-stream drop ] unit-test - [ t ] [ "smudge-me-more" "temporary" lookup >boolean ] unit-test - [ f ] [ "smudge-me" "temporary" lookup >boolean ] unit-test + [ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test + [ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test [ 3 ] [ - "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" "foo" + "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size ] unit-test [ 1 ] [ - "IN: temporary USING: arrays ; M: array smudge-me ;" "bar" + "IN: parser.tests USING: arrays ; M: array smudge-me ;" "bar" parse-stream drop "bar" source-file source-file-definitions first assoc-size ] unit-test [ 2 ] [ - "IN: temporary USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" "foo" + "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size ] unit-test [ t ] [ - array "smudge-me" "temporary" lookup order memq? + array "smudge-me" "parser.tests" lookup order memq? ] unit-test [ t ] [ - integer "smudge-me" "temporary" lookup order memq? + integer "smudge-me" "parser.tests" lookup order memq? ] unit-test [ f ] [ - string "smudge-me" "temporary" lookup order memq? + string "smudge-me" "parser.tests" lookup order memq? ] unit-test [ ] [ - "IN: temporary USE: math 2 2 +" "a" + "IN: parser.tests USE: math 2 2 +" "a" parse-stream drop ] unit-test @@ -175,7 +175,7 @@ IN: temporary ] unit-test [ ] [ - "IN: temporary USE: math 2 2 -" "a" + "IN: parser.tests USE: math 2 2 -" "a" parse-stream drop ] unit-test @@ -186,7 +186,7 @@ IN: temporary [ ] [ "a" source-files get delete-at 2 [ - "IN: temporary DEFER: x : y x ; : x y ;" + "IN: parser.tests DEFER: x : y x ; : x y ;" "a" parse-stream drop ] times ] unit-test @@ -194,19 +194,19 @@ IN: temporary "a" source-files get delete-at [ - "IN: temporary : x ; : y 3 throw ; this is an error" + "IN: parser.tests : x ; : y 3 throw ; this is an error" "a" parse-stream ] [ parse-error? ] must-fail-with [ t ] [ - "y" "temporary" lookup >boolean + "y" "parser.tests" lookup >boolean ] unit-test [ f ] [ - "IN: temporary : x ;" + "IN: parser.tests : x ;" "a" parse-stream drop - "y" "temporary" lookup + "y" "parser.tests" lookup ] unit-test ! Test new forward definition logic @@ -269,81 +269,81 @@ IN: temporary ] unit-test [ ] [ - "IN: temporary : ; : bogus ;" + "IN: parser.tests : ; : bogus ;" "bogus-error" parse-stream drop ] unit-test [ ] [ - "IN: temporary TUPLE: bogus-error ; C: bogus-error : bogus ;" + "IN: parser.tests TUPLE: bogus-error ; C: bogus-error : bogus ;" "bogus-error" parse-stream drop ] unit-test ! Problems with class predicates -vs- ordinary words [ ] [ - "IN: temporary TUPLE: killer ;" + "IN: parser.tests TUPLE: killer ;" "removing-the-predicate" parse-stream drop ] unit-test [ ] [ - "IN: temporary GENERIC: killer? ( a -- b )" + "IN: parser.tests GENERIC: killer? ( a -- b )" "removing-the-predicate" parse-stream drop ] unit-test [ t ] [ - "killer?" "temporary" lookup >boolean + "killer?" "parser.tests" lookup >boolean ] unit-test [ - "IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?" + "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?" "removing-the-predicate" parse-stream ] [ [ redefine-error? ] is? ] must-fail-with [ - "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;" + "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;" "redefining-a-class-1" parse-stream ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ - "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test" + "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test" "redefining-a-class-2" parse-stream drop ] unit-test [ - "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" + "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" "redefining-a-class-3" parse-stream drop ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ - "IN: temporary TUPLE: class-fwd-test ;" + "IN: parser.tests TUPLE: class-fwd-test ;" "redefining-a-class-3" parse-stream drop ] unit-test [ - "IN: temporary \\ class-fwd-test" + "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop ] [ [ no-word? ] is? ] must-fail-with [ ] [ - "IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" + "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" "redefining-a-class-3" parse-stream drop ] unit-test [ - "IN: temporary \\ class-fwd-test" + "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop ] [ [ no-word? ] is? ] must-fail-with [ - "IN: temporary : foo ; TUPLE: foo ;" + "IN: parser.tests : foo ; TUPLE: foo ;" "redefining-a-class-4" parse-stream drop ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ - "IN: temporary : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval + "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval ] unit-test [ - "IN: temporary : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval + "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval ] must-fail ] with-file-vocabs @@ -354,7 +354,7 @@ IN: temporary DEFER: ~b - "IN: temporary : ~b ~a ;" + "IN: parser.tests : ~b ~a ;" "smudgy" parse-stream drop : ~c ; @@ -389,43 +389,43 @@ IN: temporary ] with-scope [ ] [ - "IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval + "IN: parser.tests USE: kernel PREDICATE: object foo ( x -- y ) ;" eval ] unit-test [ t ] [ - "foo?" "temporary" lookup word eq? + "foo?" "parser.tests" lookup word eq? ] unit-test [ ] [ - "IN: temporary TUPLE: foo ; GENERIC: foo" + "IN: parser.tests TUPLE: foo ; GENERIC: foo" "redefining-a-class-5" parse-stream drop ] unit-test [ ] [ - "IN: temporary M: f foo ;" + "IN: parser.tests M: f foo ;" "redefining-a-class-6" parse-stream drop ] unit-test -[ f ] [ f "foo" "temporary" lookup execute ] unit-test +[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test [ ] [ - "IN: temporary TUPLE: foo ; GENERIC: foo" + "IN: parser.tests TUPLE: foo ; GENERIC: foo" "redefining-a-class-5" parse-stream drop ] unit-test -[ f ] [ f "foo" "temporary" lookup execute ] unit-test +[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test [ ] [ - "IN: temporary TUPLE: foo ; GENERIC: foo" + "IN: parser.tests TUPLE: foo ; GENERIC: foo" "redefining-a-class-7" parse-stream drop ] unit-test [ ] [ - "IN: temporary TUPLE: foo ;" + "IN: parser.tests TUPLE: foo ;" "redefining-a-class-7" parse-stream drop ] unit-test -[ t ] [ "foo" "temporary" lookup symbol? ] unit-test +[ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test [ "resource:core/parser/test/assert-depth.factor" run-file ] [ relative-overflow-stack { 1 2 3 } sequence= ] diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 32629724bd..6226ddca38 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint prettyprint.config prettyprint.sections sequences tools.test vectors words effects splitting generic.standard prettyprint.private continuations generic compiler.units tools.walker ; -IN: temporary +IN: prettyprint.tests [ "4" ] [ 4 unparse ] unit-test [ "1.0" ] [ 1.0 unparse ] unit-test @@ -73,12 +73,12 @@ unit-test : foo ( a -- b ) dup * ; inline -[ "USING: kernel math ;\nIN: temporary\n: foo ( a -- b ) dup * ; inline\n" ] +[ "USING: kernel math ;\nIN: prettyprint.tests\n: foo ( a -- b ) dup * ; inline\n" ] [ [ \ foo see ] with-string-writer ] unit-test : bar ( x -- y ) 2 + ; -[ "USING: math ;\nIN: temporary\n: bar ( x -- y ) 2 + ;\n" ] +[ "USING: math ;\nIN: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" ] [ [ \ bar see ] with-string-writer ] unit-test : blah @@ -115,14 +115,14 @@ unit-test [ [ parse-fresh drop ] with-compilation-unit [ - "temporary" lookup see + "prettyprint.tests" lookup see ] with-string-writer "\n" split 1 head* ] keep = ] with-scope ; : method-test { - "IN: temporary" + "IN: prettyprint.tests" "GENERIC: method-layout" "" "USING: math temporary ;" @@ -147,7 +147,7 @@ unit-test : retain-stack-test { "USING: io kernel sequences words ;" - "IN: temporary" + "IN: prettyprint.tests" ": retain-stack-layout ( x -- )" " dup stream-readln stream-readln" " >r [ define ] map r>" @@ -161,7 +161,7 @@ unit-test : soft-break-test { "USING: kernel math sequences strings ;" - "IN: temporary" + "IN: prettyprint.tests" ": soft-break-layout ( x y -- ? )" " over string? [" " over hashcode over hashcode number=" @@ -176,7 +176,7 @@ unit-test : another-retain-layout-test { "USING: kernel sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": another-retain-layout ( seq1 seq2 quot -- newseq )" " -rot 2dup dupd min-length [ each drop roll ] map" " >r 3drop r> ; inline" @@ -189,7 +189,7 @@ unit-test : another-soft-break-test { "USING: namespaces parser sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": another-soft-break-layout ( node -- quot )" " parse-error-file" " [ \"hello world foo\" add ] [ ] make ;" @@ -203,7 +203,7 @@ unit-test : string-layout { "USING: io kernel parser ;" - "IN: temporary" + "IN: prettyprint.tests" ": string-layout-test ( error -- )" " \"Expected \" write dup unexpected-want expected>string write" " \" but got \" write unexpected-got expected>string print ;" @@ -224,7 +224,7 @@ unit-test : final-soft-break-test { "USING: kernel sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": final-soft-break-layout ( class dim -- view )" " >r \"alloc\" send 0 0 r>" " first2 " @@ -240,7 +240,7 @@ unit-test : narrow-test { "USING: arrays combinators continuations kernel sequences ;" - "IN: temporary" + "IN: prettyprint.tests" ": narrow-layout ( obj -- )" " {" " { [ dup continuation? ] [ append ] }" @@ -255,7 +255,7 @@ unit-test : another-narrow-test { - "IN: temporary" + "IN: prettyprint.tests" ": another-narrow-layout ( -- obj )" " H{" " { 1 2 }" @@ -274,10 +274,10 @@ unit-test : class-see-test { - "IN: temporary" + "IN: prettyprint.tests" "TUPLE: class-see-layout ;" "" - "IN: temporary" + "IN: prettyprint.tests" "GENERIC: class-see-layout ( x -- y )" "" "USING: temporary ;" @@ -292,9 +292,9 @@ unit-test ! Regression [ t ] [ - "IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n" + "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n" dup eval - "generic-decl-test" "temporary" lookup + "generic-decl-test" "prettyprint.tests" lookup [ see ] with-string-writer = ] unit-test diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor index 90ba150a41..a4c9a619b5 100755 --- a/core/quotations/quotations-tests.factor +++ b/core/quotations/quotations-tests.factor @@ -1,5 +1,5 @@ USING: math kernel quotations tools.test sequences ; -IN: temporary +IN: quotations.tests [ [ 3 ] ] [ 3 [ ] curry ] unit-test [ [ \ + ] ] [ \ + [ ] curry ] unit-test diff --git a/core/sbufs/sbufs-tests.factor b/core/sbufs/sbufs-tests.factor index b8d5b3e3fc..b30812b06f 100644 --- a/core/sbufs/sbufs-tests.factor +++ b/core/sbufs/sbufs-tests.factor @@ -1,6 +1,6 @@ USING: kernel math namespaces sequences sbufs strings tools.test classes ; -IN: temporary +IN: sbufs.tests [ 5 ] [ "Hello" >sbuf length ] unit-test diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 40b2fef85e..c545a9baee 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -1,7 +1,7 @@ USING: arrays kernel math namespaces sequences kernel.private sequences.private strings sbufs tools.test vectors bit-arrays generic ; -IN: temporary +IN: sequences.tests [ V{ 1 2 3 4 } ] [ 1 5 dup >vector ] unit-test [ 3 ] [ 1 4 dup length ] unit-test diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor index d9227b2d95..732aeb045d 100755 --- a/core/sorting/sorting-tests.factor +++ b/core/sorting/sorting-tests.factor @@ -1,6 +1,6 @@ USING: sorting sequences kernel math random tools.test vectors ; -IN: temporary +IN: sorting.tests [ [ ] ] [ [ ] natural-sort ] unit-test diff --git a/core/splitting/splitting-tests.factor b/core/splitting/splitting-tests.factor index 2b6107e08b..d60403362c 100644 --- a/core/splitting/splitting-tests.factor +++ b/core/splitting/splitting-tests.factor @@ -1,5 +1,5 @@ USING: splitting tools.test ; -IN: temporary +IN: splitting.tests [ { 1 2 3 } 0 group ] must-fail diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 1df4e1c477..c971287ef6 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -1,6 +1,6 @@ USING: continuations kernel math namespaces strings sbufs tools.test sequences vectors arrays ; -IN: temporary +IN: strings.tests [ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor index c542e68981..296f542418 100755 --- a/core/system/system-tests.factor +++ b/core/system/system-tests.factor @@ -1,5 +1,5 @@ USING: math tools.test system prettyprint ; -IN: temporary +IN: system.tests [ t ] [ cell integer? ] unit-test [ t ] [ bootstrap-cell integer? ] unit-test diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index 00306da062..c2e627e7bf 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -1,5 +1,5 @@ USING: namespaces io tools.test threads kernel ; -IN: temporary +IN: threads.tests 3 "x" set namespace [ [ yield 2 "x" set ] bind ] curry "Test" spawn drop diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 8680a3ce61..63bb233654 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -3,7 +3,7 @@ math.constants parser sequences tools.test words assocs namespaces quotations sequences.private classes continuations generic.standard effects tuples tuples.private arrays vectors strings compiler.units ; -IN: temporary +IN: tuples.tests [ t ] [ \ tuple-class \ class class< ] unit-test [ f ] [ \ class \ tuple-class class< ] unit-test @@ -45,19 +45,19 @@ C: point 100 200 "p" set ! Use eval to sequence parsing explicitly -"IN: temporary TUPLE: point x y z ;" eval +"IN: tuples.tests TUPLE: point x y z ;" eval [ 100 ] [ "p" get point-x ] unit-test [ 200 ] [ "p" get point-y ] unit-test -[ f ] [ "p" get "point-z" "temporary" lookup execute ] unit-test +[ f ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test -300 "p" get "set-point-z" "temporary" lookup execute +300 "p" get "set-point-z" "tuples.tests" lookup execute -"IN: temporary TUPLE: point z y ;" eval +"IN: tuples.tests TUPLE: point z y ;" eval [ "p" get point-x ] must-fail [ 200 ] [ "p" get point-y ] unit-test -[ 300 ] [ "p" get "point-z" "temporary" lookup execute ] unit-test +[ 300 ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test TUPLE: predicate-test ; @@ -113,7 +113,7 @@ GENERIC: TUPLE: yo-momma ; -"IN: temporary C: yo-momma" eval +"IN: tuples.tests C: yo-momma" eval [ f ] [ \ generic? ] unit-test @@ -202,12 +202,12 @@ M: vector silly "z" ; SYMBOL: not-a-tuple-class [ - "IN: temporary C: not-a-tuple-class" + "IN: tuples.tests C: not-a-tuple-class" eval ] must-fail [ t ] [ - "not-a-tuple-class" "temporary" lookup symbol? + "not-a-tuple-class" "tuples.tests" lookup symbol? ] unit-test ! Missing check @@ -226,7 +226,7 @@ C: erg's-reshape-problem { set-erg's-reshape-problem-a } \ erg's-reshape-problem construct ; -"IN: temporary TUPLE: erg's-reshape-problem a b c d e f ;" eval +"IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test @@ -235,7 +235,7 @@ C: erg's-reshape-problem [ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test [ - "IN: temporary SYMBOL: not-a-class C: not-a-class" eval + "IN: tuples.tests SYMBOL: not-a-class C: not-a-class" eval ] [ [ check-tuple? ] is? ] must-fail-with ! Hardcore unit tests diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index b56cee1b34..d990f5f31c 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -1,7 +1,7 @@ USING: arrays kernel kernel.private math namespaces sequences sequences.private strings tools.test vectors continuations random growable classes ; -IN: temporary +IN: vectors.tests [ ] [ 10 [ [ -1000000 ] ignore-errors ] times ] unit-test diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 3a8fc37583..f99bf94aa4 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -1,5 +1,5 @@ ! Unit tests for vocabs.loader vocabulary -IN: temporary +IN: vocabs.loader.tests USING: vocabs.loader tools.test continuations vocabs math kernel arrays sequences namespaces io.streams.string parser source-files words assocs tuples definitions @@ -31,7 +31,7 @@ IN: vocabs.loader.test.2 MAIN: hello -IN: temporary +IN: vocabs.loader.tests [ { 3 3 3 } ] [ "vocabs.loader.test.2" run diff --git a/core/vocabs/vocabs-tests.factor b/core/vocabs/vocabs-tests.factor index 9b05660d9d..21c3668148 100644 --- a/core/vocabs/vocabs-tests.factor +++ b/core/vocabs/vocabs-tests.factor @@ -1,5 +1,5 @@ ! Unit tests for vocabs vocabulary USING: vocabs tools.test ; -IN: temporary +IN: vocabs.tests [ f ] [ "kernel" vocab-main ] unit-test diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 63e30178f5..97ce86d38a 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -1,13 +1,13 @@ USING: arrays generic assocs kernel math namespaces sequences tools.test words definitions parser quotations vocabs continuations tuples compiler.units io.streams.string ; -IN: temporary +IN: words.tests [ 4 ] [ [ - "poo" "temporary" create [ 2 2 + ] define + "poo" "words.tests" create [ 2 2 + ] define ] with-compilation-unit - "poo" "temporary" lookup execute + "poo" "words.tests" lookup execute ] unit-test [ t ] [ t vocabs [ words [ word? and ] each ] each ] unit-test @@ -50,7 +50,7 @@ SYMBOL: a-symbol ! See if redefining a generic as a colon def clears some ! word props. GENERIC: testing -"IN: temporary : testing ;" eval +"IN: words.tests : testing ;" eval [ f ] [ \ testing generic? ] unit-test @@ -112,13 +112,13 @@ M: array freakish ; DEFER: x [ x ] [ undefined? ] must-fail-with -[ ] [ "no-loc" "temporary" create drop ] unit-test -[ f ] [ "no-loc" "temporary" lookup where ] unit-test +[ ] [ "no-loc" "words.tests" create drop ] unit-test +[ f ] [ "no-loc" "words.tests" lookup where ] unit-test -[ ] [ "IN: temporary : no-loc-2 ;" eval ] unit-test -[ f ] [ "no-loc-2" "temporary" lookup where ] unit-test +[ ] [ "IN: words.tests : no-loc-2 ;" eval ] unit-test +[ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test -[ ] [ "IN: temporary : test-last ( -- ) ;" eval ] unit-test +[ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test [ "test-last" ] [ word word-name ] unit-test ! regression @@ -141,40 +141,40 @@ SYMBOL: quot-uses-b [ { + } ] [ \ quot-uses-b uses ] unit-test -[ "IN: temporary : undef-test ; << undef-test >>" eval ] +[ "IN: words.tests : undef-test ; << undef-test >>" eval ] [ [ undefined? ] is? ] must-fail-with [ ] [ - "IN: temporary GENERIC: symbol-generic" eval + "IN: words.tests GENERIC: symbol-generic" eval ] unit-test [ ] [ - "IN: temporary SYMBOL: symbol-generic" eval + "IN: words.tests SYMBOL: symbol-generic" eval ] unit-test -[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test -[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test +[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test +[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test [ ] [ - "IN: temporary GENERIC: symbol-generic" + "IN: words.tests GENERIC: symbol-generic" "symbol-generic-test" parse-stream drop ] unit-test [ ] [ - "IN: temporary TUPLE: symbol-generic ;" + "IN: words.tests TUPLE: symbol-generic ;" "symbol-generic-test" parse-stream drop ] unit-test -[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test -[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test +[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test +[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test ! Regressions -[ ] [ "IN: temporary : decl-forget-test ; foldable" eval ] unit-test -[ t ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test -[ f ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ; foldable" eval ] unit-test +[ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test +[ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: temporary : decl-forget-test ; flushable" eval ] unit-test -[ t ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test -[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test -[ f ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ; flushable" eval ] unit-test +[ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ;" eval ] unit-test +[ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test diff --git a/extra/ascii/ascii-tests.factor b/extra/ascii/ascii-tests.factor index ec76d89d7c..b2b13b1d78 100644 --- a/extra/ascii/ascii-tests.factor +++ b/extra/ascii/ascii-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ascii.tests USING: ascii tools.test sequences kernel math ; [ t ] [ CHAR: a letter? ] unit-test diff --git a/extra/benchmark/reverse-complement/reverse-complement-tests.factor b/extra/benchmark/reverse-complement/reverse-complement-tests.factor index c8da5f2c9f..c8d4714802 100755 --- a/extra/benchmark/reverse-complement/reverse-complement-tests.factor +++ b/extra/benchmark/reverse-complement/reverse-complement-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: benchmark.reverse-complement.tests USING: tools.test benchmark.reverse-complement crypto.md5 io.files kernel ; diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor index 1f23d4f841..eb32ce5b43 100755 --- a/extra/calendar/format/format-tests.factor +++ b/extra/calendar/format/format-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: calendar.format.tests USING: calendar.format tools.test io.streams.string ; [ 0 ] [ diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor index 1f2436cf5d..df72572c67 100755 --- a/extra/channels/channels-tests.factor +++ b/extra/channels/channels-tests.factor @@ -3,7 +3,7 @@ ! USING: kernel tools.test math channels channels.private sequences threads sorting ; -IN: temporary +IN: channels.tests { V{ 10 } } [ V{ } clone diff --git a/extra/channels/remote/remote-tests.factor b/extra/channels/remote/remote-tests.factor index 58a70fbf62..03967c954e 100644 --- a/extra/channels/remote/remote-tests.factor +++ b/extra/channels/remote/remote-tests.factor @@ -3,7 +3,7 @@ ! USING: kernel tools.test math assocs channels channels.remote channels.remote.private ; -IN: temporary +IN: channels.remote.tests { t } [ remote-channels assoc? diff --git a/extra/cocoa/cocoa-tests.factor b/extra/cocoa/cocoa-tests.factor index 44f0b50996..20b7e2a02d 100644 --- a/extra/cocoa/cocoa-tests.factor +++ b/extra/cocoa/cocoa-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: cocoa.tests USING: cocoa cocoa.messages cocoa.subclassing cocoa.types compiler kernel namespaces cocoa.classes tools.test memory compiler.units ; diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 32fca44eaf..0a08948346 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -1,6 +1,6 @@ USING: combinators.lib kernel math random sequences tools.test continuations arrays vectors ; -IN: temporary +IN: combinators.lib.tests [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test [ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test diff --git a/extra/concurrency/combinators/combinators-tests.factor b/extra/concurrency/combinators/combinators-tests.factor index e06b97489b..0f18fcf431 100755 --- a/extra/concurrency/combinators/combinators-tests.factor +++ b/extra/concurrency/combinators/combinators-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.combinators.tests USING: concurrency.combinators tools.test random kernel math concurrency.mailboxes threads sequences ; diff --git a/extra/concurrency/count-downs/count-downs-tests.factor b/extra/concurrency/count-downs/count-downs-tests.factor index f6bd64234f..649802cd95 100755 --- a/extra/concurrency/count-downs/count-downs-tests.factor +++ b/extra/concurrency/count-downs/count-downs-tests.factor @@ -1,5 +1,5 @@ USING: concurrency.count-downs threads kernel tools.test ; -IN: temporary` +IN: concurrency.count-downs.tests` [ ] [ 0 await ] unit-test diff --git a/extra/concurrency/exchangers/exchangers-tests.factor b/extra/concurrency/exchangers/exchangers-tests.factor index 91338389d1..569b1a72c2 100755 --- a/extra/concurrency/exchangers/exchangers-tests.factor +++ b/extra/concurrency/exchangers/exchangers-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.exchangers.tests USING: sequences tools.test concurrency.exchangers concurrency.count-downs concurrency.promises locals kernel threads ; diff --git a/extra/concurrency/flags/flags-tests.factor b/extra/concurrency/flags/flags-tests.factor index 44934b59c4..f23ea95167 100755 --- a/extra/concurrency/flags/flags-tests.factor +++ b/extra/concurrency/flags/flags-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.flags.tests USING: tools.test concurrency.flags kernel threads locals ; :: flag-test-1 ( -- ) diff --git a/extra/concurrency/futures/futures-tests.factor b/extra/concurrency/futures/futures-tests.factor index 39299f9cf7..208a72f820 100755 --- a/extra/concurrency/futures/futures-tests.factor +++ b/extra/concurrency/futures/futures-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.futures.tests USING: concurrency.futures kernel tools.test threads ; [ 50 ] [ diff --git a/extra/concurrency/locks/locks-tests.factor b/extra/concurrency/locks/locks-tests.factor index 806fad6c32..659bd2714e 100755 --- a/extra/concurrency/locks/locks-tests.factor +++ b/extra/concurrency/locks/locks-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.locks.tests USING: tools.test concurrency.locks concurrency.count-downs concurrency.messaging concurrency.mailboxes locals kernel threads sequences calendar ; diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor index 4541d06a5a..24d83b2961 100755 --- a/extra/concurrency/mailboxes/mailboxes-tests.factor +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.mailboxes.tests USING: concurrency.mailboxes vectors sequences threads tools.test math kernel strings ; diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 3f6e4e3ed8..6de381b166 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -4,7 +4,7 @@ USING: kernel threads vectors arrays sequences namespaces tools.test continuations dlists strings math words match quotations concurrency.messaging concurrency.mailboxes ; -IN: temporary +IN: concurrency.messaging.tests [ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test diff --git a/extra/concurrency/promises/promises-tests.factor b/extra/concurrency/promises/promises-tests.factor index fa749438d2..36fe4ef907 100755 --- a/extra/concurrency/promises/promises-tests.factor +++ b/extra/concurrency/promises/promises-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: concurrency.promises.tests USING: vectors concurrency.promises kernel threads sequences tools.test ; diff --git a/extra/coroutines/coroutines-tests.factor b/extra/coroutines/coroutines-tests.factor index 52b1123265..6710452b22 100644 --- a/extra/coroutines/coroutines-tests.factor +++ b/extra/coroutines/coroutines-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither. ! See http://factorcode.org/license.txt for BSD license. -IN: temporary +IN: coroutines.tests USING: coroutines kernel sequences prettyprint tools.test math ; : test1 ( -- co ) diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor index 64efb96f90..35c99258db 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -1,5 +1,5 @@ USING: kernel io strings sequences namespaces math parser crypto.hmac tools.test ; -IN: temporary +IN: crypto.hmac.tests [ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 "Hi There" string>md5-hmac >string ] unit-test [ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test diff --git a/extra/crypto/timing/timing-tests.factor b/extra/crypto/timing/timing-tests.factor index 1337ccca8a..9afb913724 100644 --- a/extra/crypto/timing/timing-tests.factor +++ b/extra/crypto/timing/timing-tests.factor @@ -1,4 +1,4 @@ USING: crypto.timing kernel tools.test system math ; -IN: temporary +IN: crypto.timing.tests [ t ] [ millis [ ] 1000 with-timing millis swap - 1000 >= ] unit-test diff --git a/extra/crypto/xor/xor-tests.factor b/extra/crypto/xor/xor-tests.factor index 2a6fd525e0..ef781b9f25 100644 --- a/extra/crypto/xor/xor-tests.factor +++ b/extra/crypto/xor/xor-tests.factor @@ -1,5 +1,5 @@ USING: continuations crypto.xor kernel strings tools.test ; -IN: temporary +IN: crypto.xor.tests ! No key [ "" dup xor-crypt ] [ T{ no-xor-key f } = ] must-fail-with diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor index 7ea2bb629a..250f98f73e 100755 --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -4,12 +4,10 @@ USING: kernel db.postgresql alien continuations io classes prettyprint sequences namespaces tools.test db db.tuples db.types unicode.case ; -IN: temporary +IN: db.postgresql.tests -IN: scratchpad : test-db ( -- postgresql-db ) { "localhost" "postgres" "" "factor-test" } postgresql-db ; -IN: temporary [ ] [ test-db [ ] with-db ] unit-test diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index 6c4b65ff9f..974fdb8782 100755 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -1,7 +1,7 @@ USING: io io.files io.launcher kernel namespaces prettyprint tools.test db.sqlite db sequences continuations db.types db.tuples unicode.case ; -IN: temporary +IN: db.sqlite.tests : test.db "extra/db/sqlite/test.db" resource-path ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index c9e6d302e0..aa94bbfbb6 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -3,7 +3,7 @@ USING: io.files kernel tools.test db db.tuples db.types continuations namespaces db.postgresql math prettyprint tools.walker db.sqlite ; -IN: temporary +IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real ; : ( name age real -- person ) diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index dd9a77aa21..d66357daa5 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -1,5 +1,5 @@ USING: delegate kernel arrays tools.test ; -IN: temporary +IN: delegate.tests TUPLE: hello this that ; C: hello diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor index db4f023dad..09b4ccc357 100755 --- a/extra/destructors/destructors-tests.factor +++ b/extra/destructors/destructors-tests.factor @@ -1,5 +1,5 @@ USING: destructors kernel tools.test continuations ; -IN: temporary +IN: destructors.tests TUPLE: dummy-obj destroyed? ; diff --git a/extra/documents/documents-tests.factor b/extra/documents/documents-tests.factor index dfa24c6cea..e09afebfc2 100644 --- a/extra/documents/documents-tests.factor +++ b/extra/documents/documents-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: documents.tests USING: documents namespaces tools.test ; ! Tests diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index db11833cf1..8ac2686718 100644 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -1,5 +1,5 @@ USING: farkup kernel tools.test ; -IN: temporary +IN: farkup.tests [ "
  • foo
" ] [ "-foo" parse-farkup ] unit-test [ "
  • foo
\n" ] [ "-foo\n" parse-farkup ] unit-test diff --git a/extra/fjsc/fjsc-tests.factor b/extra/fjsc/fjsc-tests.factor index ccb004581a..ce968128be 100755 --- a/extra/fjsc/fjsc-tests.factor +++ b/extra/fjsc/fjsc-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test peg fjsc ; -IN: temporary +IN: fjsc.tests { T{ ast-expression f V{ T{ ast-number f 55 } T{ ast-identifier f "2abc1" } T{ ast-number f 100 } } } } [ "55 2abc1 100" 'expression' parse parse-result-ast diff --git a/extra/fry/fry-tests.factor b/extra/fry/fry-tests.factor index fd21a4a4cd..e1ef40b44d 100755 --- a/extra/fry/fry-tests.factor +++ b/extra/fry/fry-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: fry.tests USING: fry tools.test math prettyprint kernel io arrays sequences ; diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor index 4afbd653bd..84ec798df2 100644 --- a/extra/furnace/furnace-tests.factor +++ b/extra/furnace/furnace-tests.factor @@ -1,5 +1,5 @@ USING: kernel sequences namespaces math tools.test furnace furnace.validator ; -IN: temporary +IN: furnace.tests TUPLE: test-tuple m n ; diff --git a/extra/furnace/validator/validator-tests.factor b/extra/furnace/validator/validator-tests.factor index 06d8ac815d..e84e57be6a 100644 --- a/extra/furnace/validator/validator-tests.factor +++ b/extra/furnace/validator/validator-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: furnace.validator.tests USING: kernel sequences tools.test furnace.validator furnace ; [ diff --git a/extra/globs/globs-tests.factor b/extra/globs/globs-tests.factor index 8021128810..446f1ee0a9 100644 --- a/extra/globs/globs-tests.factor +++ b/extra/globs/globs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: globs.tests USING: tools.test globs ; [ f ] [ "abd" "fdf" glob-matches? ] unit-test diff --git a/extra/help/crossref/crossref-tests.factor b/extra/help/crossref/crossref-tests.factor index eb30965f6a..1d569d8a8f 100755 --- a/extra/help/crossref/crossref-tests.factor +++ b/extra/help/crossref/crossref-tests.factor @@ -1,10 +1,10 @@ -IN: temporary +IN: help.crossref.tests USING: help.crossref help.topics help.markup tools.test words definitions assocs sequences kernel namespaces parser arrays io.streams.string continuations debugger compiler.units ; [ ] [ - "IN: temporary USING: help.syntax help.markup ; : foo ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval ] unit-test [ $subsection ] [ @@ -13,17 +13,17 @@ io.streams.string continuations debugger compiler.units ; [ t ] [ "foo" article-children - "foo" "temporary" lookup 1array sequence= + "foo" "help.crossref.tests" lookup 1array sequence= ] unit-test -[ "foo" ] [ "foo" "temporary" lookup article-parent ] unit-test +[ "foo" ] [ "foo" "help.crossref.tests" lookup article-parent ] unit-test [ ] [ - [ "foo" "temporary" lookup forget ] with-compilation-unit + [ "foo" "help.crossref.tests" lookup forget ] with-compilation-unit ] unit-test [ ] [ - "IN: temporary USING: help.syntax help.markup ; : bar ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval ] unit-test [ ] [ diff --git a/extra/help/definitions/definitions-tests.factor b/extra/help/definitions/definitions-tests.factor index 836f82a306..921d8e1c69 100755 --- a/extra/help/definitions/definitions-tests.factor +++ b/extra/help/definitions/definitions-tests.factor @@ -1,13 +1,13 @@ USING: math definitions help.topics help tools.test prettyprint parser io.streams.string kernel source-files assocs namespaces words io sequences ; -IN: temporary +IN: help.definitions.tests [ ] [ \ + >link see ] unit-test [ [ 4 ] [ - "IN: temporary USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" "foo" + "IN: help.definitions.tests USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size @@ -16,11 +16,11 @@ IN: temporary [ t ] [ "hello" articles get key? ] unit-test [ t ] [ "hello2" articles get key? ] unit-test [ t ] [ - "hello" "temporary" lookup "help" word-prop >boolean + "hello" "help.definitions" lookup "help" word-prop >boolean ] unit-test [ 2 ] [ - "IN: temporary USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" "foo" + "IN: help.definitions.tests USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" "foo" parse-stream drop "foo" source-file source-file-definitions first assoc-size @@ -29,12 +29,12 @@ IN: temporary [ t ] [ "hello" articles get key? ] unit-test [ f ] [ "hello2" articles get key? ] unit-test [ f ] [ - "hello" "temporary" lookup "help" word-prop + "hello" "help.definitions" lookup "help" word-prop ] unit-test - [ ] [ "IN: temporary USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test + [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test - [ ] [ "xxx" "temporary" lookup help ] unit-test + [ ] [ "xxx" "help.definitions" lookup help ] unit-test - [ ] [ "xxx" "temporary" lookup >link synopsis print ] unit-test + [ ] [ "xxx" "help.definitions" lookup >link synopsis print ] unit-test ] with-file-vocabs diff --git a/extra/help/markup/markup-tests.factor b/extra/help/markup/markup-tests.factor index 71a9b54760..0b4b69bf59 100644 --- a/extra/help/markup/markup-tests.factor +++ b/extra/help/markup/markup-tests.factor @@ -1,6 +1,6 @@ USING: definitions help help.markup kernel sequences tools.test words parser namespaces assocs generic io.streams.string ; -IN: temporary +IN: help.markup.tests TUPLE: blahblah quux ; diff --git a/extra/help/syntax/syntax-tests.factor b/extra/help/syntax/syntax-tests.factor index 136313c2ef..038d7fa490 100755 --- a/extra/help/syntax/syntax-tests.factor +++ b/extra/help/syntax/syntax-tests.factor @@ -1,21 +1,21 @@ -IN: temporary +IN: help.syntax.tests USING: tools.test parser vocabs help.syntax namespaces ; [ [ "foobar" ] [ - "IN: temporary USE: help.syntax ABOUT: \"foobar\"" eval - "temporary" vocab vocab-help + "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval + "help.syntax" vocab vocab-help ] unit-test [ { "foobar" } ] [ - "IN: temporary USE: help.syntax ABOUT: { \"foobar\" }" eval - "temporary" vocab vocab-help + "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval + "help.syntax" vocab vocab-help ] unit-test SYMBOL: xyz [ xyz ] [ - "IN: temporary USE: help.syntax ABOUT: xyz" eval - "temporary" vocab vocab-help + "IN: help.syntax.tests USE: help.syntax ABOUT: xyz" eval + "help.syntax" vocab vocab-help ] unit-test ] with-file-vocabs diff --git a/extra/help/topics/topics-tests.factor b/extra/help/topics/topics-tests.factor index c4c22b551f..1099f747bc 100644 --- a/extra/help/topics/topics-tests.factor +++ b/extra/help/topics/topics-tests.factor @@ -1,7 +1,7 @@ USING: definitions help help.topics help.crossref help.markup help.syntax kernel sequences tools.test words parser namespaces assocs source-files ; -IN: temporary +IN: help.topics.tests ! Test help cross-referencing diff --git a/extra/hexdump/hexdump-tests.factor b/extra/hexdump/hexdump-tests.factor index 3ddfe721a6..7fb26e10c5 100644 --- a/extra/hexdump/hexdump-tests.factor +++ b/extra/hexdump/hexdump-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: hexdump.tests USING: hexdump kernel sequences tools.test ; [ t ] [ "" hexdump "Length: 0, 0h\n" = ] unit-test diff --git a/extra/html/elements/elements-tests.factor b/extra/html/elements/elements-tests.factor index aab00e0ca3..aa6a017540 100644 --- a/extra/html/elements/elements-tests.factor +++ b/extra/html/elements/elements-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: html.elements.tests USING: tools.test html html.elements io.streams.string ; : make-html-string diff --git a/extra/html/html-tests.factor b/extra/html/html-tests.factor index 4e3344855f..2994e2d792 100644 --- a/extra/html/html-tests.factor +++ b/extra/html/html-tests.factor @@ -1,6 +1,6 @@ USING: html http io io.streams.string io.styles kernel namespaces tools.test xml.writer sbufs sequences html.private ; -IN: temporary +IN: html.tests : make-html-string [ with-html-stream ] with-string-writer ; diff --git a/extra/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor index c490b737d9..0e98c1b998 100644 --- a/extra/html/parser/parser-tests.factor +++ b/extra/html/parser/parser-tests.factor @@ -1,5 +1,5 @@ USING: html.parser kernel tools.test ; -IN: temporary +IN: html.parser.tests [ V{ T{ tag f "html" H{ } f f f } } diff --git a/extra/html/parser/utils/utils-tests.factor b/extra/html/parser/utils/utils-tests.factor index fcac31a6aa..4b25db16fd 100644 --- a/extra/html/parser/utils/utils-tests.factor +++ b/extra/html/parser/utils/utils-tests.factor @@ -3,7 +3,7 @@ hashtables.private io kernel math namespaces prettyprint quotations sequences splitting state-parser strings tools.test ; USING: html.parser.utils ; -IN: temporary +IN: html.parser.utils.tests [ "'Rome'" ] [ "Rome" single-quote ] unit-test [ "\"Roma\"" ] [ "Roma" double-quote ] unit-test diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 5146502644..0a4941aaa0 100644 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,5 +1,5 @@ USING: http tools.test ; -IN: temporary +IN: http.tests [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 18edd94f12..627d7d889d 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,7 +1,7 @@ USING: webapps.file http.server.responders http http.server namespaces io tools.test strings io.server logging ; -IN: temporary +IN: http.server.tests [ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test diff --git a/extra/http/server/templating/templating-tests.factor b/extra/http/server/templating/templating-tests.factor index d889cd848a..ceb2ed95be 100644 --- a/extra/http/server/templating/templating-tests.factor +++ b/extra/http/server/templating/templating-tests.factor @@ -1,6 +1,6 @@ USING: io io.files io.streams.string http.server.templating kernel tools.test sequences ; -IN: temporary +IN: http.server.templating.tests : test-template ( path -- ? ) "extra/http/server/templating/test/" swap append diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor index c9203d9ef8..2260bf5882 100755 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.buffers.tests USING: alien alien.c-types io.buffers kernel kernel.private libc sequences tools.test namespaces ; diff --git a/extra/io/launcher/launcher-tests.factor b/extra/io/launcher/launcher-tests.factor index 6705caa33c..bacb8eb5a9 100755 --- a/extra/io/launcher/launcher-tests.factor +++ b/extra/io/launcher/launcher-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.launcher.tests USING: tools.test io.launcher ; \ must-infer diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index 25caae036d..832b88b248 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -1,5 +1,5 @@ USING: io io.mmap io.files kernel tools.test continuations sequences ; -IN: temporary +IN: io.mmap.tests [ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ ] [ "mmap-test-file.txt" resource-path [ "12345" write ] with-file-writer ] unit-test diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor index 24b4c231d1..8e56169bb3 100755 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.server.tests USING: tools.test io.server io.server.private ; { 1 0 } [ [ ] server-loop ] must-infer-as diff --git a/extra/io/sockets/impl/impl-tests.factor b/extra/io/sockets/impl/impl-tests.factor index 51305db45c..6b930a994e 100644 --- a/extra/io/sockets/impl/impl-tests.factor +++ b/extra/io/sockets/impl/impl-tests.factor @@ -1,5 +1,5 @@ USING: io.sockets.impl io.sockets kernel tools.test ; -IN: temporary +IN: io.sockets.impl.tests [ B{ 1 2 3 4 } ] [ "1.2.3.4" T{ inet4 } inet-pton ] unit-test diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor index 103c2789c6..f5366d32ae 100755 --- a/extra/io/unix/files/files-tests.factor +++ b/extra/io/unix/files/files-tests.factor @@ -1,5 +1,5 @@ USING: tools.test io.files ; -IN: temporary +IN: io.unix.files.tests [ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test [ "/etc/" ] [ "/etc/passwd" parent-directory ] unit-test diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index eb3038e1b5..7b2a7848fc 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: io.unix.launcher.tests USING: io.unix.launcher tools.test ; [ "" tokenize-command ] must-fail diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index af7417854e..680cb0b3e5 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -1,7 +1,7 @@ USING: io.files io.sockets io kernel threads namespaces tools.test continuations strings byte-arrays sequences prettyprint system ; -IN: temporary +IN: io.unix.tests ! Unix domain stream sockets : socket-server "unix-domain-socket-test" temp-file ; diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index e4ebe3dd37..c4ac99fe4a 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -1,6 +1,6 @@ USING: io.files kernel tools.test io.backend io.windows.nt.files splitting ; -IN: temporary +IN: io.windows.nt.tests [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test [ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor index 2ea8a64bd9..3cc230126c 100644 --- a/extra/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -1,5 +1,5 @@ USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ; -IN: temporary +IN: jamshred.tunnel.tests [ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 } T{ segment T{ oint f { 1 1 1 } } 1 } diff --git a/extra/koszul/koszul-tests.factor b/extra/koszul/koszul-tests.factor index d72314fc4d..13dc341350 100644 --- a/extra/koszul/koszul-tests.factor +++ b/extra/koszul/koszul-tests.factor @@ -1,5 +1,5 @@ USING: koszul tools.test kernel sequences assocs namespaces ; -IN: temporary +IN: koszul.tests [ { V{ { } } V{ { 1 } } V{ { 2 3 } { 7 8 } } V{ { 4 5 6 } } } diff --git a/extra/lazy-lists/examples/examples-tests.factor b/extra/lazy-lists/examples/examples-tests.factor index 14798de18a..d4e3ed79b8 100644 --- a/extra/lazy-lists/examples/examples-tests.factor +++ b/extra/lazy-lists/examples/examples-tests.factor @@ -1,5 +1,5 @@ USING: lazy-lists.examples lazy-lists tools.test ; -IN: temporary +IN: lazy-lists.examples.tests [ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test [ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test diff --git a/extra/lazy-lists/lazy-lists-tests.factor b/extra/lazy-lists/lazy-lists-tests.factor index 9b7f0effd2..0424a5d069 100644 --- a/extra/lazy-lists/lazy-lists-tests.factor +++ b/extra/lazy-lists/lazy-lists-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: lazy-lists tools.test kernel math io sequences ; -IN: temporary +IN: lazy-lists.tests [ { 1 2 3 4 } ] [ { 1 2 3 4 } >list list>array diff --git a/extra/levenshtein/levenshtein-tests.factor b/extra/levenshtein/levenshtein-tests.factor index 40e055686a..722ccb86ca 100644 --- a/extra/levenshtein/levenshtein-tests.factor +++ b/extra/levenshtein/levenshtein-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: temporary +IN: levenshtein.tests USING: tools.test levenshtein ; [ 3 ] [ "sitting" "kitten" levenshtein ] unit-test diff --git a/extra/lint/lint-tests.factor b/extra/lint/lint-tests.factor index 707d34b274..9a39980c9f 100644 --- a/extra/lint/lint-tests.factor +++ b/extra/lint/lint-tests.factor @@ -1,5 +1,5 @@ USING: io lint kernel math tools.test ; -IN: temporary +IN: lint.tests ! Don't write code like this : lint1 diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index b290c25159..e48f9f4061 100644 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -1,6 +1,6 @@ USING: locals math sequences tools.test hashtables words kernel namespaces arrays strings prettyprint ; -IN: temporary +IN: locals.tests :: foo ( a b -- a a ) a a ; diff --git a/extra/macros/macros-tests.factor b/extra/macros/macros-tests.factor index d41003797c..59a53afb70 100644 --- a/extra/macros/macros-tests.factor +++ b/extra/macros/macros-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: macros.tests USING: tools.test macros math kernel arrays vectors ; diff --git a/extra/match/match-tests.factor b/extra/match/match-tests.factor index d9162ae286..044b80fe9d 100755 --- a/extra/match/match-tests.factor +++ b/extra/match/match-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test match namespaces arrays ; -IN: temporary +IN: match.tests MATCH-VARS: ?a ?b ; diff --git a/extra/math/analysis/analysis-tests.factor b/extra/math/analysis/analysis-tests.factor index 0ed66a569c..5b537c2621 100644 --- a/extra/math/analysis/analysis-tests.factor +++ b/extra/math/analysis/analysis-tests.factor @@ -1,6 +1,6 @@ USING: kernel math math.functions tools.test math.analysis math.constants ; -IN: temporary +IN: math.analysis.tests : eps .00000001 ; diff --git a/extra/math/combinatorics/combinatorics-tests.factor b/extra/math/combinatorics/combinatorics-tests.factor index 440630e38f..e6a2824433 100644 --- a/extra/math/combinatorics/combinatorics-tests.factor +++ b/extra/math/combinatorics/combinatorics-tests.factor @@ -1,5 +1,5 @@ USING: math.combinatorics math.combinatorics.private tools.test ; -IN: temporary +IN: math.combinatorics.tests [ { } ] [ 0 factoradic ] unit-test [ { 1 0 } ] [ 1 factoradic ] unit-test diff --git a/extra/math/complex/complex-tests.factor b/extra/math/complex/complex-tests.factor index e8535d0637..9174ac9988 100755 --- a/extra/math/complex/complex-tests.factor +++ b/extra/math/complex/complex-tests.factor @@ -1,6 +1,6 @@ USING: kernel math math.constants math.functions tools.test prettyprint ; -IN: temporary +IN: math.complex.tests [ 1 C{ 0 1 } rect> ] must-fail [ C{ 0 1 } 1 rect> ] must-fail diff --git a/extra/math/erato/erato-tests.factor b/extra/math/erato/erato-tests.factor index 6e961b979c..9244fa62e2 100644 --- a/extra/math/erato/erato-tests.factor +++ b/extra/math/erato/erato-tests.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: lazy-lists math.erato tools.test ; -IN: temporary +IN: math.erato.tests [ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index 6f4dc42593..6773678dab 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -1,6 +1,6 @@ USING: kernel math math.constants math.functions math.private math.libm tools.test ; -IN: temporary +IN: math.functions.tests [ t ] [ 4 4 .00000001 ~ ] unit-test [ t ] [ 4.0000001 4.0000001 .000001 ~ ] unit-test diff --git a/extra/math/matrices/elimination/elimination-tests.factor b/extra/math/matrices/elimination/elimination-tests.factor index d6fb2957e1..7c833391d8 100644 --- a/extra/math/matrices/elimination/elimination-tests.factor +++ b/extra/math/matrices/elimination/elimination-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.matrices.elimination.tests USING: kernel math.matrices math.matrices.elimination tools.test sequences ; diff --git a/extra/math/matrices/matrices-tests.factor b/extra/math/matrices/matrices-tests.factor index 9670ab80b8..ee2516e9a6 100644 --- a/extra/math/matrices/matrices-tests.factor +++ b/extra/math/matrices/matrices-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.matrices.tests USING: math.matrices math.vectors tools.test math ; [ diff --git a/extra/math/miller-rabin/miller-rabin-tests.factor b/extra/math/miller-rabin/miller-rabin-tests.factor index f8bc9d4970..9ca85ea72c 100644 --- a/extra/math/miller-rabin/miller-rabin-tests.factor +++ b/extra/math/miller-rabin/miller-rabin-tests.factor @@ -1,5 +1,5 @@ USING: math.miller-rabin tools.test ; -IN: temporary +IN: math.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test [ t ] [ 2 miller-rabin ] unit-test diff --git a/extra/math/numerical-integration/numerical-integration-tests.factor b/extra/math/numerical-integration/numerical-integration-tests.factor index 33b6e78571..c5b92c73de 100644 --- a/extra/math/numerical-integration/numerical-integration-tests.factor +++ b/extra/math/numerical-integration/numerical-integration-tests.factor @@ -1,6 +1,6 @@ USING: kernel math.numerical-integration tools.test math math.constants math.functions ; -IN: temporary +IN: math.numerical-integration.tests [ 50 ] [ 0 10 [ ] integrate-simpson ] unit-test [ 1000/3 ] [ 0 10 [ sq ] integrate-simpson ] unit-test diff --git a/extra/math/polynomials/polynomials-tests.factor b/extra/math/polynomials/polynomials-tests.factor index 4d0cdf8c8b..73215f9167 100644 --- a/extra/math/polynomials/polynomials-tests.factor +++ b/extra/math/polynomials/polynomials-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.polynomials.tests USING: kernel math math.polynomials tools.test ; ! Tests diff --git a/extra/math/quaternions/quaternions-tests.factor b/extra/math/quaternions/quaternions-tests.factor index 4f59798df0..b30a1bc271 100644 --- a/extra/math/quaternions/quaternions-tests.factor +++ b/extra/math/quaternions/quaternions-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.quaternions.tests USING: tools.test math.quaternions kernel math.vectors math.constants ; diff --git a/extra/math/ranges/ranges-tests.factor b/extra/math/ranges/ranges-tests.factor index 09416814bd..825c68d1b9 100644 --- a/extra/math/ranges/ranges-tests.factor +++ b/extra/math/ranges/ranges-tests.factor @@ -1,5 +1,5 @@ USING: math.ranges sequences tools.test arrays ; -IN: temporary +IN: math.ranges.tests [ { } ] [ 1 1 (a,b) >array ] unit-test [ { } ] [ 1 1 (a,b] >array ] unit-test diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor index 4dba49b908..75572d8415 100755 --- a/extra/math/ratios/ratios-tests.factor +++ b/extra/math/ratios/ratios-tests.factor @@ -1,6 +1,6 @@ USING: kernel math math.parser math.ratios math.functions tools.test ; -IN: temporary +IN: math.ratios.tests [ 1 2 ] [ 1/2 >fraction ] unit-test diff --git a/extra/math/statistics/statistics-tests.factor b/extra/math/statistics/statistics-tests.factor index 4d3b21bbbe..0884e1aed2 100644 --- a/extra/math/statistics/statistics-tests.factor +++ b/extra/math/statistics/statistics-tests.factor @@ -1,5 +1,5 @@ USING: kernel math math.functions math.statistics tools.test ; -IN: temporary +IN: math.statistics.tests [ 1 ] [ { 1 } mean ] unit-test [ 3/2 ] [ { 1 2 } mean ] unit-test diff --git a/extra/math/text/english/english-tests.factor b/extra/math/text/english/english-tests.factor index 00fccde1d3..8f8932c97d 100644 --- a/extra/math/text/english/english-tests.factor +++ b/extra/math/text/english/english-tests.factor @@ -1,5 +1,5 @@ USING: math.functions math.text.english tools.test ; -IN: temporary +IN: math.text.english.tests [ "Zero" ] [ 0 number>text ] unit-test [ "Twenty-One" ] [ 21 number>text ] unit-test diff --git a/extra/math/vectors/vectors-tests.factor b/extra/math/vectors/vectors-tests.factor index 924dc16c44..5c71e2374f 100644 --- a/extra/math/vectors/vectors-tests.factor +++ b/extra/math/vectors/vectors-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: math.vectors.tests USING: math.vectors tools.test ; [ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test diff --git a/extra/models/models-tests.factor b/extra/models/models-tests.factor index ea615d2f9a..bd02c2f708 100755 --- a/extra/models/models-tests.factor +++ b/extra/models/models-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: models.tests USING: arrays generic kernel math models namespaces sequences assocs tools.test ; diff --git a/extra/money/money-tests.factor b/extra/money/money-tests.factor index 19d6b6c2aa..b2ccdf93b7 100644 --- a/extra/money/money-tests.factor +++ b/extra/money/money-tests.factor @@ -1,5 +1,5 @@ USING: money parser tools.test ; -IN: temporary +IN: money.tests [ -1/10 ] [ DECIMAL: -.1 ] unit-test [ -1/10 ] [ DECIMAL: -0.1 ] unit-test diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor index 1c68cbe540..8910e64092 100755 --- a/extra/multi-methods/multi-methods-tests.factor +++ b/extra/multi-methods/multi-methods-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: multi-methods.tests USING: multi-methods tools.test kernel math arrays sequences prettyprint strings classes hashtables assocs namespaces debugger continuations ; diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor index 6f921497b2..2dd3fd911c 100755 --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/extra/parser-combinators/parser-combinators-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel lazy-lists tools.test strings math sequences parser-combinators arrays math.parser unicode.categories ; -IN: temporary +IN: parser-combinators.tests ! Testing <&> { { T{ parse-result f { "a" "b" } T{ slice f 2 4 "abcd" } } } } [ diff --git a/extra/partial-continuations/partial-continuations-tests.factor b/extra/partial-continuations/partial-continuations-tests.factor index 56dc6bcd87..7e876b0934 100644 --- a/extra/partial-continuations/partial-continuations-tests.factor +++ b/extra/partial-continuations/partial-continuations-tests.factor @@ -1,6 +1,6 @@ USING: namespaces math partial-continuations tools.test kernel sequences ; -IN: temporary +IN: partial-continuations.tests SYMBOL: sum diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index a308b9af52..452da8df05 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test peg peg.ebnf ; -IN: temporary +IN: peg.ebnf.tests { T{ ebnf-non-terminal f "abc" } } [ "abc" 'non-terminal' parse parse-result-ast diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor index 6a8d7429f3..7a1ce99883 100644 --- a/extra/peg/peg-tests.factor +++ b/extra/peg/peg-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test strings namespaces arrays sequences peg peg.private ; -IN: temporary +IN: peg.tests { 0 1 2 } [ 0 next-id set-global get-next-id get-next-id get-next-id diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index cec7b24cd0..fa8ac89f57 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test peg peg.pl0 ; -IN: temporary +IN: peg.pl0.tests { "abc" } [ "abc" ident parse parse-result-ast diff --git a/extra/peg/search/search-tests.factor b/extra/peg/search/search-tests.factor index b33161dfff..c65001be09 100755 --- a/extra/peg/search/search-tests.factor +++ b/extra/peg/search/search-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel math math.parser arrays tools.test peg peg.search ; -IN: temporary +IN: peg.search.tests { V{ 123 456 } } [ "abc 123 def 456" 'integer' search diff --git a/extra/porter-stemmer/porter-stemmer-tests.factor b/extra/porter-stemmer/porter-stemmer-tests.factor index d3e031fdc6..7294ac0e8f 100644 --- a/extra/porter-stemmer/porter-stemmer-tests.factor +++ b/extra/porter-stemmer/porter-stemmer-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: porter-stemmer.tests USING: arrays io kernel porter-stemmer sequences tools.test io.files ; diff --git a/extra/random/random-tests.factor b/extra/random/random-tests.factor index 7d506b85f3..d431e57d01 100644 --- a/extra/random/random-tests.factor +++ b/extra/random/random-tests.factor @@ -1,5 +1,5 @@ USING: kernel math random namespaces sequences tools.test ; -IN: temporary +IN: random.tests : check-random ( max -- ? ) dup >r random 0 r> between? ; diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index d4af66b72f..b19c2f39c9 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -1,6 +1,6 @@ USING: arrays kernel sequences sequences.lib math math.functions math.ranges tools.test strings ; -IN: temporary +IN: sequences.lib.tests [ 50 ] [ 100 [1,b] [ even? ] count ] unit-test [ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor index 6c80c8de7d..766103e4b0 100755 --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -4,7 +4,7 @@ USING: tools.test kernel serialize io io.streams.string math alien arrays byte-arrays sequences math prettyprint parser classes math.constants ; -IN: temporary +IN: serialize.tests TUPLE: serialize-test a b ; diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 784f446b7e..c1afeced3d 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,6 +1,6 @@ USING: smtp tools.test io.streams.string threads smtp.server kernel sequences namespaces logging ; -IN: temporary +IN: smtp.tests { 0 0 } [ [ ] with-smtp-connection ] must-infer-as diff --git a/extra/taxes/taxes-tests.factor b/extra/taxes/taxes-tests.factor index 4091156558..6aeb5aa098 100644 --- a/extra/taxes/taxes-tests.factor +++ b/extra/taxes/taxes-tests.factor @@ -1,5 +1,5 @@ USING: kernel money taxes tools.test ; -IN: temporary +IN: taxes.tests [ 426 23 diff --git a/extra/tools/annotations/annotations-tests.factor b/extra/tools/annotations/annotations-tests.factor index 90d9d26f51..ec8f48a161 100755 --- a/extra/tools/annotations/annotations-tests.factor +++ b/extra/tools/annotations/annotations-tests.factor @@ -1,5 +1,5 @@ USING: tools.test tools.annotations math parser ; -IN: temporary +IN: tools.annotations.tests : foo ; \ foo watch @@ -17,7 +17,7 @@ M: integer some-generic 1+ ; [ 4 ] [ 3 some-generic ] unit-test -[ ] [ "IN: temporary USE: math M: integer some-generic 1- ;" eval ] unit-test +[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval ] unit-test [ 2 ] [ 3 some-generic ] unit-test diff --git a/extra/tools/browser/browser-tests.factor b/extra/tools/browser/browser-tests.factor index fc7960e475..38d9ae65e2 100755 --- a/extra/tools/browser/browser-tests.factor +++ b/extra/tools/browser/browser-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: tools.browser.tests USING: tools.browser tools.test help.markup ; [ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test diff --git a/extra/tools/crossref/crossref-tests.factor b/extra/tools/crossref/crossref-tests.factor index b616766597..8616be141e 100755 --- a/extra/tools/crossref/crossref-tests.factor +++ b/extra/tools/crossref/crossref-tests.factor @@ -1,6 +1,6 @@ USING: math kernel sequences io.files tools.crossref tools.test parser namespaces source-files generic definitions ; -IN: temporary +IN: tools.crossref.tests GENERIC: foo diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 2f79669497..d473d8f640 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config tools.deploy.backend math ; diff --git a/extra/tools/memory/memory-tests.factor b/extra/tools/memory/memory-tests.factor index 36bcc73b74..9efbf63f7f 100644 --- a/extra/tools/memory/memory-tests.factor +++ b/extra/tools/memory/memory-tests.factor @@ -1,4 +1,4 @@ USING: tools.test tools.memory ; -IN: temporary +IN: tools.memory.tests [ ] [ heap-stats. ] unit-test diff --git a/extra/tools/profiler/profiler-tests.factor b/extra/tools/profiler/profiler-tests.factor index c346d9763c..e33201e22c 100755 --- a/extra/tools/profiler/profiler-tests.factor +++ b/extra/tools/profiler/profiler-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: tools.profiler.tests USING: tools.profiler tools.test kernel memory math threads alien tools.profiler.private sequences ; diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index a8c7239922..743822e7f9 100755 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -43,7 +43,7 @@ $nl } "The latter is used for vocabularies with more extensive test suites." $nl -"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run." +"If the test harness needs to define words, they should be placed in a vocabulary named " { $snippet { $emphasis "vocab" } ".tests" } " where " { $emphasis "vocab" } " is the vocab being tested." { $subsection "tools.test.write" } { $subsection "tools.test.run" } { $subsection "tools.test.failure" } ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 0ab68f502e..259b91c3af 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -50,13 +50,8 @@ SYMBOL: this-test : (run-test) ( vocab -- ) dup vocab-source-loaded? [ - vocab-tests - [ - "temporary" forget-vocab - dup [ forget-source ] each - ] with-compilation-unit - dup [ run-file ] each - ] when drop ; + vocab-tests [ run-file ] each + ] [ drop ] if ; : run-test ( vocab -- failures ) V{ } clone [ diff --git a/extra/tools/test/tools.factor b/extra/tools/test/tools.factor index 7699d61062..bf74c1ae98 100644 --- a/extra/tools/test/tools.factor +++ b/extra/tools/test/tools.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: tools.test.tests USING: completion words sequences test ; [ ] [ "swp" apropos ] unit-test diff --git a/extra/tools/walker/walker-tests.factor b/extra/tools/walker/walker-tests.factor index 1302ebe3d8..2d4a6c3396 100755 --- a/extra/tools/walker/walker-tests.factor +++ b/extra/tools/walker/walker-tests.factor @@ -1,7 +1,7 @@ USING: tools.walker io io.streams.string kernel math math.private namespaces prettyprint sequences tools.test continuations math.parser threads arrays tools.walker.debug ; -IN: temporary +IN: tools.walker.tests [ { } ] [ [ ] test-walker diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor index 0964ea7e56..570125cb45 100644 --- a/extra/trees/avl/avl-tests.factor +++ b/extra/trees/avl/avl-tests.factor @@ -1,5 +1,5 @@ USING: kernel tools.test trees trees.avl math random sequences assocs ; -IN: temporary +IN: trees.avl.tests [ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } diff --git a/extra/trees/splay/splay-tests.factor b/extra/trees/splay/splay-tests.factor index 5075163802..29ea2eee2d 100644 --- a/extra/trees/splay/splay-tests.factor +++ b/extra/trees/splay/splay-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test trees.splay math namespaces assocs sequences random ; -IN: temporary +IN: trees.splay.tests : randomize-numeric-splay-tree ( splay-tree -- ) 100 [ drop 100 random swap at drop ] with each ; diff --git a/extra/trees/trees-tests.factor b/extra/trees/trees-tests.factor index 2795b0d5da..fd26b37c70 100644 --- a/extra/trees/trees-tests.factor +++ b/extra/trees/trees-tests.factor @@ -1,5 +1,5 @@ USING: trees assocs tools.test kernel sequences ; -IN: temporary +IN: trees.tests : test-tree ( -- tree ) TREE{ diff --git a/extra/tuple-syntax/tuple-syntax-tests.factor b/extra/tuple-syntax/tuple-syntax-tests.factor index 0a9711c446..2eb9d8bb12 100755 --- a/extra/tuple-syntax/tuple-syntax-tests.factor +++ b/extra/tuple-syntax/tuple-syntax-tests.factor @@ -1,5 +1,5 @@ USING: tools.test tuple-syntax ; -IN: temporary +IN: tuple-syntax.tests TUPLE: foo bar baz ; diff --git a/extra/tuples/lib/lib-tests.factor b/extra/tuples/lib/lib-tests.factor index 88c09d81c4..5d90f25bd7 100644 --- a/extra/tuples/lib/lib-tests.factor +++ b/extra/tuples/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: kernel tools.test tuples.lib ; -IN: temporary +IN: tuples.lib.tests TUPLE: foo a b* c d* e f* ; diff --git a/extra/ui/commands/commands-tests.factor b/extra/ui/commands/commands-tests.factor index de9534ab74..8001ff9761 100644 --- a/extra/ui/commands/commands-tests.factor +++ b/extra/ui/commands/commands-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.commands.tests USING: ui.commands ui.gestures tools.test help.markup io io.streams.string ; diff --git a/extra/ui/gadgets/books/books-tests.factor b/extra/ui/gadgets/books/books-tests.factor index 9e1b0aa985..dab9ef5acf 100755 --- a/extra/ui/gadgets/books/books-tests.factor +++ b/extra/ui/gadgets/books/books-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.books.tests USING: tools.test ui.gadgets.books ; \ must-infer diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/extra/ui/gadgets/buttons/buttons-tests.factor index 224ef9e1ce..6c5d757dd4 100755 --- a/extra/ui/gadgets/buttons/buttons-tests.factor +++ b/extra/ui/gadgets/buttons/buttons-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.buttons.tests USING: ui.commands ui.gadgets.buttons ui.gadgets.labels ui.gadgets tools.test namespaces sequences kernel models ; diff --git a/extra/ui/gadgets/frames/frames-tests.factor b/extra/ui/gadgets/frames/frames-tests.factor index 80cf70b960..e38e97c76c 100644 --- a/extra/ui/gadgets/frames/frames-tests.factor +++ b/extra/ui/gadgets/frames/frames-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.frames.tests USING: ui.gadgets.frames ui.gadgets tools.test ; [ ] [ layout ] unit-test diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor index 54bae31f79..0a44e5e267 100755 --- a/extra/ui/gadgets/gadgets-tests.factor +++ b/extra/ui/gadgets/gadgets-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.tests USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test namespaces models kernel dlists math math.parser ui sequences hashtables assocs io arrays diff --git a/extra/ui/gadgets/grids/grids-tests.factor b/extra/ui/gadgets/grids/grids-tests.factor index 6f08009da3..0792d55135 100644 --- a/extra/ui/gadgets/grids/grids-tests.factor +++ b/extra/ui/gadgets/grids/grids-tests.factor @@ -1,6 +1,6 @@ USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays namespaces ; -IN: temporary +IN: ui.gadgets.grids.tests [ { 0 0 } ] [ { } pref-dim ] unit-test diff --git a/extra/ui/gadgets/labelled/labelled-tests.factor b/extra/ui/gadgets/labelled/labelled-tests.factor index 87b2a45678..377f3ab787 100644 --- a/extra/ui/gadgets/labelled/labelled-tests.factor +++ b/extra/ui/gadgets/labelled/labelled-tests.factor @@ -1,7 +1,7 @@ USING: ui.gadgets ui.gadgets.labels ui.gadgets.labelled ui.gadgets.packs ui.gadgets.frames ui.gadgets.grids namespaces kernel tools.test ui.gadgets.buttons sequences ; -IN: temporary +IN: ui.gadgets.labelled.tests TUPLE: testing ; diff --git a/extra/ui/gadgets/lists/lists-tests.factor b/extra/ui/gadgets/lists/lists-tests.factor index 44a89a7e60..bf2ad72d0e 100644 --- a/extra/ui/gadgets/lists/lists-tests.factor +++ b/extra/ui/gadgets/lists/lists-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.lists.tests USING: ui.gadgets.lists models prettyprint math tools.test kernel ; diff --git a/extra/ui/gadgets/packs/packs-tests.factor b/extra/ui/gadgets/packs/packs-tests.factor index ce6df74769..28a656e2ad 100644 --- a/extra/ui/gadgets/packs/packs-tests.factor +++ b/extra/ui/gadgets/packs/packs-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.packs.tests USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render kernel namespaces tools.test math.parser sequences ; diff --git a/extra/ui/gadgets/panes/panes-tests.factor b/extra/ui/gadgets/panes/panes-tests.factor index 848f7919d3..e3f6e36050 100755 --- a/extra/ui/gadgets/panes/panes-tests.factor +++ b/extra/ui/gadgets/panes/panes-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.panes.tests USING: alien ui.gadgets.panes ui.gadgets namespaces kernel sequences io io.streams.string tools.test prettyprint definitions help help.syntax help.markup splitting diff --git a/extra/ui/gadgets/presentations/presentations-tests.factor b/extra/ui/gadgets/presentations/presentations-tests.factor index c4f693c939..46f274d53a 100644 --- a/extra/ui/gadgets/presentations/presentations-tests.factor +++ b/extra/ui/gadgets/presentations/presentations-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.presentations.tests USING: math ui.gadgets.presentations ui.gadgets tools.test prettyprint ui.gadgets.buttons io io.streams.string kernel tuples ; diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/extra/ui/gadgets/scrollers/scrollers-tests.factor index dd667fdfec..5ccd6c7cd8 100755 --- a/extra/ui/gadgets/scrollers/scrollers-tests.factor +++ b/extra/ui/gadgets/scrollers/scrollers-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.scrollers.tests USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test kernel models ui.gadgets.viewports ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames diff --git a/extra/ui/gadgets/slots/slots-tests.factor b/extra/ui/gadgets/slots/slots-tests.factor index 5388794624..b955a2604d 100644 --- a/extra/ui/gadgets/slots/slots-tests.factor +++ b/extra/ui/gadgets/slots/slots-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.slots.tests USING: assocs ui.gadgets.slots tools.test refs ; [ t ] [ { 1 2 3 } 2 slot-editor? ] unit-test diff --git a/extra/ui/gadgets/tracks/tracks-tests.factor b/extra/ui/gadgets/tracks/tracks-tests.factor index 77c69bc8a8..e2db914089 100644 --- a/extra/ui/gadgets/tracks/tracks-tests.factor +++ b/extra/ui/gadgets/tracks/tracks-tests.factor @@ -1,5 +1,5 @@ USING: kernel ui.gadgets ui.gadgets.tracks tools.test ; -IN: temporary +IN: ui.gadgets.tracks.tests [ { 100 100 } ] [ [ diff --git a/extra/ui/gadgets/worlds/worlds-tests.factor b/extra/ui/gadgets/worlds/worlds-tests.factor index 949ad49460..2e186d875d 100644 --- a/extra/ui/gadgets/worlds/worlds-tests.factor +++ b/extra/ui/gadgets/worlds/worlds-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.gadgets.worlds.tests USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test namespaces models kernel ; diff --git a/extra/ui/operations/operations-tests.factor b/extra/ui/operations/operations-tests.factor index b7b2224cfa..1e3d08f164 100755 --- a/extra/ui/operations/operations-tests.factor +++ b/extra/ui/operations/operations-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.operations.tests USING: ui.operations ui.commands prettyprint kernel namespaces tools.test ui.gadgets ui.gadgets.editors parser io io.streams.string math help help.markup ; diff --git a/extra/ui/tools/browser/browser-tests.factor b/extra/ui/tools/browser/browser-tests.factor index 7262c72756..f56f5bcc4e 100755 --- a/extra/ui/tools/browser/browser-tests.factor +++ b/extra/ui/tools/browser/browser-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.tools.browser.tests USING: tools.test tools.test.ui ui.tools.browser ; \ must-infer diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor index 0422c4170a..fe0a654217 100755 --- a/extra/ui/tools/interactor/interactor-tests.factor +++ b/extra/ui/tools/interactor/interactor-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.tools.interactor.tests USING: ui.tools.interactor tools.test ; \ must-infer diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index 0024fa725f..13ce834df3 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -3,7 +3,7 @@ ui.tools.listener hashtables kernel namespaces parser sequences tools.test ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.panes vocabs words tools.test.ui slots.private threads ; -IN: temporary +IN: ui.tools.listener.tests [ f ] [ "word" source-editor command-map empty? ] unit-test diff --git a/extra/ui/tools/search/search-tests.factor b/extra/ui/tools/search/search-tests.factor index 49bd1a3837..4a75ebfc96 100755 --- a/extra/ui/tools/search/search-tests.factor +++ b/extra/ui/tools/search/search-tests.factor @@ -2,7 +2,7 @@ USING: assocs ui.tools.search help.topics io.files io.styles kernel namespaces sequences source-files threads tools.test ui.gadgets ui.gestures vocabs vocabs.loader words tools.test.ui debugger ; -IN: temporary +IN: ui.tools.search.tests [ f ] [ "no such word with this name exists, certainly" diff --git a/extra/ui/tools/tools-tests.factor b/extra/ui/tools/tools-tests.factor index ff2444e43b..279737466f 100755 --- a/extra/ui/tools/tools-tests.factor +++ b/extra/ui/tools/tools-tests.factor @@ -3,7 +3,7 @@ ui.tools.search ui.tools.workspace kernel models namespaces sequences tools.test ui.gadgets ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.presentations ui.gadgets.scrollers vocabs tools.test.ui ui ; -IN: temporary +IN: ui.tools.tests [ [ f ] [ diff --git a/extra/ui/tools/walker/walker-tests.factor b/extra/ui/tools/walker/walker-tests.factor index 36b2abb7dd..fefb188239 100755 --- a/extra/ui/tools/walker/walker-tests.factor +++ b/extra/ui/tools/walker/walker-tests.factor @@ -1,4 +1,4 @@ USING: ui.tools.walker tools.test ; -IN: temporary +IN: ui.tools.walker.tests \ must-infer diff --git a/extra/ui/tools/workspace/workspace-tests.factor b/extra/ui/tools/workspace/workspace-tests.factor index 5e3695fed3..49b14cda77 100755 --- a/extra/ui/tools/workspace/workspace-tests.factor +++ b/extra/ui/tools/workspace/workspace-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.tools.workspace.tests USING: tools.test ui.tools ; \ must-infer diff --git a/extra/ui/traverse/traverse-tests.factor b/extra/ui/traverse/traverse-tests.factor index 37b3f25321..5e6ac4125b 100755 --- a/extra/ui/traverse/traverse-tests.factor +++ b/extra/ui/traverse/traverse-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: ui.traverse.tests USING: ui.gadgets ui.gadgets.labels namespaces sequences kernel math arrays tools.test io ui.gadgets.panes ui.traverse definitions compiler.units ; diff --git a/extra/units/imperial/imperial-tests.factor b/extra/units/imperial/imperial-tests.factor index def13bd784..793fe5679d 100644 --- a/extra/units/imperial/imperial-tests.factor +++ b/extra/units/imperial/imperial-tests.factor @@ -1,5 +1,5 @@ USING: kernel math tools.test units.imperial inverse ; -IN: temporary +IN: units.imperial.tests [ 1 ] [ 12 inches [ feet ] undo ] unit-test [ 12 ] [ 1 feet [ inches ] undo ] unit-test diff --git a/extra/units/si/si-tests.factor b/extra/units/si/si-tests.factor index 85d2bd3317..9fb702f050 100644 --- a/extra/units/si/si-tests.factor +++ b/extra/units/si/si-tests.factor @@ -1,6 +1,6 @@ USING: kernel tools.test units.si inverse math.constants math.functions units.imperial ; -IN: temporary +IN: units.si.tests [ t ] [ 1 m 100 cm = ] unit-test diff --git a/extra/units/units-tests.factor b/extra/units/units-tests.factor index 28ab9ab7c4..81f3163a77 100644 --- a/extra/units/units-tests.factor +++ b/extra/units/units-tests.factor @@ -1,6 +1,6 @@ USING: arrays kernel math sequences tools.test units.si units.imperial units inverse math.functions ; -IN: temporary +IN: units.tests [ T{ dimensioned f 3 { m } { } } ] [ 3 m ] unit-test [ T{ dimensioned f 3 { m } { s } } ] [ 3 m/s ] unit-test diff --git a/extra/xml/tests/arithmetic.factor b/extra/xml/tests/arithmetic.factor index 371bf2d605..577ef5718c 100644 --- a/extra/xml/tests/arithmetic.factor +++ b/extra/xml/tests/arithmetic.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -IN: xml-arith +IN: xml.tests USING: xml io kernel math sequences strings xml.utilities tools.test math.parser ; PROCESS: calculate ( tag -- n ) diff --git a/extra/xml/tests/soap.factor b/extra/xml/tests/soap.factor index 8b7d17553b..775930025f 100755 --- a/extra/xml/tests/soap.factor +++ b/extra/xml/tests/soap.factor @@ -1,5 +1,5 @@ USING: sequences xml kernel arrays xml.utilities io.files tools.test ; -IN: temporary +IN: xml.tests : assemble-data ( tag -- 3array ) { "URL" "snippet" "title" } diff --git a/extra/xml/tests/templating.factor b/extra/xml/tests/templating.factor index 2dd69ca99b..6db98ec848 100644 --- a/extra/xml/tests/templating.factor +++ b/extra/xml/tests/templating.factor @@ -1,5 +1,6 @@ USING: kernel xml sequences assocs tools.test io arrays namespaces xml.data xml.utilities xml.writer generic sequences.deep ; +IN: xml.tests : sub-tag T{ name f f "sub" "http://littledan.onigirihouse.com/namespaces/replace" } ; diff --git a/extra/xml/tests/test.factor b/extra/xml/tests/test.factor index 871425559b..02c7aecb13 100644 --- a/extra/xml/tests/test.factor +++ b/extra/xml/tests/test.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -IN: temporary +IN: xml.tests USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities parser strings xml.data io.files xml.writer xml.utilities state-parser continuations assocs sequences.deep ; diff --git a/extra/xmode/catalog/catalog-tests.factor b/extra/xmode/catalog/catalog-tests.factor index d5420ed2e3..75e377bc97 100644 --- a/extra/xmode/catalog/catalog-tests.factor +++ b/extra/xmode/catalog/catalog-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: xmode.catalog.tests USING: xmode.catalog tools.test hashtables assocs kernel sequences io ; diff --git a/extra/xmode/keyword-map/keyword-map-tests.factor b/extra/xmode/keyword-map/keyword-map-tests.factor index 9fbe9110e8..b14bbd0f70 100644 --- a/extra/xmode/keyword-map/keyword-map-tests.factor +++ b/extra/xmode/keyword-map/keyword-map-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: xmode.keyword-map.tests USING: xmode.keyword-map xmode.tokens tools.test namespaces assocs kernel strings ; diff --git a/extra/xmode/marker/marker-tests.factor b/extra/xmode/marker/marker-tests.factor index 6bcba91c84..1d059852e2 100755 --- a/extra/xmode/marker/marker-tests.factor +++ b/extra/xmode/marker/marker-tests.factor @@ -1,6 +1,6 @@ USING: xmode.tokens xmode.catalog xmode.marker tools.test kernel ; -IN: temporary +IN: xmode.marker.tests [ { diff --git a/extra/xmode/rules/rules-tests.factor b/extra/xmode/rules/rules-tests.factor index 404dbb89fb..5fc62f39e9 100644 --- a/extra/xmode/rules/rules-tests.factor +++ b/extra/xmode/rules/rules-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: xmode.rules.tests USING: xmode.rules tools.test ; [ { 1 2 3 } ] [ f { 1 2 3 } ?push-all ] unit-test diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor index 713700bf7a..bbb19a7555 100755 --- a/extra/xmode/utilities/utilities-tests.factor +++ b/extra/xmode/utilities/utilities-tests.factor @@ -1,4 +1,4 @@ -IN: temporary +IN: xmode.utilities.tests USING: xmode.utilities tools.test xml xml.data kernel strings vectors sequences io.files prettyprint assocs unicode.case ; From 12d254f62973cab4ac8bcb57825d8245dc79ede2 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 2 Mar 2008 00:33:37 -0600 Subject: [PATCH 052/140] io.files tests: minor fix --- core/io/files/files-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 850a30380b..92cc548d89 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -101,7 +101,7 @@ USING: tools.test io.files io threads kernel continuations ; [ ] [ "copy-tree-test" temp-file - "copy-destination" temp-file copy-tree-to + "copy-destination" temp-file copy-tree-into ] unit-test [ "Foobar" ] [ @@ -109,7 +109,7 @@ USING: tools.test io.files io threads kernel continuations ; ] unit-test [ ] [ - "copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-to + "copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-into ] unit-test [ "Foobar" ] [ From 67eade4a296a617d2ad7e82d010fb3ff5a5d8186 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 2 Mar 2008 18:49:04 -0500 Subject: [PATCH 053/140] Fix refresh-all --- core/vocabs/loader/loader.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 57743ce9e1..acc6c783a5 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -180,8 +180,7 @@ SYMBOL: sources-changed? [ t sources-changed? set-global ] "vocabs.loader" add-init-hook : refresh-all ( -- ) - sources-changed? get-global - [ "" refresh f sources-changed? set-global ] when ; + "" refresh f sources-changed? set-global ; GENERIC: (load-vocab) ( name -- vocab ) From 151c62d609d1b5437e0bb824e7be5a36a23ff53b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 2 Mar 2008 18:51:35 -0500 Subject: [PATCH 054/140] Fix bootstrap.image.upload --- extra/bootstrap/image/upload/upload.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 110547d963..084f30a103 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -8,7 +8,7 @@ SYMBOL: upload-images-destination : destination ( -- dest ) upload-images-destination get - "slava@/var/www/factorcode.org/w/images/latest/" + "slava@/var/www/factorcode.org/newsite/images/latest/" or ; : checksums "checksums.txt" temp-file ; From c26b1a895f8ff2580c408cba41acf4eec9e51e0d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Mar 2008 02:19:36 -0600 Subject: [PATCH 055/140] More httpd work --- extra/http/http-tests.factor | 11 ++- extra/http/http.factor | 10 +- extra/http/server/actions/actions.factor | 12 +++ extra/http/server/callbacks/callbacks.factor | 53 ++--------- extra/http/server/db/db.factor | 13 +++ extra/http/server/server-tests.factor | 8 ++ extra/http/server/server.factor | 92 +++++++++++++------ .../server/sessions/sessions-tests.factor | 4 +- extra/http/server/sessions/sessions.factor | 22 ++--- extra/http/server/static/static.factor | 18 +++- 10 files changed, 148 insertions(+), 95 deletions(-) create mode 100755 extra/http/server/actions/actions.factor create mode 100755 extra/http/server/db/db.factor diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 51cc933736..b706f34d13 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -18,6 +18,11 @@ IN: http.tests [ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test +[ "/" ] [ "http://foo.com" url>path ] unit-test +[ "/" ] [ "http://foo.com/" url>path ] unit-test +[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test +[ "/bar" ] [ "/bar" url>path ] unit-test + STRING: read-request-test-1 GET http://foo/bar HTTP/1.1 Some-Header: 1 @@ -31,7 +36,7 @@ blah TUPLE{ request port: 80 method: "GET" - path: "bar" + path: "/bar" query: H{ } version: "1.1" header: H{ { "some-header" "1; 2" } { "content-length" "4" } } @@ -45,7 +50,7 @@ blah ] unit-test STRING: read-request-test-1' -GET bar HTTP/1.1 +GET /bar HTTP/1.1 content-length: 4 some-header: 1; 2 @@ -69,7 +74,7 @@ Host: www.sex.com TUPLE{ request port: 80 method: "HEAD" - path: "bar" + path: "/bar" query: H{ } version: "1.1" header: H{ { "host" "www.sex.com" } } diff --git a/extra/http/http.factor b/extra/http/http.factor index 8686d87052..35fe3ce544 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -180,9 +180,15 @@ cookies ; : set-query-param ( request value key -- request ) pick query>> set-at ; +: chop-hostname ( str -- str' ) + CHAR: / over index over length or tail + dup empty? [ drop "/" ] when ; + : url>path ( url -- path ) - url-decode "http://" ?head - [ "/" split1 "" or nip ] [ "/" ?head drop ] if ; + #! Technically, only proxies are meant to support hostnames + #! in HTTP requests, but IE sends these sometimes so we + #! just chop the hostname part. + url-decode "http://" ?head [ chop-hostname ] when ; : read-method ( request -- request ) " " read-until [ "Bad request: method" throw ] unless diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor new file mode 100755 index 0000000000..4396c7a9da --- /dev/null +++ b/extra/http/server/actions/actions.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.actions + +TUPLE: action quot params method ; + +C: action + +: extract-params ( assoc action -- ... ) + params>> [ first2 >r swap at r> call ] with each ; + +: call-action ; diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index a000a76040..fd2e8f8ad7 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -50,12 +50,12 @@ SYMBOL: exit-continuation #! When executed inside a 'show' call, this will force a #! HTTP 302 to occur to instruct the browser to forward to #! the request URL. - exit-with ; + request get swap exit-with ; : cont-id "factorcontid" ; : id>url ( id -- url ) - request get clone + request get swap cont-id associate >>query request-url ; @@ -102,9 +102,8 @@ SYMBOL: current-show [ restore-request store-current-show ] when* ; : show-final ( quot -- * ) - [ - >r store-current-show redirect-to-here r> call exit-with - ] with-scope ; inline + >r redirect-to-here store-current-show + r> call exit-with ; inline M: callback-responder call-responder [ @@ -122,49 +121,15 @@ M: callback-responder call-responder ] callcc1 >r 3drop r> ; : show-page ( quot -- ) + >r redirect-to-here store-current-show r> [ - >r store-current-show redirect-to-here r> - [ - [ ] register-callback - call - exit-with - ] callcc1 restore-request - ] with-scope ; inline + [ ] register-callback + with-scope + exit-with + ] callcc1 restore-request ; inline : quot-id ( quot -- id ) current-show get swap t register-callback ; : quot-url ( quot -- url ) quot-id id>url ; - -! SYMBOL: current-show -! -! : store-current-show ( -- ) -! #! Store the current continuation in the variable 'current-show' -! #! so it can be returned to later by href callbacks. Note that it -! #! recalls itself when the continuation is called to ensure that -! #! it resets its value back to the most recent show call. -! [ ( 0 -- ) -! [ ( 0 1 -- ) -! current-show set ( 0 -- ) -! continue -! ] callcc1 -! nip -! store-current-show -! ] callcc0 ; -! - -! -! : show-final ( quot -- * ) -! store-current-show -! redirect-to-here -! call -! exit-with ; inline -! -! : show-page ( quot -- request ) -! store-current-show redirect-to-here -! [ -! register-continuation -! call -! exit-with -! ] callcc1 restore-request ; inline diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor new file mode 100755 index 0000000000..ab45570b88 --- /dev/null +++ b/extra/http/server/db/db.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: db http.server kernel new-slots accessors ; +IN: http.server.db + +TUPLE: db-persistence responder db params ; + +C: db-persistence + +M: db-persistence call-responder + dup db>> over params>> [ + responder>> call-responder + ] with-db ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 864df9204d..0635e1f895 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -51,3 +51,11 @@ M: mock-responder call-responder header>> "location" swap at "baz/" tail? r> and ] unit-test ] with-scope + +[ + + "default" >>default + default-host set + + [ "/default" ] [ "/default" default-host get find-responder drop ] unit-test +] with-scope diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 3780b2110d..f71b1d3ec6 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -3,7 +3,7 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar new-slots html.elements accessors math.parser combinators.lib -vocabs.loader debugger html continuations random ; +vocabs.loader debugger html continuations random combinators ; IN: http.server GENERIC: call-responder ( request path responder -- response ) @@ -12,7 +12,7 @@ TUPLE: trivial-responder response ; C: trivial-responder -M: trivial-responder call-responder 2nip response>> call ; +M: trivial-responder call-responder nip response>> call ; : trivial-response-body ( code message -- ) @@ -33,18 +33,26 @@ M: trivial-responder call-responder 2nip response>> call ; SYMBOL: 404-responder -[ <404> ] 404-responder set-global +[ drop <404> ] 404-responder set-global -: ( to code message -- response ) +: modify-for-redirect ( request to -- url ) + { + { [ dup "http://" head? ] [ nip ] } + { [ dup "/" head? ] [ >>path request-url ] } + { [ t ] [ >r dup path>> "/" last-split1 drop "/" r> 3append >>path request-url ] } + } cond ; + +: ( request to code message -- response ) - swap "location" set-header ; + -rot modify-for-redirect + "location" set-header ; \ DEBUG add-input-logging -: ( to -- response ) +: ( request to -- response ) 301 "Moved Permanently" ; -: ( to -- response ) +: ( request to -- response ) 307 "Temporary Redirect" ; : ( content-type -- response ) @@ -54,31 +62,46 @@ SYMBOL: 404-responder TUPLE: dispatcher default responders ; -: get-responder ( name dispatcher -- responder ) - tuck responders>> at [ ] [ default>> ] ?if ; +: ( -- dispatcher ) + 404-responder H{ } clone dispatcher construct-boa ; + +: set-main ( dispatcher name -- dispatcher ) + [ ] curry + >>default ; + +: split-path ( path -- rest first ) + [ CHAR: / = ] left-trim "/" split1 swap ; : find-responder ( path dispatcher -- path responder ) - >r [ CHAR: / = ] left-trim "/" split1 - swap [ CHAR: / = ] right-trim r> get-responder ; + over split-path pick responders>> at* + [ >r >r 2drop r> r> ] [ 2drop default>> ] if ; : redirect-with-/ ( request -- response ) - dup path>> "/" append >>path - request-url ; + dup path>> "/" append ; M: dispatcher call-responder over [ - find-responder call-responder + 3dup find-responder call-responder [ + >r 3drop r> + ] [ + default>> [ + call-responder + ] [ + 3drop f + ] if* + ] if* ] [ 2drop redirect-with-/ ] if ; -: ( -- dispatcher ) - 404-responder get-global H{ } clone - dispatcher construct-boa ; - : add-responder ( dispatcher responder path -- dispatcher ) pick responders>> set-at ; +: add-main-responder ( dispatcher responder path -- dispatcher ) + [ add-responder ] keep set-main ; + +: ( class -- dispatcher ) + swap construct-delegate ; inline SYMBOL: virtual-hosts SYMBOL: default-host @@ -88,23 +111,33 @@ default-host global [ drop 404-responder get-global ] cache drop : find-virtual-host ( host -- responder ) virtual-hosts get at [ default-host get ] unless* ; +SYMBOL: development-mode + : <500> ( error -- response ) 500 "Internal server error" swap [ "Internal server error" [ - [ print-error nl :c ] with-html-stream + development-mode get [ + [ print-error nl :c ] with-html-stream + ] [ + 500 "Internal server error" + trivial-response-body + ] if ] simple-page ] curry >>body ; -: handle-request ( request -- ) - [ - dup dup path>> over host>> - find-virtual-host call-responder - ] [ <500> ] recover +: do-response ( request response -- ) dup write-response swap method>> "HEAD" = [ drop ] [ write-response-body ] if ; +: do-request ( request -- request ) + [ + dup dup path>> over host>> + find-virtual-host call-responder + [ <404> ] unless* + ] [ dup \ do-request log-error <500> ] recover ; + : default-timeout 1 minutes stdio get set-timeout ; LOG: httpd-hit NOTICE @@ -112,16 +145,17 @@ LOG: httpd-hit NOTICE : log-request ( request -- ) { method>> host>> path>> } map-exec-with httpd-hit ; -SYMBOL: development-mode - -: (httpd) ( -- ) +: handle-client ( -- ) default-timeout development-mode get-global [ global [ refresh-all ] bind ] when - read-request dup log-request handle-request ; + read-request + dup log-request + do-request do-response ; : httpd ( port -- ) - internet-server "http.server" [ (httpd) ] with-server ; + internet-server "http.server" + [ handle-client ] with-server ; : httpd-main ( -- ) 8888 httpd ; diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 988ae41609..4c21ba3c8d 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -1,7 +1,9 @@ -IN: temporary +IN: http.server.sessions.tests USING: tools.test http.server.sessions math namespaces kernel accessors ; +: with-session \ session swap with-variable ; inline + "1234" f [ [ ] [ 3 "x" sset ] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 4db256ca72..2977e5938d 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -9,10 +9,12 @@ IN: http.server.sessions ! WARNING: this session manager is vulnerable to XSRF attacks ! ! ! ! ! ! -TUPLE: session-manager responder init sessions ; +GENERIC: init-session ( responder -- ) + +TUPLE: session-manager responder sessions ; : ( responder class -- responder' ) - >r [ ] H{ } clone session-manager construct-boa r> + >r H{ } clone session-manager construct-boa r> construct-delegate ; inline TUPLE: session id manager namespace alarm ; @@ -42,13 +44,10 @@ TUPLE: session id manager namespace alarm ; : schange ( key quot -- ) session swap change-at ; inline -: with-session ( session quot -- ) - >r \ session r> with-variable ; inline - : new-session ( responder -- id ) [ sessions>> generate-key dup ] keep [ dup touch-session ] keep - [ init>> with-session ] 2keep + [ swap \ session [ responder>> init-session ] with-variable ] 2keep >r over r> sessions>> set-at ; : get-session ( id responder -- session ) @@ -59,7 +58,7 @@ TUPLE: session id manager namespace alarm ; ] if ; : call-responder/session ( request path responder session -- response ) - [ responder>> call-responder ] with-session ; + \ session set responder>> call-responder ; : sessions ( -- manager/f ) \ session get dup [ manager>> ] when ; @@ -82,7 +81,7 @@ M: url-sessions call-responder ( request path responder -- response ) call-responder/session ] [ new-session nip sess-id set-query-param - request-url + dup request-url ] if* ; M: url-sessions session-link* @@ -96,14 +95,15 @@ TUPLE: cookie-sessions ; : ( responder -- responder' ) cookie-sessions ; -: get-session-cookie ( request -- cookie ) - sess-id get-cookie ; +: get-session-cookie ( request responder -- cookie ) + >r sess-id get-cookie dup + [ value>> r> get-session ] [ r> 2drop f ] if ; : ( id -- cookie ) sess-id ; M: cookie-sessions call-responder ( request path responder -- response ) - pick get-session-cookie value>> over get-session [ + 3dup nip get-session-cookie [ call-responder/session ] [ dup new-session diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index e1a7a3cae9..10a3df4de8 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -87,9 +87,17 @@ TUPLE: file-responder root hook special ; drop <404> ] if ; +: <400> 400 "Bad request" ; + M: file-responder call-responder ( request path responder -- response ) - [ - responder set - swap request set - serve-object - ] with-scope ; + over [ + ".." pick subseq? [ + 3drop <400> + ] [ + responder set + swap request set + serve-object + ] if + ] [ + 2drop redirect-with-/ + ] if ; From e555c00287126c92193fddeb5cfec72a688c4967 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Mar 2008 02:22:27 -0600 Subject: [PATCH 056/140] Fix alarms bug --- extra/alarms/alarms-tests.factor | 17 +++++++++++++++++ extra/alarms/alarms.factor | 5 ++--- 2 files changed, 19 insertions(+), 3 deletions(-) create mode 100755 extra/alarms/alarms-tests.factor diff --git a/extra/alarms/alarms-tests.factor b/extra/alarms/alarms-tests.factor new file mode 100755 index 0000000000..1af851c9c6 --- /dev/null +++ b/extra/alarms/alarms-tests.factor @@ -0,0 +1,17 @@ +IN: alarms.tests +USING: alarms kernel calendar sequences tools.test threads +concurrency.count-downs ; + +[ ] [ + 1 + { f } clone 2dup + [ first cancel-alarm count-down ] 2curry 1 seconds later + swap set-first + await +] unit-test + +[ ] [ + [ + [ resume ] curry instant later drop + ] "test" suspend drop +] unit-test diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index d008b7b462..1ccfdcbd30 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -37,8 +37,8 @@ SYMBOL: alarm-thread register-alarm ; : call-alarm ( alarm -- ) - dup alarm-quot try dup alarm-entry box> drop + dup alarm-quot try dup alarm-interval [ reschedule-alarm ] [ drop ] if ; : (trigger-alarms) ( alarms now -- ) @@ -46,8 +46,7 @@ SYMBOL: alarm-thread 2drop ] [ over heap-peek drop over alarm-expired? [ - over heap-pop drop call-alarm - (trigger-alarms) + over heap-pop drop call-alarm (trigger-alarms) ] [ 2drop ] if From a239304b0db8d2a02bf1469c53561b64e1bf60e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Mar 2008 05:40:29 -0500 Subject: [PATCH 057/140] Improving http.server's db support and actions --- extra/bootstrap/image/upload/upload.factor | 2 +- .../http/server/actions/actions-tests.factor | 37 +++++++++++++++++++ extra/http/server/actions/actions.factor | 22 ++++++++++- extra/http/server/db/db.factor | 9 +++-- extra/http/server/server.factor | 6 ++- extra/http/server/static/static.factor | 2 - 6 files changed, 68 insertions(+), 10 deletions(-) create mode 100644 extra/http/server/actions/actions-tests.factor diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 084f30a103..3c0b464dbf 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -8,7 +8,7 @@ SYMBOL: upload-images-destination : destination ( -- dest ) upload-images-destination get - "slava@/var/www/factorcode.org/newsite/images/latest/" + "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/" or ; : checksums "checksums.txt" temp-file ; diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor new file mode 100644 index 0000000000..2d74e92e86 --- /dev/null +++ b/extra/http/server/actions/actions-tests.factor @@ -0,0 +1,37 @@ +IN: http.server.actions.tests +USING: http.server.actions tools.test math math.parser +multiline namespaces http io.streams.string http.server +sequences ; + +[ + ] +{ { "a" [ string>number ] } { "b" [ string>number ] } } +"GET" "action-1" set + +STRING: action-request-test-1 +GET http://foo/bar?a=12&b=13 HTTP/1.1 + +blah +; + +[ 25 ] [ + action-request-test-1 [ read-request ] with-string-reader + "/blah" + "action-1" get call-responder +] unit-test + +[ "X" concat append ] +{ { +path+ [ ] } { "xxx" [ string>number ] } } +"POST" "action-2" set + +STRING: action-request-test-2 +POST http://foo/bar/baz HTTP/1.1 +content-length: 5 + +xxx=4 +; + +[ "/blahXXXX" ] [ + action-request-test-2 [ read-request ] with-string-reader + "/blah" + "action-2" get call-responder +] unit-test diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 4396c7a9da..feb16a4488 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -1,12 +1,30 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots sequences kernel assocs combinators +http.server http hashtables namespaces ; IN: http.server.actions +SYMBOL: +path+ + TUPLE: action quot params method ; C: action -: extract-params ( assoc action -- ... ) +: extract-params ( request path -- assoc ) + >r dup method>> { + { "GET" [ query>> ] } + { "POST" [ post-data>> query>assoc ] } + } case r> +path+ associate union ; + +: push-params ( assoc action -- ... ) params>> [ first2 >r swap at r> call ] with each ; -: call-action ; +M: action call-responder ( request path action -- response ) + pick request set + pick method>> over method>> = [ + >r extract-params r> + [ push-params ] keep + quot>> call + ] [ + 3drop <400> + ] if ; diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index ab45570b88..4baee5f02b 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: db http.server kernel new-slots accessors ; +USING: db http.server kernel new-slots accessors +continuations namespaces ; IN: http.server.db TUPLE: db-persistence responder db params ; @@ -8,6 +9,6 @@ TUPLE: db-persistence responder db params ; C: db-persistence M: db-persistence call-responder - dup db>> over params>> [ - responder>> call-responder - ] with-db ; + dup db>> over params>> make-db dup db-open [ + db set responder>> call-responder + ] with-disposal ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index f71b1d3ec6..f397b280d0 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -28,6 +28,9 @@ M: trivial-responder call-responder nip response>> call ; swap >>message swap >>code ; +: <400> ( -- response ) + 400 "Bad request" ; + : <404> ( -- response ) 404 "Not Found" ; @@ -66,7 +69,7 @@ TUPLE: dispatcher default responders ; 404-responder H{ } clone dispatcher construct-boa ; : set-main ( dispatcher name -- dispatcher ) - [ ] curry + [ ] curry >>default ; : split-path ( path -- rest first ) @@ -102,6 +105,7 @@ M: dispatcher call-responder : ( class -- dispatcher ) swap construct-delegate ; inline + SYMBOL: virtual-hosts SYMBOL: default-host diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor index 10a3df4de8..8d47d38eb1 100755 --- a/extra/http/server/static/static.factor +++ b/extra/http/server/static/static.factor @@ -87,8 +87,6 @@ TUPLE: file-responder root hook special ; drop <404> ] if ; -: <400> 400 "Bad request" ; - M: file-responder call-responder ( request path responder -- response ) over [ ".." pick subseq? [ From a350a91232ad6fd4179c3c39717a234be27886eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Mar 2008 05:40:50 -0500 Subject: [PATCH 058/140] db: minor fixes --- extra/db/sqlite/ffi/ffi.factor | 2 +- extra/db/sqlite/sqlite.factor | 8 +++++--- extra/db/tuples/tuples.factor | 2 +- 3 files changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 8c957108e1..63bce0a8c3 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -112,7 +112,7 @@ FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppSt FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; +FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index c03496530b..3c548ae03d 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -173,9 +173,11 @@ M: sqlite-db ( tuple class -- statement ) " from " 0% 0% [ sql-spec-slot-name swap get-slot-named ] with subset - " where " 0% - [ ", " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + dup empty? [ drop ] [ + " where " 0% + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + ] if ";" 0% ] sqlite-make ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index e7fe7e49c2..d61fe8135e 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -103,7 +103,7 @@ HOOK: insert-tuple* db ( tuple statement -- ) db get db-delete-statements [ ] cache [ bind-tuple ] keep execute-statement ; -: select-tuples ( tuple -- tuple ) +: select-tuples ( tuple -- tuples ) dup dup class [ [ bind-tuple ] keep query-tuples ] with-disposal ; From e95a79b50c8d0c9333f43ba6a5e02358113f31ec Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 3 Mar 2008 04:52:38 -0600 Subject: [PATCH 059/140] builder: minor cleanup --- extra/builder/builder.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 0d5f4292b7..ecce3275cb 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -43,8 +43,6 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : target ( -- target ) { os [ cpu "." split ] } to-strings "-" join ; - : make-vm ( -- desc ) { "make" } >>arguments From 8bce800b4a77537735876040c7dc1a0278eb25b6 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 3 Mar 2008 04:56:39 -0600 Subject: [PATCH 060/140] builder: show git-id in report --- extra/builder/builder.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index ecce3275cb..fbe4f6149f 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -108,7 +108,8 @@ SYMBOL: build-status "Build machine: " write host-name print "CPU: " write cpu print "OS: " write os print - "Build directory: " write cwd print nl + "Build directory: " write cwd print + "git id: " write "git-id" eval-file print git-clone [ "git clone failed" print ] run-or-bail From e8f72a61dca7a048be801ab00af8465bc4fb8c7d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 3 Mar 2008 05:02:59 -0600 Subject: [PATCH 061/140] builder: fix bug --- extra/builder/builder.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index fbe4f6149f..92cd5f5241 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -109,7 +109,6 @@ SYMBOL: build-status "CPU: " write cpu print "OS: " write os print "Build directory: " write cwd print - "git id: " write "git-id" eval-file print git-clone [ "git clone failed" print ] run-or-bail @@ -126,6 +125,8 @@ SYMBOL: build-status "test-log" delete-file + "git id: " write "git-id" eval-file print nl + "Boot time: " write "boot-time" eval-file milli-seconds>time print "Load time: " write "load-time" eval-file milli-seconds>time print "Test time: " write "test-time" eval-file milli-seconds>time print nl From 15947d68535df0484db54ebd1ed4a7b5aefaa153 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Mar 2008 08:56:06 -0600 Subject: [PATCH 062/140] start moving db to new-slots redo the tuple tests so it's a bit easier to work with fix a bug where selecting based on an empty tuple wouldn't work --- extra/db/db.factor | 33 +++----- extra/db/sqlite/sqlite.factor | 14 ++-- extra/db/tuples/tuples-tests.factor | 120 +++++++++++++++------------- 3 files changed, 88 insertions(+), 79 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index a577ff5fc5..e834144d0c 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations kernel math namespaces sequences sequences.lib tuples words strings -tools.walker ; +tools.walker new-slots accessors ; IN: db TUPLE: db @@ -25,10 +25,10 @@ HOOK: db-close db ( handle -- ) : dispose-db ( db -- ) dup db [ - dup db-insert-statements dispose-statements - dup db-update-statements dispose-statements - dup db-delete-statements dispose-statements - db-handle db-close + dup insert-statements>> dispose-statements + dup update-statements>> dispose-statements + dup delete-statements>> dispose-statements + handle>> db-close ] with-variable ; TUPLE: statement handle sql in-params out-params bind-params bound? ; @@ -36,11 +36,7 @@ TUPLE: simple-statement ; TUPLE: prepared-statement ; TUPLE: result-set sql params handle n max ; : ( sql in out -- statement ) - { - set-statement-sql - set-statement-in-params - set-statement-out-params - } statement construct ; + { (>>sql) (>>in-params) (>>out-params) } statement construct ; HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) @@ -62,21 +58,18 @@ GENERIC: more-rows? ( result-set -- ? ) ] if ; : bind-statement ( obj statement -- ) - [ set-statement-bind-params ] keep + swap >>bind-params [ bind-statement* ] keep - t swap set-statement-bound? ; + t >>bound? drop ; : init-result-set ( result-set -- ) - dup #rows over set-result-set-max - 0 swap set-result-set-n ; + dup #rows >>max + 0 >>n drop ; : ( query handle tuple -- result-set ) - >r >r { statement-sql statement-in-params } get-slots r> - { - set-result-set-sql - set-result-set-params - set-result-set-handle - } result-set construct r> construct-delegate ; + >r >r { sql>> in-params>> } get-slots r> + { (>>sql) (>>params) (>>handle) } result-set + construct r> construct-delegate ; : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index c03496530b..cfdcfc7750 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,7 +5,7 @@ hashtables io.files kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators tools.walker -combinators.cleave ; +combinators.cleave io ; IN: db.sqlite TUPLE: sqlite-db path ; @@ -173,10 +173,14 @@ M: sqlite-db ( tuple class -- statement ) " from " 0% 0% [ sql-spec-slot-name swap get-slot-named ] with subset - " where " 0% - [ ", " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave - ";" 0% + dup empty? [ + drop + ] [ + " where " 0% + [ ", " 0% ] + [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + ";" 0% + ] if ] sqlite-make ; M: sqlite-db modifier-table ( -- hashtable ) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index aa94bbfbb6..517f8bcc36 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -41,73 +41,73 @@ SYMBOL: the-person2 T{ person f 2 "johnny" 10 3.14 } } ] [ T{ person f f f f 3.14 } select-tuples ] unit-test + [ + { + T{ person f 1 "billy" 200 3.14 } + T{ person f 2 "johnny" 10 3.14 } + } + ] [ T{ person f } select-tuples ] unit-test + [ ] [ the-person1 get delete-tuple ] unit-test [ f ] [ T{ person f 1 } select-tuple ] unit-test [ ] [ person drop-table ] unit-test ; -: test-sqlite ( -- ) - "tuples-test.db" resource-path sqlite-db [ - test-tuples - ] with-db ; +: make-native-person-table ( -- ) + [ person drop-table ] [ drop ] recover + person create-table + T{ person f f "billy" 200 3.14 } insert-tuple + T{ person f f "johnny" 10 3.14 } insert-tuple + ; -: test-postgresql ( -- ) - { "localhost" "postgres" "" "factor-test" } postgresql-db [ - test-tuples - ] with-db ; +: native-person-schema ( -- ) + person "PERSON" + { + { "the-id" "ID" +native-id+ } + { "the-name" "NAME" { VARCHAR 256 } +not-null+ } + { "the-number" "AGE" INTEGER { +default+ 0 } } + { "the-real" "REAL" DOUBLE { +default+ 0.3 } } + } define-persistent + "billy" 10 3.14 the-person1 set + "johnny" 10 3.14 the-person2 set ; -person "PERSON" -{ - { "the-id" "ID" +native-id+ } - { "the-name" "NAME" { VARCHAR 256 } +not-null+ } - { "the-number" "AGE" INTEGER { +default+ 0 } } - { "the-real" "REAL" DOUBLE { +default+ 0.3 } } -} define-persistent +: assigned-person-schema ( -- ) + person "PERSON" + { + { "the-id" "ID" INTEGER +assigned-id+ } + { "the-name" "NAME" { VARCHAR 256 } +not-null+ } + { "the-number" "AGE" INTEGER { +default+ 0 } } + { "the-real" "REAL" DOUBLE { +default+ 0.3 } } + } define-persistent + 1 "billy" 10 3.14 the-person1 set + 2 "johnny" 10 3.14 the-person2 set ; -"billy" 10 3.14 the-person1 set -"johnny" 10 3.14 the-person2 set - -test-sqlite -! test-postgresql - -person "PERSON" -{ - { "the-id" "ID" INTEGER +assigned-id+ } - { "the-name" "NAME" { VARCHAR 256 } +not-null+ } - { "the-number" "AGE" INTEGER { +default+ 0 } } - { "the-real" "REAL" DOUBLE { +default+ 0.3 } } -} define-persistent - -1 "billy" 10 3.14 the-person1 set -2 "johnny" 10 3.14 the-person2 set - -test-sqlite -! test-postgresql TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; -paste "PASTE" -{ - { "n" "ID" +native-id+ } - { "summary" "SUMMARY" TEXT } - { "author" "AUTHOR" TEXT } - { "channel" "CHANNEL" TEXT } - { "mode" "MODE" TEXT } - { "contents" "CONTENTS" TEXT } - { "date" "DATE" TIMESTAMP } - { "annotations" { +has-many+ annotation } } -} define-persistent +: native-paste-schema ( -- ) + paste "PASTE" + { + { "n" "ID" +native-id+ } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "channel" "CHANNEL" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + { "date" "DATE" TIMESTAMP } + { "annotations" { +has-many+ annotation } } + } define-persistent -annotation "ANNOTATION" -{ - { "n" "ID" +native-id+ } - { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } } - { "summary" "SUMMARY" TEXT } - { "author" "AUTHOR" TEXT } - { "mode" "MODE" TEXT } - { "contents" "CONTENTS" TEXT } -} define-persistent + annotation "ANNOTATION" + { + { "n" "ID" +native-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + } define-persistent ; ! { "localhost" "postgres" "" "factor-test" } postgresql-db [ ! [ paste drop-table ] [ drop ] recover @@ -117,3 +117,15 @@ annotation "ANNOTATION" ! [ ] [ paste create-table ] unit-test ! [ ] [ annotation create-table ] unit-test ! ] with-db + + +: test-sqlite ( quot -- ) + >r "tuples-test.db" resource-path sqlite-db r> with-db ; + +: test-postgresql ( -- ) + >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; + +[ native-person-schema test-tuples ] test-sqlite +[ assigned-person-schema test-tuples ] test-sqlite + +! [ make-native-person-table ] test-sqlite From 762d4ebe48e3598ef49019ef83ea3b034ffe727e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Mar 2008 08:59:32 -0600 Subject: [PATCH 063/140] headings were not included in lines. oops --- extra/farkup/farkup.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index 718b8b3e28..9b0602d7b2 100644 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -8,8 +8,6 @@ html.elements sequences.deep ascii ; USE: tools.walker IN: farkup -MEMO: any-char ( -- parser ) [ drop t ] satisfy ; - : delimiters ( -- string ) "*_^~%=[-|\\\n" ; inline @@ -108,6 +106,7 @@ MEMO: code ( -- parser ) MEMO: line ( -- parser ) [ text , strong , emphasis , link , + h1 , h2 , h3 , h4 , superscript , subscript , inline-code , escaped-char , delimiter , ] choice* repeat1 ; From cff39b475d6854d4cfcaedb0d42f62790b80b572 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Mar 2008 09:16:20 -0600 Subject: [PATCH 064/140] previous fix was wrong, real fix is to remove = from delimiters when printing them by themselves --- extra/farkup/farkup-tests.factor | 2 ++ extra/farkup/farkup.factor | 9 ++++----- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index 8ac2686718..32909478bf 100644 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -40,3 +40,5 @@ IN: farkup.tests [ "
ab
\n
cd
\n" ] [ "a|b\nc|d\n" parse-farkup ] unit-test +[ "

foo\n

aheading

\n

adfasd

" ] +[ "*foo*\n=aheading=\nadfasd" parse-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index 9b0602d7b2..003f1d57a7 100644 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -9,14 +9,14 @@ USE: tools.walker IN: farkup : delimiters ( -- string ) - "*_^~%=[-|\\\n" ; inline + "*_^~%[-=|\\\n" ; inline MEMO: text ( -- parser ) [ delimiters member? not ] satisfy repeat1 [ >string escape-string ] action ; MEMO: delimiter ( -- parser ) - [ dup delimiters member? swap CHAR: \n = not and ] satisfy + [ dup delimiters member? swap "\n=" member? not and ] satisfy [ 1string ] action ; : surround-with-foo ( string tag -- seq ) @@ -37,12 +37,12 @@ MEMO: emphasis ( -- parser ) "_" "em" delimited ; MEMO: superscript ( -- parser ) "^" "sup" delimited ; MEMO: subscript ( -- parser ) "~" "sub" delimited ; MEMO: inline-code ( -- parser ) "%" "code" delimited ; +MEMO: nl ( -- parser ) "\n" token ; +MEMO: 2nl ( -- parser ) "\n\n" token hide ; MEMO: h1 ( -- parser ) "=" "h1" delimited ; MEMO: h2 ( -- parser ) "==" "h2" delimited ; MEMO: h3 ( -- parser ) "===" "h3" delimited ; MEMO: h4 ( -- parser ) "====" "h4" delimited ; -MEMO: nl ( -- parser ) "\n" token ; -MEMO: 2nl ( -- parser ) "\n\n" token hide ; : render-code ( string mode -- string' ) >r string-lines r> @@ -106,7 +106,6 @@ MEMO: code ( -- parser ) MEMO: line ( -- parser ) [ text , strong , emphasis , link , - h1 , h2 , h3 , h4 , superscript , subscript , inline-code , escaped-char , delimiter , ] choice* repeat1 ; From 2f48327b475a4ef2687bedae8dac95adf99d9d92 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Mar 2008 13:28:53 -0600 Subject: [PATCH 065/140] move non-core peg parsers to peg.parsers document and unit test peg.parsers add just parser --- extra/peg/parsers/parsers-docs.factor | 149 +++++++++++++++++++++++++ extra/peg/parsers/parsers-tests.factor | 50 +++++++++ extra/peg/parsers/parsers.factor | 67 +++++++++++ extra/peg/peg.factor | 44 ++++---- 4 files changed, 287 insertions(+), 23 deletions(-) create mode 100644 extra/peg/parsers/parsers-docs.factor create mode 100644 extra/peg/parsers/parsers-tests.factor create mode 100644 extra/peg/parsers/parsers.factor diff --git a/extra/peg/parsers/parsers-docs.factor b/extra/peg/parsers/parsers-docs.factor new file mode 100644 index 0000000000..00d98acb71 --- /dev/null +++ b/extra/peg/parsers/parsers-docs.factor @@ -0,0 +1,149 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax peg peg.parsers.private +unicode.categories ; +IN: peg.parsers + +HELP: (list-of) +{ $values + { "items" "a sequence" } + { "separator" "a parser" } + { "repeat1?" "a boolean" } + { "parser" "a parser" } +} { $description + "Returns a parser that returns a list of items separated by the separator parser. Does not hide the separators." +} { $see-also list-of list-of-many } ; + +HELP: list-of +{ $values + { "items" "a sequence" } + { "separator" "a parser" } +} { $description + "Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of one or more items." +} { $notes "Use " { $link list-of-many } " to ensure a list contains two or more items." } +{ $examples + { $example "\"a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" }" } + { $example "\"a,a,a,a\" \"a\" token \",\" token list-of parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also list-of-many } ; + +HELP: list-of-many +{ $values + { "items" "a sequence" } + { "separator" "a parser" } +} { $description + "Returns a parser that returns a list of items separated by the separator parser. Hides the separators and matches a list of two or more items." +} { $notes "Use " { $link list-of } " to return a list of only one item." +} { $examples + { $example "\"a\" \"a\" token \",\" token list-of-many parse ." "f" } + { $example "\"a,a,a,a\" \"a\" token \",\" token list-of-many parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also list-of } ; + +HELP: epsilon +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches the empty sequence." +} ; + +HELP: any-char +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches the any single character." +} ; + +HELP: exactly-n +{ $values + { "parser" "a parser" } + { "n" "an integer" } + { "parser'" "a parser" } +} { $description + "Returns a parser that matches an exact repetition of the input parser." +} { $examples + { $example "\"aaa\" \"a\" token 4 exactly-n parse ." "f" } + { $example "\"aaaa\" \"a\" token 4 exactly-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also at-least-n at-most-n from-m-to-n } ; + +HELP: at-least-n +{ $values + { "parser" "a parser" } + { "n" "an integer" } + { "parser'" "a parser" } +} { $description + "Returns a parser that matches n or more repetitions of the input parser." +} { $examples + { $example "\"aaa\" \"a\" token 4 at-least-n parse ." "f" } + { $example "\"aaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "\"aaaaa\" \"a\" token 4 at-least-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also exactly-n at-most-n from-m-to-n } ; + +HELP: at-most-n +{ $values + { "parser" "a parser" } + { "n" "an integer" } + { "parser'" "a parser" } +} { $description + "Returns a parser that matches n or fewer repetitions of the input parser." +} { $examples + { $example "\"aaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "\"aaaaa\" \"a\" token 4 at-most-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also exactly-n at-least-n from-m-to-n } ; + +HELP: from-m-to-n +{ $values + { "parser" "a parser" } + { "m" "an integer" } + { "n" "an integer" } + { "parser'" "a parser" } +} { $description + "Returns a parser that matches between and including m to n repetitions of the input parser." +} { $examples + { $example "\"aaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" }" } + { $example "\"aaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } + { $example "\"aaaaa\" \"a\" token 3 4 from-m-to-n parse parse-result-ast ." "V{ \"a\" \"a\" \"a\" \"a\" }" } +} { $see-also exactly-n at-most-n at-least-n } ; + +HELP: pack +{ $values + { "begin" "a parser" } + { "body" "a parser" } + { "end" "a parser" } + { "parser'" "a parser" } +} { $description + "Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden." +} { $examples + { $example "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse parse-result-ast ." "V{ 123 }" } +} { $see-also surrounded-by } ; + +HELP: surrounded-by +{ $values + { "parser" "a parser" } + { "begin" "a string" } + { "end" "a string" } + { "parser'" "a parser" } +} { $description + "Calls token on begin and end to make them into string parsers. Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden." +} { $examples + { $example "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse parse-result-ast ." "V{ 123 }" } +} { $see-also pack } ; + +HELP: 'digit' +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches a single digit as defined by the " { $link digit? } " word." +} { $see-also 'integer' } ; + +HELP: 'integer' +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches an integer composed of digits, as defined by the " { $link 'digit' } " word." +} { $see-also 'digit' 'string' } ; + +HELP: 'string' +{ $values + { "parser" "a parser" } +} { $description + "Returns a parser that matches an string composed of a \", anything that is not \", and another \"." +} { $see-also 'integer' } ; diff --git a/extra/peg/parsers/parsers-tests.factor b/extra/peg/parsers/parsers-tests.factor new file mode 100644 index 0000000000..08bde98419 --- /dev/null +++ b/extra/peg/parsers/parsers-tests.factor @@ -0,0 +1,50 @@ +USING: kernel peg peg.parsers tools.test ; +IN: peg.parsers.tests + +[ V{ "a" } ] +[ "a" "a" token "," token list-of parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "a,a,a,a" "a" token "," token list-of parse parse-result-ast ] unit-test + +[ f ] +[ "a" "a" token "," token list-of-many parse ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "a,a,a,a" "a" token "," token list-of-many parse parse-result-ast ] unit-test + +[ f ] +[ "aaa" "a" token 4 exactly-n parse ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaa" "a" token 4 exactly-n parse parse-result-ast ] unit-test + +[ f ] +[ "aaa" "a" token 4 at-least-n parse ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" "a" } ] +[ "aaaaa" "a" token 4 at-least-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaaa" "a" token 4 at-most-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" } ] +[ "aaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test + +[ V{ "a" "a" "a" "a" } ] +[ "aaaaa" "a" token 3 4 from-m-to-n parse parse-result-ast ] unit-test + +[ 97 ] +[ "a" any-char parse parse-result-ast ] unit-test + +[ V{ } ] +[ "" epsilon parse parse-result-ast ] unit-test diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor new file mode 100644 index 0000000000..86a301bcbf --- /dev/null +++ b/extra/peg/parsers/parsers.factor @@ -0,0 +1,67 @@ +! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences strings namespaces math assocs shuffle + vectors arrays combinators.lib memoize math.parser match + unicode.categories sequences.deep peg ; +IN: peg.parsers + +r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq + [ unclip 1vector swap first append ] action ; +PRIVATE> + +MEMO: list-of ( items separator -- parser ) + hide f (list-of) ; + +MEMO: list-of-many ( items separator -- parser ) + hide t (list-of) ; + +MEMO: epsilon ( -- parser ) V{ } token ; + +MEMO: any-char ( -- parser ) [ drop t ] satisfy ; + + + +MEMO: exactly-n ( parser n -- parser' ) + swap seq ; + +MEMO: at-most-n ( parser n -- parser' ) + dup zero? [ + 2drop epsilon + ] [ + 2dup exactly-n + -rot 1- at-most-n 2choice + ] if ; + +MEMO: at-least-n ( parser n -- parser' ) + dupd exactly-n swap repeat0 2seq + [ flatten-vectors ] action ; + +MEMO: from-m-to-n ( parser m n -- parser' ) + >r [ exactly-n ] 2keep r> swap - at-most-n 2seq + [ flatten-vectors ] action ; + +MEMO: pack ( begin body end -- parser ) + >r >r hide r> r> hide 3seq ; + +MEMO: surrounded-by ( parser begin end -- parser' ) + [ token ] 2apply swapd pack ; + +MEMO: 'digit' ( -- parser ) + [ digit? ] satisfy [ digit> ] action ; + +MEMO: 'integer' ( -- parser ) + 'digit' repeat1 [ 10 digits>integer ] action ; + +MEMO: 'string' ( -- parser ) + [ + [ CHAR: " = ] satisfy hide , + [ CHAR: " = not ] satisfy repeat0 , + [ CHAR: " = ] satisfy hide , + ] { } make seq [ first >string ] action ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index ed7012da45..a843c460a1 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib memoize math.parser match - unicode.categories ; + unicode.categories sequences.lib ; IN: peg TUPLE: parse-result remaining ast ; @@ -292,6 +292,18 @@ M: delay-parser compile ( parser -- quot ) delay-parser-quot % \ compile , \ call , ] [ ] make ; +TUPLE: just-parser p1 ; + +: just-pattern + [ + ?quot call dup + [ parse-result-remaining empty? [ drop f ] unless ] [ f ] if* + ] ; + + +M: just-parser compile ( parser -- quot ) + just-parser-p1 compile \ ?quot just-pattern match-replace ; + PRIVATE> MEMO: token ( string -- parser ) @@ -312,6 +324,9 @@ MEMO: range ( min max -- parser ) : 3seq ( parser1 parser2 parser3 -- parser ) 3array seq ; +: 4seq ( parser1 parser2 parser3 parser4 -- parser ) + 4array seq ; + : seq* ( quot -- paser ) { } make seq ; inline @@ -324,6 +339,9 @@ MEMO: range ( min max -- parser ) : 3choice ( parser1 parser2 parser3 -- parser ) 3array choice ; +: 4choice ( parser1 parser2 parser3 parser4 -- parser ) + 4array choice ; + : choice* ( quot -- paser ) { } make choice ; inline @@ -354,25 +372,5 @@ MEMO: hide ( parser -- parser ) MEMO: delay ( parser -- parser ) delay-parser construct-boa init-parser ; -MEMO: (list-of) ( items separator repeat1? -- parser ) - >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq - [ unclip 1vector swap first append ] action ; - -MEMO: list-of ( items separator -- parser ) - hide f (list-of) ; - -MEMO: list-of* ( items separator -- parser ) - hide t (list-of) ; - -MEMO: 'digit' ( -- parser ) - [ digit? ] satisfy [ digit> ] action ; - -MEMO: 'integer' ( -- parser ) - 'digit' repeat1 [ 10 digits>integer ] action ; - -MEMO: 'string' ( -- parser ) - [ - [ CHAR: " = ] satisfy hide , - [ CHAR: " = not ] satisfy repeat0 , - [ CHAR: " = ] satisfy hide , - ] { } make seq [ first >string ] action ; +MEMO: just ( parser -- parser ) + just-parser construct-boa init-parser ; From a969b9c778abab4646a5a1b66581d85ab953941d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Mar 2008 13:29:28 -0600 Subject: [PATCH 066/140] use sequences.deep's flatten --- extra/parser-combinators/parser-combinators.factor | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index cdf89e1f37..bf06708e09 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: lazy-lists promises kernel sequences strings math arrays splitting quotations combinators namespaces -unicode.case unicode.categories ; +unicode.case unicode.categories sequences.deep ; IN: parser-combinators ! Parser combinator protocol @@ -329,11 +329,6 @@ LAZY: <(+)> ( parser -- parser ) LAZY: surrounded-by ( parser start end -- parser' ) [ token ] 2apply swapd pack ; -: flatten* ( obj -- ) - dup array? [ [ flatten* ] each ] [ , ] if ; - -: flatten [ flatten* ] { } make ; - : exactly-n ( parser n -- parser' ) swap [ flatten ] <@ ; From 64c5dc591c79535b2e56c6a77fac977eec621e26 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Mar 2008 14:06:16 -0600 Subject: [PATCH 067/140] fix using --- extra/builder/util/util.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index 1081d3256d..9682fc1346 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -3,7 +3,7 @@ USING: kernel words namespaces classes parser continuations io io.files io.launcher io.sockets math math.parser combinators sequences splitting quotations arrays strings tools.time - parser-combinators new-slots accessors assocs.lib + sequences.deep new-slots accessors assocs.lib combinators.cleave bake calendar calendar.format ; IN: builder.util @@ -108,4 +108,4 @@ USE: prettyprint ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: failsafe ( quot -- ) [ drop ] recover ; \ No newline at end of file +: failsafe ( quot -- ) [ drop ] recover ; From 6378d38d636893882eadaf6528bd84d380977f82 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Mar 2008 14:32:37 -0600 Subject: [PATCH 068/140] add missing usings --- extra/peg/ebnf/ebnf.factor | 4 ++-- extra/peg/pl0/pl0.factor | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index d134f3316f..5d7d7297ef 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser words arrays strings math.parser sequences quotations vectors namespaces math assocs continuations peg - unicode.categories ; + peg.parsers unicode.categories ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; @@ -182,4 +182,4 @@ DEFER: 'choice' f ] if* ; -: " parse-tokens " " join ebnf>quot call ; parsing \ No newline at end of file +: " parse-tokens " " join ebnf>quot call ; parsing diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor index b6b030f56c..6844eb44dc 100644 --- a/extra/peg/pl0/pl0.factor +++ b/extra/peg/pl0/pl0.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays strings math.parser sequences peg peg.ebnf memoize ; +USING: kernel arrays strings math.parser sequences +peg peg.ebnf peg.parsers memoize ; IN: peg.pl0 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0 From bd7fea256880887fedea3ec38160c1b46f57f701 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Mar 2008 14:38:09 -0600 Subject: [PATCH 069/140] add missing using --- extra/fjsc/fjsc.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index 5b5900f0bc..3811949c1d 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg strings promises sequences math math.parser namespaces words quotations arrays hashtables io - io.streams.string assocs memoize ascii ; + io.streams.string assocs memoize ascii peg.parsers ; IN: fjsc TUPLE: ast-number value ; From dd42efaa20457ad8f03ff8c3fd020a41f5cac1e4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Mar 2008 14:39:29 -0600 Subject: [PATCH 070/140] fix load --- extra/farkup/farkup.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index 003f1d57a7..a1636d0356 100644 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -2,9 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel memoize namespaces peg peg.ebnf sequences strings html.elements xml.entities -xmode.code2html splitting io.streams.string html -html.elements sequences.deep ascii ; -! unicode.categories ; +xmode.code2html splitting io.streams.string html peg.parsers +html.elements sequences.deep unicode.categories ; USE: tools.walker IN: farkup From c3c315a580720dddc2521e2b6ebe4b091eb7ee46 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Mar 2008 14:41:22 -0600 Subject: [PATCH 071/140] fix path --- extra/io/files/temporary/temporary.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/files/temporary/temporary.factor b/extra/io/files/temporary/temporary.factor index 5c5e72e83f..c4b197cf5e 100644 --- a/extra/io/files/temporary/temporary.factor +++ b/extra/io/files/temporary/temporary.factor @@ -27,6 +27,6 @@ IN: io.files.temporary [ with-directory ] 2keep drop delete-tree ; { - { [ unix? ] [ "io.unix.files.temporary" ] } - { [ windows? ] [ "io.windows.files.temporary" ] } + { [ unix? ] [ "io.unix.files.unique" ] } + { [ windows? ] [ "io.windows.files.unique" ] } } cond require From ae6ad23855e7c3b116236551bf005d1c3d54b118 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Mar 2008 14:42:32 -0600 Subject: [PATCH 072/140] remove io.windows.files.temporary --- extra/io/windows/files/temporary/temporary.factor | 10 ---------- 1 file changed, 10 deletions(-) delete mode 100644 extra/io/windows/files/temporary/temporary.factor diff --git a/extra/io/windows/files/temporary/temporary.factor b/extra/io/windows/files/temporary/temporary.factor deleted file mode 100644 index 426cab367b..0000000000 --- a/extra/io/windows/files/temporary/temporary.factor +++ /dev/null @@ -1,10 +0,0 @@ -USING: io.files.temporary.backend io.nonblocking io.windows -kernel system windows.kernel32 ; - -IN: io.windows.files.temporary - -M: windows-io (temporary-file) ( path -- stream ) - GENERIC_WRITE CREATE_NEW 0 open-file 0 ; - -M: windows-io temporary-path ( -- path ) - "TEMP" os-env ; From 58d6e4c97d10e960bb8ee32b98cd83501070b0cb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Mar 2008 14:44:48 -0600 Subject: [PATCH 073/140] remove extra files --- .../io/files/temporary/backend/backend.factor | 5 --- extra/io/files/temporary/temporary.factor | 32 ------------------- 2 files changed, 37 deletions(-) delete mode 100644 extra/io/files/temporary/backend/backend.factor delete mode 100644 extra/io/files/temporary/temporary.factor diff --git a/extra/io/files/temporary/backend/backend.factor b/extra/io/files/temporary/backend/backend.factor deleted file mode 100644 index 5c6900b3d2..0000000000 --- a/extra/io/files/temporary/backend/backend.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: io.backend ; -IN: io.files.temporary.backend - -HOOK: (temporary-file) io-backend ( path -- stream path ) -HOOK: temporary-path io-backend ( -- path ) diff --git a/extra/io/files/temporary/temporary.factor b/extra/io/files/temporary/temporary.factor deleted file mode 100644 index c4b197cf5e..0000000000 --- a/extra/io/files/temporary/temporary.factor +++ /dev/null @@ -1,32 +0,0 @@ -USING: kernel math math.bitfields combinators.lib math.parser -random sequences sequences.lib continuations namespaces -io.files io.backend io.nonblocking io arrays -io.files.temporary.backend system combinators vocabs.loader ; -IN: io.files.temporary - -: random-letter ( -- ch ) 26 random { CHAR: a CHAR: A } random + ; - -: random-ch ( -- ch ) - { t f } random [ 10 random CHAR: 0 + ] [ random-letter ] if ; - -: random-name ( n -- string ) [ drop random-ch ] "" map-as ; - -: ( prefix suffix -- path duplex-stream ) - temporary-path -rot - [ 10 random-name swap 3append path+ dup (temporary-file) ] 3curry - 10 retry ; - -: with-temporary-file ( quot -- path ) - >r f f r> with-stream ; - -: temporary-directory ( -- path ) - [ temporary-path 10 random-name path+ dup make-directory ] 10 retry ; - -: with-temporary-directory ( quot -- ) - >r temporary-directory r> - [ with-directory ] 2keep drop delete-tree ; - -{ - { [ unix? ] [ "io.unix.files.unique" ] } - { [ windows? ] [ "io.windows.files.unique" ] } -} cond require From 07f8203d3e4437de81a4a839887939e00db5ce59 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 3 Mar 2008 15:23:12 -0600 Subject: [PATCH 074/140] list-of* -> list-of-many --- extra/farkup/farkup.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index a1636d0356..810ab22ce1 100644 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -84,7 +84,7 @@ MEMO: table-column ( -- parser ) MEMO: table-row ( -- parser ) [ - table-column "|" token hide list-of* , + table-column "|" token hide list-of-many , ] seq* [ "tr" surround-with-foo ] action ; MEMO: table ( -- parser ) From 2c23357f25570e464ba1e25db15012abec874f0c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Mar 2008 16:44:24 -0600 Subject: [PATCH 075/140] Unit test fixes --- core/listener/listener-tests.factor | 2 +- core/parser/parser-tests.factor | 6 +- core/prettyprint/prettyprint-tests.factor | 10 +-- core/source-files/source-files.factor | 5 +- extra/fry/fry-tests.factor | 88 ++++++++++--------- extra/fry/fry.factor | 83 +++++++++-------- extra/furnace/furnace-tests.factor | 2 +- .../help/definitions/definitions-tests.factor | 8 +- extra/help/syntax/syntax-tests.factor | 6 +- .../http/server/templating/templating.factor | 4 +- extra/tools/crossref/crossref-tests.factor | 2 +- extra/tools/{ => crossref}/test/foo.factor | 2 +- 12 files changed, 115 insertions(+), 103 deletions(-) mode change 100644 => 100755 extra/furnace/furnace-tests.factor rename extra/tools/{ => crossref}/test/foo.factor (50%) mode change 100644 => 100755 diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor index 71ea6e66c6..d694c62c67 100755 --- a/core/listener/listener-tests.factor +++ b/core/listener/listener-tests.factor @@ -9,7 +9,7 @@ IN: listener.tests stream-read-quot ; [ [ ] ] [ - "USE: temporary hello" parse-interactive + "USE: listener.tests hello" parse-interactive ] unit-test [ diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index bfea532242..89783d1b3c 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -24,7 +24,7 @@ IN: parser.tests [ "hello world" ] [ "IN: parser.tests : hello \"hello world\" ;" - eval "USE: temporary hello" eval + eval "USE: parser.tests hello" eval ] unit-test [ ] @@ -104,12 +104,12 @@ IN: parser.tests "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ; parsing" eval - [ ] [ "USE: temporary foo" eval ] unit-test + [ ] [ "USE: parser.tests foo" eval ] unit-test "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ;" eval [ t ] [ - "USE: temporary \\ foo" eval + "USE: parser.tests \\ foo" eval "foo" "parser.tests" lookup eq? ] unit-test diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 6226ddca38..20130d7f7e 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -125,18 +125,18 @@ unit-test "IN: prettyprint.tests" "GENERIC: method-layout" "" - "USING: math temporary ;" + "USING: math prettyprint.tests ;" "M: complex method-layout" " \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"" " ;" "" - "USING: math temporary ;" + "USING: math prettyprint.tests ;" "M: fixnum method-layout ;" "" - "USING: math temporary ;" + "USING: math prettyprint.tests ;" "M: integer method-layout ;" "" - "USING: kernel temporary ;" + "USING: kernel prettyprint.tests ;" "M: object method-layout ;" } ; @@ -280,7 +280,7 @@ unit-test "IN: prettyprint.tests" "GENERIC: class-see-layout ( x -- y )" "" - "USING: temporary ;" + "USING: prettyprint.tests ;" "M: class-see-layout class-see-layout ;" } ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index dd5313383e..98c39ae390 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -68,7 +68,10 @@ uses definitions ; : reset-checksums ( -- ) source-files get [ swap ?resource-path dup exists? - [ file-lines swap record-checksum ] [ 2drop ] if + [ + over record-modified + file-lines swap record-checksum + ] [ 2drop ] if ] assoc-each ; M: pathname where pathname-string 1 2array ; diff --git a/extra/fry/fry-tests.factor b/extra/fry/fry-tests.factor index e1ef40b44d..4d2c9fe1c8 100755 --- a/extra/fry/fry-tests.factor +++ b/extra/fry/fry-tests.factor @@ -1,42 +1,46 @@ -IN: fry.tests -USING: fry tools.test math prettyprint kernel io arrays -sequences ; - -[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test - -[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test - -[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test - -[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test - -[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test - -[ [ "a" write "b" print ] ] -[ "a" "b" '[ , write , print ] ] unit-test - -[ [ 1 2 + 3 4 - ] ] -[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test - -[ 1/2 ] [ - 1 '[ , _ / ] 2 swap call -] unit-test - -[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [ - 1 '[ , _ _ 3array ] - { "a" "b" "c" } { "A" "B" "C" } rot 2map -] unit-test - -[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [ - '[ 1 _ 2array ] - { "a" "b" "c" } swap map -] unit-test - -[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [ - 1 2 '[ , _ , 3array ] - { "a" "b" "c" } swap map -] unit-test - -: funny-dip '[ @ _ ] call ; inline - -[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test +IN: fry.tests +USING: fry tools.test math prettyprint kernel io arrays +sequences ; + +[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test + +[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test + +[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test + +[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test + +[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test + +[ [ "a" write "b" print ] ] +[ "a" "b" '[ , write , print ] ] unit-test + +[ [ 1 2 + 3 4 - ] ] +[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test + +[ 1/2 ] [ + 1 '[ , _ / ] 2 swap call +] unit-test + +[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [ + 1 '[ , _ _ 3array ] + { "a" "b" "c" } { "A" "B" "C" } rot 2map +] unit-test + +[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [ + '[ 1 _ 2array ] + { "a" "b" "c" } swap map +] unit-test + +[ 1 2 ] [ + 1 2 '[ _ , ] call +] unit-test + +[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [ + 1 2 '[ , _ , 3array ] + { "a" "b" "c" } swap map +] unit-test + +: funny-dip '[ @ _ ] call ; inline + +[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor index 0b0b91f0d0..f8d49af163 100755 --- a/extra/fry/fry.factor +++ b/extra/fry/fry.factor @@ -1,39 +1,44 @@ -! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences combinators parser splitting -quotations ; -IN: fry - -: , "Only valid inside a fry" throw ; -: @ "Only valid inside a fry" throw ; -: _ "Only valid inside a fry" throw ; - -DEFER: (fry) - -: ((fry)) ( accum quot adder -- result ) - >r [ ] swap (fry) r> - append swap dup empty? [ drop ] [ - [ swap compose ] curry append - ] if ; inline - -: (fry) ( accum quot -- result ) - dup empty? [ - drop 1quotation - ] [ - unclip { - { , [ [ curry ] ((fry)) ] } - { @ [ [ compose ] ((fry)) ] } - [ swap >r add r> (fry) ] - } case - ] if ; - -: trivial-fry ( quot -- quot' ) [ ] swap (fry) ; - -: fry ( quot -- quot' ) - { _ } last-split1 [ - >r fry [ [ dip ] curry ] r> trivial-fry [ compose ] compose 3compose - ] [ - trivial-fry - ] if* ; - -: '[ \ ] parse-until fry over push-all ; parsing +! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences combinators parser splitting +quotations arrays namespaces ; +IN: fry + +: , "Only valid inside a fry" throw ; +: @ "Only valid inside a fry" throw ; +: _ "Only valid inside a fry" throw ; + +DEFER: (fry) + +: ((fry)) ( accum quot adder -- result ) + >r [ ] swap (fry) r> + append swap dup empty? [ drop ] [ + [ swap compose ] curry append + ] if ; inline + +: (fry) ( accum quot -- result ) + dup empty? [ + drop 1quotation + ] [ + unclip { + { , [ [ curry ] ((fry)) ] } + { @ [ [ compose ] ((fry)) ] } + [ swap >r add r> (fry) ] + } case + ] if ; + +: trivial-fry ( quot -- quot' ) [ ] swap (fry) ; + +: fry ( quot -- quot' ) + { _ } last-split1 [ + [ + trivial-fry % + [ >r ] % + fry % + [ [ dip ] curry r> compose ] % + ] [ ] make + ] [ + trivial-fry + ] if* ; + +: '[ \ ] parse-until fry over push-all ; parsing diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor old mode 100644 new mode 100755 index 84ec798df2..d8124d1f2b --- a/extra/furnace/furnace-tests.factor +++ b/extra/furnace/furnace-tests.factor @@ -39,7 +39,7 @@ TUPLE: test-tuple m n ; ] unit-test [ - "/responder/temporary/foo?foo=3" + "/responder/furnace.tests/foo?foo=3" ] [ [ [ "3" foo ] quot-link diff --git a/extra/help/definitions/definitions-tests.factor b/extra/help/definitions/definitions-tests.factor index 921d8e1c69..7134c6b0b0 100755 --- a/extra/help/definitions/definitions-tests.factor +++ b/extra/help/definitions/definitions-tests.factor @@ -16,7 +16,7 @@ IN: help.definitions.tests [ t ] [ "hello" articles get key? ] unit-test [ t ] [ "hello2" articles get key? ] unit-test [ t ] [ - "hello" "help.definitions" lookup "help" word-prop >boolean + "hello" "help.definitions.tests" lookup "help" word-prop >boolean ] unit-test [ 2 ] [ @@ -29,12 +29,12 @@ IN: help.definitions.tests [ t ] [ "hello" articles get key? ] unit-test [ f ] [ "hello2" articles get key? ] unit-test [ f ] [ - "hello" "help.definitions" lookup "help" word-prop + "hello" "help.definitions.tests" lookup "help" word-prop ] unit-test [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test - [ ] [ "xxx" "help.definitions" lookup help ] unit-test + [ ] [ "xxx" "help.definitions.tests" lookup help ] unit-test - [ ] [ "xxx" "help.definitions" lookup >link synopsis print ] unit-test + [ ] [ "xxx" "help.definitions.tests" lookup >link synopsis print ] unit-test ] with-file-vocabs diff --git a/extra/help/syntax/syntax-tests.factor b/extra/help/syntax/syntax-tests.factor index 038d7fa490..bcf92b77c7 100755 --- a/extra/help/syntax/syntax-tests.factor +++ b/extra/help/syntax/syntax-tests.factor @@ -4,18 +4,18 @@ USING: tools.test parser vocabs help.syntax namespaces ; [ [ "foobar" ] [ "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval - "help.syntax" vocab vocab-help + "help.syntax.tests" vocab vocab-help ] unit-test [ { "foobar" } ] [ "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval - "help.syntax" vocab vocab-help + "help.syntax.tests" vocab vocab-help ] unit-test SYMBOL: xyz [ xyz ] [ "IN: help.syntax.tests USE: help.syntax ABOUT: xyz" eval - "help.syntax" vocab vocab-help + "help.syntax.tests" vocab vocab-help ] unit-test ] with-file-vocabs diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index 3b0dcb8e5e..4c451f7f6e 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -82,10 +82,10 @@ DEFER: <% delimiter templating-vocab use+ ! so that reload works properly dup source-file file set - dup ?resource-path file-contents + ?resource-path file-contents [ eval-template ] [ html-error. drop ] recover ] with-file-vocabs - ] assert-depth drop ; + ] curry assert-depth ; : run-relative-template-file ( filename -- ) file get source-file-path parent-directory diff --git a/extra/tools/crossref/crossref-tests.factor b/extra/tools/crossref/crossref-tests.factor index 8616be141e..a277a68ed7 100755 --- a/extra/tools/crossref/crossref-tests.factor +++ b/extra/tools/crossref/crossref-tests.factor @@ -6,7 +6,7 @@ GENERIC: foo M: integer foo + ; -"resource:extra/tools/test/foo.factor" run-file +"resource:extra/tools/crossref/test/foo.factor" run-file [ t ] [ integer \ foo method method-word \ + usage member? ] unit-test [ t ] [ \ foo usage [ pathname? ] contains? ] unit-test diff --git a/extra/tools/test/foo.factor b/extra/tools/crossref/test/foo.factor old mode 100644 new mode 100755 similarity index 50% rename from extra/tools/test/foo.factor rename to extra/tools/crossref/test/foo.factor index 944a25cf5e..f7bc321912 --- a/extra/tools/test/foo.factor +++ b/extra/tools/crossref/test/foo.factor @@ -1,4 +1,4 @@ -USE: temporary +USE: tools.crossref.tests USE: kernel 1 2 foo drop From 05a02ade7aa6a2f69f7e155c25dfbdf82b41b894 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Mar 2008 16:45:18 -0600 Subject: [PATCH 076/140] Unix now compiles --- extra/io/unix/launcher/launcher.factor | 32 +------------ .../unix/launcher/parser/parser-tests.factor | 33 +++++++++++++ extra/io/unix/launcher/parser/parser.factor | 47 +++++++++++++++++++ extra/peg/parsers/parsers-docs.factor | 4 +- extra/peg/parsers/parsers.factor | 18 ++++++- extra/peg/peg.factor | 15 ------ 6 files changed, 101 insertions(+), 48 deletions(-) create mode 100755 extra/io/unix/launcher/parser/parser-tests.factor create mode 100755 extra/io/unix/launcher/parser/parser.factor mode change 100644 => 100755 extra/peg/parsers/parsers-docs.factor mode change 100644 => 100755 extra/peg/parsers/parsers.factor diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 0393b13c7f..444a662c32 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -2,41 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.backend io.launcher io.unix.backend io.unix.files io.nonblocking sequences kernel namespaces math system - alien.c-types debugger continuations arrays assocs -combinators unix.process parser-combinators memoize -promises strings threads unix ; +alien.c-types debugger continuations arrays assocs combinators +unix.process strings threads unix ; IN: io.unix.launcher ! Search unix first USE: unix -! Our command line parser. Supported syntax: -! foo bar baz -- simple tokens -! foo\ bar -- escaping the space -! 'foo bar' -- quotation -! "foo bar" -- quotation -LAZY: 'escaped-char' "\\" token any-char-parser &> ; - -LAZY: 'quoted-char' ( delimiter -- parser' ) - 'escaped-char' - swap [ member? not ] curry satisfy - <|> ; inline - -LAZY: 'quoted' ( delimiter -- parser ) - dup 'quoted-char' swap dup surrounded-by ; - -LAZY: 'unquoted' ( -- parser ) " '\"" 'quoted-char' ; - -LAZY: 'argument' ( -- parser ) - "\"" 'quoted' "'" 'quoted' 'unquoted' <|> <|> - [ >string ] <@ ; - -MEMO: 'arguments' ( -- parser ) - 'argument' " " token nonempty-list-of ; - -: tokenize-command ( command -- arguments ) - 'arguments' just parse-1 ; - : get-arguments ( -- seq ) +command+ get [ tokenize-command ] [ +arguments+ get ] if* ; diff --git a/extra/io/unix/launcher/parser/parser-tests.factor b/extra/io/unix/launcher/parser/parser-tests.factor new file mode 100755 index 0000000000..63aadcabbe --- /dev/null +++ b/extra/io/unix/launcher/parser/parser-tests.factor @@ -0,0 +1,33 @@ +IN: io.unix.launcher.parser.tests +USING: io.unix.launcher.parser tools.test ; + +[ "" tokenize-command ] must-fail +[ " " tokenize-command ] must-fail +[ V{ "a" } ] [ "a" tokenize-command ] unit-test +[ V{ "abc" } ] [ "abc" tokenize-command ] unit-test +[ V{ "abc" } ] [ "abc " tokenize-command ] unit-test +[ V{ "abc" } ] [ " abc" tokenize-command ] unit-test +[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test +[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test +[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test +[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test +[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test +[ "'abc def' \"hey" tokenize-command ] must-fail +[ "'abc def" tokenize-command ] must-fail +[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test + +[ + V{ + "Hello world.app/Contents/MacOS/hello-ui" + "-i=boot.macosx-ppc.image" + "-include= math compiler ui" + "-deploy-vocab=hello-ui" + "-output-image=Hello world.app/Contents/Resources/hello-ui.image" + "-no-stack-traces" + "-no-user-init" + } +] [ + "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command +] unit-test diff --git a/extra/io/unix/launcher/parser/parser.factor b/extra/io/unix/launcher/parser/parser.factor new file mode 100755 index 0000000000..9be5a48d1d --- /dev/null +++ b/extra/io/unix/launcher/parser/parser.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +IN: io.unix.launcher.parser +USING: peg peg.parsers kernel sequences strings qualified +words ; +QUALIFIED: compiler.units + +! Our command line parser. Supported syntax: +! foo bar baz -- simple tokens +! foo\ bar -- escaping the space +! 'foo bar' -- quotation +! "foo bar" -- quotation +: 'escaped-char' + "\\" token [ drop t ] satisfy 2seq [ second ] action ; + +: 'quoted-char' ( delimiter -- parser' ) + 'escaped-char' + swap [ member? not ] curry satisfy + 2choice ; inline + +: 'quoted' ( delimiter -- parser ) + dup 'quoted-char' repeat0 swap dup surrounded-by ; + +: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; + +: 'argument' ( -- parser ) + "\"" 'quoted' + "'" 'quoted' + 'unquoted' 3choice + [ >string ] action ; + +: 'arguments' ( -- parser ) + 'argument' " " token repeat1 list-of + " " token repeat0 swap over pack + just ; + +DEFER: argument-parser + +[ + \ argument-parser + 'arguments' compile + define +] compiler.units:with-compilation-unit + +: tokenize-command ( command -- arguments ) + argument-parser + dup [ parse-result-ast ] [ "Parse failed" throw ] if ; diff --git a/extra/peg/parsers/parsers-docs.factor b/extra/peg/parsers/parsers-docs.factor old mode 100644 new mode 100755 index 00d98acb71..437edc1007 --- a/extra/peg/parsers/parsers-docs.factor +++ b/extra/peg/parsers/parsers-docs.factor @@ -112,7 +112,7 @@ HELP: pack } { $description "Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden." } { $examples - { $example "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse parse-result-ast ." "V{ 123 }" } + { $example "\"hi123bye\" \"hi\" token 'integer' \"bye\" token pack parse parse-result-ast ." "123" } } { $see-also surrounded-by } ; HELP: surrounded-by @@ -124,7 +124,7 @@ HELP: surrounded-by } { $description "Calls token on begin and end to make them into string parsers. Returns a parser that parses the begin, body, and end parsers in order. The begin and end parsers are hidden." } { $examples - { $example "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse parse-result-ast ." "V{ 123 }" } + { $example "\"hi123bye\" 'integer' \"hi\" \"bye\" surrounded-by parse parse-result-ast ." "123" } } { $see-also pack } ; HELP: 'digit' diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor old mode 100644 new mode 100755 index 86a301bcbf..60002a450a --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -5,6 +5,22 @@ USING: kernel sequences strings namespaces math assocs shuffle unicode.categories sequences.deep peg ; IN: peg.parsers +TUPLE: just-parser p1 ; + +: just-pattern + [ + dup [ + dup parse-result-remaining empty? [ drop f ] unless + ] when + ] ; + + +M: just-parser compile ( parser -- quot ) + just-parser-p1 compile just-pattern swap append ; + +MEMO: just ( parser -- parser ) + just-parser construct-boa init-parser ; + r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq @@ -48,7 +64,7 @@ MEMO: from-m-to-n ( parser m n -- parser' ) [ flatten-vectors ] action ; MEMO: pack ( begin body end -- parser ) - >r >r hide r> r> hide 3seq ; + >r >r hide r> r> hide 3seq [ first ] action ; MEMO: surrounded-by ( parser begin end -- parser' ) [ token ] 2apply swapd pack ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index a843c460a1..91877d680c 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -292,18 +292,6 @@ M: delay-parser compile ( parser -- quot ) delay-parser-quot % \ compile , \ call , ] [ ] make ; -TUPLE: just-parser p1 ; - -: just-pattern - [ - ?quot call dup - [ parse-result-remaining empty? [ drop f ] unless ] [ f ] if* - ] ; - - -M: just-parser compile ( parser -- quot ) - just-parser-p1 compile \ ?quot just-pattern match-replace ; - PRIVATE> MEMO: token ( string -- parser ) @@ -371,6 +359,3 @@ MEMO: hide ( parser -- parser ) MEMO: delay ( parser -- parser ) delay-parser construct-boa init-parser ; - -MEMO: just ( parser -- parser ) - just-parser construct-boa init-parser ; From b705f18a6b1ac1e6bc52f97fdfda62b17806a7ff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Mar 2008 16:45:34 -0600 Subject: [PATCH 077/140] Remove obsolete file --- extra/io/unix/launcher/launcher-tests.factor | 33 -------------------- 1 file changed, 33 deletions(-) delete mode 100755 extra/io/unix/launcher/launcher-tests.factor diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor deleted file mode 100755 index 7b2a7848fc..0000000000 --- a/extra/io/unix/launcher/launcher-tests.factor +++ /dev/null @@ -1,33 +0,0 @@ -IN: io.unix.launcher.tests -USING: io.unix.launcher tools.test ; - -[ "" tokenize-command ] must-fail -[ " " tokenize-command ] must-fail -[ { "a" } ] [ "a" tokenize-command ] unit-test -[ { "abc" } ] [ "abc" tokenize-command ] unit-test -[ { "abc" } ] [ "abc " tokenize-command ] unit-test -[ { "abc" } ] [ " abc" tokenize-command ] unit-test -[ { "abc" "def" } ] [ "abc def" tokenize-command ] unit-test -[ { "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test -[ { "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test -[ { "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test -[ { "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test -[ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test -[ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test -[ "'abc def' \"hey" tokenize-command ] must-fail -[ "'abc def" tokenize-command ] must-fail -[ { "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test - -[ - { - "Hello world.app/Contents/MacOS/hello-ui" - "-i=boot.macosx-ppc.image" - "-include= math compiler ui" - "-deploy-vocab=hello-ui" - "-output-image=Hello world.app/Contents/Resources/hello-ui.image" - "-no-stack-traces" - "-no-user-init" - } -] [ - "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command -] unit-test From 47a96775d87de48b9d300b7b999c9290d60390be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Mar 2008 16:57:30 -0600 Subject: [PATCH 078/140] Add PEG: word --- extra/farkup/farkup-tests.factor | 46 ++++++++++----------- extra/farkup/farkup.factor | 32 ++++---------- extra/io/unix/launcher/parser/parser.factor | 29 ++++--------- extra/peg/parsers/parsers.factor | 4 +- extra/peg/peg.factor | 12 +++++- 5 files changed, 52 insertions(+), 71 deletions(-) mode change 100644 => 100755 extra/farkup/farkup-tests.factor mode change 100644 => 100755 extra/farkup/farkup.factor diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor old mode 100644 new mode 100755 index 32909478bf..2e0d9832b0 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -1,44 +1,44 @@ USING: farkup kernel tools.test ; IN: farkup.tests -[ "
  • foo
" ] [ "-foo" parse-farkup ] unit-test -[ "
  • foo
\n" ] [ "-foo\n" parse-farkup ] unit-test -[ "
  • foo
  • bar
" ] [ "-foo\n-bar" parse-farkup ] unit-test -[ "
  • foo
  • bar
\n" ] [ "-foo\n-bar\n" parse-farkup ] unit-test +[ "
  • foo
" ] [ "-foo" convert-farkup ] unit-test +[ "
  • foo
\n" ] [ "-foo\n" convert-farkup ] unit-test +[ "
  • foo
  • bar
" ] [ "-foo\n-bar" convert-farkup ] unit-test +[ "
  • foo
  • bar
\n" ] [ "-foo\n-bar\n" convert-farkup ] unit-test -[ "
  • foo
\n

bar\n

" ] [ "-foo\nbar\n" parse-farkup ] unit-test -[ "

*foo\nbar\n

" ] [ "*foo\nbar\n" parse-farkup ] unit-test -[ "

Wow!

" ] [ "*Wow!*" parse-farkup ] unit-test -[ "

Wow.

" ] [ "_Wow._" parse-farkup ] unit-test +[ "
  • foo
\n

bar\n

" ] [ "-foo\nbar\n" convert-farkup ] unit-test +[ "

*foo\nbar\n

" ] [ "*foo\nbar\n" convert-farkup ] unit-test +[ "

Wow!

" ] [ "*Wow!*" convert-farkup ] unit-test +[ "

Wow.

" ] [ "_Wow._" convert-farkup ] unit-test -[ "

*

" ] [ "*" parse-farkup ] unit-test -[ "

*

" ] [ "\\*" parse-farkup ] unit-test -[ "

**

" ] [ "\\**" parse-farkup ] unit-test +[ "

*

" ] [ "*" convert-farkup ] unit-test +[ "

*

" ] [ "\\*" convert-farkup ] unit-test +[ "

**

" ] [ "\\**" convert-farkup ] unit-test -[ "" ] [ "\n\n" parse-farkup ] unit-test -[ "\n" ] [ "\n\n\n" parse-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\n\nbar" parse-farkup ] unit-test +[ "" ] [ "\n\n" convert-farkup ] unit-test +[ "\n" ] [ "\n\n\n" convert-farkup ] unit-test +[ "

foo

bar

" ] [ "foo\n\nbar" convert-farkup ] unit-test -[ "\n

bar\n

" ] [ "\nbar\n" parse-farkup ] unit-test +[ "\n

bar\n

" ] [ "\nbar\n" convert-farkup ] unit-test -[ "

foo

\n

bar

" ] [ "foo\n\n\nbar" parse-farkup ] unit-test +[ "

foo

\n

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test -[ "" ] [ "" parse-farkup ] unit-test +[ "" ] [ "" convert-farkup ] unit-test [ "

|a

" ] -[ "|a" parse-farkup ] unit-test +[ "|a" convert-farkup ] unit-test [ "

|a|

" ] -[ "|a|" parse-farkup ] unit-test +[ "|a|" convert-farkup ] unit-test [ "
ab
" ] -[ "a|b" parse-farkup ] unit-test +[ "a|b" convert-farkup ] unit-test [ "
ab
\n
cd
" ] -[ "a|b\nc|d" parse-farkup ] unit-test +[ "a|b\nc|d" convert-farkup ] unit-test [ "
ab
\n
cd
\n" ] -[ "a|b\nc|d\n" parse-farkup ] unit-test +[ "a|b\nc|d\n" convert-farkup ] unit-test [ "

foo\n

aheading

\n

adfasd

" ] -[ "*foo*\n=aheading=\nadfasd" parse-farkup ] unit-test +[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor old mode 100644 new mode 100755 index 810ab22ce1..dac4359d90 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io kernel memoize namespaces peg -peg.ebnf sequences strings html.elements xml.entities -xmode.code2html splitting io.streams.string html peg.parsers -html.elements sequences.deep unicode.categories ; -USE: tools.walker +USING: arrays io kernel memoize namespaces peg sequences strings +html.elements xml.entities xmode.code2html splitting +io.streams.string html peg.parsers html.elements sequences.deep +unicode.categories ; IN: farkup : delimiters ( -- string ) @@ -118,28 +117,13 @@ MEMO: paragraph ( -- parser ) [ "

" swap "

" 3array ] unless ] action ; -MEMO: farkup ( -- parser ) +PEG: parse-farkup ( -- parser ) [ list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl , ] choice* repeat0 "\n" token optional 2seq ; -: farkup. ( parse-result -- ) - parse-result-ast +: write-farkup ( parse-result -- ) [ dup string? [ write ] [ drop ] if ] deep-each ; -: parse-farkup ( string -- string' ) - farkup parse [ farkup. ] with-string-writer ; - -! MEMO: table-column ( -- parser ) - ! text [ "td" surround-with-foo ] action ; -! -! MEMO: table-row ( -- parser ) - ! [ - ! "|" token hide , - ! table-column "|" token hide list-of , - ! "|" token "\n" token 2array choice hide , - ! ] seq* [ "tr" surround-with-foo ] action ; -! -! MEMO: table ( -- parser ) - ! table-row repeat1 - ! [ "table" surround-with-foo ] action ; +: convert-farkup ( string -- string' ) + parse-farkup [ write-farkup ] with-string-writer ; diff --git a/extra/io/unix/launcher/parser/parser.factor b/extra/io/unix/launcher/parser/parser.factor index 9be5a48d1d..21ce131abd 100755 --- a/extra/io/unix/launcher/parser/parser.factor +++ b/extra/io/unix/launcher/parser/parser.factor @@ -1,47 +1,34 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. +USING: peg peg.parsers kernel sequences strings words +memoize ; IN: io.unix.launcher.parser -USING: peg peg.parsers kernel sequences strings qualified -words ; -QUALIFIED: compiler.units ! Our command line parser. Supported syntax: ! foo bar baz -- simple tokens ! foo\ bar -- escaping the space ! 'foo bar' -- quotation ! "foo bar" -- quotation -: 'escaped-char' +MEMO: 'escaped-char' "\\" token [ drop t ] satisfy 2seq [ second ] action ; -: 'quoted-char' ( delimiter -- parser' ) +MEMO: 'quoted-char' ( delimiter -- parser' ) 'escaped-char' swap [ member? not ] curry satisfy 2choice ; inline -: 'quoted' ( delimiter -- parser ) +MEMO: 'quoted' ( delimiter -- parser ) dup 'quoted-char' repeat0 swap dup surrounded-by ; -: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; +MEMO: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; -: 'argument' ( -- parser ) +MEMO: 'argument' ( -- parser ) "\"" 'quoted' "'" 'quoted' 'unquoted' 3choice [ >string ] action ; -: 'arguments' ( -- parser ) +PEG: tokenize-command ( command -- ast/f ) 'argument' " " token repeat1 list-of " " token repeat0 swap over pack just ; - -DEFER: argument-parser - -[ - \ argument-parser - 'arguments' compile - define -] compiler.units:with-compilation-unit - -: tokenize-command ( command -- arguments ) - argument-parser - dup [ parse-result-ast ] [ "Parse failed" throw ] if ; diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 60002a450a..5e82756853 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib memoize math.parser match - unicode.categories sequences.deep peg ; + unicode.categories sequences.deep peg peg.private ; IN: peg.parsers TUPLE: just-parser p1 ; @@ -16,7 +16,7 @@ TUPLE: just-parser p1 ; M: just-parser compile ( parser -- quot ) - just-parser-p1 compile just-pattern swap append ; + just-parser-p1 compile just-pattern append ; MEMO: just ( parser -- parser ) just-parser construct-boa init-parser ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 91877d680c..01decc2c81 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces math assocs shuffle vectors arrays combinators.lib memoize math.parser match - unicode.categories sequences.lib ; + unicode.categories sequences.lib compiler.units parser + words ; IN: peg TUPLE: parse-result remaining ast ; @@ -359,3 +360,12 @@ MEMO: hide ( parser -- parser ) MEMO: delay ( parser -- parser ) delay-parser construct-boa init-parser ; + +: PEG: + (:) [ + [ + call compile + [ dup [ parse-result-ast ] [ "Parse failed" throw ] if ] + append define + ] with-compilation-unit + ] 2curry over push-all ; parsing From a20398874260ae20711a09110975c15aad2260bd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 3 Mar 2008 18:44:57 -0500 Subject: [PATCH 079/140] Unix launcher load fix --- extra/io/launcher/launcher.factor | 16 +++++++++++++--- extra/io/unix/launcher/launcher.factor | 9 +++++---- extra/io/unix/launcher/parser/parser.factor | 2 +- 3 files changed, 19 insertions(+), 8 deletions(-) diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 021ea487fc..b9cdab06f9 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.backend io.timeouts system kernel namespaces -strings hashtables sequences assocs combinators vocabs.loader -init threads continuations math ; +USING: io io.backend io.nonblocking io.streams.duplex +io.timeouts system kernel namespaces strings hashtables +sequences assocs combinators vocabs.loader init threads +continuations math ; IN: io.launcher ! Non-blocking process exit notification facility @@ -141,3 +142,12 @@ TUPLE: process-stream process ; [ set-process-status ] keep [ processes get delete-at* drop [ resume ] each ] keep f swap set-process-handle ; + +GENERIC: underlying-handle ( stream -- handle ) + +M: port underlying-handle port-handle ; + +M: duplex-stream underlying-handle + dup duplex-stream-in underlying-handle + swap duplex-stream-out underlying-handle tuck = + [ "Invalid duplex stream" throw ] when ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 444a662c32..a589af0457 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.backend io.launcher io.unix.backend io.unix.files -io.nonblocking sequences kernel namespaces math system -alien.c-types debugger continuations arrays assocs combinators -unix.process strings threads unix ; +USING: io io.backend io.launcher io.nonblocking io.unix.backend +io.unix.files io.nonblocking sequences kernel namespaces math +system alien.c-types debugger continuations arrays assocs +combinators unix.process strings threads unix +io.unix.launcher.parser ; IN: io.unix.launcher ! Search unix first diff --git a/extra/io/unix/launcher/parser/parser.factor b/extra/io/unix/launcher/parser/parser.factor index 21ce131abd..f3bb82343a 100755 --- a/extra/io/unix/launcher/parser/parser.factor +++ b/extra/io/unix/launcher/parser/parser.factor @@ -9,7 +9,7 @@ IN: io.unix.launcher.parser ! foo\ bar -- escaping the space ! 'foo bar' -- quotation ! "foo bar" -- quotation -MEMO: 'escaped-char' +MEMO: 'escaped-char' ( -- parser ) "\\" token [ drop t ] satisfy 2seq [ second ] action ; MEMO: 'quoted-char' ( delimiter -- parser' ) From 39d27c32b0fee1df1f5b0720baef19e810369714 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 Mar 2008 16:07:57 -0500 Subject: [PATCH 080/140] io.launcher work in progress --- extra/io/launcher/launcher.factor | 5 +- extra/io/unix/launcher/launcher-tests.factor | 80 ++++++++++++++++++++ extra/io/unix/launcher/launcher.factor | 26 +++++-- 3 files changed, 105 insertions(+), 6 deletions(-) create mode 100644 extra/io/unix/launcher/launcher-tests.factor diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index b9cdab06f9..c5ea4feeaf 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -36,13 +36,16 @@ SYMBOL: +environment-mode+ SYMBOL: +stdin+ SYMBOL: +stdout+ SYMBOL: +stderr+ -SYMBOL: +closed+ + SYMBOL: +timeout+ SYMBOL: +prepend-environment+ SYMBOL: +replace-environment+ SYMBOL: +append-environment+ +SYMBOL: +closed+ +SYMBOL: +inherit+ + : default-descriptor H{ { +command+ f } diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor new file mode 100644 index 0000000000..fd2fb53cc5 --- /dev/null +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -0,0 +1,80 @@ +IN: io.unix.launcher.tests +USING: io.files tools.test io.launcher arrays io namespaces +continuations math ; + +[ ] [ + [ "launcher-test-1" temp-file delete-file ] ignore-errors +] unit-test + +[ ] [ + "touch" + "launcher-test-1" temp-file + 2array + try-process +] unit-test + +[ t ] [ "launcher-test-1" temp-file exists? ] unit-test + +[ ] [ + [ "launcher-test-1" temp-file delete-file ] ignore-errors +] unit-test + +[ ] [ + [ + "echo Hello" +command+ set + "launcher-test-1" temp-file +stdout+ set + ] { } make-assoc try-process +] unit-test + +[ "Hello\n" ] [ + "cat" + "launcher-test-1" temp-file + 2array + contents +] unit-test + +[ "" ] [ + [ + "cat" + "launcher-test-1" temp-file + 2array +arguments+ set + +inherit+ +stdout+ set + ] { } make-assoc contents +] unit-test + +[ ] [ + [ "launcher-test-1" temp-file delete-file ] ignore-errors +] unit-test + +[ ] [ + [ + "cat" +command+ set + +closed+ +stdin+ set + "launcher-test-1" temp-file +stdout+ set + ] { } make-assoc try-process +] unit-test + +[ "" ] [ + "cat" + "launcher-test-1" temp-file + 2array + contents +] unit-test + +[ ] [ + 2 [ + "launcher-test-1" temp-file [ + [ + +stdout+ set + "echo Hello" +command+ set + ] { } make-assoc try-process + ] with-disposal + ] times +] unit-test + +[ "Hello\nHello\n" ] [ + "cat" + "launcher-test-1" temp-file + 2array + contents +] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index a589af0457..58e41a06c0 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -16,14 +16,30 @@ USE: unix : assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ; -: (redirect) ( path mode fd -- ) - >r file-mode open dup io-error dup - r> dup2 io-error close ; +: redirect-fd ( oldfd fd -- ) + 2dup = [ 2drop ] [ dupd dup2 io-error close ] if ; + +: reset-fd ( fd -- ) F_SETFL 0 fcntl io-error ; + +: redirect-inherit ( obj mode fd -- ) + 2nip reset-fd ; + +: redirect-file ( obj mode fd -- ) + >r file-mode open dup io-error r> redirect-fd ; + +: redirect-closed ( obj mode fd -- ) + >r >r drop "/dev/null" r> r> redirect-file ; + +: redirect-stream ( obj mode fd -- ) + >r drop underlying-handle dup reset-fd r> redirect-fd ; : redirect ( obj mode fd -- ) { - { [ pick not ] [ 2nip F_SETFL 0 fcntl io-error ] } - { [ pick string? ] [ (redirect) ] } + { [ pick not ] [ redirect-inherit ] } + { [ pick string? ] [ redirect-file ] } + { [ pick +closed+ eq? ] [ redirect-closed ] } + { [ pick +inherit+ eq? ] [ redirect-closed ] } + { [ t ] [ redirect-stream ] } } cond ; : ?closed dup +closed+ eq? [ drop "/dev/null" ] when ; From b1b8210664c644259e219373098e4511815e12df Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 4 Mar 2008 15:11:00 -0600 Subject: [PATCH 081/140] add install-macosx, which will use port to install git, and then bootstrap factor --- misc/factor.sh | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/misc/factor.sh b/misc/factor.sh index 4f503f427b..01ec694048 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -95,6 +95,7 @@ check_installed_programs() { ensure_program_installed md5sum md5 ensure_program_installed cut case $OS in + macosx) ensure_program_installed port;; netbsd) ensure_program_installed gmake;; esac check_gcc_version @@ -371,20 +372,26 @@ make_boot_image() { } -install_libraries() { +install_libraries_apt() { yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make check_ret sudo } +install_libraries_port() { + ensure_program_installed port + yes | sudo port install git-core +} + usage() { - echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|net-bootstrap" + echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap" echo "If you are behind a firewall, invoke as:" echo "env GIT_PROTOCOL=http $0 " } case "$1" in install) install ;; - install-x11) install_libraries; install ;; + install-x11) install_libraries_apt; install ;; + install-macosx) install_libraries_port; install ;; self-update) update; make_boot_image; bootstrap;; quick-update) update; refresh_image ;; update) update; update_bootstrap ;; From 91ff00999545313a8e20f68558e8249b62fd429b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 4 Mar 2008 15:19:00 -0600 Subject: [PATCH 082/140] fix whitespace --- misc/factor.sh | 502 ++++++++++++++++++++++++------------------------- 1 file changed, 251 insertions(+), 251 deletions(-) diff --git a/misc/factor.sh b/misc/factor.sh index 01ec694048..b5c24a3ff1 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -15,247 +15,247 @@ GIT_PROTOCOL=${GIT_PROTOCOL:="git"} GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"} test_program_installed() { - if ! [[ -n `type -p $1` ]] ; then - return 0; + if ! [[ -n `type -p $1` ]] ; then + return 0; fi - return 1; + return 1; } ensure_program_installed() { - installed=0; - for i in $* ; - do - echo -n "Checking for $i..." - test_program_installed $i - if [[ $? -eq 0 ]]; then - echo -n "not " - else - installed=$(( $installed + 1 )) - fi - echo "found!" - done - if [[ $installed -eq 0 ]] ; then - echo -n "Install " - if [[ $# -eq 1 ]] ; then - echo -n $1 - else - echo -n "any of [ $* ]" - fi - echo " and try again." - exit 1 - fi + installed=0; + for i in $* ; + do + echo -n "Checking for $i..." + test_program_installed $i + if [[ $? -eq 0 ]]; then + echo -n "not " + else + installed=$(( $installed + 1 )) + fi + echo "found!" + done + if [[ $installed -eq 0 ]] ; then + echo -n "Install " + if [[ $# -eq 1 ]] ; then + echo -n $1 + else + echo -n "any of [ $* ]" + fi + echo " and try again." + exit 1 + fi } check_ret() { - RET=$? - if [[ $RET -ne 0 ]] ; then - echo $1 failed - exit 2 - fi + RET=$? + if [[ $RET -ne 0 ]] ; then + echo $1 failed + exit 2 + fi } check_gcc_version() { - echo -n "Checking gcc version..." - GCC_VERSION=`gcc --version` - check_ret gcc - if [[ $GCC_VERSION == *3.3.* ]] ; then - echo "bad!" - echo "You have a known buggy version of gcc (3.3)" - echo "Install gcc 3.4 or higher and try again." - exit 3 - fi - echo "ok." + echo -n "Checking gcc version..." + GCC_VERSION=`gcc --version` + check_ret gcc + if [[ $GCC_VERSION == *3.3.* ]] ; then + echo "bad!" + echo "You have a known buggy version of gcc (3.3)" + echo "Install gcc 3.4 or higher and try again." + exit 3 + fi + echo "ok." } set_downloader() { - test_program_installed wget - if [[ $? -ne 0 ]] ; then - DOWNLOAD=wget - else - DOWNLOAD="curl -O" - fi + test_program_installed wget + if [[ $? -ne 0 ]] ; then + DOWNLOAD=wget + else + DOWNLOAD="curl -O" + fi } set_md5sum() { - test_program_installed md5sum - if [[ $? -ne 0 ]] ; then - MD5SUM=md5sum - else - MD5SUM="md5 -r" - fi + test_program_installed md5sum + if [[ $? -ne 0 ]] ; then + MD5SUM=md5sum + else + MD5SUM="md5 -r" + fi } check_installed_programs() { - ensure_program_installed chmod - ensure_program_installed uname - ensure_program_installed git - ensure_program_installed wget curl - ensure_program_installed gcc - ensure_program_installed make - ensure_program_installed md5sum md5 - ensure_program_installed cut - case $OS in - macosx) ensure_program_installed port;; - netbsd) ensure_program_installed gmake;; - esac - check_gcc_version + ensure_program_installed chmod + ensure_program_installed uname + ensure_program_installed git + ensure_program_installed wget curl + ensure_program_installed gcc + ensure_program_installed make + ensure_program_installed md5sum md5 + ensure_program_installed cut + case $OS in + macosx) ensure_program_installed port;; + netbsd) ensure_program_installed gmake;; + esac + check_gcc_version } check_library_exists() { - GCC_TEST=factor-library-test.c - GCC_OUT=factor-library-test.out - echo -n "Checking for library $1..." - echo "int main(){return 0;}" > $GCC_TEST - gcc $GCC_TEST -o $GCC_OUT -l $1 - if [[ $? -ne 0 ]] ; then - echo "not found!" - echo "Warning: library $1 not found." - echo "***Factor will compile NO_UI=1" - NO_UI=1 - fi - rm -f $GCC_TEST - check_ret rm - rm -f $GCC_OUT - check_ret rm - echo "found." + GCC_TEST=factor-library-test.c + GCC_OUT=factor-library-test.out + echo -n "Checking for library $1..." + echo "int main(){return 0;}" > $GCC_TEST + gcc $GCC_TEST -o $GCC_OUT -l $1 + if [[ $? -ne 0 ]] ; then + echo "not found!" + echo "Warning: library $1 not found." + echo "***Factor will compile NO_UI=1" + NO_UI=1 + fi + rm -f $GCC_TEST + check_ret rm + rm -f $GCC_OUT + check_ret rm + echo "found." } check_X11_libraries() { - check_library_exists freetype - check_library_exists GLU - check_library_exists GL - check_library_exists X11 + check_library_exists freetype + check_library_exists GLU + check_library_exists GL + check_library_exists X11 } check_libraries() { - case $OS in - linux) check_X11_libraries;; - esac + case $OS in + linux) check_X11_libraries;; + esac } check_factor_exists() { - if [[ -d "factor" ]] ; then - echo "A directory called 'factor' already exists." - echo "Rename or delete it and try again." - exit 4 - fi + if [[ -d "factor" ]] ; then + echo "A directory called 'factor' already exists." + echo "Rename or delete it and try again." + exit 4 + fi } find_os() { - echo "Finding OS..." - uname_s=`uname -s` - check_ret uname - case $uname_s in - CYGWIN_NT-5.2-WOW64) OS=winnt;; - *CYGWIN_NT*) OS=winnt;; - *CYGWIN*) OS=winnt;; - *darwin*) OS=macosx;; - *Darwin*) OS=macosx;; - *linux*) OS=linux;; - *Linux*) OS=linux;; - *NetBSD*) OS=netbsd;; - esac + echo "Finding OS..." + uname_s=`uname -s` + check_ret uname + case $uname_s in + CYGWIN_NT-5.2-WOW64) OS=winnt;; + *CYGWIN_NT*) OS=winnt;; + *CYGWIN*) OS=winnt;; + *darwin*) OS=macosx;; + *Darwin*) OS=macosx;; + *linux*) OS=linux;; + *Linux*) OS=linux;; + *NetBSD*) OS=netbsd;; + esac } find_architecture() { - echo "Finding ARCH..." - uname_m=`uname -m` - check_ret uname - case $uname_m in - i386) ARCH=x86;; - i686) ARCH=x86;; - *86) ARCH=x86;; - *86_64) ARCH=x86;; - "Power Macintosh") ARCH=ppc;; - esac + echo "Finding ARCH..." + uname_m=`uname -m` + check_ret uname + case $uname_m in + i386) ARCH=x86;; + i686) ARCH=x86;; + *86) ARCH=x86;; + *86_64) ARCH=x86;; + "Power Macintosh") ARCH=ppc;; + esac } write_test_program() { - echo "#include " > $C_WORD.c - echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c + echo "#include " > $C_WORD.c + echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c } find_word_size() { - echo "Finding WORD..." - C_WORD=factor-word-size - write_test_program - gcc -o $C_WORD $C_WORD.c - WORD=$(./$C_WORD) - check_ret $C_WORD - rm -f $C_WORD* + echo "Finding WORD..." + C_WORD=factor-word-size + write_test_program + gcc -o $C_WORD $C_WORD.c + WORD=$(./$C_WORD) + check_ret $C_WORD + rm -f $C_WORD* } set_factor_binary() { - case $OS in - # winnt) FACTOR_BINARY=factor-nt;; - # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; - *) FACTOR_BINARY=factor;; - esac + case $OS in + # winnt) FACTOR_BINARY=factor-nt;; + # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; + *) FACTOR_BINARY=factor;; + esac } echo_build_info() { - echo OS=$OS - echo ARCH=$ARCH - echo WORD=$WORD - echo FACTOR_BINARY=$FACTOR_BINARY - echo MAKE_TARGET=$MAKE_TARGET - echo BOOT_IMAGE=$BOOT_IMAGE - echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET - echo GIT_PROTOCOL=$GIT_PROTOCOL - echo GIT_URL=$GIT_URL + echo OS=$OS + echo ARCH=$ARCH + echo WORD=$WORD + echo FACTOR_BINARY=$FACTOR_BINARY + echo MAKE_TARGET=$MAKE_TARGET + echo BOOT_IMAGE=$BOOT_IMAGE + echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET + echo GIT_PROTOCOL=$GIT_PROTOCOL + echo GIT_URL=$GIT_URL } set_build_info() { - if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then - echo "OS: $OS" - echo "ARCH: $ARCH" - echo "WORD: $WORD" - echo "OS, ARCH, or WORD is empty. Please report this" - exit 5 - fi + if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then + echo "OS: $OS" + echo "ARCH: $ARCH" + echo "WORD: $WORD" + echo "OS, ARCH, or WORD is empty. Please report this" + exit 5 + fi - MAKE_TARGET=$OS-$ARCH-$WORD - MAKE_IMAGE_TARGET=$ARCH.$WORD - BOOT_IMAGE=boot.$ARCH.$WORD.image - if [[ $OS == macosx && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.macosx-ppc.image - fi - if [[ $OS == linux && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.linux-ppc.image - fi + MAKE_TARGET=$OS-$ARCH-$WORD + MAKE_IMAGE_TARGET=$ARCH.$WORD + BOOT_IMAGE=boot.$ARCH.$WORD.image + if [[ $OS == macosx && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH + MAKE_TARGET=$OS-$ARCH + BOOT_IMAGE=boot.macosx-ppc.image + fi + if [[ $OS == linux && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH + MAKE_TARGET=$OS-$ARCH + BOOT_IMAGE=boot.linux-ppc.image + fi } find_build_info() { - find_os - find_architecture - find_word_size - set_factor_binary - set_build_info - echo_build_info + find_os + find_architecture + find_word_size + set_factor_binary + set_build_info + echo_build_info } invoke_git() { - git $* - check_ret git + git $* + check_ret git } git_clone() { - echo "Downloading the git repository from factorcode.org..." - invoke_git clone $GIT_URL + echo "Downloading the git repository from factorcode.org..." + invoke_git clone $GIT_URL } git_pull_factorcode() { - echo "Updating the git repository from factorcode.org..." - invoke_git pull $GIT_URL master + echo "Updating the git repository from factorcode.org..." + invoke_git pull $GIT_URL master } cd_factor() { - cd factor - check_ret cd + cd factor + check_ret cd } invoke_make() { @@ -268,134 +268,134 @@ invoke_make() { } make_clean() { - invoke_make clean + invoke_make clean } make_factor() { - invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5 + invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5 } update_boot_images() { - echo "Deleting old images..." - rm checksums.txt* > /dev/null 2>&1 - rm $BOOT_IMAGE.* > /dev/null 2>&1 - rm staging.*.image > /dev/null 2>&1 - if [[ -f $BOOT_IMAGE ]] ; then - get_url http://factorcode.org/images/latest/checksums.txt - factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`; - set_md5sum - disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`; - echo "Factorcode md5: $factorcode_md5"; - echo "Disk md5: $disk_md5"; - if [[ "$factorcode_md5" == "$disk_md5" ]] ; then - echo "Your disk boot image matches the one on factorcode.org." - else - rm $BOOT_IMAGE > /dev/null 2>&1 - get_boot_image; - fi + echo "Deleting old images..." + rm checksums.txt* > /dev/null 2>&1 + rm $BOOT_IMAGE.* > /dev/null 2>&1 + rm staging.*.image > /dev/null 2>&1 + if [[ -f $BOOT_IMAGE ]] ; then + get_url http://factorcode.org/images/latest/checksums.txt + factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`; + set_md5sum + disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`; + echo "Factorcode md5: $factorcode_md5"; + echo "Disk md5: $disk_md5"; + if [[ "$factorcode_md5" == "$disk_md5" ]] ; then + echo "Your disk boot image matches the one on factorcode.org." else - get_boot_image + rm $BOOT_IMAGE > /dev/null 2>&1 + get_boot_image; fi + else + get_boot_image + fi } get_boot_image() { - echo "Downloading boot image $BOOT_IMAGE." - get_url http://factorcode.org/images/latest/$BOOT_IMAGE + echo "Downloading boot image $BOOT_IMAGE." + get_url http://factorcode.org/images/latest/$BOOT_IMAGE } get_url() { - if [[ $DOWNLOAD -eq "" ]] ; then - set_downloader; - fi - echo $DOWNLOAD $1 ; - $DOWNLOAD $1 - check_ret $DOWNLOAD + if [[ $DOWNLOAD -eq "" ]] ; then + set_downloader; + fi + echo $DOWNLOAD $1 ; + $DOWNLOAD $1 + check_ret $DOWNLOAD } maybe_download_dlls() { - if [[ $OS == winnt ]] ; then - get_url http://factorcode.org/dlls/freetype6.dll - get_url http://factorcode.org/dlls/zlib1.dll - get_url http://factorcode.org/dlls/OpenAL32.dll - get_url http://factorcode.org/dlls/alut.dll - get_url http://factorcode.org/dlls/ogg.dll - get_url http://factorcode.org/dlls/theora.dll - get_url http://factorcode.org/dlls/vorbis.dll - get_url http://factorcode.org/dlls/sqlite3.dll - chmod 777 *.dll - check_ret chmod - fi + if [[ $OS == winnt ]] ; then + get_url http://factorcode.org/dlls/freetype6.dll + get_url http://factorcode.org/dlls/zlib1.dll + get_url http://factorcode.org/dlls/OpenAL32.dll + get_url http://factorcode.org/dlls/alut.dll + get_url http://factorcode.org/dlls/ogg.dll + get_url http://factorcode.org/dlls/theora.dll + get_url http://factorcode.org/dlls/vorbis.dll + get_url http://factorcode.org/dlls/sqlite3.dll + chmod 777 *.dll + check_ret chmod + fi } get_config_info() { - find_build_info - check_installed_programs - check_libraries + find_build_info + check_installed_programs + check_libraries } bootstrap() { - ./$FACTOR_BINARY -i=$BOOT_IMAGE + ./$FACTOR_BINARY -i=$BOOT_IMAGE } install() { - check_factor_exists - get_config_info - git_clone - cd_factor - make_factor - get_boot_image - maybe_download_dlls - bootstrap + check_factor_exists + get_config_info + git_clone + cd_factor + make_factor + get_boot_image + maybe_download_dlls + bootstrap } update() { - get_config_info - git_pull_factorcode - make_clean - make_factor + get_config_info + git_pull_factorcode + make_clean + make_factor } update_bootstrap() { - update_boot_images - bootstrap + update_boot_images + bootstrap } refresh_image() { - ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit" - check_ret factor + ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit" + check_ret factor } make_boot_image() { - ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" - check_ret factor + ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" + check_ret factor } install_libraries_apt() { - yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make - check_ret sudo + yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make + check_ret sudo } install_libraries_port() { - ensure_program_installed port - yes | sudo port install git-core + ensure_program_installed port + yes | sudo port install git-core } usage() { - echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap" - echo "If you are behind a firewall, invoke as:" - echo "env GIT_PROTOCOL=http $0 " + echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap" + echo "If you are behind a firewall, invoke as:" + echo "env GIT_PROTOCOL=http $0 " } case "$1" in - install) install ;; - install-x11) install_libraries_apt; install ;; - install-macosx) install_libraries_port; install ;; - self-update) update; make_boot_image; bootstrap;; - quick-update) update; refresh_image ;; - update) update; update_bootstrap ;; - bootstrap) get_config_info; bootstrap ;; - net-bootstrap) get_config_info; update_boot_images; bootstrap ;; - *) usage ;; + install) install ;; + install-x11) install_libraries_apt; install ;; + install-macosx) install_libraries_port; install ;; + self-update) update; make_boot_image; bootstrap;; + quick-update) update; refresh_image ;; + update) update; update_bootstrap ;; + bootstrap) get_config_info; bootstrap ;; + net-bootstrap) get_config_info; update_boot_images; bootstrap ;; + *) usage ;; esac From b80434b2e394480fa317348955b1f7b89e284bde Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 4 Mar 2008 15:25:36 -0600 Subject: [PATCH 083/140] fix whitespace (again) --- misc/factor.sh | 416 ++++++++++++++++++++++++------------------------- 1 file changed, 208 insertions(+), 208 deletions(-) diff --git a/misc/factor.sh b/misc/factor.sh index b5c24a3ff1..3a6d2d64f9 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -17,7 +17,7 @@ GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"} test_program_installed() { if ! [[ -n `type -p $1` ]] ; then return 0; - fi + fi return 1; } @@ -47,24 +47,24 @@ ensure_program_installed() { } check_ret() { - RET=$? - if [[ $RET -ne 0 ]] ; then - echo $1 failed - exit 2 - fi + RET=$? + if [[ $RET -ne 0 ]] ; then + echo $1 failed + exit 2 + fi } check_gcc_version() { - echo -n "Checking gcc version..." - GCC_VERSION=`gcc --version` - check_ret gcc - if [[ $GCC_VERSION == *3.3.* ]] ; then - echo "bad!" - echo "You have a known buggy version of gcc (3.3)" - echo "Install gcc 3.4 or higher and try again." - exit 3 - fi - echo "ok." + echo -n "Checking gcc version..." + GCC_VERSION=`gcc --version` + check_ret gcc + if [[ $GCC_VERSION == *3.3.* ]] ; then + echo "bad!" + echo "You have a known buggy version of gcc (3.3)" + echo "Install gcc 3.4 or higher and try again." + exit 3 + fi + echo "ok." } set_downloader() { @@ -86,176 +86,176 @@ set_md5sum() { } check_installed_programs() { - ensure_program_installed chmod - ensure_program_installed uname - ensure_program_installed git - ensure_program_installed wget curl - ensure_program_installed gcc - ensure_program_installed make - ensure_program_installed md5sum md5 - ensure_program_installed cut - case $OS in - macosx) ensure_program_installed port;; - netbsd) ensure_program_installed gmake;; - esac - check_gcc_version + ensure_program_installed chmod + ensure_program_installed uname + ensure_program_installed git + ensure_program_installed wget curl + ensure_program_installed gcc + ensure_program_installed make + ensure_program_installed md5sum md5 + ensure_program_installed cut + case $OS in + macosx) ensure_program_installed port;; + netbsd) ensure_program_installed gmake;; + esac + check_gcc_version } check_library_exists() { - GCC_TEST=factor-library-test.c - GCC_OUT=factor-library-test.out - echo -n "Checking for library $1..." - echo "int main(){return 0;}" > $GCC_TEST - gcc $GCC_TEST -o $GCC_OUT -l $1 - if [[ $? -ne 0 ]] ; then - echo "not found!" - echo "Warning: library $1 not found." - echo "***Factor will compile NO_UI=1" - NO_UI=1 - fi - rm -f $GCC_TEST - check_ret rm - rm -f $GCC_OUT - check_ret rm - echo "found." + GCC_TEST=factor-library-test.c + GCC_OUT=factor-library-test.out + echo -n "Checking for library $1..." + echo "int main(){return 0;}" > $GCC_TEST + gcc $GCC_TEST -o $GCC_OUT -l $1 + if [[ $? -ne 0 ]] ; then + echo "not found!" + echo "Warning: library $1 not found." + echo "***Factor will compile NO_UI=1" + NO_UI=1 + fi + rm -f $GCC_TEST + check_ret rm + rm -f $GCC_OUT + check_ret rm + echo "found." } check_X11_libraries() { - check_library_exists freetype - check_library_exists GLU - check_library_exists GL - check_library_exists X11 + check_library_exists freetype + check_library_exists GLU + check_library_exists GL + check_library_exists X11 } check_libraries() { - case $OS in - linux) check_X11_libraries;; - esac + case $OS in + linux) check_X11_libraries;; + esac } check_factor_exists() { - if [[ -d "factor" ]] ; then - echo "A directory called 'factor' already exists." - echo "Rename or delete it and try again." - exit 4 - fi + if [[ -d "factor" ]] ; then + echo "A directory called 'factor' already exists." + echo "Rename or delete it and try again." + exit 4 + fi } find_os() { - echo "Finding OS..." - uname_s=`uname -s` - check_ret uname - case $uname_s in - CYGWIN_NT-5.2-WOW64) OS=winnt;; - *CYGWIN_NT*) OS=winnt;; - *CYGWIN*) OS=winnt;; - *darwin*) OS=macosx;; - *Darwin*) OS=macosx;; - *linux*) OS=linux;; - *Linux*) OS=linux;; - *NetBSD*) OS=netbsd;; - esac + echo "Finding OS..." + uname_s=`uname -s` + check_ret uname + case $uname_s in + CYGWIN_NT-5.2-WOW64) OS=winnt;; + *CYGWIN_NT*) OS=winnt;; + *CYGWIN*) OS=winnt;; + *darwin*) OS=macosx;; + *Darwin*) OS=macosx;; + *linux*) OS=linux;; + *Linux*) OS=linux;; + *NetBSD*) OS=netbsd;; + esac } find_architecture() { - echo "Finding ARCH..." - uname_m=`uname -m` - check_ret uname - case $uname_m in - i386) ARCH=x86;; - i686) ARCH=x86;; - *86) ARCH=x86;; - *86_64) ARCH=x86;; - "Power Macintosh") ARCH=ppc;; - esac + echo "Finding ARCH..." + uname_m=`uname -m` + check_ret uname + case $uname_m in + i386) ARCH=x86;; + i686) ARCH=x86;; + *86) ARCH=x86;; + *86_64) ARCH=x86;; + "Power Macintosh") ARCH=ppc;; + esac } write_test_program() { - echo "#include " > $C_WORD.c - echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c + echo "#include " > $C_WORD.c + echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c } find_word_size() { - echo "Finding WORD..." - C_WORD=factor-word-size - write_test_program - gcc -o $C_WORD $C_WORD.c - WORD=$(./$C_WORD) - check_ret $C_WORD - rm -f $C_WORD* + echo "Finding WORD..." + C_WORD=factor-word-size + write_test_program + gcc -o $C_WORD $C_WORD.c + WORD=$(./$C_WORD) + check_ret $C_WORD + rm -f $C_WORD* } set_factor_binary() { - case $OS in - # winnt) FACTOR_BINARY=factor-nt;; - # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; - *) FACTOR_BINARY=factor;; - esac + case $OS in + # winnt) FACTOR_BINARY=factor-nt;; + # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; + *) FACTOR_BINARY=factor;; + esac } echo_build_info() { - echo OS=$OS - echo ARCH=$ARCH - echo WORD=$WORD - echo FACTOR_BINARY=$FACTOR_BINARY - echo MAKE_TARGET=$MAKE_TARGET - echo BOOT_IMAGE=$BOOT_IMAGE - echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET - echo GIT_PROTOCOL=$GIT_PROTOCOL - echo GIT_URL=$GIT_URL + echo OS=$OS + echo ARCH=$ARCH + echo WORD=$WORD + echo FACTOR_BINARY=$FACTOR_BINARY + echo MAKE_TARGET=$MAKE_TARGET + echo BOOT_IMAGE=$BOOT_IMAGE + echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET + echo GIT_PROTOCOL=$GIT_PROTOCOL + echo GIT_URL=$GIT_URL } set_build_info() { - if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then - echo "OS: $OS" - echo "ARCH: $ARCH" - echo "WORD: $WORD" - echo "OS, ARCH, or WORD is empty. Please report this" - exit 5 + if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then + echo "OS: $OS" + echo "ARCH: $ARCH" + echo "WORD: $WORD" + echo "OS, ARCH, or WORD is empty. Please report this" + exit 5 fi - MAKE_TARGET=$OS-$ARCH-$WORD - MAKE_IMAGE_TARGET=$ARCH.$WORD - BOOT_IMAGE=boot.$ARCH.$WORD.image - if [[ $OS == macosx && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.macosx-ppc.image - fi - if [[ $OS == linux && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.linux-ppc.image - fi + MAKE_TARGET=$OS-$ARCH-$WORD + MAKE_IMAGE_TARGET=$ARCH.$WORD + BOOT_IMAGE=boot.$ARCH.$WORD.image + if [[ $OS == macosx && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH + MAKE_TARGET=$OS-$ARCH + BOOT_IMAGE=boot.macosx-ppc.image + fi + if [[ $OS == linux && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH + MAKE_TARGET=$OS-$ARCH + BOOT_IMAGE=boot.linux-ppc.image + fi } find_build_info() { - find_os - find_architecture - find_word_size - set_factor_binary - set_build_info - echo_build_info + find_os + find_architecture + find_word_size + set_factor_binary + set_build_info + echo_build_info } invoke_git() { - git $* - check_ret git + git $* + check_ret git } git_clone() { - echo "Downloading the git repository from factorcode.org..." - invoke_git clone $GIT_URL + echo "Downloading the git repository from factorcode.org..." + invoke_git clone $GIT_URL } git_pull_factorcode() { - echo "Updating the git repository from factorcode.org..." - invoke_git pull $GIT_URL master + echo "Updating the git repository from factorcode.org..." + invoke_git pull $GIT_URL master } cd_factor() { - cd factor - check_ret cd + cd factor + check_ret cd } invoke_make() { @@ -268,34 +268,34 @@ invoke_make() { } make_clean() { - invoke_make clean + invoke_make clean } make_factor() { - invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5 + invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5 } update_boot_images() { - echo "Deleting old images..." - rm checksums.txt* > /dev/null 2>&1 - rm $BOOT_IMAGE.* > /dev/null 2>&1 - rm staging.*.image > /dev/null 2>&1 - if [[ -f $BOOT_IMAGE ]] ; then - get_url http://factorcode.org/images/latest/checksums.txt - factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`; - set_md5sum - disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`; - echo "Factorcode md5: $factorcode_md5"; - echo "Disk md5: $disk_md5"; - if [[ "$factorcode_md5" == "$disk_md5" ]] ; then - echo "Your disk boot image matches the one on factorcode.org." - else - rm $BOOT_IMAGE > /dev/null 2>&1 - get_boot_image; - fi - else - get_boot_image - fi + echo "Deleting old images..." + rm checksums.txt* > /dev/null 2>&1 + rm $BOOT_IMAGE.* > /dev/null 2>&1 + rm staging.*.image > /dev/null 2>&1 + if [[ -f $BOOT_IMAGE ]] ; then + get_url http://factorcode.org/images/latest/checksums.txt + factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`; + set_md5sum + disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`; + echo "Factorcode md5: $factorcode_md5"; + echo "Disk md5: $disk_md5"; + if [[ "$factorcode_md5" == "$disk_md5" ]] ; then + echo "Your disk boot image matches the one on factorcode.org." + else + rm $BOOT_IMAGE > /dev/null 2>&1 + get_boot_image; + fi + else + get_boot_image + fi } get_boot_image() { @@ -313,89 +313,89 @@ get_url() { } maybe_download_dlls() { - if [[ $OS == winnt ]] ; then - get_url http://factorcode.org/dlls/freetype6.dll - get_url http://factorcode.org/dlls/zlib1.dll - get_url http://factorcode.org/dlls/OpenAL32.dll - get_url http://factorcode.org/dlls/alut.dll - get_url http://factorcode.org/dlls/ogg.dll - get_url http://factorcode.org/dlls/theora.dll - get_url http://factorcode.org/dlls/vorbis.dll - get_url http://factorcode.org/dlls/sqlite3.dll - chmod 777 *.dll - check_ret chmod - fi + if [[ $OS == winnt ]] ; then + get_url http://factorcode.org/dlls/freetype6.dll + get_url http://factorcode.org/dlls/zlib1.dll + get_url http://factorcode.org/dlls/OpenAL32.dll + get_url http://factorcode.org/dlls/alut.dll + get_url http://factorcode.org/dlls/ogg.dll + get_url http://factorcode.org/dlls/theora.dll + get_url http://factorcode.org/dlls/vorbis.dll + get_url http://factorcode.org/dlls/sqlite3.dll + chmod 777 *.dll + check_ret chmod + fi } get_config_info() { - find_build_info - check_installed_programs - check_libraries + find_build_info + check_installed_programs + check_libraries } bootstrap() { - ./$FACTOR_BINARY -i=$BOOT_IMAGE + ./$FACTOR_BINARY -i=$BOOT_IMAGE } install() { - check_factor_exists - get_config_info - git_clone - cd_factor - make_factor - get_boot_image - maybe_download_dlls - bootstrap + check_factor_exists + get_config_info + git_clone + cd_factor + make_factor + get_boot_image + maybe_download_dlls + bootstrap } update() { - get_config_info - git_pull_factorcode - make_clean - make_factor + get_config_info + git_pull_factorcode + make_clean + make_factor } update_bootstrap() { - update_boot_images - bootstrap + update_boot_images + bootstrap } refresh_image() { - ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit" - check_ret factor + ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit" + check_ret factor } make_boot_image() { - ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" - check_ret factor + ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" + check_ret factor } install_libraries_apt() { - yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make - check_ret sudo + yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make + check_ret sudo } install_libraries_port() { - ensure_program_installed port - yes | sudo port install git-core + ensure_program_installed port + yes | sudo port install git-core } usage() { - echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap" - echo "If you are behind a firewall, invoke as:" - echo "env GIT_PROTOCOL=http $0 " + echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap" + echo "If you are behind a firewall, invoke as:" + echo "env GIT_PROTOCOL=http $0 " } case "$1" in - install) install ;; - install-x11) install_libraries_apt; install ;; - install-macosx) install_libraries_port; install ;; - self-update) update; make_boot_image; bootstrap;; - quick-update) update; refresh_image ;; - update) update; update_bootstrap ;; - bootstrap) get_config_info; bootstrap ;; - net-bootstrap) get_config_info; update_boot_images; bootstrap ;; - *) usage ;; + install) install ;; + install-x11) install_libraries_apt; install ;; + install-macosx) install_libraries_port; install ;; + self-update) update; make_boot_image; bootstrap;; + quick-update) update; refresh_image ;; + update) update; update_bootstrap ;; + bootstrap) get_config_info; bootstrap ;; + net-bootstrap) get_config_info; update_boot_images; bootstrap ;; + *) usage ;; esac From 1764f8671be5c72be57ae6f9853858f54abdd868 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 4 Mar 2008 17:44:08 -0600 Subject: [PATCH 084/140] Deleting duplication in files --- core/io/files/files.factor | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 16d1c64eab..785de80f36 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -6,10 +6,6 @@ system combinators splitting sbufs continuations io.encodings io.encodings.binary ; IN: io.files -HOOK: cd io-backend ( path -- ) - -HOOK: cwd io-backend ( -- path ) - HOOK: (file-reader) io-backend ( path -- stream ) HOOK: (file-writer) io-backend ( path -- stream ) @@ -25,14 +21,8 @@ HOOK: (file-appender) io-backend ( path -- stream ) : ( path encoding -- stream ) swap (file-appender) swap ; -HOOK: delete-file io-backend ( path -- ) - HOOK: rename-file io-backend ( from to -- ) -HOOK: make-directory io-backend ( path -- ) - -HOOK: delete-directory io-backend ( path -- ) - ! Pathnames : path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ; @@ -215,14 +205,6 @@ DEFER: copy-tree-to : resource-exists? ( path -- ? ) ?resource-path exists? ; -: temp-directory ( -- path ) - "temp" resource-path - dup exists? not - [ dup make-directory ] - when ; - -: temp-file ( name -- path ) temp-directory swap path+ ; - ! Pathname presentations TUPLE: pathname string ; From ffc3b8078cf1df36e265bde4147c20ecf410a821 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 4 Mar 2008 17:52:32 -0600 Subject: [PATCH 085/140] Fixing unresolved conflict --- extra/benchmark/sockets/sockets.factor | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index c10a123af3..6af2dadb9f 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -23,21 +23,11 @@ SYMBOL: counter ] curry "Client handler" spawn drop server-loop ; : simple-server ( -- ) -<<<<<<< HEAD:extra/benchmark/sockets/sockets.factor - 7777 local-server "benchmark.sockets" ascii [ - read1 CHAR: x = [ - stop-server - ] [ - 20 [ read1 write1 flush ] times - ] if - ] with-server ; -======= [ - server-addr dup "server" set [ + server-addr ascii dup "server" set [ server-loop ] with-disposal ] ignore-errors ; ->>>>>>> b80434b2e394480fa317348955b1f7b89e284bde:extra/benchmark/sockets/sockets.factor : simple-client ( -- ) server-addr [ From a9c6ea1ce32a59596519ec79727563751d47b047 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 4 Mar 2008 18:04:51 -0600 Subject: [PATCH 086/140] Resolving conflict --- extra/io/unix/launcher/launcher.factor | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 63002887ab..e79ca43e33 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -1,18 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -<<<<<<< HEAD:extra/io/unix/launcher/launcher.factor -USING: io io.backend io.launcher io.unix.backend io.unix.files -io.nonblocking sequences kernel namespaces math system - alien.c-types debugger continuations arrays assocs -combinators unix.process parser-combinators memoize -promises strings threads unix io.encodings.latin1 ; -======= USING: io io.backend io.launcher io.nonblocking io.unix.backend io.unix.files io.nonblocking sequences kernel namespaces math system alien.c-types debugger continuations arrays assocs combinators unix.process strings threads unix -io.unix.launcher.parser ; ->>>>>>> b80434b2e394480fa317348955b1f7b89e284bde:extra/io/unix/launcher/launcher.factor +io.unix.launcher.parser io.encodings.latin1 ; IN: io.unix.launcher ! Search unix first From 578d6202233f6fab41c13b82748e8ae8048f4aba Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 4 Mar 2008 18:12:01 -0600 Subject: [PATCH 087/140] Fixing unit tests and listener merge --- core/io/files/files-tests.factor | 10 +++++----- core/listener/listener.factor | 2 +- extra/io/unix/launcher/launcher-tests.factor | 12 ++++++------ 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 79ada7e4c2..e7f7f4f777 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -70,7 +70,7 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; [ ] [ "delete-tree-test/a/b/c/d" temp-file - [ "Hi" print ] with-file-writer + ascii [ "Hi" print ] with-file-writer ] unit-test [ ] [ @@ -83,7 +83,7 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; [ ] [ "copy-tree-test/a/b/c/d" temp-file - [ "Foobar" write ] with-file-writer + ascii [ "Foobar" write ] with-file-writer ] unit-test [ ] [ @@ -92,7 +92,7 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; ] unit-test [ "Foobar" ] [ - "copy-destination/a/b/c/d" temp-file file-contents + "copy-destination/a/b/c/d" temp-file ascii file-contents ] unit-test [ ] [ @@ -105,7 +105,7 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; ] unit-test [ "Foobar" ] [ - "copy-destination/copy-tree-test/a/b/c/d" temp-file file-contents + "copy-destination/copy-tree-test/a/b/c/d" temp-file ascii file-contents ] unit-test [ ] [ @@ -113,7 +113,7 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; ] unit-test [ "Foobar" ] [ - "d" temp-file file-contents + "d" temp-file ascii file-contents ] unit-test [ ] [ "d" temp-file delete-file ] unit-test diff --git a/core/listener/listener.factor b/core/listener/listener.factor index fce4886112..61d3f9836d 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io kernel math math.parser memory -namespaces parser sequences strings io.styles io.streams.lines +namespaces parser sequences strings io.styles io.streams.duplex vectors words generic system combinators tuples continuations debugger definitions compiler.units ; IN: listener diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index fd2fb53cc5..c24d5c7c9e 100644 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,6 +1,6 @@ IN: io.unix.launcher.tests USING: io.files tools.test io.launcher arrays io namespaces -continuations math ; +continuations math io.encodings.ascii ; [ ] [ [ "launcher-test-1" temp-file delete-file ] ignore-errors @@ -30,7 +30,7 @@ continuations math ; "cat" "launcher-test-1" temp-file 2array - contents + ascii contents ] unit-test [ "" ] [ @@ -39,7 +39,7 @@ continuations math ; "launcher-test-1" temp-file 2array +arguments+ set +inherit+ +stdout+ set - ] { } make-assoc contents + ] { } make-assoc ascii contents ] unit-test [ ] [ @@ -58,12 +58,12 @@ continuations math ; "cat" "launcher-test-1" temp-file 2array - contents + ascii contents ] unit-test [ ] [ 2 [ - "launcher-test-1" temp-file [ + "launcher-test-1" temp-file ascii [ [ +stdout+ set "echo Hello" +command+ set @@ -76,5 +76,5 @@ continuations math ; "cat" "launcher-test-1" temp-file 2array - contents + ascii contents ] unit-test From 30eba0077435c84261c2099ecf9999febf9a188e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 4 Mar 2008 21:05:58 -0600 Subject: [PATCH 088/140] Bug fixes; docs --- core/io/encodings/encodings-docs.factor | 43 +++++++-- core/io/encodings/encodings.factor | 6 +- extra/io/unix/files/files.factor | 9 +- extra/logging/server/server.factor | 113 +----------------------- 4 files changed, 48 insertions(+), 123 deletions(-) diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index bb1a991903..d1f6aef364 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -1,13 +1,44 @@ USING: help.markup help.syntax ; IN: io.encodings +ABOUT: "encodings" + ARTICLE: "encodings" "I/O encodings" "Many streams deal with bytes, rather than Unicode code points, at some level. The translation between these two things is specified by an encoding. To abstract this away from the programmer, Factor provides a system where these streams are associated with an encoding which is always used when the stream is read from or written to. For most purposes, an encoding descriptor consisting of a symbol is all that is needed when initializing a stream." -"To make an encoded stream directly (something which is normally handled by the appropriate stream constructor), use the following words:" +{ $subsection "encodings-constructors" } +{ $subsection "encodings-descriptors" } +{ $subsection "encodings-string" } +{ $subsection "encodings-protocol" } ; + +ARTICLE: "encodings-constructors" "Constructing an encoded stream" { $subsection } { $subsection } -{ $subsection } -"To encode or decode a string, use" -{ $subsection encode-string } -! { $subsection decode-string } -; +{ $subsection } ; + +HELP: ( stream encoding -- newstream ) +{ $values { "stream" "an output stream" } + { "encoding" "an encoding descriptor" } + { "newstream" "an encoded output stream" } } +{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ; + +HELP: ( stream encoding -- newstream ) +{ $values { "stream" "an input stream" } + { "encoding" "an encoding descriptor" } + { "newstream" "an encoded output stream" } } +{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ; + +HELP: ( stream-in stream-out encoding -- duplex ) +{ $values { "stream-in" "an input stream" } + { "stream-out" "an output stream" } + { "encoding" "an encoding descriptor" } + { "duplex" "an encoded duplex stream" } } +{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." } ; + +{ } related-words + +ARTICLE: "encodings-descriptors" "Encoding descriptors" +"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use include:" +{ $vocab-link "io.encodings.utf8" } +{ $vocab-link "io.encodings.ascii" } +{ $vocab-link "io.encodings.binary" } +{ $vocab-link "io.encodings.utf16" } ; diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 79079929bb..bc4f21e8e2 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -54,7 +54,7 @@ GENERIC: decode-step ( buf byte ch state encoding -- buf ch state ) decode-read-loop ; TUPLE: decoded code cr ; -: ( stream decoding-class -- decoded-stream ) +: ( stream encoding -- newstream ) dup binary eq? [ drop ] [ construct-empty { set-delegate set-decoded-code } decoded construct @@ -126,7 +126,7 @@ TUPLE: encode-error ; : encode-error ( -- * ) \ encode-error construct-empty throw ; TUPLE: encoded code ; -: ( stream encoding-class -- encoded-stream ) +: ( stream encoding -- newstream ) dup binary eq? [ drop ] [ construct-empty { set-delegate set-encoded-code } encoded construct @@ -153,7 +153,7 @@ INSTANCE: encoded plain-writer : redecode ( stream encoding -- newstream ) over decoded? [ >r delegate r> ] when ; -: ( stream-in stream-out encoding -- duplex-stream ) +: ( stream-in stream-out encoding -- duplex ) tuck reencode >r redecode r> ; ! The null encoding does nothing diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 7946704e55..f6b0fe7ce6 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io - unix unix.stat unix.time kernel math continuations math.bitfields - byte-arrays alien combinators combinators.cleave calendar ; +unix unix.stat unix.time kernel math continuations math.bitfields +byte-arrays alien combinators combinators.cleave calendar +io.encodings.binary ; IN: io.unix.files @@ -60,8 +61,8 @@ M: unix-io delete-directory ( path -- ) : (copy-file) ( from to -- ) dup parent-directory make-directories - [ - swap [ + binary [ + swap binary [ swap stream-copy ] with-disposal ] with-disposal ; diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index b7e8d208e4..d181ab8a16 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -1,116 +1,10 @@ -<<<<<<< HEAD:extra/logging/server/server.factor -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel io calendar sequences io.files -io.sockets continuations prettyprint assocs math.parser -words debugger math combinators concurrency.messaging -threads arrays init math.ranges strings io.encodings.utf8 ; -IN: logging.server - -: log-root ( -- string ) - \ log-root get "logs" resource-path or ; - -: log-path ( service -- path ) - log-root swap path+ ; - -: log# ( path n -- path' ) - number>string ".log" append path+ ; - -SYMBOL: log-files - -: open-log-stream ( service -- stream ) - log-path - dup make-directories - 1 log# utf8 ; - -: log-stream ( service -- stream ) - log-files get [ open-log-stream ] cache ; - -: multiline-header 20 CHAR: - ; foldable - -: (write-message) ( msg word-name level multi? -- ) - [ - "[" write multiline-header write "] " write - ] [ - "[" write now (timestamp>rfc3339) "] " write - ] if - write bl write ": " write print ; - -: write-message ( msg word-name level -- ) - rot [ empty? not ] subset { - { [ dup empty? ] [ 3drop ] } - { [ dup length 1 = ] [ first -rot f (write-message) ] } - { [ t ] [ - [ first -rot f (write-message) ] 3keep - 1 tail -rot [ t (write-message) ] 2curry each - ] } - } cond ; - -: (log-message) ( msg -- ) - #! msg: { msg word-name level service } - first4 log-stream [ write-message flush ] with-stream* ; - -: try-dispose ( stream -- ) - [ dispose ] curry [ error. ] recover ; - -: close-log ( service -- ) - log-files get delete-at* - [ try-dispose ] [ drop ] if ; - -: (close-logs) ( -- ) - log-files get - dup values [ try-dispose ] each - clear-assoc ; - -: keep-logs 10 ; - -: ?delete-file ( path -- ) - dup exists? [ delete-file ] [ drop ] if ; - -: delete-oldest keep-logs log# ?delete-file ; - -: ?rename-file ( old new -- ) - over exists? [ rename-file ] [ 2drop ] if ; - -: advance-log ( path n -- ) - [ 1- log# ] 2keep log# ?rename-file ; - -: rotate-log ( service -- ) - dup close-log - log-path - dup delete-oldest - keep-logs 1 [a,b] [ advance-log ] with each ; - -: (rotate-logs) ( -- ) - (close-logs) - log-root directory [ drop rotate-log ] assoc-each ; - -: log-server-loop ( -- ) - receive unclip { - { "log-message" [ (log-message) ] } - { "rotate-logs" [ drop (rotate-logs) ] } - { "close-logs" [ drop (close-logs) ] } - } case log-server-loop ; - -: log-server ( -- ) - [ [ log-server-loop ] [ error. (close-logs) ] recover t ] - "Log server" spawn-server - "log-server" set-global ; - -[ - H{ } clone log-files set-global - log-server -] "logging" add-init-hook - -USE: multiline -! Need to resolve this merge conflict -<" ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel io calendar sequences io.files io.sockets continuations prettyprint assocs math.parser words debugger math combinators concurrency.messaging -threads arrays init math.ranges strings calendar.format ; +threads arrays init math.ranges strings calendar.format +io.encodings.ascii ; IN: logging.server : log-root ( -- string ) @@ -127,7 +21,7 @@ SYMBOL: log-files : open-log-stream ( service -- stream ) log-path dup make-directories - 1 log# ; + 1 log# ascii ; : log-stream ( service -- stream ) log-files get [ open-log-stream ] cache ; @@ -207,4 +101,3 @@ SYMBOL: log-files H{ } clone log-files set-global log-server ] "logging" add-init-hook -"> drop From 84052ac5f328321d3b3e9d028441f928796f709a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 4 Mar 2008 21:13:14 -0600 Subject: [PATCH 089/140] Update to encodings docs --- core/io/encodings/encodings-docs.factor | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index d1f6aef364..132da2bb70 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -42,3 +42,12 @@ ARTICLE: "encodings-descriptors" "Encoding descriptors" { $vocab-link "io.encodings.ascii" } { $vocab-link "io.encodings.binary" } { $vocab-link "io.encodings.utf16" } ; + +ARTICLE: "encodings-protocol" "Encoding protocol" +"An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again." +{ $subsection decode-step } +{ $subsection encode-string } ; + +ARTICLE: "encodings-string" "Encoding and decoding strings" +"Strings can be encoded and decoded with the following words:" +{ $subsection encode-string } ; From 27dd4f17019d5287d1d9ab524694e7cd81bbddd4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 Mar 2008 22:04:56 -0600 Subject: [PATCH 090/140] Working on Windows launcher stream inheritance --- extra/io/launcher/launcher-docs.factor | 16 ++- extra/io/windows/nt/launcher/launcher.factor | 116 ++++++++++++------- extra/io/windows/windows.factor | 2 +- 3 files changed, 88 insertions(+), 46 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 96639dee87..31d7e7a60d 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -35,33 +35,43 @@ HELP: +environment-mode+ HELP: +stdin+ { $description "Launch descriptor key. Must equal one of the following:" { $list - { { $link f } " - standard input is inherited" } + { { $link f } " - standard input is either inherited from the current process, or is a " { $link } " pipe" } + { { $link +inherit+ } " - standard input is inherited from the current process" } { { $link +closed+ } " - standard input is closed" } { "a path name - standard input is read from the given file, which must exist" } + { "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" } } } ; HELP: +stdout+ { $description "Launch descriptor key. Must equal one of the following:" { $list - { { $link f } " - standard output is inherited" } + { { $link f } " - standard output is either inherited from the current process, or is a " { $link } " pipe" } + { { $link +inherit+ } " - standard output is inherited from the current process" } { { $link +closed+ } " - standard output is closed" } { "a path name - standard output is written to the given file, which is overwritten if it already exists" } + { "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" } } } ; HELP: +stderr+ { $description "Launch descriptor key. Must equal one of the following:" { $list - { { $link f } " - standard error is inherited" } + { { $link f } " - standard error is inherited from the current process" } + { { $link +inherit+ } " - same as above" } + { { $link +stdout+ } " - standard error is merged with standard output" } { { $link +closed+ } " - standard error is closed" } { "a path name - standard error is written to the given file, which is overwritten if it already exists" } + { "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" } } } ; HELP: +closed+ { $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; +HELP: +inherit+ +{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; + HELP: +prepend-environment+ { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence." $nl diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index cd9bb9baef..a4a3122b4d 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -1,18 +1,38 @@ -! Copyright (C) 2007 Doug Coleman, Slava Pestov. +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays continuations destructors io io.windows libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system strings io.windows.launcher io.windows.nt.pipes io.backend -combinators ; +combinators shuffle ; IN: io.windows.nt.launcher +: duplicate-handle ( handle -- handle' ) + GetCurrentProcess ! source process + swap ! handle + GetCurrentProcess ! target process + f [ ! target handle + DUPLICATE_SAME_ACCESS ! desired access + TRUE ! inherit handle + DUPLICATE_CLOSE_SOURCE ! options + DuplicateHandle win32-error=0/f + ] keep *void* ; + ! The below code is based on the example given in ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx -: (redirect) ( path access-mode create-mode -- handle ) - >r >r +: redirect-default ( default obj access-mode create-mode -- handle ) + 3drop ; + +: redirect-inherit ( default obj access-mode create-mode -- handle ) + 4drop f ; + +: redirect-closed ( default obj access-mode create-mode -- handle ) + drop 2nip null-pipe ; + +: redirect-file ( default path access-mode create-mode -- handle ) + >r >r >r drop r> normalize-pathname r> ! access-mode share-mode @@ -22,47 +42,59 @@ IN: io.windows.nt.launcher f ! template file CreateFile dup invalid-handle? dup close-later ; -: redirect ( obj access-mode create-mode -- handle ) - { - { [ pick not ] [ 3drop f ] } - { [ pick +closed+ eq? ] [ drop nip null-pipe ] } - { [ pick string? ] [ (redirect) ] } - } cond ; - -: ?closed or dup t eq? [ drop f ] when ; - -: inherited-stdout ( args -- handle ) - CreateProcess-args-stdout-pipe - [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ; - -: redirect-stdout ( args -- handle ) - +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect - swap inherited-stdout ?closed ; - -: inherited-stderr ( args -- handle ) - drop STD_ERROR_HANDLE GetStdHandle ; - -: redirect-stderr ( args -- handle ) - +stderr+ get - dup +stdout+ eq? [ - drop - CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput - ] [ - GENERIC_WRITE CREATE_ALWAYS redirect - swap inherited-stderr ?closed - ] if ; - -: inherited-stdin ( args -- handle ) - CreateProcess-args-stdin-pipe - [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ; - -: redirect-stdin ( args -- handle ) - +stdin+ get GENERIC_READ OPEN_EXISTING redirect - swap inherited-stdin ?closed ; - : set-inherit ( handle ? -- ) >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; +: redirect-stream ( default stream access-mode create-mode -- handle ) + 2drop nip + underlying-handle win32-file-handle + duplicate-handle dup t set-inherit ; + +: redirect ( default obj access-mode create-mode -- handle ) + { + { [ pick not ] [ redirect-default ] } + { [ pick +inherit+ eq? ] [ redirect-inherit ] } + { [ pick +closed+ eq? ] [ redirect-closed ] } + { [ pick string? ] [ redirect-file ] } + { [ t ] [ redirect-stream ] } + } cond ; + +: default-stdout ( args -- handle ) + CreateProcess-args-stdout-pipe dup [ pipe-out ] when ; + +: redirect-stdout ( args -- handle ) + default-stdout + +stdout+ get + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_OUTPUT_HANDLE GetStdHandle or ; + +: redirect-stderr ( args -- handle ) + +stderr+ get +stdout+ eq? [ + CreateProcess-args-lpStartupInfo + STARTUPINFO-hStdOutput + ] [ + drop + f + +stderr+ get + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_ERROR_HANDLE GetStdHandle or + ] if ; + +: default-stdin ( args -- handle ) + CreateProcess-args-stdin-pipe dup [ pipe-in ] when ; + +: redirect-stdin ( args -- handle ) + default-stdin + +stdin+ get + GENERIC_READ + OPEN_EXISTING + redirect + STD_INPUT_HANDLE GetStdHandle or ; + : add-pipe-dtors ( pipe -- ) dup pipe-in close-later diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 38b7d4829c..291bef6018 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -55,7 +55,7 @@ M: win32-file close-handle ( handle -- ) : open-file ( path access-mode create-mode flags -- handle ) [ >r >r >r normalize-pathname r> - share-mode f r> r> CreateFile-flags f CreateFile + share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile dup invalid-handle? dup close-later dup add-completion ] with-destructors ; From 18d8f449b9f319a9f25b637ea0cb284ae5745467 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 Mar 2008 22:13:30 -0600 Subject: [PATCH 091/140] Remove unnecessary method tuple, move its slots to word properties --- core/generic/generic-docs.factor | 10 +- core/generic/generic.factor | 52 +- core/generic/math/math.factor | 2 +- core/generic/standard/standard.factor | 2 +- core/inference/backend/backend.factor | 3 +- core/optimizer/inlining/inlining.factor | 416 ++++++------- core/optimizer/optimizer-tests.factor | 756 ++++++++++++------------ core/prettyprint/prettyprint.factor | 14 +- core/words/words.factor | 2 +- 9 files changed, 629 insertions(+), 628 deletions(-) diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 631aa7e62d..b2fba47d3a 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -116,16 +116,18 @@ HELP: method-spec { $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." } { $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ; +HELP: method-body +{ $class-description "The class of method bodies, which are words with special word properties set." } ; + HELP: method -{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } } -{ $description "Looks up a method definition." } -{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ; +{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } } +{ $description "Looks up a method definition." } ; { method define-method POSTPONE: M: } related-words HELP: { $values { "def" "a quotation" } { "method" "a new method definition" } } -{ $description "Creates a new "{ $link method } " instance." } ; +{ $description "Creates a new method." } ; HELP: methods { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } } diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 35cc471033..dbff82777f 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -33,8 +33,6 @@ M: generic definition drop f ; dup { "unannotated-def" } reset-props dup dup "combination" word-prop perform-combination define ; -TUPLE: method word def specializer generic loc ; - : method ( class generic -- method/f ) "methods" word-prop at ; @@ -47,7 +45,7 @@ PREDICATE: pair method-spec : methods ( word -- assoc ) "methods" word-prop [ keys sort-classes ] keep - [ dupd at method-word ] curry { } map>assoc ; + [ dupd at ] curry { } map>assoc ; TUPLE: check-method class generic ; @@ -63,29 +61,33 @@ TUPLE: check-method class generic ; : method-word-name ( class word -- string ) word-name "/" rot word-name 3append ; -: make-method-def ( quot word combination -- quot ) +: make-method-def ( quot class generic -- quot ) "combination" word-prop method-prologue swap append ; -PREDICATE: word method-body "method" word-prop >boolean ; +PREDICATE: word method-body "method-def" word-prop >boolean ; M: method-body stack-effect - "method" word-prop method-generic stack-effect ; + "method-generic" word-prop stack-effect ; -: ( quot class generic -- word ) - [ make-method-def ] 2keep - method-word-name f - dup rot define - dup xref ; +: method-word-props ( quot class generic -- assoc ) + [ + "method-generic" set + "method-class" set + "method-def" set + ] H{ } make-assoc ; -: ( quot class generic -- method ) +: ( quot class generic -- word ) check-method - [ ] 3keep f \ method construct-boa - dup method-word over "method" set-word-prop ; + [ make-method-def ] 3keep + [ method-word-props ] 2keep + method-word-name f + tuck set-word-props + dup rot define ; : redefine-method ( quot class generic -- ) - [ method set-method-def ] 3keep + [ method swap "method-def" set-word-prop ] 3keep [ make-method-def ] 2keep - method method-word swap define ; + method swap define ; : define-method ( quot class generic -- ) >r bootstrap-word r> @@ -102,21 +104,22 @@ M: method-body stack-effect ! Definition protocol M: method-spec where - dup first2 method [ method-word ] [ second ] ?if where ; + dup first2 method [ ] [ second ] ?if where ; M: method-spec set-where - first2 method method-word set-where ; + first2 method set-where ; M: method-spec definer drop \ M: \ ; ; M: method-spec definition - first2 method dup [ method-def ] when ; + first2 method dup + [ "method-def" word-prop ] when ; : forget-method ( class generic -- ) check-method [ delete-at* ] with-methods - [ method-word forget-word ] [ drop ] if ; + [ forget-word ] [ drop ] if ; M: method-spec forget* first2 forget-method ; @@ -125,11 +128,11 @@ M: method-body definer drop \ M: \ ; ; M: method-body definition - "method" word-prop method-def ; + "method-def" word-prop ; M: method-body forget* - "method" word-prop - { method-specializer method-generic } get-slots + dup "method-class" word-prop + swap "method-generic" word-prop forget-method ; : implementors* ( classes -- words ) @@ -168,8 +171,7 @@ M: word subwords drop f ; M: generic subwords dup "methods" word-prop values - swap "default-method" word-prop add - [ method-word ] map ; + swap "default-method" word-prop add ; M: generic forget-word dup subwords [ forget-word ] each (forget-word) ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 0b2b9fcca3..27b0ddb7a2 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ; : applicable-method ( generic class -- quot ) over method - [ method-word word-def ] + [ word-def ] [ default-math-method ] ?if ; : object-method ( generic -- quot ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 230ec446c7..313f487c99 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -69,7 +69,7 @@ TUPLE: no-method object generic ; ] if ; : default-method ( word -- pair ) - "default-method" word-prop method-word + "default-method" word-prop object bootstrap-word swap 2array ; : method-alist>quot ( alist base-class -- quot ) diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index cadf326692..2a2e6995eb 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -10,8 +10,7 @@ IN: inference.backend recursive-state get at ; : inline? ( word -- ? ) - dup "method" word-prop - [ method-generic inline? ] [ "inline" word-prop ] ?if ; + dup "method-generic" word-prop swap or "inline" word-prop ; : local-recursive-state ( -- assoc ) recursive-state get dup keys diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index f3709780f9..04d7ab4ee5 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -1,208 +1,208 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic assocs inference inference.class -inference.dataflow inference.backend inference.state io kernel -math namespaces sequences vectors words quotations hashtables -combinators classes generic.math continuations optimizer.def-use -optimizer.backend generic.standard optimizer.specializers -optimizer.def-use optimizer.pattern-match generic.standard -optimizer.control kernel.private ; -IN: optimizer.inlining - -: remember-inlining ( node history -- ) - [ swap set-node-history ] curry each-node ; - -: inlining-quot ( node quot -- node ) - over node-in-d dataflow-with - dup rot infer-classes/node ; - -: splice-quot ( #call quot history -- node ) - #! Must add history *before* splicing in, otherwise - #! the rest of the IR will also remember the history - pick node-history append - >r dupd inlining-quot dup r> remember-inlining - tuck splice-node ; - -! A heuristic to avoid excessive inlining -DEFER: (flat-length) - -: word-flat-length ( word -- n ) - { - ! heuristic: { ... } declare comes up in method bodies - ! and we don't care about it - { [ dup \ declare eq? ] [ drop -2 ] } - ! recursive - { [ dup get ] [ drop 1 ] } - ! not inline - { [ dup inline? not ] [ drop 1 ] } - ! inline - { [ t ] [ dup dup set word-def (flat-length) ] } - } cond ; - -: (flat-length) ( seq -- n ) - [ - { - { [ dup quotation? ] [ (flat-length) 1+ ] } - { [ dup array? ] [ (flat-length) ] } - { [ dup word? ] [ word-flat-length ] } - { [ t ] [ drop 1 ] } - } cond - ] map sum ; - -: flat-length ( seq -- n ) - [ word-def (flat-length) ] with-scope ; - -! Single dispatch method inlining optimization -: specific-method ( class word -- class ) order min-class ; - -: node-class# ( node n -- class ) - over node-in-d ?nth node-class ; - -: dispatching-class ( node word -- class ) - [ dispatch# node-class# ] keep specific-method ; - -: inline-standard-method ( node word -- node ) - 2dup dispatching-class dup [ - over +inlined+ depends-on - swap method method-word 1quotation f splice-quot - ] [ - 3drop t - ] if ; - -! Partial dispatch of math-generic words -: math-both-known? ( word left right -- ? ) - math-class-max swap specific-method ; - -: inline-math-method ( #call word -- node ) - over node-input-classes first2 3dup math-both-known? - [ math-method f splice-quot ] [ 2drop 2drop t ] if ; - -: inline-method ( #call -- node ) - dup node-param { - { [ dup standard-generic? ] [ inline-standard-method ] } - { [ dup math-generic? ] [ inline-math-method ] } - { [ t ] [ 2drop t ] } - } cond ; - -! Resolve type checks at compile time where possible -: comparable? ( actual testing -- ? ) - #! If actual is a subset of testing or if the two classes - #! are disjoint, return t. - 2dup class< >r classes-intersect? not r> or ; - -: optimize-predicate? ( #call -- ? ) - dup node-param "predicating" word-prop dup [ - >r node-class-first r> comparable? - ] [ - 2drop f - ] if ; - -: literal-quot ( node literals -- quot ) - #! Outputs a quotation which drops the node's inputs, and - #! pushes some literals. - >r node-in-d length \ drop - r> [ literalize ] map append >quotation ; - -: inline-literals ( node literals -- node ) - #! Make #shuffle -> #push -> #return -> successor - dupd literal-quot f splice-quot ; - -: evaluate-predicate ( #call -- ? ) - dup node-param "predicating" word-prop >r - node-class-first r> class< ; - -: optimize-predicate ( #call -- node ) - #! If the predicate is followed by a branch we fold it - #! immediately - dup evaluate-predicate swap - dup node-successor #if? [ - dup drop-inputs >r - node-successor swap 0 1 ? fold-branch - r> [ set-node-successor ] keep - ] [ - swap 1array inline-literals - ] if ; - -: optimizer-hooks ( node -- conditions ) - node-param "optimizer-hooks" word-prop ; - -: optimizer-hook ( node -- pair/f ) - dup optimizer-hooks [ first call ] find 2nip ; - -: optimize-hook ( node -- ) - dup optimizer-hook second call ; - -: define-optimizers ( word optimizers -- ) - "optimizer-hooks" set-word-prop ; - -: flush-eval? ( #call -- ? ) - dup node-param "flushable" word-prop [ - node-out-d [ unused? ] all? - ] [ - drop f - ] if ; - -: flush-eval ( #call -- node ) - dup node-param +inlined+ depends-on - dup node-out-d length f inline-literals ; - -: partial-eval? ( #call -- ? ) - dup node-param "foldable" word-prop [ - dup node-in-d [ node-literal? ] with all? - ] [ - drop f - ] if ; - -: literal-in-d ( #call -- inputs ) - dup node-in-d [ node-literal ] with map ; - -: partial-eval ( #call -- node ) - dup node-param +inlined+ depends-on - dup literal-in-d over node-param 1quotation - [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ; - -: define-identities ( words identities -- ) - [ "identities" set-word-prop ] curry each ; - -: find-identity ( node -- quot ) - [ node-param "identities" word-prop ] keep - [ swap first in-d-match? ] curry find - nip dup [ second ] when ; - -: apply-identities ( node -- node/f ) - dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; - -: optimistic-inline? ( #call -- ? ) - dup node-param "specializer" word-prop dup [ - >r node-input-classes r> specialized-length tail* - [ types length 1 = ] all? - ] [ - 2drop f - ] if ; - -: splice-word-def ( #call word -- node ) - dup +inlined+ depends-on - dup word-def swap 1array splice-quot ; - -: optimistic-inline ( #call -- node ) - dup node-param over node-history memq? [ - drop t - ] [ - dup node-param splice-word-def - ] if ; - -: method-body-inline? ( #call -- ? ) - node-param dup method-body? - [ flat-length 10 <= ] [ drop f ] if ; - -M: #call optimize-node* - { - { [ dup flush-eval? ] [ flush-eval ] } - { [ dup partial-eval? ] [ partial-eval ] } - { [ dup find-identity ] [ apply-identities ] } - { [ dup optimizer-hook ] [ optimize-hook ] } - { [ dup optimize-predicate? ] [ optimize-predicate ] } - { [ dup optimistic-inline? ] [ optimistic-inline ] } - { [ dup method-body-inline? ] [ optimistic-inline ] } - { [ t ] [ inline-method ] } - } cond dup not ; +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays generic assocs inference inference.class +inference.dataflow inference.backend inference.state io kernel +math namespaces sequences vectors words quotations hashtables +combinators classes generic.math continuations optimizer.def-use +optimizer.backend generic.standard optimizer.specializers +optimizer.def-use optimizer.pattern-match generic.standard +optimizer.control kernel.private ; +IN: optimizer.inlining + +: remember-inlining ( node history -- ) + [ swap set-node-history ] curry each-node ; + +: inlining-quot ( node quot -- node ) + over node-in-d dataflow-with + dup rot infer-classes/node ; + +: splice-quot ( #call quot history -- node ) + #! Must add history *before* splicing in, otherwise + #! the rest of the IR will also remember the history + pick node-history append + >r dupd inlining-quot dup r> remember-inlining + tuck splice-node ; + +! A heuristic to avoid excessive inlining +DEFER: (flat-length) + +: word-flat-length ( word -- n ) + { + ! heuristic: { ... } declare comes up in method bodies + ! and we don't care about it + { [ dup \ declare eq? ] [ drop -2 ] } + ! recursive + { [ dup get ] [ drop 1 ] } + ! not inline + { [ dup inline? not ] [ drop 1 ] } + ! inline + { [ t ] [ dup dup set word-def (flat-length) ] } + } cond ; + +: (flat-length) ( seq -- n ) + [ + { + { [ dup quotation? ] [ (flat-length) 1+ ] } + { [ dup array? ] [ (flat-length) ] } + { [ dup word? ] [ word-flat-length ] } + { [ t ] [ drop 1 ] } + } cond + ] map sum ; + +: flat-length ( seq -- n ) + [ word-def (flat-length) ] with-scope ; + +! Single dispatch method inlining optimization +: specific-method ( class word -- class ) order min-class ; + +: node-class# ( node n -- class ) + over node-in-d ?nth node-class ; + +: dispatching-class ( node word -- class ) + [ dispatch# node-class# ] keep specific-method ; + +: inline-standard-method ( node word -- node ) + 2dup dispatching-class dup [ + over +inlined+ depends-on + swap method 1quotation f splice-quot + ] [ + 3drop t + ] if ; + +! Partial dispatch of math-generic words +: math-both-known? ( word left right -- ? ) + math-class-max swap specific-method ; + +: inline-math-method ( #call word -- node ) + over node-input-classes first2 3dup math-both-known? + [ math-method f splice-quot ] [ 2drop 2drop t ] if ; + +: inline-method ( #call -- node ) + dup node-param { + { [ dup standard-generic? ] [ inline-standard-method ] } + { [ dup math-generic? ] [ inline-math-method ] } + { [ t ] [ 2drop t ] } + } cond ; + +! Resolve type checks at compile time where possible +: comparable? ( actual testing -- ? ) + #! If actual is a subset of testing or if the two classes + #! are disjoint, return t. + 2dup class< >r classes-intersect? not r> or ; + +: optimize-predicate? ( #call -- ? ) + dup node-param "predicating" word-prop dup [ + >r node-class-first r> comparable? + ] [ + 2drop f + ] if ; + +: literal-quot ( node literals -- quot ) + #! Outputs a quotation which drops the node's inputs, and + #! pushes some literals. + >r node-in-d length \ drop + r> [ literalize ] map append >quotation ; + +: inline-literals ( node literals -- node ) + #! Make #shuffle -> #push -> #return -> successor + dupd literal-quot f splice-quot ; + +: evaluate-predicate ( #call -- ? ) + dup node-param "predicating" word-prop >r + node-class-first r> class< ; + +: optimize-predicate ( #call -- node ) + #! If the predicate is followed by a branch we fold it + #! immediately + dup evaluate-predicate swap + dup node-successor #if? [ + dup drop-inputs >r + node-successor swap 0 1 ? fold-branch + r> [ set-node-successor ] keep + ] [ + swap 1array inline-literals + ] if ; + +: optimizer-hooks ( node -- conditions ) + node-param "optimizer-hooks" word-prop ; + +: optimizer-hook ( node -- pair/f ) + dup optimizer-hooks [ first call ] find 2nip ; + +: optimize-hook ( node -- ) + dup optimizer-hook second call ; + +: define-optimizers ( word optimizers -- ) + "optimizer-hooks" set-word-prop ; + +: flush-eval? ( #call -- ? ) + dup node-param "flushable" word-prop [ + node-out-d [ unused? ] all? + ] [ + drop f + ] if ; + +: flush-eval ( #call -- node ) + dup node-param +inlined+ depends-on + dup node-out-d length f inline-literals ; + +: partial-eval? ( #call -- ? ) + dup node-param "foldable" word-prop [ + dup node-in-d [ node-literal? ] with all? + ] [ + drop f + ] if ; + +: literal-in-d ( #call -- inputs ) + dup node-in-d [ node-literal ] with map ; + +: partial-eval ( #call -- node ) + dup node-param +inlined+ depends-on + dup literal-in-d over node-param 1quotation + [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ; + +: define-identities ( words identities -- ) + [ "identities" set-word-prop ] curry each ; + +: find-identity ( node -- quot ) + [ node-param "identities" word-prop ] keep + [ swap first in-d-match? ] curry find + nip dup [ second ] when ; + +: apply-identities ( node -- node/f ) + dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; + +: optimistic-inline? ( #call -- ? ) + dup node-param "specializer" word-prop dup [ + >r node-input-classes r> specialized-length tail* + [ types length 1 = ] all? + ] [ + 2drop f + ] if ; + +: splice-word-def ( #call word -- node ) + dup +inlined+ depends-on + dup word-def swap 1array splice-quot ; + +: optimistic-inline ( #call -- node ) + dup node-param over node-history memq? [ + drop t + ] [ + dup node-param splice-word-def + ] if ; + +: method-body-inline? ( #call -- ? ) + node-param dup method-body? + [ flat-length 10 <= ] [ drop f ] if ; + +M: #call optimize-node* + { + { [ dup flush-eval? ] [ flush-eval ] } + { [ dup partial-eval? ] [ partial-eval ] } + { [ dup find-identity ] [ apply-identities ] } + { [ dup optimizer-hook ] [ optimize-hook ] } + { [ dup optimize-predicate? ] [ optimize-predicate ] } + { [ dup optimistic-inline? ] [ optimistic-inline ] } + { [ dup method-body-inline? ] [ optimistic-inline ] } + { [ t ] [ inline-method ] } + } cond dup not ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 5116d66715..3abccecc7f 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -1,378 +1,378 @@ -USING: arrays compiler.units generic hashtables inference kernel -kernel.private math optimizer prettyprint sequences sbufs -strings tools.test vectors words sequences.private quotations -optimizer.backend classes inference.dataflow tuples.private -continuations growable optimizer.inlining namespaces hints ; -IN: optimizer.tests - -[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* -] unit-test - -[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* -] unit-test - -! Test method inlining -[ f ] [ fixnum { } min-class ] unit-test - -[ string ] [ - \ string - [ integer string array reversed sbuf - slice vector quotation ] - sort-classes min-class -] unit-test - -[ fixnum ] [ - \ fixnum - [ fixnum integer object ] - sort-classes min-class -] unit-test - -[ integer ] [ - \ fixnum - [ integer float object ] - sort-classes min-class -] unit-test - -[ object ] [ - \ word - [ integer float object ] - sort-classes min-class -] unit-test - -[ reversed ] [ - \ reversed - [ integer reversed slice ] - sort-classes min-class -] unit-test - -GENERIC: xyz ( obj -- obj ) -M: array xyz xyz ; - -[ t ] [ \ xyz compiled? ] unit-test - -! Test predicate inlining -: pred-test-1 - dup fixnum? [ - dup integer? [ "integer" ] [ "nope" ] if - ] [ - "not a fixnum" - ] if ; - -[ 1 "integer" ] [ 1 pred-test-1 ] unit-test - -TUPLE: pred-test ; - -: pred-test-2 - dup tuple? [ - dup pred-test? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test - -: pred-test-3 - dup pred-test? [ - dup tuple? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test - -: inline-test - "nom" = ; - -[ t ] [ "nom" inline-test ] unit-test -[ f ] [ "shayin" inline-test ] unit-test -[ f ] [ 3 inline-test ] unit-test - -: fixnum-declarations >fixnum 24 shift 1234 bitxor ; - -[ ] [ 1000000 fixnum-declarations . ] unit-test - -! regression - -: literal-not-branch 0 not [ ] [ ] if ; - -[ ] [ literal-not-branch ] unit-test - -! regression - -: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline -: bad-kill-2 bad-kill-1 drop ; - -[ 3 ] [ t bad-kill-2 ] unit-test - -! regression -: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline -: the-test ( -- x y ) 2 dup (the-test) ; - -[ 2 0 ] [ the-test ] unit-test - -! regression -: (double-recursion) ( start end -- ) - < [ - 6 1 (double-recursion) - 3 2 (double-recursion) - ] when ; inline - -: double-recursion 0 2 (double-recursion) ; - -[ ] [ double-recursion ] unit-test - -! regression -: double-label-1 ( a b c -- d ) - [ f double-label-1 ] [ swap nth-unsafe ] if ; inline - -: double-label-2 ( a -- b ) - dup array? [ ] [ ] if 0 t double-label-1 ; - -[ 0 ] [ 10 double-label-2 ] unit-test - -! regression -GENERIC: void-generic ( obj -- * ) -: breakage "hi" void-generic ; -[ t ] [ \ breakage compiled? ] unit-test -[ breakage ] must-fail - -! regression -: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline -: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline -: test-2 ( -- ) 5 test-1 ; - -[ f ] [ f test-2 ] unit-test - -: branch-fold-regression-0 ( m -- n ) - t [ ] [ 1+ branch-fold-regression-0 ] if ; inline - -: branch-fold-regression-1 ( -- m ) - 10 branch-fold-regression-0 ; - -[ 10 ] [ branch-fold-regression-1 ] unit-test - -! another regression -: constant-branch-fold-0 "hey" ; foldable -: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline -[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test - -! another regression -: foo f ; -: bar foo 4 4 = and ; -[ f ] [ bar ] unit-test - -! ensure identities are working in some form -[ t ] [ - [ { number } declare 0 + ] dataflow optimize - [ #push? ] node-exists? not -] unit-test - -! compiling with a non-literal class failed -: -regression ; - -[ t ] [ \ -regression compiled? ] unit-test - -GENERIC: foozul ( a -- b ) -M: reversed foozul ; -M: integer foozul ; -M: slice foozul ; - -[ reversed ] [ reversed \ foozul specific-method ] unit-test - -! regression -: constant-fold-2 f ; foldable -: constant-fold-3 4 ; foldable - -[ f t ] [ - [ constant-fold-2 constant-fold-3 4 = ] compile-call -] unit-test - -: constant-fold-4 f ; foldable -: constant-fold-5 f ; foldable - -[ f ] [ - [ constant-fold-4 constant-fold-5 or ] compile-call -] unit-test - -[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test -[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test -[ 0 ] [ 5 [ dup - ] compile-call ] unit-test - -[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test -[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test - -[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test -[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test - -[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test -[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test - -[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test - -[ f ] [ 5 [ dup < ] compile-call ] unit-test -[ t ] [ 5 [ dup <= ] compile-call ] unit-test -[ f ] [ 5 [ dup > ] compile-call ] unit-test -[ t ] [ 5 [ dup >= ] compile-call ] unit-test - -[ t ] [ 5 [ dup eq? ] compile-call ] unit-test -[ t ] [ 5 [ dup = ] compile-call ] unit-test -[ t ] [ 5 [ dup number= ] compile-call ] unit-test -[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test - -GENERIC: detect-number ( obj -- obj ) -M: number detect-number ; - -[ 10 f [ 0 + detect-number ] compile-call ] must-fail - -! Regression -[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test - -! Regression -USE: sorting -USE: sorting.private - -: old-binsearch ( elt quot seq -- elt quot i ) - dup length 1 <= [ - slice-from - ] [ - [ midpoint swap call ] 3keep roll dup zero? - [ drop dup slice-from swap midpoint@ + ] - [ partition old-binsearch ] if - ] if ; inline - -[ 10 ] [ - 10 20 >vector - [ [ - ] swap old-binsearch ] compile-call 2nip -] unit-test - -! Regression -TUPLE: silly-tuple a b ; - -[ 1 2 { silly-tuple-a silly-tuple-b } ] [ - T{ silly-tuple f 1 2 } - [ - { silly-tuple-a silly-tuple-b } [ get-slots ] keep - ] compile-call -] unit-test - -! Regression -: empty-compound ; - -: node-successor-f-bug ( x -- * ) - [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; - -[ t ] [ \ node-successor-f-bug compiled? ] unit-test - -[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test - -[ ] [ [ ] dataflow optimize drop ] unit-test - -! Make sure we have sane heuristics -: should-inline? method method-word flat-length 10 <= ; - -[ t ] [ \ fixnum \ shift should-inline? ] unit-test -[ f ] [ \ array \ equal? should-inline? ] unit-test -[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test -[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test - -! Regression -: lift-throw-tail-regression - dup integer? [ "an integer" ] [ - dup string? [ "a string" ] [ - "error" throw - ] if - ] if ; - -[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test -[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test -[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test - -: lift-loop-tail-test-1 ( a quot -- ) - over even? [ - [ >r 3 - r> call ] keep lift-loop-tail-test-1 - ] [ - over 0 < [ - 2drop - ] [ - [ >r 2 - r> call ] keep lift-loop-tail-test-1 - ] if - ] if ; inline - -: lift-loop-tail-test-2 - 10 [ ] lift-loop-tail-test-1 1 2 3 ; - -[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test - -! Make sure we don't lose -GENERIC: generic-inline-test ( x -- y ) -M: integer generic-inline-test ; - -: generic-inline-test-1 - 1 - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test - generic-inline-test ; - -[ { t f } ] [ - \ generic-inline-test-1 word-def dataflow - [ optimize-1 , optimize-1 , drop ] { } make -] unit-test - -! Forgot a recursive inline check -: recursive-inline-hang ( a -- a ) - dup array? [ recursive-inline-hang ] when ; - -HINTS: recursive-inline-hang array ; - -: recursive-inline-hang-1 - { } recursive-inline-hang ; - -[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test - -DEFER: recursive-inline-hang-3 - -: recursive-inline-hang-2 ( a -- a ) - dup array? [ recursive-inline-hang-3 ] when ; - -HINTS: recursive-inline-hang-2 array ; - -: recursive-inline-hang-3 ( a -- a ) - dup array? [ recursive-inline-hang-2 ] when ; - -HINTS: recursive-inline-hang-3 array ; - - +USING: arrays compiler.units generic hashtables inference kernel +kernel.private math optimizer prettyprint sequences sbufs +strings tools.test vectors words sequences.private quotations +optimizer.backend classes inference.dataflow tuples.private +continuations growable optimizer.inlining namespaces hints ; +IN: optimizer.tests + +[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* +] unit-test + +[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* +] unit-test + +! Test method inlining +[ f ] [ fixnum { } min-class ] unit-test + +[ string ] [ + \ string + [ integer string array reversed sbuf + slice vector quotation ] + sort-classes min-class +] unit-test + +[ fixnum ] [ + \ fixnum + [ fixnum integer object ] + sort-classes min-class +] unit-test + +[ integer ] [ + \ fixnum + [ integer float object ] + sort-classes min-class +] unit-test + +[ object ] [ + \ word + [ integer float object ] + sort-classes min-class +] unit-test + +[ reversed ] [ + \ reversed + [ integer reversed slice ] + sort-classes min-class +] unit-test + +GENERIC: xyz ( obj -- obj ) +M: array xyz xyz ; + +[ t ] [ \ xyz compiled? ] unit-test + +! Test predicate inlining +: pred-test-1 + dup fixnum? [ + dup integer? [ "integer" ] [ "nope" ] if + ] [ + "not a fixnum" + ] if ; + +[ 1 "integer" ] [ 1 pred-test-1 ] unit-test + +TUPLE: pred-test ; + +: pred-test-2 + dup tuple? [ + dup pred-test? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test + +: pred-test-3 + dup pred-test? [ + dup tuple? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test + +: inline-test + "nom" = ; + +[ t ] [ "nom" inline-test ] unit-test +[ f ] [ "shayin" inline-test ] unit-test +[ f ] [ 3 inline-test ] unit-test + +: fixnum-declarations >fixnum 24 shift 1234 bitxor ; + +[ ] [ 1000000 fixnum-declarations . ] unit-test + +! regression + +: literal-not-branch 0 not [ ] [ ] if ; + +[ ] [ literal-not-branch ] unit-test + +! regression + +: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline +: bad-kill-2 bad-kill-1 drop ; + +[ 3 ] [ t bad-kill-2 ] unit-test + +! regression +: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline +: the-test ( -- x y ) 2 dup (the-test) ; + +[ 2 0 ] [ the-test ] unit-test + +! regression +: (double-recursion) ( start end -- ) + < [ + 6 1 (double-recursion) + 3 2 (double-recursion) + ] when ; inline + +: double-recursion 0 2 (double-recursion) ; + +[ ] [ double-recursion ] unit-test + +! regression +: double-label-1 ( a b c -- d ) + [ f double-label-1 ] [ swap nth-unsafe ] if ; inline + +: double-label-2 ( a -- b ) + dup array? [ ] [ ] if 0 t double-label-1 ; + +[ 0 ] [ 10 double-label-2 ] unit-test + +! regression +GENERIC: void-generic ( obj -- * ) +: breakage "hi" void-generic ; +[ t ] [ \ breakage compiled? ] unit-test +[ breakage ] must-fail + +! regression +: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline +: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline +: test-2 ( -- ) 5 test-1 ; + +[ f ] [ f test-2 ] unit-test + +: branch-fold-regression-0 ( m -- n ) + t [ ] [ 1+ branch-fold-regression-0 ] if ; inline + +: branch-fold-regression-1 ( -- m ) + 10 branch-fold-regression-0 ; + +[ 10 ] [ branch-fold-regression-1 ] unit-test + +! another regression +: constant-branch-fold-0 "hey" ; foldable +: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline +[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test + +! another regression +: foo f ; +: bar foo 4 4 = and ; +[ f ] [ bar ] unit-test + +! ensure identities are working in some form +[ t ] [ + [ { number } declare 0 + ] dataflow optimize + [ #push? ] node-exists? not +] unit-test + +! compiling with a non-literal class failed +: -regression ; + +[ t ] [ \ -regression compiled? ] unit-test + +GENERIC: foozul ( a -- b ) +M: reversed foozul ; +M: integer foozul ; +M: slice foozul ; + +[ reversed ] [ reversed \ foozul specific-method ] unit-test + +! regression +: constant-fold-2 f ; foldable +: constant-fold-3 4 ; foldable + +[ f t ] [ + [ constant-fold-2 constant-fold-3 4 = ] compile-call +] unit-test + +: constant-fold-4 f ; foldable +: constant-fold-5 f ; foldable + +[ f ] [ + [ constant-fold-4 constant-fold-5 or ] compile-call +] unit-test + +[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test +[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test +[ 0 ] [ 5 [ dup - ] compile-call ] unit-test + +[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test +[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test + +[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test +[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test + +[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test +[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test + +[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test + +[ f ] [ 5 [ dup < ] compile-call ] unit-test +[ t ] [ 5 [ dup <= ] compile-call ] unit-test +[ f ] [ 5 [ dup > ] compile-call ] unit-test +[ t ] [ 5 [ dup >= ] compile-call ] unit-test + +[ t ] [ 5 [ dup eq? ] compile-call ] unit-test +[ t ] [ 5 [ dup = ] compile-call ] unit-test +[ t ] [ 5 [ dup number= ] compile-call ] unit-test +[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test + +GENERIC: detect-number ( obj -- obj ) +M: number detect-number ; + +[ 10 f [ 0 + detect-number ] compile-call ] must-fail + +! Regression +[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test + +! Regression +USE: sorting +USE: sorting.private + +: old-binsearch ( elt quot seq -- elt quot i ) + dup length 1 <= [ + slice-from + ] [ + [ midpoint swap call ] 3keep roll dup zero? + [ drop dup slice-from swap midpoint@ + ] + [ partition old-binsearch ] if + ] if ; inline + +[ 10 ] [ + 10 20 >vector + [ [ - ] swap old-binsearch ] compile-call 2nip +] unit-test + +! Regression +TUPLE: silly-tuple a b ; + +[ 1 2 { silly-tuple-a silly-tuple-b } ] [ + T{ silly-tuple f 1 2 } + [ + { silly-tuple-a silly-tuple-b } [ get-slots ] keep + ] compile-call +] unit-test + +! Regression +: empty-compound ; + +: node-successor-f-bug ( x -- * ) + [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; + +[ t ] [ \ node-successor-f-bug compiled? ] unit-test + +[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test + +[ ] [ [ ] dataflow optimize drop ] unit-test + +! Make sure we have sane heuristics +: should-inline? method flat-length 10 <= ; + +[ t ] [ \ fixnum \ shift should-inline? ] unit-test +[ f ] [ \ array \ equal? should-inline? ] unit-test +[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test +[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test + +! Regression +: lift-throw-tail-regression + dup integer? [ "an integer" ] [ + dup string? [ "a string" ] [ + "error" throw + ] if + ] if ; + +[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test +[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test +[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test + +: lift-loop-tail-test-1 ( a quot -- ) + over even? [ + [ >r 3 - r> call ] keep lift-loop-tail-test-1 + ] [ + over 0 < [ + 2drop + ] [ + [ >r 2 - r> call ] keep lift-loop-tail-test-1 + ] if + ] if ; inline + +: lift-loop-tail-test-2 + 10 [ ] lift-loop-tail-test-1 1 2 3 ; + +[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test + +! Make sure we don't lose +GENERIC: generic-inline-test ( x -- y ) +M: integer generic-inline-test ; + +: generic-inline-test-1 + 1 + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test + generic-inline-test ; + +[ { t f } ] [ + \ generic-inline-test-1 word-def dataflow + [ optimize-1 , optimize-1 , drop ] { } make +] unit-test + +! Forgot a recursive inline check +: recursive-inline-hang ( a -- a ) + dup array? [ recursive-inline-hang ] when ; + +HINTS: recursive-inline-hang array ; + +: recursive-inline-hang-1 + { } recursive-inline-hang ; + +[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test + +DEFER: recursive-inline-hang-3 + +: recursive-inline-hang-2 ( a -- a ) + dup array? [ recursive-inline-hang-3 ] when ; + +HINTS: recursive-inline-hang-2 array ; + +: recursive-inline-hang-3 ( a -- a ) + dup array? [ recursive-inline-hang-2 ] when ; + +HINTS: recursive-inline-hang-3 array ; + + diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 2efc9b4e67..6cb03e4199 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -175,10 +175,10 @@ M: method-spec synopsis* dup definer. [ pprint-word ] each ; M: method-body synopsis* - dup definer. - "method" word-prop dup - method-specializer pprint* - method-generic pprint* ; + dup dup + definer. + "method-class" word-prop pprint* + "method-generic" word-prop pprint* ; M: mixin-instance synopsis* dup definer. @@ -269,7 +269,7 @@ M: builtin-class see-class* : see-implementors ( class -- seq ) dup implementors - [ method method-word ] with map + [ method ] with map natural-sort ; : see-class ( class -- ) @@ -280,9 +280,7 @@ M: builtin-class see-class* ] when drop ; : see-methods ( generic -- seq ) - "methods" word-prop - [ nip method-word ] { } assoc>map - natural-sort ; + "methods" word-prop values natural-sort ; M: word see dup see-class diff --git a/core/words/words.factor b/core/words/words.factor index e8b3fd9781..c9505d3d1d 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -68,7 +68,7 @@ SYMBOL: bootstrapping? : crossref? ( word -- ? ) { { [ dup "forgotten" word-prop ] [ f ] } - { [ dup "method" word-prop ] [ t ] } + { [ dup "method-definition" word-prop ] [ t ] } { [ dup word-vocabulary ] [ t ] } { [ t ] [ f ] } } cond nip ; From e156e0212ca1646dc677c542369bc5d52790ee63 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 4 Mar 2008 22:32:12 -0600 Subject: [PATCH 092/140] add a c-struct update a using --- extra/windows/kernel32/kernel32.factor | 12 ++++ extra/windows/time/time.factor | 78 +++++++++++++------------- 2 files changed, 51 insertions(+), 39 deletions(-) diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 3574df36db..37b833cae1 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -445,6 +445,18 @@ C-STRUCT: WIN32_FIND_DATA { { "TCHAR" 260 } "cFileName" } { { "TCHAR" 14 } "cAlternateFileName" } ; +C-STRUCT: BY_HANDLE_FILE_INFORMATION + { "DWORD" "dwFileAttributes" } + { "FILETIME" "ftCreationTime" } + { "FILETIME" "ftLastAccessTime" } + { "FILETIME" "ftLastWriteTime" } + { "DWORD" "dwVolumeSerialNumber" } + { "DWORD" "nFileSizeHigh" } + { "DWORD" "nFileSizeLow" } + { "DWORD" "nNumberOfLinks" } + { "DWORD" "nFileIndexHigh" } + { "DWORD" "nFileIndexLow" } ; + TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA TYPEDEF: WIN32_FIND_DATA* LPWIN32_FIND_DATA TYPEDEF: void* POVERLAPPED diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor index 62d2805f01..e910ca2888 100755 --- a/extra/windows/time/time.factor +++ b/extra/windows/time/time.factor @@ -1,39 +1,39 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types kernel math windows windows.kernel32 -namespaces calendar.backend ; -IN: windows.time - -: >64bit ( lo hi -- n ) - 32 shift bitor ; - -: windows-1601 ( -- timestamp ) - 1601 1 1 0 0 0 0 ; - -: FILETIME>windows-time ( FILETIME -- n ) - [ FILETIME-dwLowDateTime ] keep - FILETIME-dwHighDateTime >64bit ; - -: windows-time>timestamp ( n -- timestamp ) - 10000000 /i seconds windows-1601 swap time+ ; - -: windows-time ( -- n ) - "FILETIME" [ GetSystemTimeAsFileTime ] keep - FILETIME>windows-time ; - -: timestamp>windows-time ( timestamp -- n ) - #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC) - >gmt windows-1601 (time-) 10000000 * >integer ; - -: windows-time>FILETIME ( n -- FILETIME ) - "FILETIME" - [ - [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep - >r -32 shift r> set-FILETIME-dwHighDateTime - ] keep ; - -: timestamp>FILETIME ( timestamp -- FILETIME/f ) - [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ; - -: FILETIME>timestamp ( FILETIME -- timestamp/f ) - FILETIME>windows-time windows-time>timestamp ; +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types kernel math windows windows.kernel32 +namespaces calendar calendar.backend ; +IN: windows.time + +: >64bit ( lo hi -- n ) + 32 shift bitor ; + +: windows-1601 ( -- timestamp ) + 1601 1 1 0 0 0 0 ; + +: FILETIME>windows-time ( FILETIME -- n ) + [ FILETIME-dwLowDateTime ] keep + FILETIME-dwHighDateTime >64bit ; + +: windows-time>timestamp ( n -- timestamp ) + 10000000 /i seconds windows-1601 swap time+ ; + +: windows-time ( -- n ) + "FILETIME" [ GetSystemTimeAsFileTime ] keep + FILETIME>windows-time ; + +: timestamp>windows-time ( timestamp -- n ) + #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC) + >gmt windows-1601 (time-) 10000000 * >integer ; + +: windows-time>FILETIME ( n -- FILETIME ) + "FILETIME" + [ + [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep + >r -32 shift r> set-FILETIME-dwHighDateTime + ] keep ; + +: timestamp>FILETIME ( timestamp -- FILETIME/f ) + [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ; + +: FILETIME>timestamp ( FILETIME -- timestamp/f ) + FILETIME>windows-time windows-time>timestamp ; From 5c93d43aa124b4618be99afb29846ab70e3f6216 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 4 Mar 2008 22:32:42 -0600 Subject: [PATCH 093/140] add some more bit-twiddling words --- extra/math/functions/functions.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor index 59ade44365..85e07fe73f 100755 --- a/extra/math/functions/functions.factor +++ b/extra/math/functions/functions.factor @@ -34,6 +34,10 @@ M: real sqrt : set-bit ( x n -- y ) 2^ bitor ; foldable : bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable : bit-set? ( x n -- ? ) bit-clear? not ; foldable +: unmask ( x n -- ? ) bitnot bitand ; foldable +: unmask? ( x n -- ? ) unmask 0 > ; foldable +: mask ( x n -- ? ) bitand ; foldable +: mask? ( x n -- ? ) mask 0 > ; foldable GENERIC: (^) ( x y -- z ) foldable From 6282a4ec5d42c2ec4a1279b47309182352dce5ec Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 4 Mar 2008 22:35:45 -0600 Subject: [PATCH 094/140] add windows replacement for stat --- extra/io/windows/files/files.factor | 108 ++++++++++++++++++++++++++++ 1 file changed, 108 insertions(+) create mode 100644 extra/io/windows/files/files.factor diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor new file mode 100644 index 0000000000..fdd574d00e --- /dev/null +++ b/extra/io/windows/files/files.factor @@ -0,0 +1,108 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types io.files io.windows kernel +math windows windows.kernel32 combinators.cleave +windows.time calendar combinators math.functions +sequences combinators.lib namespaces words ; +IN: io.windows.files + +SYMBOL: +read-only+ +SYMBOL: +hidden+ +SYMBOL: +system+ +SYMBOL: +directory+ +SYMBOL: +archive+ +SYMBOL: +device+ +SYMBOL: +normal+ +SYMBOL: +temporary+ +SYMBOL: +sparse-file+ +SYMBOL: +reparse-point+ +SYMBOL: +compressed+ +SYMBOL: +offline+ +SYMBOL: +not-content-indexed+ +SYMBOL: +encrypted+ + +: expand-constants ( word/obj -- obj'/obj ) + dup word? [ execute ] when ; + +: get-flags ( n seq -- seq' ) + [ + [ + first2 expand-constants + [ swapd mask? [ , ] [ drop ] if ] 2curry + ] map call-with + ] { } make ; + +: win32-file-attributes ( n -- seq ) + { + { +read-only+ FILE_ATTRIBUTE_READONLY } + { +hidden+ FILE_ATTRIBUTE_HIDDEN } + { +system+ FILE_ATTRIBUTE_SYSTEM } + { +directory+ FILE_ATTRIBUTE_DIRECTORY } + { +archive+ FILE_ATTRIBUTE_ARCHIVE } + { +device+ FILE_ATTRIBUTE_DEVICE } + { +normal+ FILE_ATTRIBUTE_NORMAL } + { +temporary+ FILE_ATTRIBUTE_TEMPORARY } + { +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE } + { +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT } + { +compressed+ FILE_ATTRIBUTE_COMPRESSED } + { +offline+ FILE_ATTRIBUTE_OFFLINE } + { +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED } + { +encrypted+ FILE_ATTRIBUTE_ENCRYPTED } + } get-flags ; + +: WIN32_FIND_DATA>file-info + { + [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ] + [ + [ WIN32_FIND_DATA-nFileSizeLow ] + [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit + ] + [ WIN32_FIND_DATA-dwFileAttributes ] + [ + WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp + ] + } cleave + \ file-info construct-boa ; + +: find-first-file-stat ( path -- WIN32_FIND_DATA ) + "WIN32_FIND_DATA" [ + FindFirstFile + [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep + FindClose win32-error=0/f + ] keep ; + +: BY_HANDLE_FILE_INFORMATION>file-info + { + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes ] + [ + [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] + [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit + ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ] + [ + BY_HANDLE_FILE_INFORMATION-ftLastWriteTime + FILETIME>timestamp + ] + } cleave + \ file-info construct-boa ; + +: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION ) + [ + "BY_HANDLE_FILE_INFORMATION" + [ GetFileInformationByHandle win32-error=0/f ] keep + ] keep CloseHandle win32-error=0/f ; + +: get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION ) + dup + GENERIC_READ FILE_SHARE_READ f + OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f + CreateFileW dup INVALID_HANDLE_VALUE = [ + drop find-first-file-stat WIN32_FIND_DATA>file-info + ] [ + nip + get-file-information BY_HANDLE_FILE_INFORMATION>file-info + ] if ; + +M: windows-nt-io file-info ( path -- info ) + get-file-information-stat ; + From c51ad0aa5a7af55782f0ae5aed8cce039b015b2a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 Mar 2008 22:44:46 -0600 Subject: [PATCH 095/140] Update modules for method changes --- extra/locals/locals.factor | 12 ++++++------ extra/tools/profiler/profiler.factor | 5 ++--- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 2e6fd6485d..79af9e63f8 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -279,7 +279,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ; ! are unified : create-method ( class generic -- method ) 2dup method dup - [ 2nip method-word ] + [ 2nip ] [ drop 2dup [ ] -rot define-method create-method ] if ; : CREATE-METHOD ( -- class generic body ) @@ -369,14 +369,14 @@ M: lambda-method definition : method-stack-effect dup "lambda" word-prop lambda-vars - swap "method" word-prop method-generic stack-effect dup [ effect-out ] when + swap "method-generic" word-prop stack-effect + dup [ effect-out ] when ; M: lambda-method synopsis* - dup definer. - dup "method" word-prop dup - method-specializer pprint* - method-generic pprint* + dup dup definer. + "method-specializer" word-prop pprint* + "method-generic" word-prop pprint* method-stack-effect effect>string comment. ; PRIVATE> diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor index 784c9e8da6..467fcc14f4 100755 --- a/extra/tools/profiler/profiler.factor +++ b/extra/tools/profiler/profiler.factor @@ -29,9 +29,8 @@ M: string (profile.) dup write-object ; M: method-body (profile.) - "method" word-prop - dup method-specializer over method-generic 2array synopsis - swap method-generic write-object ; + dup synopsis swap "method-generic" word-prop + write-object ; : counter. ( obj n -- ) [ From e933cf97fe035697209df546430393445c2b0ab3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 4 Mar 2008 22:46:01 -0600 Subject: [PATCH 096/140] Add $vocab-subsection --- core/vocabs/vocabs.factor | 2 ++ extra/help/markup/markup.factor | 26 ++++++++++++++----- extra/logging/insomniac/insomniac-docs.factor | 2 +- extra/logging/logging-docs.factor | 6 ++--- 4 files changed, 25 insertions(+), 11 deletions(-) mode change 100644 => 100755 extra/help/markup/markup.factor mode change 100644 => 100755 extra/logging/insomniac/insomniac-docs.factor mode change 100644 => 100755 extra/logging/logging-docs.factor diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 720a1ef645..1a3fecc3fb 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -55,6 +55,8 @@ M: f vocab-docs-loaded? ; M: f set-vocab-docs-loaded? 2drop ; +M: f vocab-help ; + : create-vocab ( name -- vocab ) dictionary get [ ] cache ; diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor old mode 100644 new mode 100755 index 5f1b027823..a866293bbe --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -144,20 +144,32 @@ M: f print-element drop ; : $link ( element -- ) first ($link) ; -: ($subsection) ( object -- ) - [ article-title ] keep >link write-object ; +: ($long-link) ( object -- ) + dup article-title swap >link write-link ; -: $subsection ( element -- ) +: ($subsection) ( element quot -- ) [ subsection-style get [ bullet get write bl - first ($subsection) + call ] with-style - ] ($block) ; + ] ($block) ; inline -: ($vocab-link) ( vocab -- ) dup f >vocab-link write-link ; +: $subsection ( element -- ) + [ first ($long-link) ] ($subsection) ; -: $vocab-link ( element -- ) first ($vocab-link) ; +: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ; + +: $vocab-subsection ( element -- ) + [ + first2 dup vocab-help dup [ + 2nip ($long-link) + ] [ + drop ($vocab-link) + ] if + ] ($subsection) ; + +: $vocab-link ( element -- ) first dup ($vocab-link) ; : $vocabulary ( element -- ) first word-vocabulary [ diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor old mode 100644 new mode 100755 index 64ac3b4ff6..93485e4c7c --- a/extra/logging/insomniac/insomniac-docs.factor +++ b/extra/logging/insomniac/insomniac-docs.factor @@ -27,7 +27,7 @@ HELP: schedule-insomniac { $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } } { $description "Starts a thread which e-mails log reports and rotates logs daily." } ; -ARTICLE: "logging.insomniac" "Automating log analysis and rotation" +ARTICLE: "logging.insomniac" "Automated log analysis" "The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary." $nl "Required configuration parameters:" diff --git a/extra/logging/logging-docs.factor b/extra/logging/logging-docs.factor old mode 100644 new mode 100755 index 939388026d..715b1551b9 --- a/extra/logging/logging-docs.factor +++ b/extra/logging/logging-docs.factor @@ -115,9 +115,9 @@ ARTICLE: "logging" "Logging framework" { $subsection "logging.levels" } { $subsection "logging.messages" } { $subsection "logging.rotation" } -{ $subsection "logging.parser" } -{ $subsection "logging.analysis" } -{ $subsection "logging.insomniac" } +{ $vocab-subsection "Log file parser" "logging.parser" } +{ $vocab-subsection "Log analysis" "logging.analysis" } +{ $vocab-subsection "Automated log analysis" "logging.insomniac" } { $subsection "logging.server" } ; ABOUT: "logging" From 4fd4882e024aabf424272208881ab170424d33b2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 13:51:31 -0600 Subject: [PATCH 097/140] fix unit tests --- extra/db/postgresql/postgresql-tests.factor | 259 -------------------- extra/db/sqlite/sqlite-tests.factor | 194 +-------------- 2 files changed, 12 insertions(+), 441 deletions(-) diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor index 250f98f73e..a6c2975c89 100755 --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -33,24 +33,6 @@ IN: db.postgresql.tests ] with-db ] unit-test -[ - { { "John" "America" } } -] [ - test-db [ - "select * from person where name = $1 and country = $2" - f f [ - { { "Jane" TEXT } { "New Zealand" TEXT } } - over do-bound-query - - { { "Jane" "New Zealand" } } = - [ "test fails" throw ] unless - - { { "John" TEXT } { "America" TEXT } } - swap do-bound-query - ] with-disposal - ] with-db -] unit-test - [ { { "John" "America" } @@ -111,244 +93,3 @@ IN: db.postgresql.tests : with-dummy-db ( quot -- ) >r T{ postgresql-db } db r> with-variable ; - -! TEST TUPLE DB - -TUPLE: puppy id name age ; -: ( name age -- puppy ) - { set-puppy-name set-puppy-age } puppy construct ; - -puppy "PUPPY" { - { "id" "ID" +native-id+ +not-null+ } - { "name" "NAME" { VARCHAR 256 } } - { "age" "AGE" INTEGER } -} define-persistent - -TUPLE: kitty id name age ; -: ( name age -- kitty ) - { set-kitty-name set-kitty-age } kitty construct ; - -kitty "KITTY" { - { "id" "ID" INTEGER +assigned-id+ } - { "name" "NAME" TEXT } - { "age" "AGE" INTEGER } -} define-persistent - -TUPLE: basket id puppies kitties ; -basket "BASKET" -{ - { "id" "ID" +native-id+ +not-null+ } - { "location" "LOCATION" TEXT } - { "puppies" { +has-many+ puppy } } - { "kitties" { +has-many+ kitty } } -} define-persistent - -! Create table -[ - "create table puppy(id serial primary key not null, name varchar 256, age integer);" -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table create-table-sql >lower - ] with-variable -] unit-test - -[ - "create table kitty(id integer primary key, name text, age integer);" -] [ - T{ postgresql-db } db [ - kitty dup db-columns swap db-table create-table-sql >lower - ] with-variable -] unit-test - -[ - "create table basket(id serial primary key not null, location text);" -] [ - T{ postgresql-db } db [ - basket dup db-columns swap db-table create-table-sql >lower - ] with-variable -] unit-test - -! Create function -[ - "create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;" -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table create-function-sql >lower - ] with-variable -] unit-test - -! Drop table - -[ - "drop table puppy;" -] [ - T{ postgresql-db } db [ - puppy db-table drop-table-sql >lower - ] with-variable -] unit-test - -[ - "drop table kitty;" -] [ - T{ postgresql-db } db [ - kitty db-table drop-table-sql >lower - ] with-variable -] unit-test - -[ - "drop table basket;" -] [ - T{ postgresql-db } db [ - basket db-table drop-table-sql >lower - ] with-variable -] unit-test - - -! Drop function -[ - "drop function add_puppy(varchar, integer);" -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table drop-function-sql >lower - ] with-variable -] unit-test - -! Insert -[ -] [ - T{ postgresql-db } db [ - puppy - ] with-variable -] unit-test - -[ - "insert into kitty(id, name, age) values($1, $2, $3);" - { - T{ - sql-spec - f - "id" - "ID" - INTEGER - { +assigned-id+ } - +assigned-id+ - } - T{ sql-spec f "name" "NAME" TEXT { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - } - { } -] [ - T{ postgresql-db } db [ - kitty - ] with-variable -] unit-test - -! Update -[ - "update puppy set name = $1, age = $2 where id = $3" - { - T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - T{ - sql-spec - f - "id" - "ID" - +native-id+ - { +not-null+ } - +native-id+ - } - } - { } -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table >r >r >lower r> r> - ] with-variable -] unit-test - -[ - "update kitty set name = $1, age = $2 where id = $3" - { - T{ sql-spec f "name" "NAME" TEXT { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - T{ - sql-spec - f - "id" - "ID" - INTEGER - { +assigned-id+ } - +assigned-id+ - } - } - { } -] [ - T{ postgresql-db } db [ - kitty dup db-columns swap db-table >r >r >lower r> r> - ] with-variable -] unit-test - -! Delete -[ - "delete from puppy where id = $1" - { - T{ - sql-spec - f - "id" - "ID" - +native-id+ - { +not-null+ } - +native-id+ - } - } - { } -] [ - T{ postgresql-db } db [ - puppy dup db-columns swap db-table >r >r >lower r> r> - ] with-variable -] unit-test - -[ - "delete from KITTY where ID = $1" - { - T{ - sql-spec - f - "id" - "ID" - INTEGER - { +assigned-id+ } - +assigned-id+ - } - } - { } -] [ - T{ postgresql-db } db [ - kitty dup db-columns swap db-table - ] with-variable -] unit-test - -! Select -[ - "select from PUPPY ID, NAME, AGE where NAME = $1;" - { T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } } - { - T{ - sql-spec - f - "id" - "ID" - +native-id+ - { +not-null+ } - +native-id+ - } - T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - } -] [ - T{ postgresql-db } db [ - T{ puppy f f "Mr. Clunkers" } - - ] with-variable -] unit-test diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index 974fdb8782..08139610a0 100755 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -3,49 +3,34 @@ prettyprint tools.test db.sqlite db sequences continuations db.types db.tuples unicode.case ; IN: db.sqlite.tests -: test.db "extra/db/sqlite/test.db" resource-path ; +: db-path "extra/db/sqlite/test.db" resource-path ; +: test.db db-path sqlite-db ; -[ ] [ [ test.db delete-file ] ignore-errors ] unit-test +[ ] [ [ db-path delete-file ] ignore-errors ] unit-test [ ] [ test.db [ "create table person (name varchar(30), country varchar(30))" sql-command "insert into person values('John', 'America')" sql-command "insert into person values('Jane', 'New Zealand')" sql-command - ] with-sqlite + ] with-db ] unit-test [ { { "John" "America" } { "Jane" "New Zealand" } } ] [ test.db [ "select * from person" sql-query - ] with-sqlite -] unit-test - -[ { { "John" "America" } } ] [ - test.db [ - "select * from person where name = :name and country = :country" - [ - { { ":name" "Jane" TEXT } { ":country" "New Zealand" TEXT } } - over do-bound-query - - { { "Jane" "New Zealand" } } = - [ "test fails" throw ] unless - - { { ":name" "John" TEXT } { ":country" "America" TEXT } } - swap do-bound-query - ] with-disposal - ] with-sqlite + ] with-db ] unit-test [ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ] -[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test +[ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test [ ] [ test.db [ "insert into person(name, country) values('Jimmy', 'Canada')" sql-command - ] with-sqlite + ] with-db ] unit-test [ @@ -54,7 +39,7 @@ IN: db.sqlite.tests { "2" "Jane" "New Zealand" } { "3" "Jimmy" "Canada" } } -] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test +] [ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test [ test.db [ @@ -63,13 +48,13 @@ IN: db.sqlite.tests "insert into person(name, country) values('Jose', 'Mexico')" sql-command "oops" throw ] with-transaction - ] with-sqlite + ] with-db ] must-fail [ 3 ] [ test.db [ "select * from person" sql-query length - ] with-sqlite + ] with-db ] unit-test [ @@ -81,166 +66,11 @@ IN: db.sqlite.tests "insert into person(name, country) values('Jose', 'Mexico')" sql-command ] with-transaction - ] with-sqlite + ] with-db ] unit-test [ 5 ] [ test.db [ "select * from person" sql-query length - ] with-sqlite -] unit-test - -! TEST TUPLE DB - -TUPLE: puppy id name age ; -: ( name age -- puppy ) - { set-puppy-name set-puppy-age } puppy construct ; - -puppy "PUPPY" { - { "id" "ID" +native-id+ +not-null+ } - { "name" "NAME" { VARCHAR 256 } } - { "age" "AGE" INTEGER } -} define-persistent - -TUPLE: kitty id name age ; -: ( name age -- kitty ) - { set-kitty-name set-kitty-age } kitty construct ; - -kitty "KITTY" { - { "id" "ID" INTEGER +assigned-id+ } - { "name" "NAME" TEXT } - { "age" "AGE" INTEGER } -} define-persistent - -TUPLE: basket id puppies kitties ; -basket "BASKET" -{ - { "id" "ID" +native-id+ +not-null+ } - { "location" "LOCATION" TEXT } - { "puppies" { +has-many+ puppy } } - { "kitties" { +has-many+ kitty } } -} define-persistent - -! Create table -[ - "create table puppy(id integer primary key not null, name varchar, age integer);" -] [ - T{ sqlite-db } db [ - puppy dup db-columns swap db-table create-sql >lower - ] with-variable -] unit-test - -[ - "create table kitty(id integer primary key, name text, age integer);" -] [ - T{ sqlite-db } db [ - kitty dup db-columns swap db-table create-sql >lower - ] with-variable -] unit-test - -[ - "create table basket(id integer primary key not null, location text);" -] [ - T{ sqlite-db } db [ - basket dup db-columns swap db-table create-sql >lower - ] with-variable -] unit-test - -! Drop table -[ - "drop table puppy;" -] [ - T{ sqlite-db } db [ - puppy db-table drop-sql >lower - ] with-variable -] unit-test - -[ - "drop table kitty;" -] [ - T{ sqlite-db } db [ - kitty db-table drop-sql >lower - ] with-variable -] unit-test - -[ - "drop table basket;" -] [ - T{ sqlite-db } db [ - basket db-table drop-sql >lower - ] with-variable -] unit-test - -! Insert -[ - "insert into puppy(name, age) values(:name, :age);" -] [ - T{ sqlite-db } db [ - puppy dup db-columns swap db-table insert-sql* >lower - ] with-variable -] unit-test - -[ - "insert into kitty(id, name, age) values(:id, :name, :age);" -] [ - T{ sqlite-db } db [ - kitty dup db-columns swap db-table insert-sql* >lower - ] with-variable -] unit-test - -! Update -[ - "update puppy set name = :name, age = :age where id = :id" -] [ - T{ sqlite-db } db [ - puppy dup db-columns swap db-table update-sql* >lower - ] with-variable -] unit-test - -[ - "update kitty set name = :name, age = :age where id = :id" -] [ - T{ sqlite-db } db [ - kitty dup db-columns swap db-table update-sql* >lower - ] with-variable -] unit-test - -! Delete -[ - "delete from puppy where id = :id" -] [ - T{ sqlite-db } db [ - puppy dup db-columns swap db-table delete-sql* >lower - ] with-variable -] unit-test - -[ - "delete from kitty where id = :id" -] [ - T{ sqlite-db } db [ - kitty dup db-columns swap db-table delete-sql* >lower - ] with-variable -] unit-test - -! Select -[ - "select from puppy id, name, age where name = :name;" - { - T{ - sql-spec - f - "id" - "ID" - +native-id+ - { +not-null+ } - +native-id+ - } - T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } - T{ sql-spec f "age" "AGE" INTEGER { } f } - } -] [ - T{ sqlite-db } db [ - T{ puppy f f "Mr. Clunkers" } - select-sql >r >lower r> - ] with-variable + ] with-db ] unit-test From 93c4ac23a859347bb88f302e650c378d0588c76e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 5 Mar 2008 14:51:01 -0600 Subject: [PATCH 098/140] Encodings updates; /* */ comments in multline --- core/io/encodings/encodings-docs.factor | 32 +++++- .../encodings-tests.factor} | 8 +- core/io/encodings/encodings.factor | 105 ++++++++---------- core/io/encodings/utf8/utf8-docs.factor | 2 +- core/io/encodings/utf8/utf8.factor | 20 ++-- core/io/io-docs.factor | 2 +- .../streams/byte-array/byte-array-docs.factor | 33 ++++++ core/io/streams/string/string-docs.factor | 2 +- core/io/streams/string/string.factor | 2 +- extra/help/handbook/handbook.factor | 5 +- extra/io/encodings/ascii/ascii.factor | 2 +- extra/io/encodings/latin1/latin1.factor | 4 +- extra/io/encodings/utf16/utf16-docs.factor | 51 +++------ extra/io/encodings/utf16/utf16.factor | 72 ++++++------ extra/multiline/multiline.factor | 2 + 15 files changed, 188 insertions(+), 154 deletions(-) rename core/io/{streams/lines/lines-tests.factor => encodings/encodings-tests.factor} (86%) create mode 100644 core/io/streams/byte-array/byte-array-docs.factor diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index 132da2bb70..6dfd94a2b9 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -3,7 +3,7 @@ IN: io.encodings ABOUT: "encodings" -ARTICLE: "encodings" "I/O encodings" +ARTICLE: "io.encodings" "I/O encodings" "Many streams deal with bytes, rather than Unicode code points, at some level. The translation between these two things is specified by an encoding. To abstract this away from the programmer, Factor provides a system where these streams are associated with an encoding which is always used when the stream is read from or written to. For most purposes, an encoding descriptor consisting of a symbol is all that is needed when initializing a stream." { $subsection "encodings-constructors" } { $subsection "encodings-descriptors" } @@ -37,17 +37,37 @@ HELP: ( stream-in stream-out encoding -- duplex ) { } related-words ARTICLE: "encodings-descriptors" "Encoding descriptors" -"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use include:" -{ $vocab-link "io.encodings.utf8" } -{ $vocab-link "io.encodings.ascii" } -{ $vocab-link "io.encodings.binary" } -{ $vocab-link "io.encodings.utf16" } ; +"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:" +$nl { $vocab-link "io.encodings.utf8" } +$nl { $vocab-link "io.encodings.ascii" } +$nl { $vocab-link "io.encodings.binary" } +$nl { $vocab-link "io.encodings.utf16" } ; ARTICLE: "encodings-protocol" "Encoding protocol" "An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again." { $subsection decode-step } +{ $subsection init-decoder } { $subsection encode-string } ; ARTICLE: "encodings-string" "Encoding and decoding strings" "Strings can be encoded and decoded with the following words:" { $subsection encode-string } ; + +HELP: decode-step ( buf char encoding -- ) +{ $values { "buf" "A string buffer which characters can be pushed to" } + { "char" "An octet which is read from a stream" } + { "encoding" "An encoding descriptor tuple" } } +{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change." } ; + +HELP: encode-string ( string encoding -- byte-array ) +{ $values { "string" "a string" } + { "encoding" "an encoding descriptor" } + { "byte-array" "an encoded byte-array" } } +{ $description "Encodes the string with the given encoding descriptor, outputting the result to a byte-array." } ; + +HELP: init-decoder ( stream encoding -- encoding ) +{ $values { "stream" "an input stream" } + { "encoding" "an encoding descriptor" } } +{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM." } ; + +{ init-decoder decode-step encode-string } related-words diff --git a/core/io/streams/lines/lines-tests.factor b/core/io/encodings/encodings-tests.factor similarity index 86% rename from core/io/streams/lines/lines-tests.factor rename to core/io/encodings/encodings-tests.factor index e8ecc65526..73d2efa7d4 100755 --- a/core/io/streams/lines/lines-tests.factor +++ b/core/io/encodings/encodings-tests.factor @@ -1,9 +1,9 @@ -USING: io.streams.lines io.files io.streams.string io -tools.test kernel ; -IN: io.streams.lines.tests +USING: io.files io.streams.string io +tools.test kernel io.encodings.ascii ; +IN: io.streams.encodings.tests : ( resource -- stream ) - resource-path ; + resource-path ascii ; [ { } ] [ "/core/io/test/empty-file.txt" lines ] diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index bc4f21e8e2..8489c46d2e 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -3,9 +3,22 @@ USING: math kernel sequences sbufs vectors namespaces growable strings io classes continuations combinators io.styles io.streams.plain io.encodings.binary splitting -io.streams.duplex ; +io.streams.duplex byte-arrays ; IN: io.encodings +! The encoding descriptor protocol + +GENERIC: decode-step ( buf char encoding -- ) +M: object decode-step drop swap push ; + +GENERIC: init-decoder ( stream encoding -- encoding ) +M: tuple-class init-decoder construct-empty init-decoder ; +M: object init-decoder nip ; + +GENERIC: encode-string ( string encoding -- byte-array ) +M: tuple-class encode-string construct-empty encode-string ; +M: object encode-string drop >byte-array ; + ! Decoding TUPLE: decode-error ; @@ -21,19 +34,6 @@ SYMBOL: begin ! This is the replacement character HEX: fffd push-decoded ; -: finish-decoding ( buf ch state -- str ) - begin eq? [ decode-error ] unless drop "" like ; - -: start-decoding ( seq length -- buf ch state seq ) - 0 begin roll ; - -GENERIC: decode-step ( buf byte ch state encoding -- buf ch state ) - -: decode ( seq quot -- string ) - >r dup length start-decoding r> - [ -rot ] swap compose each - finish-decoding ; inline - : space ( resizable -- room-left ) dup underlying swap [ length ] 2apply - ; @@ -42,34 +42,34 @@ GENERIC: decode-step ( buf byte ch state encoding -- buf ch state ) : end-read-loop ( buf ch state stream quot -- string/f ) 2drop 2drop >string f like ; -: decode-read-loop ( buf ch state stream encoding -- string/f ) - >r >r pick r> r> rot full? [ end-read-loop ] [ +: decode-read-loop ( buf stream encoding -- string/f ) + pick full? [ 2drop >string ] [ over stream-read1 [ - -rot tuck >r >r >r -rot r> decode-step r> r> decode-read-loop - ] [ end-read-loop ] if* + -rot tuck >r >r >r dupd r> decode-step r> r> + decode-read-loop + ] [ 2drop >string f like ] if* ] if ; : decode-read ( length stream encoding -- string ) - >r swap >fixnum start-decoding r> - decode-read-loop ; + rot -rot decode-read-loop ; -TUPLE: decoded code cr ; +TUPLE: decoder code cr ; : ( stream encoding -- newstream ) dup binary eq? [ drop ] [ - construct-empty { set-delegate set-decoded-code } - decoded construct + dupd init-decoder { set-delegate set-decoder-code } + decoder construct ] if ; -: cr+ t swap set-decoded-cr ; inline +: cr+ t swap set-decoder-cr ; inline -: cr- f swap set-decoded-cr ; inline +: cr- f swap set-decoder-cr ; inline : line-ends/eof ( stream str -- str ) f like swap cr- ; inline : line-ends\r ( stream str -- str ) swap cr+ ; inline : line-ends\n ( stream str -- str ) - over decoded-cr over empty? and + over decoder-cr over empty? and [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline : handle-readln ( stream str ch -- str ) @@ -80,43 +80,43 @@ TUPLE: decoded code cr ; } case ; : fix-read ( stream string -- string ) - over decoded-cr [ + over decoder-cr [ over cr- "\n" ?head [ swap stream-read1 [ add ] when* ] [ nip ] if ] [ nip ] if ; -M: decoded stream-read - tuck { delegate decoded-code } get-slots decode-read fix-read ; +M: decoder stream-read + tuck { delegate decoder-code } get-slots decode-read fix-read ; -M: decoded stream-read-partial stream-read ; +M: decoder stream-read-partial stream-read ; -: decoded-read-until ( stream delim -- ch ) +: decoder-read-until ( stream delim -- ch ) ! Copied from { c-reader stream-read-until }!!! over stream-read1 dup [ - dup pick memq? [ 2nip ] [ , decoded-read-until ] if + dup pick memq? [ 2nip ] [ , decoder-read-until ] if ] [ 2nip ] if ; -M: decoded stream-read-until +M: decoder stream-read-until ! Copied from { c-reader stream-read-until }!!! - [ swap decoded-read-until ] "" make + [ swap decoder-read-until ] "" make swap over empty? over not and [ 2drop f f ] when ; : fix-read1 ( stream char -- char ) - over decoded-cr [ + over decoder-cr [ over cr- dup CHAR: \n = [ drop stream-read1 ] [ nip ] if ] [ nip ] if ; -M: decoded stream-read1 +M: decoder stream-read1 1 swap stream-read f like [ first ] [ f ] if* ; -M: decoded stream-readln ( stream -- str ) +M: decoder stream-readln ( stream -- str ) "\r\n" over stream-read-until handle-readln ; ! Encoding @@ -125,41 +125,30 @@ TUPLE: encode-error ; : encode-error ( -- * ) \ encode-error construct-empty throw ; -TUPLE: encoded code ; +TUPLE: encoder code ; : ( stream encoding -- newstream ) dup binary eq? [ drop ] [ - construct-empty { set-delegate set-encoded-code } - encoded construct + construct-empty { set-delegate set-encoder-code } + encoder construct ] if ; -GENERIC: encode-string ( string encoding -- byte-array ) -M: tuple-class encode-string construct-empty encode-string ; - -M: encoded stream-write1 +M: encoder stream-write1 >r 1string r> stream-write ; -M: encoded stream-write - [ encoded-code encode-string ] keep delegate stream-write ; +M: encoder stream-write + [ encoder-code encode-string ] keep delegate stream-write ; -M: encoded dispose delegate dispose ; +M: encoder dispose delegate dispose ; -INSTANCE: encoded plain-writer +INSTANCE: encoder plain-writer ! Rebinding duplex streams which have not read anything yet : reencode ( stream encoding -- newstream ) - over encoded? [ >r delegate r> ] when ; + over encoder? [ >r delegate r> ] when ; : redecode ( stream encoding -- newstream ) - over decoded? [ >r delegate r> ] when ; + over decoder? [ >r delegate r> ] when ; : ( stream-in stream-out encoding -- duplex ) tuck reencode >r redecode r> ; - -! The null encoding does nothing -! (used to wrap things as line-reader/plain-writer) -! Later this will be replaced by inheritance - -TUPLE: null-encoding ; -M: null-encoding encode-string drop ; -M: null-encoding decode-step 3drop over push f f ; diff --git a/core/io/encodings/utf8/utf8-docs.factor b/core/io/encodings/utf8/utf8-docs.factor index 734a7f7236..3e901ec83b 100755 --- a/core/io/encodings/utf8/utf8-docs.factor +++ b/core/io/encodings/utf8/utf8-docs.factor @@ -6,6 +6,6 @@ ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data" { $subsection utf8 } ; HELP: utf8 -{ $class-description "This is the class of encoding tuples which denote a UTF-8 encoding. You can pass this class symbol as an encoding descriptor to words like " { $link } " and " { $link encode-string } "." } ; +{ $class-description "This is the class of encoding tuples which denote a UTF-8 encoding. You can pass this class symbol as an encoding descriptor to words like " { $link } " and " { $link encode-string } ". This conforms to the " { $link "encodings-protocol" } "." } ; ABOUT: "io.encodings.utf8" diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index 2e7585b8a9..edc4663214 100644 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -6,6 +6,8 @@ IN: io.encodings.utf8 ! Decoding UTF-8 +TUPLE: utf8 ch state ; + SYMBOL: double SYMBOL: triple SYMBOL: triple2 @@ -44,8 +46,16 @@ SYMBOL: quad3 { quad3 [ end-multibyte ] } } case ; -: decode-utf8 ( seq -- str ) - [ decode-utf8-step ] decode ; +: unpack-state ( encoding -- ch state ) + { utf8-ch utf8-state } get-slots ; + +: pack-state ( ch state encoding -- ) + { set-utf8-ch set-utf8-state } set-slots ; + +M: utf8 decode-step ( buf char encoding -- ) + [ unpack-state decode-utf8-step ] keep pack-state drop ; + +M: utf8 init-decoder nip begin over set-utf8-state ; ! Encoding UTF-8 @@ -75,10 +85,4 @@ SYMBOL: quad3 : encode-utf8 ( str -- seq ) [ [ char>utf8 ] each ] B{ } make ; -! Interface for streams - -TUPLE: utf8 ; - M: utf8 encode-string drop encode-utf8 ; -M: utf8 decode-step drop decode-utf8-step ; -! In the future, this should detect and ignore a BOM at the beginning diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 0986196e8d..fd40950e62 100755 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -100,7 +100,7 @@ $nl { $subsection "stream-protocol" } { $subsection "stdio" } { $subsection "stream-utils" } -{ $see-also "io.streams.string" "io.streams.lines" "io.streams.plain" "io.streams.duplex" } ; +{ $see-also "io.streams.string" "io.streams.plain" "io.streams.duplex" } ; ABOUT: "streams" diff --git a/core/io/streams/byte-array/byte-array-docs.factor b/core/io/streams/byte-array/byte-array-docs.factor new file mode 100644 index 0000000000..8e0b97e06b --- /dev/null +++ b/core/io/streams/byte-array/byte-array-docs.factor @@ -0,0 +1,33 @@ +USING: help.syntax help.markup io byte-arrays quotations ; +IN: io.streams.byte-array + +ABOUT: "io.streams.byte-array" + +ARTICLE: "io.streams.byte-array" "Byte-array streams" +"Byte array streams:" +{ $subsection } +{ $subsection } +"Utility combinators:" +{ $subsection with-byte-reader } +{ $subsection with-byte-writer } ; + +HELP: +{ $values { "byte-array" byte-array } + { "encoding" "an encoding descriptor" } } +{ $description "Provides an input stream reading off the given byte array using the given encoding." } ; + +HELP: +{ $values { "encoding" "an encoding descriptor" } + { "stream" "an output stream" } } +{ $description "Provides an output stream, putting things in the given encoding, storing everything written to it in a byte-array." } ; + +HELP: with-byte-reader +{ $values { "encoding" "an encoding descriptor" } + { "quot" quotation } { "byte-array" byte-array } } +{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading the byte array in the given encoding from beginning to end." } ; + +HELP: with-byte-writer +{ $values { "encoding" "an encoding descriptor" } + { "quot" quotation } + { "byte-array" byte-array } } +{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to a new byte array writer, putting things in the given encoding. The accumulated byte array is output when the quotation returns." } ; diff --git a/core/io/streams/string/string-docs.factor b/core/io/streams/string/string-docs.factor index e948d2162a..91ac244608 100644 --- a/core/io/streams/string/string-docs.factor +++ b/core/io/streams/string/string-docs.factor @@ -26,4 +26,4 @@ HELP: HELP: with-string-reader { $values { "str" string } { "quot" quotation } } -{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end. The accumulated string is output when the quotation returns." } ; +{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end." } ; diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index 15fc2b704e..7833e0aa47 100755 --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -50,7 +50,7 @@ M: growable stream-read-partial stream-read ; : ( str -- stream ) - >sbuf dup reverse-here null-encoding ; + >sbuf dup reverse-here f ; : with-string-reader ( str quot -- ) >r r> with-stream ; inline diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 178b7a5d35..a078db8762 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -2,7 +2,7 @@ USING: help help.markup help.syntax help.definitions help.topics namespaces words sequences classes assocs vocabs kernel arrays prettyprint.backend kernel.private io generic math system strings sbufs vectors byte-arrays bit-arrays float-arrays -quotations ; +quotations io.streams.byte-array ; IN: help.handbook ARTICLE: "conventions" "Conventions" @@ -176,9 +176,9 @@ ARTICLE: "io" "Input and output" { $subsection "streams" } "Wrapper streams:" { $subsection "io.streams.duplex" } -{ $subsection "io.streams.lines" } { $subsection "io.streams.plain" } { $subsection "io.streams.string" } +{ $subsection "io.streams.byte-array" } "Utilities:" { $subsection "stream-binary" } { $subsection "styles" } @@ -187,6 +187,7 @@ ARTICLE: "io" "Input and output" { $subsection "io.mmap" } { $subsection "io.monitors" } { $heading "Other features" } +{ $subsection "io.encodings" } { $subsection "network-streams" } { $subsection "io.launcher" } { $subsection "io.timeouts" } ; diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor index 0878a7a624..6dd8d23155 100644 --- a/extra/io/encodings/ascii/ascii.factor +++ b/extra/io/encodings/ascii/ascii.factor @@ -12,4 +12,4 @@ M: ascii encode-string drop 127 encode-check<= ; M: ascii decode-step - 3drop dup 127 >= [ encode-error ] when over push f f ; + drop dup 128 >= [ encode-error ] [ swap push ] if ; diff --git a/extra/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor index b914589dc9..36e38caa1c 100755 --- a/extra/io/encodings/latin1/latin1.factor +++ b/extra/io/encodings/latin1/latin1.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.encodings strings kernel io.encodings.ascii sequences ; +USING: io io.encodings strings kernel io.encodings.ascii sequences math ; IN: io.encodings.latin1 TUPLE: latin1 ; @@ -9,4 +9,4 @@ M: latin1 encode-string drop 255 encode-check<= ; M: latin1 decode-step - 3drop over push f f ; + drop dup 256 >= [ encode-error ] [ swap push ] if ; diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/extra/io/encodings/utf16/utf16-docs.factor index c49c030ef3..018a15a534 100644 --- a/extra/io/encodings/utf16/utf16-docs.factor +++ b/extra/io/encodings/utf16/utf16-docs.factor @@ -1,45 +1,22 @@ USING: help.markup help.syntax io.encodings strings ; IN: io.encodings.utf16 -ARTICLE: "io.utf16" "Working with UTF16-encoded data" -"The UTF16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences." -{ $subsection encode-utf16le } -{ $subsection encode-utf16be } -{ $subsection decode-utf16le } -{ $subsection decode-utf16be } -"Support for UTF16 data with a byte order mark:" -{ $subsection encode-utf16 } -{ $subsection decode-utf16 } ; +ARTICLE: "utf16" "Working with UTF-16-encoded data" +"The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:" +{ $subsection utf16le } +{ $subsection utf16be } +{ $subsection utf16 } +"All of these conform to the " { $link "encodings-protocol" } "." ; -ABOUT: "io.utf16" +ABOUT: "utf16" -HELP: decode-utf16 -{ $values { "seq" "a sequence of bytes" } { "str" string } } -{ $description "Decodes a sequence of bytes representing a Unicode string in UTF16 format. The bytes must begin with a UTF16 byte order mark, which determines if the input is in little or big endian. To decode data without a byte order mark, use " { $link decode-utf16le } " or " { $link decode-utf16be } "." } -{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ; +HELP: utf16le +{ $class-description "The encoding protocol for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." } ; -HELP: decode-utf16be -{ $values { "seq" "a sequence of bytes" } { "str" string } } -{ $description "Decodes a sequence of bytes representing a Unicode string in big endian UTF16 format. The bytes must not begin with a UTF16 byte order mark. To decode data with a byte order mark, use " { $link decode-utf16 } "." } -{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ; +HELP: utf16be +{ $class-description "The encoding protocol for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." } ; -HELP: decode-utf16le -{ $values { "seq" "a sequence of bytes" } { "str" string } } -{ $description "Decodes a sequence of bytes representing a Unicode string in little endian UTF16 format. The bytes must not begin with a UTF16 byte order mark. To decode data with a byte order mark, use " { $link decode-utf16 } "." } -{ $errors "Throws a " { $link decode-error } " if the input is malformed." } ; +HELP: utf16 +{ $class-description "The encoding protocol for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." } ; -{ decode-utf16 decode-utf16le decode-utf16be } related-words - -HELP: encode-utf16be -{ $values { "str" string } { "seq" "a sequence of bytes" } } -{ $description "Encodes a Unicode string as a sequence of bytes in big endian UTF16 format." } ; - -HELP: encode-utf16le -{ $values { "str" string } { "seq" "a sequence of bytes" } } -{ $description "Encodes a Unicode string as a sequence of bytes in little endian UTF16 format." } ; - -HELP: encode-utf16 -{ $values { "str" string } { "seq" "a sequence of bytes" } } -{ $description "Encodes a Unicode string as a sequence of bytes in UTF16 format with a byte order mark." } ; - -{ encode-utf16 encode-utf16be encode-utf16le } related-words +{ utf16 utf16le utf16be } related-words diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor index 3e10dcba35..8815d588ad 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/extra/io/encodings/utf16/utf16.factor @@ -4,6 +4,10 @@ USING: math kernel sequences sbufs vectors namespaces io.binary io.encodings combinators splitting io byte-arrays ; IN: io.encodings.utf16 +! UTF-16BE decoding + +TUPLE: utf16be ch state ; + SYMBOL: double SYMBOL: quad1 SYMBOL: quad2 @@ -40,8 +44,20 @@ SYMBOL: ignore { ignore [ 2drop push-replacement ] } } case ; -: decode-utf16be ( seq -- str ) - [ decode-utf16be-step ] decode ; +: unpack-state-be ( encoding -- ch state ) + { utf16be-ch utf16be-state } get-slots ; + +: pack-state-be ( ch state encoding -- ) + { set-utf16be-ch set-utf16be-state } set-slots ; + +M: utf16be decode-step + [ unpack-state-be decode-utf16be-step ] keep pack-state-be drop ; + +M: utf16be init-decoder nip begin over set-utf16be-state ; + +! UTF-16LE decoding + +TUPLE: utf16le ch state ; : handle-double ( buf byte ch -- buf ch state ) swap dup -3 shift BIN: 11011 = [ @@ -64,8 +80,18 @@ SYMBOL: ignore { quad3 [ handle-quad3le ] } } case ; -: decode-utf16le ( seq -- str ) - [ decode-utf16le-step ] decode ; +: unpack-state-le ( encoding -- ch state ) + { utf16le-ch utf16le-state } get-slots ; + +: pack-state-le ( ch state encoding -- ) + { set-utf16le-ch set-utf16le-state } set-slots ; + +M: utf16le decode-step + [ unpack-state-le decode-utf16le-step ] keep pack-state-le drop ; + +M: utf16le init-decoder nip begin over set-utf16le-state ; + +! UTF-16LE/BE encoding : encode-first -10 shift @@ -97,6 +123,11 @@ SYMBOL: ignore : encode-utf16le ( str -- seq ) [ [ char>utf16le ] each ] B{ } make ; +M: utf16le encode-string drop encode-utf16le ; +M: utf16be encode-string drop encode-utf16be ; + +! UTF-16 + : bom-le B{ HEX: ff HEX: fe } ; inline : bom-be B{ HEX: fe HEX: ff } ; inline @@ -108,40 +139,17 @@ SYMBOL: ignore : start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ; -: decode-utf16 ( seq -- str ) - { - { [ start-utf16le? ] [ decode-utf16le ] } - { [ start-utf16be? ] [ decode-utf16be ] } - { [ t ] [ decode-error ] } - } cond ; - -TUPLE: utf16le ; - -M: utf16le encode-string drop encode-utf16le ; -M: utf16le decode-step drop decode-utf16le-step ; - -TUPLE: utf16be ; - -M: utf16be encode-string drop encode-utf16be ; -M: utf16be decode-step drop decode-utf16be-step ; - -TUPLE: utf16 encoding ; +TUPLE: utf16 started? ; M: utf16 encode-string >r encode-utf16le r> - dup utf16-encoding [ drop ] - [ t swap set-utf16-encoding bom-le swap append ] if ; + dup utf16-started? [ drop ] + [ t swap set-utf16-started? bom-le swap append ] if ; : bom>le/be ( bom -- le/be ) dup bom-le sequence= [ drop utf16le ] [ bom-be sequence= [ utf16be ] [ decode-error ] if ] if ; -: read-bom ( utf16 -- encoding ) - 2 over delegate stream-read bom>le/be construct-empty - [ swap set-utf16-encoding ] keep ; - -M: utf16 decode-step - ! inefficient: checks if bom is done many times - ! This should transform itself into utf16be or utf16le after reading BOM - dup utf16-encoding [ ] [ read-bom ] ?if decode-step ; +M: utf16 init-decoder ( stream encoding -- newencoding ) + 2 rot stream-read bom>le/be construct-empty init-decoder ; diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor index d32c11dd06..5baa205d15 100755 --- a/extra/multiline/multiline.factor +++ b/extra/multiline/multiline.factor @@ -38,3 +38,5 @@ IN: multiline : <" "\">" parse-multiline-string parsed ; parsing + +: /* "*/" parse-multiline-string drop ; parsing From fa898aa8c6cfbb331f6141a28b0f8a331fc602d5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 15:02:02 -0600 Subject: [PATCH 099/140] Fixes --- extra/benchmark/sockets/sockets.factor | 123 ++++++++++----------- extra/bootstrap/image/upload/upload.factor | 2 +- 2 files changed, 59 insertions(+), 66 deletions(-) diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index c739bb787c..4927776575 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,65 +1,58 @@ -USING: io.sockets io kernel math threads -debugger tools.time prettyprint concurrency.count-downs -namespaces arrays continuations ; -IN: benchmark.sockets - -SYMBOL: counter - -: number-of-requests 1 ; - -: server-addr "127.0.0.1" 7777 ; - -: server-loop ( server -- ) - dup accept [ - [ - read1 CHAR: x = [ - "server" get dispose - ] [ - number-of-requests - [ read1 write1 flush ] times - counter get count-down - ] if - ] with-stream - ] curry "Client handler" spawn drop server-loop ; - -: simple-server ( -- ) - [ - server-addr dup "server" set [ - server-loop - ] with-disposal - ] ignore-errors ; - -: simple-client ( -- ) - server-addr [ - CHAR: b write1 flush - number-of-requests - [ CHAR: a dup write1 flush read1 assert= ] times - counter get count-down - ] with-stream ; - -: stop-server ( -- ) - server-addr [ - CHAR: x write1 - ] with-stream ; - -: clients ( n -- ) - dup pprint " clients: " write [ - dup 2 * counter set - [ simple-server ] "Simple server" spawn drop - yield yield - [ [ simple-client ] "Simple client" spawn drop ] times - counter get await - stop-server - yield yield - ] time ; - -: socket-benchmarks - 10 clients - 20 clients - 40 clients ; - ! 80 clients - ! 160 clients - ! 320 clients - ! 640 clients ; - -MAIN: socket-benchmarks +USING: io.sockets io kernel math threads +debugger tools.time prettyprint concurrency.count-downs +namespaces arrays continuations ; +IN: benchmark.sockets + +SYMBOL: counter + +: number-of-requests 1 ; + +: server-addr "127.0.0.1" 7777 ; + +: server-loop ( server -- ) + dup accept [ + [ + read1 CHAR: x = [ + "server" get dispose + ] [ + number-of-requests + [ read1 write1 flush ] times + counter get count-down + ] if + ] with-stream + ] curry "Client handler" spawn drop server-loop ; + +: simple-server ( -- ) + [ + server-addr dup "server" set [ + server-loop + ] with-disposal + ] ignore-errors ; + +: simple-client ( -- ) + server-addr [ + CHAR: b write1 flush + number-of-requests + [ CHAR: a dup write1 flush read1 assert= ] times + counter get count-down + ] with-stream ; + +: stop-server ( -- ) + server-addr [ + CHAR: x write1 + ] with-stream ; + +: clients ( n -- ) + dup pprint " clients: " write [ + dup 2 * counter set + [ simple-server ] "Simple server" spawn drop + yield yield + [ [ simple-client ] "Simple client" spawn drop ] times + counter get await + stop-server + yield yield + ] time ; + +: socket-benchmarks ; + +MAIN: socket-benchmarks diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index 084f30a103..3c0b464dbf 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -8,7 +8,7 @@ SYMBOL: upload-images-destination : destination ( -- dest ) upload-images-destination get - "slava@/var/www/factorcode.org/newsite/images/latest/" + "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/" or ; : checksums "checksums.txt" temp-file ; From 492d7bc6464bc4ba49c52b5fd2dd51ef7d87a8bb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 15:23:02 -0600 Subject: [PATCH 100/140] Fix load error --- extra/delegate/delegate.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 667805dcc3..33ac780caa 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -39,7 +39,7 @@ M: tuple-class group-words : define-mimic ( group mimicker mimicked -- ) >r >r group-words r> r> [ pick "methods" word-prop at dup - [ method-def spin define-method ] [ 3drop ] if + [ "method-def" word-prop spin define-method ] [ 3drop ] if ] 2curry each ; : MIMIC: From e96a4bd4507ea8004bb94d40a81a7ce8e995b691 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 15:24:13 -0600 Subject: [PATCH 101/140] Fix load error --- extra/delegate/delegate.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 667805dcc3..654d096b26 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -39,7 +39,8 @@ M: tuple-class group-words : define-mimic ( group mimicker mimicked -- ) >r >r group-words r> r> [ pick "methods" word-prop at dup - [ method-def spin define-method ] [ 3drop ] if + [ "method-def" word-prop spin define-method ] + [ 3drop ] if ] 2curry each ; : MIMIC: From 00acf627ef9d1f114681f7ce7ff6c0cd7f18c041 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 15:59:15 -0600 Subject: [PATCH 102/140] Markup fixes --- extra/benchmark/benchmark.factor | 2 +- extra/help/markup/markup.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index bd13455357..231c6edf50 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -21,7 +21,7 @@ IN: benchmark ] with-row [ [ - swap [ ($vocab-link) ] with-cell + swap [ dup ($vocab-link) ] with-cell first2 pprint-cell pprint-cell ] with-row ] assoc-each diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor index a866293bbe..32e29db7db 100755 --- a/extra/help/markup/markup.factor +++ b/extra/help/markup/markup.factor @@ -173,7 +173,7 @@ M: f print-element drop ; : $vocabulary ( element -- ) first word-vocabulary [ - "Vocabulary" $heading nl ($vocab-link) + "Vocabulary" $heading nl dup ($vocab-link) ] when* ; : textual-list ( seq quot -- ) From 3c98385c11b566f9f7c20df6e1e227fd1ff30b6c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 16:00:34 -0600 Subject: [PATCH 103/140] Fixes for recent method tuple cleanup --- core/words/words.factor | 2 +- extra/db/sqlite/test.db | Bin 0 -> 2048 bytes extra/locals/locals.factor | 4 ++-- extra/tools/deploy/shaker/strip-cocoa.factor | 3 ++- 4 files changed, 5 insertions(+), 4 deletions(-) create mode 100644 extra/db/sqlite/test.db diff --git a/core/words/words.factor b/core/words/words.factor index c9505d3d1d..ce69c1ff2e 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -68,7 +68,7 @@ SYMBOL: bootstrapping? : crossref? ( word -- ? ) { { [ dup "forgotten" word-prop ] [ f ] } - { [ dup "method-definition" word-prop ] [ t ] } + { [ dup "method-def" word-prop ] [ t ] } { [ dup word-vocabulary ] [ t ] } { [ t ] [ f ] } } cond nip ; diff --git a/extra/db/sqlite/test.db b/extra/db/sqlite/test.db new file mode 100644 index 0000000000000000000000000000000000000000..e483c47cea528c95f10fcf66fcbb67ffa351ffd1 GIT binary patch literal 2048 zcmWFz^vNtqRY=P(%1ta$FlJz3U}R))P*7lCU|k literal 0 HcmV?d00001 diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 79af9e63f8..5f58f1464a 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -367,14 +367,14 @@ M: lambda-method definer drop \ M:: \ ; ; M: lambda-method definition "lambda" word-prop lambda-body ; -: method-stack-effect +: method-stack-effect ( method -- effect ) dup "lambda" word-prop lambda-vars swap "method-generic" word-prop stack-effect dup [ effect-out ] when ; M: lambda-method synopsis* - dup dup definer. + dup dup dup definer. "method-specializer" word-prop pprint* "method-generic" word-prop pprint* method-stack-effect effect>string comment. ; diff --git a/extra/tools/deploy/shaker/strip-cocoa.factor b/extra/tools/deploy/shaker/strip-cocoa.factor index 2eddce6475..b37e42f323 100755 --- a/extra/tools/deploy/shaker/strip-cocoa.factor +++ b/extra/tools/deploy/shaker/strip-cocoa.factor @@ -1,5 +1,6 @@ USING: cocoa cocoa.messages cocoa.application cocoa.nibs -assocs namespaces kernel words compiler sequences ui.cocoa ; +assocs namespaces kernel words compiler.units sequences +ui.cocoa ; "stop-after-last-window?" get global [ From 914456f31578965c0f07fcaa6c065e5f48bc6230 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 16:07:25 -0600 Subject: [PATCH 104/140] year month day > timestamp year month day hour minute second > timestamp --- extra/calendar/format/format.factor | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 75ceea8ea2..d89afe615e 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -125,6 +125,35 @@ M: timestamp year. ( timestamp -- ) : rfc3339>timestamp ( str -- timestamp ) [ (rfc3339>timestamp) ] with-string-reader ; +: (ymdhms>timestamp) ( -- timestamp ) + read-0000 ! year + "-" expect + read-00 ! month + "-" expect + read-00 ! day + " " expect + read-00 ! hour + ":" expect + read-00 ! minute + ":" expect + read-00 ! second + 0 ! timezone + ; + +: ymdhms>timestamp ( str -- timestamp ) + [ (ymdhms>timestamp) ] with-string-reader ; + +: (ymd>timestamp) ( -- timestamp ) + read-0000 ! year + "-" expect + read-00 ! month + "-" expect + read-00 ! day + 0 0 0 0 ; + +: ymd>timestamp ( str -- timestamp ) + [ (ymd>timestamp) ] with-string-reader ; + : file-time-string ( timestamp -- string ) [ [ month>> month-abbreviations nth write ] keep bl From 82ed128f4733d1939bed9b4d64f0e4364c3aca94 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 16:10:29 -0600 Subject: [PATCH 105/140] make unknown elements f instead of 0 add hours:minutes:seconds --- extra/calendar/format/format.factor | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index d89afe615e..9b349fcc6c 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -143,13 +143,25 @@ M: timestamp year. ( timestamp -- ) : ymdhms>timestamp ( str -- timestamp ) [ (ymdhms>timestamp) ] with-string-reader ; +: (hms>timestamp) ( -- timestamp ) + f f f + read-00 ! hour + ":" expect + read-00 ! minute + ":" expect + read-00 ! second + f ; + +: hms>timestamp ( str -- timestamp ) + [ (hms>timestamp) ] with-string-reader ; + : (ymd>timestamp) ( -- timestamp ) read-0000 ! year "-" expect read-00 ! month "-" expect read-00 ! day - 0 0 0 0 ; + f f f f ; : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; From 2c3b23286f823dde18effb55c5578adc066cac29 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 16:21:02 -0600 Subject: [PATCH 106/140] add timestamp>ymdhms and related code --- extra/calendar/format/format.factor | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 9b349fcc6c..c1bd6427a7 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -166,6 +166,34 @@ M: timestamp year. ( timestamp -- ) : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; + +: (timestamp>ymd) ( timestamp -- ) + dup timestamp-year number>string write + "-" write + dup timestamp-month write-00 + "-" write + timestamp-day write-00 ; + +: timestamp>ymd ( timestamp -- str ) + [ (timestamp>ymd) ] with-string-writer ; + +: (timestamp>hms) + dup timestamp-hour write-00 + ":" write + dup timestamp-minute write-00 + ":" write + timestamp-second >integer write-00 ; + +: timestamp>hms ( timestamp -- str ) + [ (timestamp>hms) ] with-string-writer ; + +: timestamp>ymdhms ( timestamp -- str ) + [ + dup (timestamp>ymd) + " " write + (timestamp>hms) + ] with-string-writer ; + : file-time-string ( timestamp -- string ) [ [ month>> month-abbreviations nth write ] keep bl From b6b8ab32b55b91ec59dccd9f388449502e4e75a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 16:24:32 -0600 Subject: [PATCH 107/140] Fixing unit tests --- core/classes/classes-tests.factor | 4 ++-- core/generic/generic.factor | 2 -- core/words/words-tests.factor | 2 +- extra/tools/crossref/crossref-tests.factor | 2 +- 4 files changed, 4 insertions(+), 6 deletions(-) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 38ca796384..640439312d 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -56,8 +56,8 @@ UNION: c a b ; [ t ] [ \ c \ tuple class< ] unit-test [ f ] [ \ tuple \ c class< ] unit-test -DEFER: bah -FORGET: bah +! DEFER: bah +! FORGET: bah UNION: bah fixnum alien ; [ bah ] [ \ bah? "predicating" word-prop ] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index dbff82777f..f73579661d 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -25,8 +25,6 @@ GENERIC: make-default-method ( generic combination -- method ) PREDICATE: word generic "combination" word-prop >boolean ; -M: generic definer drop f f ; - M: generic definition drop f ; : make-generic ( word -- ) diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 97ce86d38a..06f3c7a782 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -141,7 +141,7 @@ SYMBOL: quot-uses-b [ { + } ] [ \ quot-uses-b uses ] unit-test -[ "IN: words.tests : undef-test ; << undef-test >>" eval ] +[ "IN: words.tests FORGET: undef-test : undef-test ; << undef-test >>" eval ] [ [ undefined? ] is? ] must-fail-with [ ] [ diff --git a/extra/tools/crossref/crossref-tests.factor b/extra/tools/crossref/crossref-tests.factor index a277a68ed7..0717763ed0 100755 --- a/extra/tools/crossref/crossref-tests.factor +++ b/extra/tools/crossref/crossref-tests.factor @@ -8,5 +8,5 @@ M: integer foo + ; "resource:extra/tools/crossref/test/foo.factor" run-file -[ t ] [ integer \ foo method method-word \ + usage member? ] unit-test +[ t ] [ integer \ foo method \ + usage member? ] unit-test [ t ] [ \ foo usage [ pathname? ] contains? ] unit-test From 2aabeb9bb3d16d021737c9ea28c8c1fc7a969cdc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 17:40:42 -0600 Subject: [PATCH 108/140] add failing unit test to farkup --- extra/farkup/farkup-tests.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index 2e0d9832b0..f4b3025fcd 100755 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -42,3 +42,7 @@ IN: farkup.tests [ "

foo\n

aheading

\n

adfasd

" ] [ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test + +[ "

=foo\n

" ] [ "=foo\n" convert-farkup ] unit-test +[ "

foo

\n" ] [ "=foo=\n" convert-farkup ] unit-test +[ "

lol

foo

\n" ] [ "lol=foo=\n" convert-farkup ] unit-test From e06885550e277d783a3291517d22c89158e92cf8 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 5 Mar 2008 17:41:25 -0600 Subject: [PATCH 109/140] Replacing encode/decode-utf8 with utf8 encode/decode-string --- core/io/encodings/string/string.factor | 5 +++++ extra/http/http.factor | 10 +++++----- extra/ui/x11/x11.factor | 6 +++--- extra/x11/clipboard/clipboard.factor | 5 +++-- 4 files changed, 16 insertions(+), 10 deletions(-) create mode 100644 core/io/encodings/string/string.factor diff --git a/core/io/encodings/string/string.factor b/core/io/encodings/string/string.factor new file mode 100644 index 0000000000..acfe2edd89 --- /dev/null +++ b/core/io/encodings/string/string.factor @@ -0,0 +1,5 @@ +USING: io.encodings io io.streams.byte-array ; +IN: io.encodings.string + +: decode-string ( byte-array encoding -- string ) + contents ; diff --git a/extra/http/http.factor b/extra/http/http.factor index 35fe3ce544..7ed921480c 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: hashtables io io.streams.string kernel math namespaces math.parser assocs sequences strings splitting ascii -io.encodings.utf8 namespaces unicode.case combinators -vectors sorting new-slots accessors calendar calendar.format -quotations arrays ; +io.encodings.utf8 io.encodings io.encodings.string namespaces +unicode.case combinators vectors sorting new-slots accessors +calendar calendar.format quotations arrays ; IN: http : http-port 80 ; inline @@ -18,7 +18,7 @@ IN: http swap "/_-." member? or ; foldable : push-utf8 ( ch -- ) - 1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; + 1string utf8 encode-string [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; : url-encode ( str -- str ) [ [ @@ -50,7 +50,7 @@ IN: http ] if ; : url-decode ( str -- str ) - [ 0 swap url-decode-iter ] "" make decode-utf8 ; + [ 0 swap url-decode-iter ] "" make utf8 decode-string ; : crlf "\r\n" write ; diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 1fec668717..ae56c6a43f 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types arrays ui ui.gadgets ui.gestures ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math namespaces opengl sequences strings x11.xlib x11.events x11.xim -x11.glx x11.clipboard x11.constants x11.windows +x11.glx x11.clipboard x11.constants x11.windows io.encodings io.encodings.utf8 combinators debugger system command-line ui.render math.vectors tuples opengl.gl threads ; IN: ui.x11 @@ -137,7 +137,7 @@ M: world selection-notify-event : encode-clipboard ( string type -- bytes ) XSelectionRequestEvent-target XA_UTF8_STRING = - [ encode-utf8 ] [ string>char-alien ] if ; + [ utf8 encode-string ] [ string>char-alien ] if ; : set-selection-prop ( evt -- ) dpy get swap @@ -212,7 +212,7 @@ M: x-clipboard paste-clipboard : set-title-new ( dpy window string -- ) >r XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace - r> encode-utf8 dup length XChangeProperty drop ; + r> utf8 encode-string dup length XChangeProperty drop ; M: x11-ui-backend set-title ( string world -- ) world-handle x11-handle-window swap dpy get -rot diff --git a/extra/x11/clipboard/clipboard.factor b/extra/x11/clipboard/clipboard.factor index eb4191ebb1..b839e262d9 100755 --- a/extra/x11/clipboard/clipboard.factor +++ b/extra/x11/clipboard/clipboard.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax arrays kernel math -namespaces sequences io.encodings.utf8 x11.xlib x11.constants ; +namespaces sequences io.encodings.string io.encodings.utf8 x11.xlib +x11.constants ; IN: x11.clipboard ! This code was based on by McCLIM's Backends/CLX/port.lisp @@ -35,7 +36,7 @@ TUPLE: x-clipboard atom contents ; >r XSelectionEvent-property zero? [ r> drop f ] [ - r> selection-property 1 window-property decode-utf8 + r> selection-property 1 window-property utf8 decode-string ] if ; : own-selection ( prop win -- ) From 1abb7c643e6665940872503b4a0fc4c8e4fc7aab Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 5 Mar 2008 17:49:02 -0600 Subject: [PATCH 110/140] Tests for decode-string --- core/io/encodings/string/string-tests.factor | 5 +++++ extra/benchmark/sockets/sockets.factor | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) create mode 100644 core/io/encodings/string/string-tests.factor diff --git a/core/io/encodings/string/string-tests.factor b/core/io/encodings/string/string-tests.factor new file mode 100644 index 0000000000..50d246183b --- /dev/null +++ b/core/io/encodings/string/string-tests.factor @@ -0,0 +1,5 @@ +USING: io.encodings.utf8 io.encodings.utf16 io.encodings.string tools.test ; +IN: io.encodings.string.tests + +[ "hello" ] [ "hello" utf8 decode-string ] unit-test +[ "he" ] [ "\0h\0e" utf16be decode-string ] unit-test diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 30d069b9e0..25212c7264 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,4 +1,4 @@ -USING: io.sockets io kernel math threads +USING: io.sockets io kernel math threads io.encodings.ascii debugger tools.time prettyprint concurrency.count-downs namespaces arrays continuations ; IN: benchmark.sockets From f84761ae0c5c0a172787d71312a87d6be518af21 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 18:15:28 -0600 Subject: [PATCH 111/140] fix docs for delay --- extra/peg/peg-docs.factor | 3 ++- extra/peg/peg.factor | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index 6dff95c829..9ad375ea04 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -135,9 +135,10 @@ HELP: hide HELP: delay { $values + { "quot" "a quotation" } { "parser" "a parser" } } { $description "Delays the construction of a parser until it is actually required to parse. This " "allows for calling a parser that results in a recursive call to itself. The quotation " - "should return the constructed parser." } ; \ No newline at end of file + "should return the constructed parser." } ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 01decc2c81..16cf40f884 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -358,7 +358,7 @@ MEMO: sp ( parser -- parser ) MEMO: hide ( parser -- parser ) [ drop ignore ] action ; -MEMO: delay ( parser -- parser ) +MEMO: delay ( quot -- parser ) delay-parser construct-boa init-parser ; : PEG: From 3eb7830d2c7c99aef369a7a3a5b1f5ec4deb0584 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 19:08:33 -0600 Subject: [PATCH 112/140] before major overhaul on return values --- extra/db/sqlite/lib/lib.factor | 32 +++++++++--- extra/db/sqlite/sqlite.factor | 8 ++- extra/db/tuples/tuples-tests.factor | 75 ++++++++++++++++++++++------- extra/db/types/types.factor | 28 ++++++----- 4 files changed, 105 insertions(+), 38 deletions(-) diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 648d8493dc..40486ba19f 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -2,7 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators -continuations db.types ; +continuations db.types calendar.format serialize +io.streams.string byte-arrays ; +USE: tools.walker IN: db.sqlite.lib : sqlite-error ( n -- * ) @@ -55,6 +57,10 @@ IN: db.sqlite.lib : sqlite-bind-null ( handle i -- ) sqlite3_bind_null sqlite-check-result ; +: sqlite-bind-blob ( handle i byte-array -- ) + dup length SQLITE_TRANSIENT + sqlite3_bind_blob sqlite-check-result ; + : sqlite-bind-text-by-name ( handle name text -- ) parameter-index sqlite-bind-text ; @@ -67,20 +73,33 @@ IN: db.sqlite.lib : sqlite-bind-double-by-name ( handle name double -- ) parameter-index sqlite-bind-double ; +: sqlite-bind-blob-by-name ( handle name blob -- ) + parameter-index sqlite-bind-blob ; + : sqlite-bind-null-by-name ( handle name obj -- ) parameter-index drop sqlite-bind-null ; : sqlite-bind-type ( handle key value type -- ) + over [ drop NULL ] unless dup array? [ first ] when { { INTEGER [ sqlite-bind-int-by-name ] } - { BIG_INTEGER [ sqlite-bind-int64-by-name ] } + { BIG-INTEGER [ sqlite-bind-int64-by-name ] } { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } - { TIMESTAMP [ sqlite-bind-double-by-name ] } + { DATE [ sqlite-bind-text-by-name ] } + { TIME [ sqlite-bind-text-by-name ] } + { DATETIME [ sqlite-bind-text-by-name ] } + { TIMESTAMP [ sqlite-bind-text-by-name ] } + { BLOB [ sqlite-bind-blob-by-name ] } + { FACTOR-BLOB [ + break + [ serialize ] with-string-writer >byte-array + sqlite-bind-blob-by-name + ] } { +native-id+ [ sqlite-bind-int-by-name ] } - ! { NULL [ sqlite-bind-null-by-name ] } + { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; @@ -93,21 +112,20 @@ IN: db.sqlite.lib : sqlite-#columns ( query -- int ) sqlite3_column_count ; -! TODO : sqlite-column ( handle index -- string ) sqlite3_column_text ; : sqlite-column-typed ( handle index type -- obj ) { { INTEGER [ sqlite3_column_int ] } - { BIG_INTEGER [ sqlite3_column_int64 ] } + { BIG-INTEGER [ sqlite3_column_int64 ] } { TEXT [ sqlite3_column_text ] } { DOUBLE [ sqlite3_column_double ] } { TIMESTAMP [ sqlite3_column_double ] } + ! { NULL [ 2drop f ] } [ no-sql-type ] } case ; -! TODO : sqlite-row ( handle -- seq ) dup sqlite-#columns [ sqlite-column ] with map ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index cfdcfc7750..1e55dc8331 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -179,8 +179,7 @@ M: sqlite-db ( tuple class -- statement ) " where " 0% [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave - ";" 0% - ] if + ] if ";" 0% ] sqlite-make ; M: sqlite-db modifier-table ( -- hashtable ) @@ -209,8 +208,13 @@ M: sqlite-db type-table ( -- assoc ) { INTEGER "integer" } { TEXT "text" } { VARCHAR "text" } + { DATE "date" } + { TIME "time" } + { DATETIME "datetime" } { TIMESTAMP "timestamp" } { DOUBLE "real" } + { BLOB "blob" } + { FACTOR-BLOB "blob" } } ; M: sqlite-db create-type-table diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 517f8bcc36..e30b06411f 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -2,39 +2,45 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.tuples db.types continuations namespaces db.postgresql math -prettyprint tools.walker db.sqlite ; +prettyprint tools.walker db.sqlite calendar ; IN: db.tuples.tests -TUPLE: person the-id the-name the-number the-real ; +TUPLE: person the-id the-name the-number the-real ts date time blob ; : ( name age real -- person ) { set-person-the-name set-person-the-number set-person-the-real + set-person-ts + set-person-date + set-person-time + set-person-blob } person construct ; : ( id name number the-real -- obj ) [ set-person-the-id ] keep ; -SYMBOL: the-person1 -SYMBOL: the-person2 +SYMBOL: person1 +SYMBOL: person2 +SYMBOL: person3 +SYMBOL: person4 : test-tuples ( -- ) [ person drop-table ] [ drop ] recover [ ] [ person create-table ] unit-test [ person create-table ] must-fail - [ ] [ the-person1 get insert-tuple ] unit-test + [ ] [ person1 get insert-tuple ] unit-test - [ 1 ] [ the-person1 get person-the-id ] unit-test + [ 1 ] [ person1 get person-the-id ] unit-test - 200 the-person1 get set-person-the-number + 200 person1 get set-person-the-number - [ ] [ the-person1 get update-tuple ] unit-test + [ ] [ person1 get update-tuple ] unit-test [ T{ person f 1 "billy" 200 3.14 } ] [ T{ person f 1 } select-tuple ] unit-test - [ ] [ the-person2 get insert-tuple ] unit-test + [ ] [ person2 get insert-tuple ] unit-test [ { T{ person f 1 "billy" 200 3.14 } @@ -49,8 +55,19 @@ SYMBOL: the-person2 ] [ T{ person f } select-tuples ] unit-test - [ ] [ the-person1 get delete-tuple ] unit-test + [ ] [ person1 get delete-tuple ] unit-test [ f ] [ T{ person f 1 } select-tuple ] unit-test + + [ ] [ person3 get insert-tuple ] unit-test + + [ + T{ person f 3 "teddy" 10 3.14 + T{ timestamp f 2008 3 5 16 24 11 0 } + T{ timestamp f 2008 11 22 f f f f } + T{ timestamp f f f f 12 34 56 f } + "storeinablob" } + ] [ T{ person f 3 } select-tuple ] unit-test + [ ] [ person drop-table ] unit-test ; : make-native-person-table ( -- ) @@ -67,9 +84,14 @@ SYMBOL: the-person2 { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "the-real" "REAL" DOUBLE { +default+ 0.3 } } + { "ts" "TS" TIMESTAMP } + { "date" "D" DATE } + { "time" "T" TIME } + { "blob" "B" BLOB } } define-persistent - "billy" 10 3.14 the-person1 set - "johnny" 10 3.14 the-person2 set ; + "billy" 10 3.14 f f f f person1 set + "johnny" 10 3.14 f f f f person2 set + "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } person3 set ; : assigned-person-schema ( -- ) person "PERSON" @@ -78,10 +100,14 @@ SYMBOL: the-person2 { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "the-real" "REAL" DOUBLE { +default+ 0.3 } } + { "ts" "TS" TIMESTAMP } + { "date" "D" DATE } + { "time" "T" TIME } + { "blob" "B" BLOB } } define-persistent - 1 "billy" 10 3.14 the-person1 set - 2 "johnny" 10 3.14 the-person2 set ; - + 1 "billy" 10 3.14 f f f f person1 set + 2 "johnny" 10 3.14 f f f f person2 set + 3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } person3 set ; TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; @@ -125,7 +151,22 @@ TUPLE: annotation n paste-id summary author mode contents ; : test-postgresql ( -- ) >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; -[ native-person-schema test-tuples ] test-sqlite -[ assigned-person-schema test-tuples ] test-sqlite + +! [ native-person-schema test-tuples ] test-sqlite +! [ assigned-person-schema test-tuples ] test-sqlite + +TUPLE: serialize-me id data ; +[ + serialize-me "SERIALIZED" + { + { "id" "ID" +native-id+ } + { "data" "DATA" FACTOR-BLOB } + } define-persistent + [ serialize-me drop-table ] [ drop ] recover + [ ] [ serialize-me create-table ] unit-test + + [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test + [ ] [ T{ serialize-me f 1 } select-tuples ] unit-test +] test-sqlite ! [ make-native-person-table ] test-sqlite diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index c84b23c50f..89c26c1dd6 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -3,7 +3,8 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes -mirrors tuples combinators ; +mirrors tuples combinators calendar.format serialize +io.streams.string ; IN: db.types HOOK: modifier-table db ( -- hash ) @@ -60,14 +61,19 @@ SYMBOL: +has-many+ : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; SYMBOL: INTEGER -SYMBOL: BIG_INTEGER +SYMBOL: BIG-INTEGER SYMBOL: DOUBLE SYMBOL: REAL SYMBOL: BOOLEAN SYMBOL: TEXT SYMBOL: VARCHAR -SYMBOL: TIMESTAMP SYMBOL: DATE +SYMBOL: TIME +SYMBOL: DATETIME +SYMBOL: TIMESTAMP +SYMBOL: BLOB +SYMBOL: FACTOR-BLOB +SYMBOL: NULL : spec>tuple ( class spec -- tuple ) [ ?first3 ] keep 3 ?tail* @@ -80,15 +86,6 @@ SYMBOL: DATE } sql-spec construct dup normalize-spec ; -: sql-type-hash ( -- assoc ) - H{ - { INTEGER "integer" } - { TEXT "text" } - { VARCHAR "varchar" } - { DOUBLE "real" } - { TIMESTAMP "timestamp" } - } ; - TUPLE: no-sql-type ; : no-sql-type ( -- * ) T{ no-sql-type } throw ; @@ -212,13 +209,20 @@ TUPLE: no-slot-named ; ] curry { } map>assoc ; : sql-type>factor-type ( obj type -- obj ) +break dup array? [ first ] when { { +native-id+ [ string>number ] } { INTEGER [ string>number ] } { DOUBLE [ string>number ] } { REAL [ string>number ] } + { DATE [ dup [ ymd>timestamp ] when ] } + { TIME [ dup [ hms>timestamp ] when ] } + { DATETIME [ dup [ ymdhms>timestamp ] when ] } + { TIMESTAMP [ dup [ ymdhms>timestamp ] when ] } { TEXT [ ] } { VARCHAR [ ] } + { BLOB [ ] } + { FACTOR-BLOB [ break [ deserialize ] with-string-reader ] } [ "no conversion from sql type to factor type" throw ] } case ; From 946d3e741499653ca6f0d41550198a8cf1575063 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 5 Mar 2008 19:12:40 -0600 Subject: [PATCH 113/140] changes in io.encodings.string --- core/io/encodings/encodings-docs.factor | 5 ----- core/io/encodings/string/authors.txt | 1 + core/io/encodings/string/string-docs.factor | 16 ++++++++++++++++ core/io/encodings/string/string-tests.factor | 10 +++++++--- core/io/encodings/string/string.factor | 7 +++++-- core/io/encodings/string/summary.txt | 1 + core/io/encodings/string/tags.factor | 1 + extra/help/handbook/handbook.factor | 6 ++++-- extra/http/http.factor | 6 +++--- extra/ui/x11/x11.factor | 6 +++--- extra/x11/clipboard/clipboard.factor | 2 +- 11 files changed, 42 insertions(+), 19 deletions(-) create mode 100644 core/io/encodings/string/authors.txt create mode 100644 core/io/encodings/string/string-docs.factor create mode 100644 core/io/encodings/string/summary.txt create mode 100644 core/io/encodings/string/tags.factor diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index 6dfd94a2b9..562e7dcd9a 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -7,7 +7,6 @@ ARTICLE: "io.encodings" "I/O encodings" "Many streams deal with bytes, rather than Unicode code points, at some level. The translation between these two things is specified by an encoding. To abstract this away from the programmer, Factor provides a system where these streams are associated with an encoding which is always used when the stream is read from or written to. For most purposes, an encoding descriptor consisting of a symbol is all that is needed when initializing a stream." { $subsection "encodings-constructors" } { $subsection "encodings-descriptors" } -{ $subsection "encodings-string" } { $subsection "encodings-protocol" } ; ARTICLE: "encodings-constructors" "Constructing an encoded stream" @@ -49,10 +48,6 @@ ARTICLE: "encodings-protocol" "Encoding protocol" { $subsection init-decoder } { $subsection encode-string } ; -ARTICLE: "encodings-string" "Encoding and decoding strings" -"Strings can be encoded and decoded with the following words:" -{ $subsection encode-string } ; - HELP: decode-step ( buf char encoding -- ) { $values { "buf" "A string buffer which characters can be pushed to" } { "char" "An octet which is read from a stream" } diff --git a/core/io/encodings/string/authors.txt b/core/io/encodings/string/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/core/io/encodings/string/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/core/io/encodings/string/string-docs.factor b/core/io/encodings/string/string-docs.factor new file mode 100644 index 0000000000..a5f92db165 --- /dev/null +++ b/core/io/encodings/string/string-docs.factor @@ -0,0 +1,16 @@ +USING: help.markup help.syntax byte-arrays strings ; +IN: io.encodings.string + +ARTICLE: "io.encodings.string" "Encoding and decoding strings" +"Strings can be encoded or decoded to and from byte arrays through an encoding with the following words:" +{ $subsection encode } +{ $subsection decode } ; + +HELP: decode +{ $values { "byte-array" byte-array } { "encoding" "an encoding descriptor" } + { "string" string } } +{ $description "Decodes the byte array using the given encoding, outputting a string" } ; + +HELP: encode +{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } } +{ $description "Encodes the given string into a byte array with the given encoding." } ; diff --git a/core/io/encodings/string/string-tests.factor b/core/io/encodings/string/string-tests.factor index 50d246183b..8d8db84799 100644 --- a/core/io/encodings/string/string-tests.factor +++ b/core/io/encodings/string/string-tests.factor @@ -1,5 +1,9 @@ -USING: io.encodings.utf8 io.encodings.utf16 io.encodings.string tools.test ; +USING: strings io.encodings.utf8 io.encodings.utf16 +io.encodings.string tools.test ; IN: io.encodings.string.tests -[ "hello" ] [ "hello" utf8 decode-string ] unit-test -[ "he" ] [ "\0h\0e" utf16be decode-string ] unit-test +[ "hello" ] [ "hello" utf8 decode ] unit-test +[ "he" ] [ "\0h\0e" utf16be decode ] unit-test + +[ "hello" ] [ "hello" utf8 encode >string ] unit-test +[ "\0h\0e" ] [ "he" utf16be encode >string ] unit-test diff --git a/core/io/encodings/string/string.factor b/core/io/encodings/string/string.factor index acfe2edd89..c6e01121dc 100644 --- a/core/io/encodings/string/string.factor +++ b/core/io/encodings/string/string.factor @@ -1,5 +1,8 @@ -USING: io.encodings io io.streams.byte-array ; +USING: io io.streams.byte-array ; IN: io.encodings.string -: decode-string ( byte-array encoding -- string ) +: decode ( byte-array encoding -- string ) contents ; + +: encode ( string encoding -- byte-array ) + [ write ] with-byte-writer ; diff --git a/core/io/encodings/string/summary.txt b/core/io/encodings/string/summary.txt new file mode 100644 index 0000000000..59b8927dea --- /dev/null +++ b/core/io/encodings/string/summary.txt @@ -0,0 +1 @@ +Encoding and decoding strings diff --git a/core/io/encodings/string/tags.factor b/core/io/encodings/string/tags.factor new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/core/io/encodings/string/tags.factor @@ -0,0 +1 @@ +text diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index a078db8762..84108a1db6 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -2,7 +2,7 @@ USING: help help.markup help.syntax help.definitions help.topics namespaces words sequences classes assocs vocabs kernel arrays prettyprint.backend kernel.private io generic math system strings sbufs vectors byte-arrays bit-arrays float-arrays -quotations io.streams.byte-array ; +quotations io.streams.byte-array io.encodings.string ; IN: help.handbook ARTICLE: "conventions" "Conventions" @@ -186,8 +186,10 @@ ARTICLE: "io" "Input and output" { $subsection "io.files" } { $subsection "io.mmap" } { $subsection "io.monitors" } -{ $heading "Other features" } +{ $heading "Encodings" } { $subsection "io.encodings" } +{ $subsection "io.encodings.string" } +{ $heading "Other features" } { $subsection "network-streams" } { $subsection "io.launcher" } { $subsection "io.timeouts" } ; diff --git a/extra/http/http.factor b/extra/http/http.factor index 7ed921480c..849b9e2fc9 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: hashtables io io.streams.string kernel math namespaces math.parser assocs sequences strings splitting ascii -io.encodings.utf8 io.encodings io.encodings.string namespaces +io.encodings.utf8 io.encodings.string namespaces unicode.case combinators vectors sorting new-slots accessors calendar calendar.format quotations arrays ; IN: http @@ -18,7 +18,7 @@ IN: http swap "/_-." member? or ; foldable : push-utf8 ( ch -- ) - 1string utf8 encode-string [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; + 1string utf8 encode [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; : url-encode ( str -- str ) [ [ @@ -50,7 +50,7 @@ IN: http ] if ; : url-decode ( str -- str ) - [ 0 swap url-decode-iter ] "" make utf8 decode-string ; + [ 0 swap url-decode-iter ] "" make utf8 decode ; : crlf "\r\n" write ; diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index ae56c6a43f..158a48a1c0 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types arrays ui ui.gadgets ui.gestures ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math namespaces opengl sequences strings x11.xlib x11.events x11.xim -x11.glx x11.clipboard x11.constants x11.windows io.encodings +x11.glx x11.clipboard x11.constants x11.windows io.encodings.string io.encodings.utf8 combinators debugger system command-line ui.render math.vectors tuples opengl.gl threads ; IN: ui.x11 @@ -137,7 +137,7 @@ M: world selection-notify-event : encode-clipboard ( string type -- bytes ) XSelectionRequestEvent-target XA_UTF8_STRING = - [ utf8 encode-string ] [ string>char-alien ] if ; + [ utf8 encode ] [ string>char-alien ] if ; : set-selection-prop ( evt -- ) dpy get swap @@ -212,7 +212,7 @@ M: x-clipboard paste-clipboard : set-title-new ( dpy window string -- ) >r XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace - r> utf8 encode-string dup length XChangeProperty drop ; + r> utf8 encode dup length XChangeProperty drop ; M: x11-ui-backend set-title ( string world -- ) world-handle x11-handle-window swap dpy get -rot diff --git a/extra/x11/clipboard/clipboard.factor b/extra/x11/clipboard/clipboard.factor index b839e262d9..0313776a20 100755 --- a/extra/x11/clipboard/clipboard.factor +++ b/extra/x11/clipboard/clipboard.factor @@ -36,7 +36,7 @@ TUPLE: x-clipboard atom contents ; >r XSelectionEvent-property zero? [ r> drop f ] [ - r> selection-property 1 window-property utf8 decode-string + r> selection-property 1 window-property utf8 decode ] if ; : own-selection ( prop win -- ) From d8858ef9249b6b8c0943d69660bbf8561a3ac205 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 5 Mar 2008 19:14:58 -0600 Subject: [PATCH 114/140] Stack effect comment typo in io.files --- core/io/files/files.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 5779aa6783..a2b640e267 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -218,10 +218,10 @@ M: pathname <=> [ pathname-string ] compare ; dupd swap file-length [ stream-copy ] keep >string ; -: with-file-reader ( path quot -- ) +: with-file-reader ( path encoding quot -- ) >r r> with-stream ; inline -: with-file-writer ( path quot -- ) +: with-file-writer ( path encoding quot -- ) >r r> with-stream ; inline : with-file-appender ( path encoding quot -- ) From dfb3dac5fd50973af8c2f4bae99cfab90db5f071 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 19:59:29 -0600 Subject: [PATCH 115/140] sqlite now gets return types with the optimized native functions removed a hack in type conversion serialize arbitrary factor objects to db --- extra/db/db.factor | 10 +++++++--- extra/db/sqlite/lib/lib.factor | 21 +++++++++++++++++++-- extra/db/sqlite/sqlite.factor | 5 +++-- extra/db/tuples/tuples-tests.factor | 19 ++++++++++++++----- extra/db/tuples/tuples.factor | 11 ++++------- extra/db/types/types.factor | 19 ------------------- 6 files changed, 47 insertions(+), 38 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index e834144d0c..170d9a60f1 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -34,7 +34,7 @@ HOOK: db-close db ( handle -- ) TUPLE: statement handle sql in-params out-params bind-params bound? ; TUPLE: simple-statement ; TUPLE: prepared-statement ; -TUPLE: result-set sql params handle n max ; +TUPLE: result-set sql in-params out-params handle n max ; : ( sql in out -- statement ) { (>>sql) (>>in-params) (>>out-params) } statement construct ; @@ -47,6 +47,7 @@ GENERIC: query-results ( query -- result-set ) GENERIC: #rows ( result-set -- n ) GENERIC: #columns ( result-set -- n ) GENERIC# row-column 1 ( result-set n -- obj ) +GENERIC# row-column-typed 1 ( result-set n -- sql ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) @@ -67,13 +68,16 @@ GENERIC: more-rows? ( result-set -- ? ) 0 >>n drop ; : ( query handle tuple -- result-set ) - >r >r { sql>> in-params>> } get-slots r> - { (>>sql) (>>params) (>>handle) } result-set + >r >r { sql>> in-params>> out-params>> } get-slots r> + { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set construct r> construct-delegate ; : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; +: sql-row-typed ( result-set -- seq ) + dup #columns [ row-column-typed ] with map ; + : query-each ( statement quot -- ) over more-rows? [ [ call ] 2keep over advance-row query-each diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 40486ba19f..f11f1e2ba6 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -94,7 +94,6 @@ IN: db.sqlite.lib { TIMESTAMP [ sqlite-bind-text-by-name ] } { BLOB [ sqlite-bind-blob-by-name ] } { FACTOR-BLOB [ - break [ serialize ] with-string-writer >byte-array sqlite-bind-blob-by-name ] } @@ -115,13 +114,31 @@ IN: db.sqlite.lib : sqlite-column ( handle index -- string ) sqlite3_column_text ; +: sqlite-column-blob ( handle index -- byte-array/f ) + [ sqlite3_column_bytes ] 2keep + pick zero? [ + 3drop f + ] [ + sqlite3_column_blob swap memory>byte-array + ] if ; + : sqlite-column-typed ( handle index type -- obj ) + dup array? [ first ] when { + { +native-id+ [ sqlite3_column_int64 ] } { INTEGER [ sqlite3_column_int ] } { BIG-INTEGER [ sqlite3_column_int64 ] } { TEXT [ sqlite3_column_text ] } + { VARCHAR [ sqlite3_column_text ] } { DOUBLE [ sqlite3_column_double ] } - { TIMESTAMP [ sqlite3_column_double ] } + { DATE [ sqlite3_column_text dup [ ymd>timestamp ] when ] } + { TIME [ sqlite3_column_text dup [ hms>timestamp ] when ] } + { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } + { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } + { BLOB [ sqlite-column-blob ] } + { FACTOR-BLOB [ + sqlite-column-blob [ deserialize ] with-string-reader + ] } ! { NULL [ 2drop f ] } [ no-sql-type ] } case ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 1e55dc8331..1524ee5a4f 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -80,8 +80,9 @@ M: sqlite-result-set #columns ( result-set -- n ) M: sqlite-result-set row-column ( result-set n -- obj ) >r result-set-handle r> sqlite-column ; -M: sqlite-result-set row-column-typed ( result-set n type -- obj ) - >r result-set-handle r> sqlite-column-typed ; +M: sqlite-result-set row-column-typed ( result-set n -- obj ) + dup pick result-set-out-params nth sql-spec-type + >r >r result-set-handle r> r> sqlite-column-typed ; M: sqlite-result-set advance-row ( result-set -- ) [ result-set-handle sqlite-next ] keep diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index e30b06411f..c9ceffe035 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -61,11 +61,18 @@ SYMBOL: person4 [ ] [ person3 get insert-tuple ] unit-test [ - T{ person f 3 "teddy" 10 3.14 + T{ + person + f + 3 + "teddy" + 10 + 3.14 T{ timestamp f 2008 3 5 16 24 11 0 } T{ timestamp f 2008 11 22 f f f f } T{ timestamp f f f f 12 34 56 f } - "storeinablob" } + B{ 115 116 111 114 101 105 110 97 98 108 111 98 } + } ] [ T{ person f 3 } select-tuple ] unit-test [ ] [ person drop-table ] unit-test ; @@ -152,8 +159,8 @@ TUPLE: annotation n paste-id summary author mode contents ; >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; -! [ native-person-schema test-tuples ] test-sqlite -! [ assigned-person-schema test-tuples ] test-sqlite +[ native-person-schema test-tuples ] test-sqlite +[ assigned-person-schema test-tuples ] test-sqlite TUPLE: serialize-me id data ; [ @@ -166,7 +173,9 @@ TUPLE: serialize-me id data ; [ ] [ serialize-me create-table ] unit-test [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test - [ ] [ T{ serialize-me f 1 } select-tuples ] unit-test + [ + { T{ serialize-me f 1 H{ { 1 2 } } } } + ] [ T{ serialize-me f 1 } select-tuples ] unit-test ] test-sqlite ! [ make-native-person-table ] test-sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index e7fe7e49c2..10a7c115ac 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -37,27 +37,24 @@ HOOK: db ( class -- obj ) HOOK: db ( tuple -- tuple ) -HOOK: row-column-typed db ( result-set n type -- sql ) HOOK: insert-tuple* db ( tuple statement -- ) : resulting-tuple ( row out-params -- tuple ) dup first sql-spec-class construct-empty [ [ - >r [ sql-spec-type sql-type>factor-type ] keep - sql-spec-slot-name r> set-slot-named + >r sql-spec-slot-name r> set-slot-named ] curry 2each ] keep ; : query-tuples ( statement -- seq ) [ statement-out-params ] keep query-results [ - [ sql-row swap resulting-tuple ] with query-map + [ sql-row-typed swap resulting-tuple ] with query-map ] with-disposal ; : query-modify-tuple ( tuple statement -- ) - [ query-results [ sql-row ] with-disposal ] keep + [ query-results [ sql-row-typed ] with-disposal ] keep statement-out-params rot [ - >r [ sql-spec-type sql-type>factor-type ] keep - sql-spec-slot-name r> set-slot-named + >r sql-spec-slot-name r> set-slot-named ] curry 2each ; : sql-props ( class -- columns table ) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 89c26c1dd6..c2aa825db8 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -207,22 +207,3 @@ TUPLE: no-slot-named ; >r dup sql-spec-type swap sql-spec-slot-name r> get-slot-named swap ] curry { } map>assoc ; - -: sql-type>factor-type ( obj type -- obj ) -break - dup array? [ first ] when - { - { +native-id+ [ string>number ] } - { INTEGER [ string>number ] } - { DOUBLE [ string>number ] } - { REAL [ string>number ] } - { DATE [ dup [ ymd>timestamp ] when ] } - { TIME [ dup [ hms>timestamp ] when ] } - { DATETIME [ dup [ ymdhms>timestamp ] when ] } - { TIMESTAMP [ dup [ ymdhms>timestamp ] when ] } - { TEXT [ ] } - { VARCHAR [ ] } - { BLOB [ ] } - { FACTOR-BLOB [ break [ deserialize ] with-string-reader ] } - [ "no conversion from sql type to factor type" throw ] - } case ; From b8eb5abd13b84a068a33b30fb928d87ed83f569d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 20:56:40 -0600 Subject: [PATCH 116/140] before major query overhaul --- extra/db/sqlite/sqlite.factor | 12 +++----- extra/db/tuples/tuples-tests.factor | 48 +++++++++++++++++++++++------ 2 files changed, 44 insertions(+), 16 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 1524ee5a4f..643b42165d 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -142,6 +142,10 @@ M: sqlite-db ( tuple -- statement ) " where " 0% find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ; +: where-clause ( specs -- ) + " where " 0% + [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ; + M: sqlite-db ( class -- statement ) [ "update " 0% @@ -174,13 +178,7 @@ M: sqlite-db ( tuple class -- statement ) " from " 0% 0% [ sql-spec-slot-name swap get-slot-named ] with subset - dup empty? [ - drop - ] [ - " where " 0% - [ ", " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave - ] if ";" 0% + dup empty? [ drop ] [ where-clause ] if ";" 0% ] sqlite-make ; M: sqlite-db modifier-table ( -- hashtable ) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index c9ceffe035..3a1e2c4f25 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -2,11 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.tuples db.types continuations namespaces db.postgresql math -prettyprint tools.walker db.sqlite calendar ; +prettyprint tools.walker db.sqlite calendar +math.intervals ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real ts date time blob ; -: ( name age real -- person ) +: ( name age real ts date time blob -- person ) { set-person-the-name set-person-the-number @@ -17,7 +18,7 @@ TUPLE: person the-id the-name the-number the-real ts date time blob ; set-person-blob } person construct ; -: ( id name number the-real -- obj ) +: ( id name age real ts date time blob -- person ) [ set-person-the-id ] keep ; SYMBOL: person1 @@ -54,6 +55,12 @@ SYMBOL: person4 } ] [ T{ person f } select-tuples ] unit-test + [ + { + T{ person f 2 "johnny" 10 3.14 } + } + ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test + [ ] [ person1 get delete-tuple ] unit-test [ f ] [ T{ person f 1 } select-tuple ] unit-test @@ -151,19 +158,18 @@ TUPLE: annotation n paste-id summary author mode contents ; ! [ ] [ annotation create-table ] unit-test ! ] with-db - : test-sqlite ( quot -- ) >r "tuples-test.db" resource-path sqlite-db r> with-db ; : test-postgresql ( -- ) >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; - [ native-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-tuples ] test-sqlite TUPLE: serialize-me id data ; -[ + +: test-serialize ( -- ) serialize-me "SERIALIZED" { { "id" "ID" +native-id+ } @@ -175,7 +181,31 @@ TUPLE: serialize-me id data ; [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test [ { T{ serialize-me f 1 H{ { 1 2 } } } } - ] [ T{ serialize-me f 1 } select-tuples ] unit-test -] test-sqlite + ] [ T{ serialize-me f 1 } select-tuples ] unit-test ; -! [ make-native-person-table ] test-sqlite +! [ test-serialize ] test-sqlite + +TUPLE: exam id name score ; + +: test-ranges ( -- ) + exam "EXAM" + { + { "id" "ID" +native-id+ } + { "name" "NAME" TEXT } + { "score" "SCORE" INTEGER } + } define-persistent + [ exam drop-table ] [ drop ] recover + [ ] [ exam create-table ] unit-test + + [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test + [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test + + [ + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test + ; + +! [ test-ranges ] test-sqlite From 6fe9e6f1ce7b69d1220fdb40183d2503fdb7b799 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 21:35:08 -0600 Subject: [PATCH 117/140] add singleton classes --- extra/singleton/authors.txt | 1 + extra/singleton/singleton-docs.factor | 14 ++++++++++++++ extra/singleton/singleton.factor | 9 +++++++++ 3 files changed, 24 insertions(+) create mode 100644 extra/singleton/authors.txt create mode 100644 extra/singleton/singleton-docs.factor create mode 100644 extra/singleton/singleton.factor diff --git a/extra/singleton/authors.txt b/extra/singleton/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/singleton/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor new file mode 100644 index 0000000000..b87c557366 --- /dev/null +++ b/extra/singleton/singleton-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax ; +IN: singleton + +HELP: SINGLETON: +{ $syntax "SINGLETON: class" +} { $values + { "class" "a new tuple class to define" } +} { $description + "Defines a new tuple class with membership predicate name? and a default empty constructor that is the class name itself." +} { $examples + { $example "SINGLETON: foo\nfoo ." "T{ foo f }" } +} { $see-also + POSTPONE: TUPLE: +} ; diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor new file mode 100644 index 0000000000..3a9af90071 --- /dev/null +++ b/extra/singleton/singleton.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel parser quotations tuples words ; +IN: singleton + +: SINGLETON: + CREATE-CLASS + dup { } define-tuple-class + dup construct-empty 1quotation define ; parsing From 9f66ce692e76f48b23f411791efa8b5c7d9167df Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 21:37:25 -0600 Subject: [PATCH 118/140] begin work on regexp2 --- extra/regexp2/regexp2-tests.factor | 5 + extra/regexp2/regexp2.factor | 262 +++++++++++++++++++++++++++++ 2 files changed, 267 insertions(+) create mode 100644 extra/regexp2/regexp2-tests.factor create mode 100644 extra/regexp2/regexp2.factor diff --git a/extra/regexp2/regexp2-tests.factor b/extra/regexp2/regexp2-tests.factor new file mode 100644 index 0000000000..1fb3f61f29 --- /dev/null +++ b/extra/regexp2/regexp2-tests.factor @@ -0,0 +1,5 @@ +USING: kernel peg regexp2 sequences tools.test ; +IN: regexp2.tests + +[ T{ parse-result f T{ slice f 3 3 "056" } 46 } ] + [ "056" 'octal' parse ] unit-test diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor new file mode 100644 index 0000000000..e62eb76cb1 --- /dev/null +++ b/extra/regexp2/regexp2.factor @@ -0,0 +1,262 @@ +USING: assocs combinators.lib kernel math math.parser +namespaces peg unicode.case sequences unicode.categories +memoize peg.parsers ; +USE: io +USE: tools.walker +IN: regexp2 + +upper [ swap ch>upper = ] ] [ [ = ] ] if + curry ; + +: char-between?-quot ( ch1 ch2 -- quot ) + ignore-case? get + [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ] + [ [ between? ] ] + if 2curry ; + +: or-predicates ( quots -- quot ) + [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ; + +: literal-action [ nip ] curry action ; + +: delay-action [ curry ] curry action ; + +PRIVATE> + +: ascii? ( n -- ? ) + 0 HEX: 7f between? ; + +: octal-digit? ( n -- ? ) + CHAR: 0 CHAR: 7 between? ; + +: hex-digit? ( n -- ? ) + { + [ dup digit? ] + [ dup CHAR: a CHAR: f between? ] + [ dup CHAR: A CHAR: F between? ] + } || nip ; + +: control-char? ( n -- ? ) + { [ dup 0 HEX: 1f between? ] [ dup HEX: 7f = ] } || nip ; + +: punct? ( n -- ? ) + "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ; + +: c-identifier-char? ( ch -- ? ) + { [ dup alpha? ] [ dup CHAR: _ = ] } || nip ; + +: java-blank? ( n -- ? ) + { + CHAR: \s + CHAR: \t CHAR: \n CHAR: \r + HEX: c HEX: 7 HEX: 1b + } member? ; + +: java-printable? ( n -- ? ) + { [ dup alpha? ] [ dup punct? ] } || nip ; + +MEMO: 'ordinary-char' ( -- parser ) + [ "\\^*+?|(){}[$" member? not ] satisfy + [ char=-quot ] action ; + +MEMO: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ; + +MEMO: 'octal' ( -- parser ) + "0" token hide 'octal-digit' 1 3 from-m-to-n 2seq + [ first oct> ] action ; + +MEMO: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ; + +MEMO: 'hex' ( -- parser ) + "x" token hide 'hex-digit' 2 exactly-n 2seq + "u" token hide 'hex-digit' 6 exactly-n 2seq 2choice + [ first hex> ] action ; + +: satisfy-tokens ( assoc -- parser ) + [ >r token r> literal-action ] { } assoc>map choice ; + +MEMO: 'simple-escape-char' ( -- parser ) + { + { "\\" CHAR: \\ } + { "t" CHAR: \t } + { "n" CHAR: \n } + { "r" CHAR: \r } + { "f" HEX: c } + { "a" HEX: 7 } + { "e" HEX: 1b } + } [ char=-quot ] assoc-map satisfy-tokens ; + +MEMO: 'predefined-char-class' ( -- parser ) + { + { "d" [ digit? ] } + { "D" [ digit? not ] } + { "s" [ java-blank? ] } + { "S" [ java-blank? not ] } + { "w" [ c-identifier-char? ] } + { "W" [ c-identifier-char? not ] } + } satisfy-tokens ; + +MEMO: 'posix-character-class' ( -- parser ) + { + { "Lower" [ letter? ] } + { "Upper" [ LETTER? ] } + { "ASCII" [ ascii? ] } + { "Alpha" [ Letter? ] } + { "Digit" [ digit? ] } + { "Alnum" [ alpha? ] } + { "Punct" [ punct? ] } + { "Graph" [ java-printable? ] } + { "Print" [ java-printable? ] } + { "Blank" [ " \t" member? ] } + { "Cntrl" [ control-char? ] } + { "XDigit" [ hex-digit? ] } + { "Space" [ java-blank? ] } + } satisfy-tokens "p{" "}" surrounded-by ; + +MEMO: 'simple-escape' ( -- parser ) + [ + 'octal' , + 'hex' , + "c" token hide [ LETTER? ] satisfy 2seq , + any-char , + ] choice* [ char=-quot ] action ; + +MEMO: 'escape' ( -- parser ) + "\\" token hide [ + 'simple-escape-char' , + 'predefined-char-class' , + 'posix-character-class' , + 'simple-escape' , + ] choice* 2seq ; + +MEMO: 'any-char' ( -- parser ) + "." token [ drop t ] literal-action ; + +MEMO: 'char' ( -- parser ) + 'any-char' 'escape' 'ordinary-char' 3choice [ satisfy ] action ; + +DEFER: 'regexp' + +TUPLE: group-result str ; + +C: group-result + +MEMO: 'non-capturing-group' ( -- parser ) + "?:" token hide 'regexp' ; + +MEMO: 'positive-lookahead-group' ( -- parser ) + "?=" token hide 'regexp' [ ensure ] action ; + +MEMO: 'negative-lookahead-group' ( -- parser ) + "?!" token hide 'regexp' [ ensure-not ] action ; + +MEMO: 'simple-group' ( -- parser ) + 'regexp' [ [ ] action ] action ; + +MEMO: 'group' ( -- parser ) + [ + 'non-capturing-group' , + 'positive-lookahead-group' , + 'negative-lookahead-group' , + 'simple-group' , + ] choice* "(" ")" surrounded-by ; + +MEMO: 'range' ( -- parser ) + any-char "-" token hide any-char 3seq + [ first2 char-between?-quot ] action ; + +MEMO: 'character-class-term' ( -- parser ) + 'range' + 'escape' + [ "\\]" member? not ] satisfy [ char=-quot ] action + 3choice ; + +MEMO: 'positive-character-class' ( -- parser ) + ! todo + "]" token [ CHAR: ] = ] literal-action 'character-class-term' repeat0 2seq + 'character-class-term' repeat1 2choice [ or-predicates ] action ; + +MEMO: 'negative-character-class' ( -- parser ) + "^" token hide 'positive-character-class' 2seq + [ [ not ] append ] action ; + +MEMO: 'character-class' ( -- parser ) + 'negative-character-class' 'positive-character-class' 2choice + "[" "]" surrounded-by [ satisfy ] action ; + +MEMO: 'escaped-seq' ( -- parser ) + any-char repeat1 + [ ignore-case? get token ] action "\\Q" "\\E" surrounded-by ; + +MEMO: 'break' ( quot -- parser ) + satisfy ensure + epsilon just 2choice ; + +MEMO: 'break-escape' ( -- parser ) + "$" token [ "\r\n" member? ] 'break' literal-action + "\\b" token [ blank? ] 'break' literal-action + "\\B" token [ blank? not ] 'break' literal-action + "\\z" token epsilon just literal-action 4choice ; + +MEMO: 'simple' ( -- parser ) + [ + 'escaped-seq' , + 'break-escape' , + 'group' , + 'character-class' , + 'char' , + ] choice* ; + +MEMO: 'exactly-n' ( -- parser ) + 'integer' [ exactly-n ] delay-action ; + +MEMO: 'at-least-n' ( -- parser ) + 'integer' "," token hide 2seq [ at-least-n ] delay-action ; + +MEMO: 'at-most-n' ( -- parser ) + "," token hide 'integer' 2seq [ at-most-n ] delay-action ; + +MEMO: 'from-m-to-n' ( -- parser ) + 'integer' "," token hide 'integer' 3seq + [ first2 from-m-to-n ] delay-action ; + +MEMO: 'greedy-interval' ( -- parser ) + 'exactly-n' 'at-least-n' 'at-most-n' 'from-m-to-n' 4choice ; + +MEMO: 'interval' ( -- parser ) + 'greedy-interval' + 'greedy-interval' "?" token hide 2seq [ "reluctant {}" print ] action + 'greedy-interval' "+" token hide 2seq [ "possessive {}" print ] action + 3choice "{" "}" surrounded-by ; + +MEMO: 'repetition' ( -- parser ) + [ + ! Possessive + ! "*+" token [ ] literal-action , + ! "++" token [ ] literal-action , + ! "?+" token [ ] literal-action , + ! Reluctant + ! "*?" token [ <(*)> ] literal-action , + ! "+?" token [ <(+)> ] literal-action , + ! "??" token [ <(?)> ] literal-action , + ! Greedy + "*" token [ repeat0 ] literal-action , + "+" token [ repeat1 ] literal-action , + "?" token [ optional ] literal-action , + ] choice* ; + +MEMO: 'dummy' ( -- parser ) + epsilon [ ] literal-action ; + +! todo -- check the action +! MEMO: 'term' ( -- parser ) + ! 'simple' + ! 'repetition' 'interval' 'dummy' 3choice 2seq [ first2 call ] action + ! [ ] action ; + From 2feda7c5d7de3488cffa5e0904978fe0b3905616 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 5 Mar 2008 21:38:15 -0600 Subject: [PATCH 119/140] http.server form validation --- extra/destructors/destructors-docs.factor | 4 +- extra/destructors/destructors-tests.factor | 2 +- extra/destructors/destructors.factor | 16 +- extra/furnace/authors.txt | 2 - extra/furnace/furnace-tests.factor | 47 ---- extra/furnace/furnace.factor | 217 ------------------ extra/furnace/sessions/authors.txt | 1 - extra/furnace/sessions/sessions.factor | 50 ---- extra/furnace/summary.txt | 1 - extra/furnace/tags.txt | 1 - extra/furnace/validator/authors.txt | 1 - .../furnace/validator/validator-tests.factor | 30 --- extra/furnace/validator/validator.factor | 43 ---- .../http/server/actions/actions-tests.factor | 16 +- extra/http/server/actions/actions.factor | 37 +-- .../http/server/components/components.factor | 129 +++++++++++ extra/http/server/crud/crud.factor | 13 ++ extra/http/server/db/db.factor | 12 +- extra/http/server/server.factor | 22 +- .../server/templating/{ => fhtml}/authors.txt | 0 .../fhtml-tests.factor} | 8 +- .../{templating.factor => fhtml/fhtml.factor} | 2 +- .../templating/{ => fhtml}/test/bug.fhtml | 0 .../templating/{ => fhtml}/test/bug.html | 0 .../templating/{ => fhtml}/test/example.fhtml | 0 .../templating/{ => fhtml}/test/example.html | 0 .../templating/{ => fhtml}/test/stack.fhtml | 0 .../templating/{ => fhtml}/test/stack.html | 0 .../server/validators/validators-tests.factor | 4 + .../http/server/validators/validators.factor | 64 ++++++ 30 files changed, 280 insertions(+), 442 deletions(-) delete mode 100644 extra/furnace/authors.txt delete mode 100755 extra/furnace/furnace-tests.factor delete mode 100755 extra/furnace/furnace.factor delete mode 100755 extra/furnace/sessions/authors.txt delete mode 100755 extra/furnace/sessions/sessions.factor delete mode 100755 extra/furnace/summary.txt delete mode 100644 extra/furnace/tags.txt delete mode 100755 extra/furnace/validator/authors.txt delete mode 100644 extra/furnace/validator/validator-tests.factor delete mode 100644 extra/furnace/validator/validator.factor create mode 100644 extra/http/server/components/components.factor create mode 100644 extra/http/server/crud/crud.factor rename extra/http/server/templating/{ => fhtml}/authors.txt (100%) rename extra/http/server/templating/{templating-tests.factor => fhtml/fhtml-tests.factor} (65%) rename extra/http/server/templating/{templating.factor => fhtml/fhtml.factor} (98%) rename extra/http/server/templating/{ => fhtml}/test/bug.fhtml (100%) rename extra/http/server/templating/{ => fhtml}/test/bug.html (100%) rename extra/http/server/templating/{ => fhtml}/test/example.fhtml (100%) rename extra/http/server/templating/{ => fhtml}/test/example.html (100%) rename extra/http/server/templating/{ => fhtml}/test/stack.fhtml (100%) rename extra/http/server/templating/{ => fhtml}/test/stack.html (100%) create mode 100644 extra/http/server/validators/validators-tests.factor create mode 100644 extra/http/server/validators/validators.factor diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor index 4c51e7ddfb..f96931c412 100755 --- a/extra/destructors/destructors-docs.factor +++ b/extra/destructors/destructors-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax libc kernel ; +USING: help.markup help.syntax libc kernel continuations ; IN: destructors HELP: free-always @@ -23,7 +23,7 @@ HELP: close-later HELP: with-destructors { $values { "quot" "a quotation" } } -{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link destruct } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } +{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } { $notes "Destructors are not allowed to throw exceptions. No exceptions." } { $examples { $code "[ 10 malloc free-always ] with-destructors" } diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor index 09b4ccc357..147e183688 100755 --- a/extra/destructors/destructors-tests.factor +++ b/extra/destructors/destructors-tests.factor @@ -9,7 +9,7 @@ TUPLE: dummy-destructor obj ; C: dummy-destructor -M: dummy-destructor destruct ( obj -- ) +M: dummy-destructor dispose ( obj -- ) dummy-destructor-obj t swap set-dummy-obj-destroyed? ; : destroy-always diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor index 0f8ec3af84..b2561c7439 100755 --- a/extra/destructors/destructors.factor +++ b/extra/destructors/destructors.factor @@ -4,18 +4,16 @@ USING: continuations io.backend libc kernel namespaces sequences system vectors ; IN: destructors -GENERIC: destruct ( obj -- ) - SYMBOL: error-destructors SYMBOL: always-destructors TUPLE: destructor object destroyed? ; -M: destructor destruct +M: destructor dispose dup destructor-destroyed? [ drop ] [ - dup destructor-object destruct + dup destructor-object dispose t swap set-destructor-destroyed? ] if ; @@ -29,10 +27,10 @@ M: destructor destruct always-destructors get push ; : do-always-destructors ( -- ) - always-destructors get [ destruct ] each ; + always-destructors get [ dispose ] each ; : do-error-destructors ( -- ) - error-destructors get [ destruct ] each ; + error-destructors get [ dispose ] each ; : with-destructors ( quot -- ) [ @@ -47,7 +45,7 @@ TUPLE: memory-destructor alien ; C: memory-destructor -M: memory-destructor destruct ( obj -- ) +M: memory-destructor dispose ( obj -- ) memory-destructor-alien free ; : free-always ( alien -- ) @@ -63,7 +61,7 @@ C: handle-destructor HOOK: destruct-handle io-backend ( obj -- ) -M: handle-destructor destruct ( obj -- ) +M: handle-destructor dispose ( obj -- ) handle-destructor-alien destruct-handle ; : close-always ( handle -- ) @@ -79,7 +77,7 @@ C: socket-destructor HOOK: destruct-socket io-backend ( obj -- ) -M: socket-destructor destruct ( obj -- ) +M: socket-destructor dispose ( obj -- ) socket-destructor-alien destruct-socket ; : close-socket-always ( handle -- ) diff --git a/extra/furnace/authors.txt b/extra/furnace/authors.txt deleted file mode 100644 index f372b574ae..0000000000 --- a/extra/furnace/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Slava Pestov -Doug Coleman diff --git a/extra/furnace/furnace-tests.factor b/extra/furnace/furnace-tests.factor deleted file mode 100755 index d8124d1f2b..0000000000 --- a/extra/furnace/furnace-tests.factor +++ /dev/null @@ -1,47 +0,0 @@ -USING: kernel sequences namespaces math tools.test furnace furnace.validator ; -IN: furnace.tests - -TUPLE: test-tuple m n ; - -[ H{ { "m" 3 } { "n" 2 } } ] -[ - [ T{ test-tuple f 3 2 } explode-tuple ] H{ } make-assoc -] unit-test - -[ - { 3 } -] [ - H{ { "n" "3" } } { { "n" v-number } } - [ action-param drop ] with map -] unit-test - -: foo ; - -\ foo { { "foo" "2" v-default } { "bar" v-required } } define-action - -[ t ] [ [ 1 2 foo ] action-call? ] unit-test -[ f ] [ [ 2 + ] action-call? ] unit-test - -[ - { "2" "hello" } -] [ - [ - H{ - { "bar" "hello" } - } \ foo query>seq - ] with-scope -] unit-test - -[ - H{ { "foo" "1" } { "bar" "2" } } -] [ - { "1" "2" } \ foo quot>query -] unit-test - -[ - "/responder/furnace.tests/foo?foo=3" -] [ - [ - [ "3" foo ] quot-link - ] with-scope -] unit-test diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor deleted file mode 100755 index 3bbd2d03da..0000000000 --- a/extra/furnace/furnace.factor +++ /dev/null @@ -1,217 +0,0 @@ -! Copyright (C) 2006, 2008 Slava Pestov, Doug Coleman -! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs calendar debugger furnace.sessions -furnace.validator hashtables heaps html.elements http -http.server.responders http.server.templating io.files kernel -math namespaces quotations sequences splitting words strings -vectors webapps.callback continuations tuples classes vocabs -html io ; -IN: furnace - -: code>quotation ( word/quot -- quot ) - dup word? [ 1quotation ] when ; - -SYMBOL: default-action -SYMBOL: template-path - -: render-template ( template -- ) - template-path get swap path+ - ".furnace" append resource-path - run-template-file ; - -: define-action ( word hash -- ) - over t "action" set-word-prop - "action-params" set-word-prop ; - -: define-form ( word1 word2 hash -- ) - dupd define-action - swap code>quotation "form-failed" set-word-prop ; - -: default-values ( word hash -- ) - "default-values" set-word-prop ; - -SYMBOL: request-params -SYMBOL: current-action -SYMBOL: validators-errored -SYMBOL: validation-errors - -: build-url ( str query-params -- newstr ) - [ - over % - dup assoc-empty? [ - 2drop - ] [ - CHAR: ? rot member? "&" "?" ? % - assoc>query % - ] if - ] "" make ; - -: action-link ( query action -- url ) - [ - "/responder/" % - dup word-vocabulary "webapps." ?head drop % - "/" % - word-name % - ] "" make swap build-url ; - -: action-param ( hash paramsepc -- obj error/f ) - unclip rot at swap >quotation apply-validators ; - -: query>seq ( hash word -- seq ) - "action-params" word-prop [ - dup first -rot - action-param [ - t validators-errored >session - rot validation-errors session> set-at - ] [ - nip - ] if* - ] with map ; - -: lookup-session ( hash -- session ) - "furnace-session-id" over at get-session - [ ] [ new-session "furnace-session-id" roll set-at ] ?if ; - -: quot>query ( seq action -- hash ) - >r >array r> "action-params" word-prop - [ first swap 2array ] 2map >hashtable ; - -PREDICATE: word action "action" word-prop ; - -: action-call? ( quot -- ? ) - >vector dup pop action? >r [ word? not ] all? r> and ; - -: unclip* dup 1 head* swap peek ; - -: quot-link ( quot -- url ) - dup action-call? [ - unclip* [ quot>query ] keep action-link - ] [ - t register-html-callback - ] if ; - -: replace-variables ( quot -- quot ) - [ dup string? [ request-params session> at ] when ] map ; - -: furnace-session-id ( -- hash ) - "furnace-session-id" request-params session> at - "furnace-session-id" associate ; - -: redirect-to-action ( -- ) - current-action session> - "form-failed" word-prop replace-variables - quot-link furnace-session-id build-url permanent-redirect ; - -: if-form-page ( if then -- ) - current-action session> "form-failed" word-prop -rot if ; - -: do-action - current-action session> [ query>seq ] keep add >quotation call ; - -: process-form ( -- ) - H{ } clone validation-errors >session - request-params session> current-action session> query>seq - validators-errored session> [ - drop redirect-to-action - ] [ - current-action session> add >quotation call - ] if ; - -: page-submitted ( -- ) - [ process-form ] [ request-params session> do-action ] if-form-page ; - -: action-first-time ( -- ) - request-params session> current-action session> - [ "default-values" word-prop swap union request-params >session ] keep - request-params session> do-action ; - -: page-not-submitted ( -- ) - [ redirect-to-action ] [ action-first-time ] if-form-page ; - -: setup-call-action ( hash word -- ) - over lookup-session session set - current-action >session - request-params session> swap union - request-params >session - f validators-errored >session ; - -: call-action ( hash word -- ) - setup-call-action - "furnace-form-submitted" request-params session> at - [ page-submitted ] [ page-not-submitted ] if ; - -: responder-vocab ( str -- newstr ) - "webapps." swap append ; - -: lookup-action ( str webapp -- word ) - responder-vocab lookup dup [ - dup "action" word-prop [ drop f ] unless - ] when ; - -: truncate-url ( str -- newstr ) - CHAR: / over index [ head ] when* ; - -: parse-action ( str -- word/f ) - dup empty? [ drop default-action get ] when - truncate-url "responder" get lookup-action ; - -: service-request ( hash str -- ) - parse-action [ - [ call-action ] [ 
 print-error
] recover - ] [ - "404 no such action: " "argument" get append httpd-error - ] if* ; - -: service-get - "query" get swap service-request ; - -: service-post - "response" get swap service-request ; - -: web-app ( name defaul path -- ) - [ - template-path set - default-action set - "responder" set - [ service-get ] "get" set - [ service-post ] "post" set - ] make-responder ; - -: explode-tuple ( tuple -- ) - dup tuple-slots swap class "slot-names" word-prop - [ set ] 2each ; - -SYMBOL: model - -: with-slots ( model quot -- ) - [ - >r [ dup model set explode-tuple ] when* r> call - ] with-scope ; - -: render-component ( model template -- ) - swap [ render-template ] with-slots ; - -: browse-webapp-source ( vocab -- ) - - "Browse source" write - ; - -: send-resource ( name -- ) - template-path get swap path+ resource-path - stdio get stream-copy ; - -: render-link ( quot name -- ) - write ; - -: session-var ( str -- newstr ) - request-params session> at ; - -: render ( str -- ) - request-params session> at [ write ] when* ; - -: render-error ( str error-str -- ) - swap validation-errors session> at validation-error? [ - write - ] [ - drop - ] if ; diff --git a/extra/furnace/sessions/authors.txt b/extra/furnace/sessions/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/furnace/sessions/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor deleted file mode 100755 index cf03fee6b1..0000000000 --- a/extra/furnace/sessions/sessions.factor +++ /dev/null @@ -1,50 +0,0 @@ -USING: assocs calendar init kernel math.parser -namespaces random boxes alarms combinators.lib ; -IN: furnace.sessions - -SYMBOL: sessions - -: timeout ( -- dt ) 20 minutes ; - -[ - H{ } clone sessions set-global -] "furnace.sessions" add-init-hook - -: new-session-id ( -- str ) - [ 4 big-random >hex ] - [ sessions get-global key? not ] generate ; - -TUPLE: session id namespace alarm user-agent ; - -: cancel-timeout ( session -- ) - session-alarm ?box [ cancel-alarm ] [ drop ] if ; - -: delete-session ( session -- ) - sessions get-global delete-at* - [ cancel-timeout ] [ drop ] if ; - -: touch-session ( session -- ) - dup cancel-timeout - dup [ session-id delete-session ] curry timeout later - swap session-alarm >box ; - -: ( id -- session ) - H{ } clone f session construct-boa ; - -: new-session ( -- session id ) - new-session-id [ - dup [ - [ sessions get-global set-at ] keep - touch-session - ] keep - ] keep ; - -: get-session ( id -- session/f ) - sessions get-global at* - [ dup touch-session ] when ; - -: session> ( str -- obj ) - session get session-namespace at ; - -: >session ( value key -- ) - session get session-namespace set-at ; diff --git a/extra/furnace/summary.txt b/extra/furnace/summary.txt deleted file mode 100755 index 5696506f79..0000000000 --- a/extra/furnace/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Action-based web framework diff --git a/extra/furnace/tags.txt b/extra/furnace/tags.txt deleted file mode 100644 index 0aef4feca8..0000000000 --- a/extra/furnace/tags.txt +++ /dev/null @@ -1 +0,0 @@ -enterprise diff --git a/extra/furnace/validator/authors.txt b/extra/furnace/validator/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/furnace/validator/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/furnace/validator/validator-tests.factor b/extra/furnace/validator/validator-tests.factor deleted file mode 100644 index e84e57be6a..0000000000 --- a/extra/furnace/validator/validator-tests.factor +++ /dev/null @@ -1,30 +0,0 @@ -IN: furnace.validator.tests -USING: kernel sequences tools.test furnace.validator furnace ; - -[ - 123 f -] [ - H{ { "foo" "123" } } { "foo" v-number } action-param -] unit-test - -: validation-fails - [ action-param nip not ] append [ f ] swap unit-test ; - -[ H{ { "foo" "12X3" } } { "foo" v-number } ] validation-fails - -[ H{ { "foo" "" } } { "foo" 4 v-min-length } ] validation-fails - -[ "ABCD" f ] -[ H{ { "foo" "ABCD" } } { "foo" 4 v-min-length } action-param ] -unit-test - -[ H{ { "foo" "ABCD" } } { "foo" 2 v-max-length } ] -validation-fails - -[ "AB" f ] -[ H{ { "foo" "AB" } } { "foo" 2 v-max-length } action-param ] -unit-test - -[ "AB" f ] -[ H{ { "foo" f } } { "foo" "AB" v-default } action-param ] -unit-test diff --git a/extra/furnace/validator/validator.factor b/extra/furnace/validator/validator.factor deleted file mode 100644 index 698c77fa9a..0000000000 --- a/extra/furnace/validator/validator.factor +++ /dev/null @@ -1,43 +0,0 @@ -! Copyright (C) 2006 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences math namespaces math.parser ; -IN: furnace.validator - -TUPLE: validation-error reason ; - -: apply-validators ( string quot -- obj error/f ) - [ - call f - ] [ - dup validation-error? [ >r 2drop f r> ] [ rethrow ] if - ] recover ; - -: validation-error ( msg -- * ) - \ validation-error construct-boa throw ; - -: v-default ( obj value -- obj ) - over empty? [ nip ] [ drop ] if ; - -: v-required ( str -- str ) - dup empty? [ "required" validation-error ] when ; - -: v-min-length ( str n -- str ) - over length over < [ - [ "must be at least " % # " characters" % ] "" make - validation-error - ] [ - drop - ] if ; - -: v-max-length ( str n -- str ) - over length over > [ - [ "must be no more than " % # " characters" % ] "" make - validation-error - ] [ - drop - ] if ; - -: v-number ( str -- n ) - string>number [ - "must be a number" validation-error - ] unless* ; diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index 2d74e92e86..13089ae6e8 100644 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -1,11 +1,12 @@ IN: http.server.actions.tests USING: http.server.actions tools.test math math.parser multiline namespaces http io.streams.string http.server -sequences ; +sequences accessors ; -[ + ] -{ { "a" [ string>number ] } { "b" [ string>number ] } } -"GET" "action-1" set + + [ "a" get "b" get + ] >>get + { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params +"action-1" set STRING: action-request-test-1 GET http://foo/bar?a=12&b=13 HTTP/1.1 @@ -19,9 +20,10 @@ blah "action-1" get call-responder ] unit-test -[ "X" concat append ] -{ { +path+ [ ] } { "xxx" [ string>number ] } } -"POST" "action-2" set + + [ +path+ get "xxx" get "X" concat append ] >>post + { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params +"action-2" set STRING: action-request-test-2 POST http://foo/bar/baz HTTP/1.1 diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index feb16a4488..5e5b7a9563 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -1,14 +1,18 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors new-slots sequences kernel assocs combinators -http.server http hashtables namespaces ; +http.server http.server.validators http hashtables namespaces ; IN: http.server.actions SYMBOL: +path+ -TUPLE: action quot params method ; +TUPLE: action get get-params post post-params revalidate ; -C: action +: + action construct-empty + [ <400> ] >>get + [ <400> ] >>post + [ <400> ] >>revalidate ; : extract-params ( request path -- assoc ) >r dup method>> { @@ -16,15 +20,22 @@ C: action { "POST" [ post-data>> query>assoc ] } } case r> +path+ associate union ; -: push-params ( assoc action -- ... ) - params>> [ first2 >r swap at r> call ] with each ; +: action-params ( request path param -- error? ) + -rot extract-params validate-params ; + +: get-action ( request path -- response ) + action get get-params>> action-params + [ <400> ] [ action get get>> call ] if ; + +: post-action ( request path -- response ) + action get post-params>> action-params + [ action get revalidate>> ] [ action get post>> ] if call ; M: action call-responder ( request path action -- response ) - pick request set - pick method>> over method>> = [ - >r extract-params r> - [ push-params ] keep - quot>> call - ] [ - 3drop <400> - ] if ; + action set + over request set + over method>> + { + { "GET" [ get-action ] } + { "POST" [ post-action ] } + } case ; diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor new file mode 100644 index 0000000000..6fefb1b5dd --- /dev/null +++ b/extra/http/server/components/components.factor @@ -0,0 +1,129 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: new-slots html.elements http.server.validators +accessors namespaces kernel io farkup math.parser assocs +classes words tuples arrays sequences io.files +http.server.templating.fhtml splitting ; +IN: http.server.components + +SYMBOL: components + +TUPLE: component id ; + +: component ( name -- component ) + dup components get at + [ ] [ "No such component: " swap append throw ] ?if ; + +GENERIC: validate* ( string component -- result ) +GENERIC: render-view* ( value component -- ) +GENERIC: render-edit* ( value component -- ) +GENERIC: render-error* ( reason value component -- ) + +SYMBOL: values + +: value values get at ; + +: render-view ( component -- ) + dup id>> value swap render-view* ; + +: render-error ( error -- ) + write ; + +: render-edit ( component -- ) + dup id>> value dup validation-error? [ + dup reason>> swap value>> rot render-error* + ] [ + swap render-edit* + ] if ; + +: ( id string -- component ) + >r \ component construct-boa r> construct-delegate ; inline + +TUPLE: string min max ; + +: ( id -- component ) string ; + +M: string validate* + [ min>> v-min-length ] keep max>> v-max-length ; + +M: string render-view* + drop write ; + +: render-input + > dup =id =name =value input/> ; + +M: string render-edit* + render-input ; + +M: string render-error* + render-input render-error ; + +TUPLE: text ; + +: ( id -- component ) text construct-delegate ; + +: render-textarea + ; + +M: text render-edit* + render-textarea ; + +M: text render-error* + render-textarea render-error ; + +TUPLE: farkup ; + +: ( id -- component ) farkup construct-delegate ; + +M: farkup render-view* + drop string-lines "\n" join convert-farkup write ; + +TUPLE: number min max ; + +: ( id -- component ) number ; + +M: number validate* + >r v-number r> [ min>> v-min-value ] keep max>> v-max-value ; + +M: number render-view* + drop number>string write ; + +M: number render-edit* + >r number>string r> render-input ; + +M: number render-error* + render-input render-error ; + +: tuple>slots ( tuple -- alist ) + dup class "slot-names" word-prop swap tuple-slots + 2array flip ; + +: with-components ( tuple components quot -- ) + [ + >r components set + dup tuple>slots values set + tuple set + r> call + ] with-scope ; inline + +TUPLE: form view-template edit-template components ; + +:
( id view-template edit-template -- form ) + V{ } clone form construct-boa + swap \ component construct-boa + over set-delegate ; + +: add-field ( form component -- form ) + dup id>> pick components>> set-at ; + +M: form render-view* ( value form -- ) + dup components>> + swap view-template>> + [ resource-path run-template-file ] curry + with-components ; + +M: form render-edit* ( value form -- ) + dup components>> + swap edit-template>> + [ resource-path run-template-file ] curry + with-components ; diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor new file mode 100644 index 0000000000..099ded2f7f --- /dev/null +++ b/extra/http/server/crud/crud.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.crud +USING: kernel namespaces db.tuples math.parser +http.server.actions accessors ; + +: by-id ( class -- tuple ) + construct-empty "id" get >>id ; + +: ( class -- action ) + + { { "id" [ string>number ] } } >>post-params + swap [ by-id delete-tuple f ] curry >>post ; diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index 4baee5f02b..511921ce06 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -1,14 +1,18 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: db http.server kernel new-slots accessors -continuations namespaces ; +continuations namespaces destructors ; IN: http.server.db TUPLE: db-persistence responder db params ; C: db-persistence +: connect-db ( db-persistence -- ) + dup db>> swap params>> make-db + dup db set + dup db-open + add-always-destructor ; + M: db-persistence call-responder - dup db>> over params>> make-db dup db-open [ - db set responder>> call-responder - ] with-disposal ; + dup connect-db responder>> call-responder ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index f397b280d0..990c77f71e 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -3,7 +3,8 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar new-slots html.elements accessors math.parser combinators.lib -vocabs.loader debugger html continuations random combinators ; +vocabs.loader debugger html continuations random combinators +destructors ; IN: http.server GENERIC: call-responder ( request path responder -- response ) @@ -135,7 +136,7 @@ SYMBOL: development-mode swap method>> "HEAD" = [ drop ] [ write-response-body ] if ; -: do-request ( request -- request ) +: do-request ( request -- response ) [ dup dup path>> over host>> find-virtual-host call-responder @@ -149,13 +150,18 @@ LOG: httpd-hit NOTICE : log-request ( request -- ) { method>> host>> path>> } map-exec-with httpd-hit ; -: handle-client ( -- ) - default-timeout +: ?refresh-all ( -- ) development-mode get-global - [ global [ refresh-all ] bind ] when - read-request - dup log-request - do-request do-response ; + [ global [ refresh-all ] bind ] when ; + +: handle-client ( -- ) + [ + default-timeout + ?refresh-all + read-request + dup log-request + do-request do-response + ] with-destructors ; : httpd ( port -- ) internet-server "http.server" diff --git a/extra/http/server/templating/authors.txt b/extra/http/server/templating/fhtml/authors.txt similarity index 100% rename from extra/http/server/templating/authors.txt rename to extra/http/server/templating/fhtml/authors.txt diff --git a/extra/http/server/templating/templating-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor similarity index 65% rename from extra/http/server/templating/templating-tests.factor rename to extra/http/server/templating/fhtml/fhtml-tests.factor index ceb2ed95be..0ae3b41454 100644 --- a/extra/http/server/templating/templating-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -1,9 +1,9 @@ -USING: io io.files io.streams.string http.server.templating kernel tools.test - sequences ; -IN: http.server.templating.tests +USING: io io.files io.streams.string +http.server.templating.fhtml kernel tools.test sequences ; +IN: http.server.templating.fhtml.tests : test-template ( path -- ? ) - "extra/http/server/templating/test/" swap append + "extra/http/server/templating/fhtml/test/" swap append [ ".fhtml" append resource-path [ run-template-file ] with-string-writer diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/fhtml/fhtml.factor similarity index 98% rename from extra/http/server/templating/templating.factor rename to extra/http/server/templating/fhtml/fhtml.factor index b298faca74..37f4b85c51 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -7,7 +7,7 @@ source-files debugger combinators math quotations generic strings splitting accessors http.server.static http.server assocs ; -IN: http.server.templating +IN: http.server.templating.fhtml : templating-vocab ( -- vocab-name ) "http.server.templating" ; diff --git a/extra/http/server/templating/test/bug.fhtml b/extra/http/server/templating/fhtml/test/bug.fhtml similarity index 100% rename from extra/http/server/templating/test/bug.fhtml rename to extra/http/server/templating/fhtml/test/bug.fhtml diff --git a/extra/http/server/templating/test/bug.html b/extra/http/server/templating/fhtml/test/bug.html similarity index 100% rename from extra/http/server/templating/test/bug.html rename to extra/http/server/templating/fhtml/test/bug.html diff --git a/extra/http/server/templating/test/example.fhtml b/extra/http/server/templating/fhtml/test/example.fhtml similarity index 100% rename from extra/http/server/templating/test/example.fhtml rename to extra/http/server/templating/fhtml/test/example.fhtml diff --git a/extra/http/server/templating/test/example.html b/extra/http/server/templating/fhtml/test/example.html similarity index 100% rename from extra/http/server/templating/test/example.html rename to extra/http/server/templating/fhtml/test/example.html diff --git a/extra/http/server/templating/test/stack.fhtml b/extra/http/server/templating/fhtml/test/stack.fhtml similarity index 100% rename from extra/http/server/templating/test/stack.fhtml rename to extra/http/server/templating/fhtml/test/stack.fhtml diff --git a/extra/http/server/templating/test/stack.html b/extra/http/server/templating/fhtml/test/stack.html similarity index 100% rename from extra/http/server/templating/test/stack.html rename to extra/http/server/templating/fhtml/test/stack.html diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor new file mode 100644 index 0000000000..ff68dcfc64 --- /dev/null +++ b/extra/http/server/validators/validators-tests.factor @@ -0,0 +1,4 @@ +IN: http.server.validators.tests +USING: kernel sequences tools.test http.server.validators ; + +[ t t ] [ "foo" [ v-number ] with-validator >r validation-error? r> ] unit-test diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor new file mode 100644 index 0000000000..03beb8c3ff --- /dev/null +++ b/extra/http/server/validators/validators.factor @@ -0,0 +1,64 @@ +! Copyright (C) 2006, 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel continuations sequences math namespaces +math.parser assocs new-slots ; +IN: http.server.validators + +TUPLE: validation-error value reason ; + +: validation-error ( value reason -- * ) + \ validation-error construct-boa throw ; + +: with-validator ( string quot -- result error? ) + [ f ] compose curry + [ dup validation-error? [ t ] [ rethrow ] if ] recover ; inline + +: validate-param ( name validator assoc -- error? ) + swap pick + >r >r at r> with-validator swap r> set ; + +: validate-params ( validators assoc -- error? ) + [ validate-param ] curry { } assoc>map [ ] contains? ; + +: v-default ( str def -- str ) + over empty? spin ? ; + +: v-required ( str -- str ) + dup empty? [ "required" validation-error ] when ; + +: v-min-length ( str n -- str ) + over length over < [ + [ "must be at least " % # " characters" % ] "" make + validation-error + ] [ + drop + ] if ; + +: v-max-length ( str n -- str ) + over length over > [ + [ "must be no more than " % # " characters" % ] "" make + validation-error + ] [ + drop + ] if ; + +: v-number ( str -- n ) + dup string>number [ ] [ + "must be a number" validation-error + ] ?if ; + +: v-min-value ( str n -- str ) + 2dup < [ + [ "must be at least " % # ] "" make + validation-error + ] [ + drop + ] if ; + +: v-max-value ( str n -- str ) + 2dup > [ + [ "must be no more than " % # ] "" make + validation-error + ] [ + drop + ] if ; From b3fcd179a04d397b05d11c390577eb4d9b380be2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 5 Mar 2008 22:07:45 -0600 Subject: [PATCH 120/140] refactor conversions --- extra/calendar/format/format.factor | 55 +++++++++-------------------- 1 file changed, 17 insertions(+), 38 deletions(-) diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index c1bd6427a7..89e09e0d0c 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -36,8 +36,12 @@ M: timestamp year. ( timestamp -- ) : pad-00 number>string 2 CHAR: 0 pad-left ; +: pad-0000 number>string 4 CHAR: 0 pad-left ; + : write-00 pad-00 write ; +: write-0000 pad-0000 write ; + : (timestamp>string) ( timestamp -- ) dup day-of-week day-abbreviations3 nth write ", " write dup day>> number>string write bl @@ -107,18 +111,16 @@ M: timestamp year. ( timestamp -- ) 60 / + * ] if ; +: read-ymd ( -- y m d ) + read-0000 "-" expect read-00 "-" expect read-00 ; + +: read-hms ( -- h m s ) + read-00 ":" expect read-00 ":" expect read-00 ; + : (rfc3339>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day + read-ymd "Tt" expect - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second + read-hms read-rfc3339-gmt-offset ! timezone ; @@ -126,49 +128,25 @@ M: timestamp year. ( timestamp -- ) [ (rfc3339>timestamp) ] with-string-reader ; : (ymdhms>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day - " " expect - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second - 0 ! timezone - ; + read-ymd " " expect read-hms 0 ; : ymdhms>timestamp ( str -- timestamp ) [ (ymdhms>timestamp) ] with-string-reader ; : (hms>timestamp) ( -- timestamp ) - f f f - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second - f ; + f f f read-hms f ; : hms>timestamp ( str -- timestamp ) [ (hms>timestamp) ] with-string-reader ; : (ymd>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day - f f f f ; + read-ymd f f f f ; : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; - : (timestamp>ymd) ( timestamp -- ) - dup timestamp-year number>string write + dup timestamp-year write-0000 "-" write dup timestamp-month write-00 "-" write @@ -188,6 +166,7 @@ M: timestamp year. ( timestamp -- ) [ (timestamp>hms) ] with-string-writer ; : timestamp>ymdhms ( timestamp -- str ) + >gmt [ dup (timestamp>ymd) " " write From ee9b940bc629bd100fa820b4fb013ba47ddc9108 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 6 Mar 2008 00:23:38 -0600 Subject: [PATCH 121/140] Modifications to the encoding protocol for later optimization --- core/io/encodings/encodings-docs.factor | 16 ++++----- core/io/encodings/encodings.factor | 7 ++-- core/io/encodings/string/string-docs.factor | 2 ++ core/io/encodings/string/string-tests.factor | 2 ++ core/io/encodings/string/string.factor | 2 ++ core/io/encodings/utf8/utf8-tests.factor | 13 ++++--- core/io/encodings/utf8/utf8.factor | 17 +++++---- extra/io/encodings/ascii/ascii.factor | 8 ++--- extra/io/encodings/latin1/latin1.factor | 4 +-- extra/io/encodings/utf16/utf16-tests.factor | 36 ++++++++------------ extra/io/encodings/utf16/utf16.factor | 36 ++++++++++---------- 11 files changed, 70 insertions(+), 73 deletions(-) diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index 562e7dcd9a..e5e71b05f0 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -46,23 +46,23 @@ ARTICLE: "encodings-protocol" "Encoding protocol" "An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again." { $subsection decode-step } { $subsection init-decoder } -{ $subsection encode-string } ; +{ $subsection stream-write-encoded } ; HELP: decode-step ( buf char encoding -- ) { $values { "buf" "A string buffer which characters can be pushed to" } { "char" "An octet which is read from a stream" } { "encoding" "An encoding descriptor tuple" } } -{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change." } ; +{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change. This should not be used directly." } ; -HELP: encode-string ( string encoding -- byte-array ) +HELP: stream-write-encoded ( string stream encoding -- ) { $values { "string" "a string" } - { "encoding" "an encoding descriptor" } - { "byte-array" "an encoded byte-array" } } -{ $description "Encodes the string with the given encoding descriptor, outputting the result to a byte-array." } ; + { "stream" "an output stream" } + { "encoding" "an encoding descriptor" } } +{ $description "Encodes the string with the given encoding descriptor, outputing the result to the given stream. This should not be used directly." } ; HELP: init-decoder ( stream encoding -- encoding ) { $values { "stream" "an input stream" } { "encoding" "an encoding descriptor" } } -{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM." } ; +{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM. This should not be used directly." } ; -{ init-decoder decode-step encode-string } related-words +{ init-decoder decode-step stream-write-encoded } related-words diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 8489c46d2e..2f68334bde 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -15,9 +15,8 @@ GENERIC: init-decoder ( stream encoding -- encoding ) M: tuple-class init-decoder construct-empty init-decoder ; M: object init-decoder nip ; -GENERIC: encode-string ( string encoding -- byte-array ) -M: tuple-class encode-string construct-empty encode-string ; -M: object encode-string drop >byte-array ; +GENERIC: stream-write-encoded ( string stream encoding -- byte-array ) +M: object stream-write-encoded drop stream-write ; ! Decoding @@ -136,7 +135,7 @@ M: encoder stream-write1 >r 1string r> stream-write ; M: encoder stream-write - [ encoder-code encode-string ] keep delegate stream-write ; + { delegate encoder-code } get-slots stream-write-encoded ; M: encoder dispose delegate dispose ; diff --git a/core/io/encodings/string/string-docs.factor b/core/io/encodings/string/string-docs.factor index a5f92db165..0a35eee272 100644 --- a/core/io/encodings/string/string-docs.factor +++ b/core/io/encodings/string/string-docs.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax byte-arrays strings ; IN: io.encodings.string diff --git a/core/io/encodings/string/string-tests.factor b/core/io/encodings/string/string-tests.factor index 8d8db84799..ddae9c8734 100644 --- a/core/io/encodings/string/string-tests.factor +++ b/core/io/encodings/string/string-tests.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. USING: strings io.encodings.utf8 io.encodings.utf16 io.encodings.string tools.test ; IN: io.encodings.string.tests diff --git a/core/io/encodings/string/string.factor b/core/io/encodings/string/string.factor index c6e01121dc..5e57a943a9 100644 --- a/core/io/encodings/string/string.factor +++ b/core/io/encodings/string/string.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. USING: io io.streams.byte-array ; IN: io.encodings.string diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor index 0671fe2129..8f1c998f3d 100644 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -1,21 +1,20 @@ -USING: io.encodings.utf8 tools.test sbufs kernel io io.encodings -sequences strings arrays unicode io.streams.byte-array ; +USING: io.encodings.utf8 tools.test io.encodings.string strings arrays ; : decode-utf8-w/stream ( array -- newarray ) - utf8 contents >array ; + utf8 decode >array ; : encode-utf8-w/stream ( array -- newarray ) - utf8 [ write ] with-byte-writer >array ; + utf8 encode >array ; -[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream >array ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test -[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test +[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream ] unit-test [ "x" ] [ "x" decode-utf8-w/stream >string ] unit-test [ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream >array ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream ] unit-test [ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index edc4663214..5887a8375e 100644 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -60,29 +60,28 @@ M: utf8 init-decoder nip begin over set-utf8-state ; ! Encoding UTF-8 : encoded ( char -- ) - BIN: 111111 bitand BIN: 10000000 bitor , ; + BIN: 111111 bitand BIN: 10000000 bitor write1 ; : char>utf8 ( char -- ) { - { [ dup -7 shift zero? ] [ , ] } + { [ dup -7 shift zero? ] [ write1 ] } { [ dup -11 shift zero? ] [ - dup -6 shift BIN: 11000000 bitor , + dup -6 shift BIN: 11000000 bitor write1 encoded ] } { [ dup -16 shift zero? ] [ - dup -12 shift BIN: 11100000 bitor , + dup -12 shift BIN: 11100000 bitor write1 dup -6 shift encoded encoded ] } { [ t ] [ - dup -18 shift BIN: 11110000 bitor , + dup -18 shift BIN: 11110000 bitor write1 dup -12 shift encoded dup -6 shift encoded encoded ] } } cond ; -: encode-utf8 ( str -- seq ) - [ [ char>utf8 ] each ] B{ } make ; - -M: utf8 encode-string drop encode-utf8 ; +M: utf8 stream-write-encoded + ! For efficiency, this should be modified to avoid variable reads + drop [ [ char>utf8 ] each ] with-stream* ; diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor index 6dd8d23155..f310f53e29 100644 --- a/extra/io/encodings/ascii/ascii.factor +++ b/extra/io/encodings/ascii/ascii.factor @@ -3,13 +3,13 @@ USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ; IN: io.encodings.ascii -: encode-check<= ( string max -- byte-array ) - dupd [ <= ] curry all? [ >byte-array ] [ encode-error ] if ; +: encode-check<= ( string stream max -- ) + [ pick > [ encode-error ] [ stream-write1 ] if ] 2curry each ; TUPLE: ascii ; -M: ascii encode-string +M: ascii stream-write-encoded ( string stream encoding -- ) drop 127 encode-check<= ; M: ascii decode-step - drop dup 128 >= [ encode-error ] [ swap push ] if ; + drop dup 128 >= [ decode-error ] [ swap push ] if ; diff --git a/extra/io/encodings/latin1/latin1.factor b/extra/io/encodings/latin1/latin1.factor index 36e38caa1c..989f45bc64 100755 --- a/extra/io/encodings/latin1/latin1.factor +++ b/extra/io/encodings/latin1/latin1.factor @@ -5,8 +5,8 @@ IN: io.encodings.latin1 TUPLE: latin1 ; -M: latin1 encode-string +M: latin1 stream-write-encoded drop 255 encode-check<= ; M: latin1 decode-step - drop dup 256 >= [ encode-error ] [ swap push ] if ; + drop dup 256 >= [ decode-error ] [ swap push ] if ; diff --git a/extra/io/encodings/utf16/utf16-tests.factor b/extra/io/encodings/utf16/utf16-tests.factor index 7ee5c9574e..89b61a3e37 100755 --- a/extra/io/encodings/utf16/utf16-tests.factor +++ b/extra/io/encodings/utf16/utf16-tests.factor @@ -1,28 +1,22 @@ USING: kernel tools.test io.encodings.utf16 arrays sbufs -sequences io.encodings io unicode io.streams.byte-array ; +sequences io.encodings io unicode io.encodings.string ; -: decode-w/stream ( array encoding -- newarray ) - contents >array ; +[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test +[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test -: encode-w/stream ( array encoding -- newarray ) - [ write ] with-byte-writer >array ; +[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test -[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode-w/stream ] unit-test -[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode-w/stream ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode-w/stream ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode-w/stream ] unit-test +[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test +[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test +[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test -[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode-w/stream ] unit-test +[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test -[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode-w/stream ] unit-test -[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode-w/stream ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode-w/stream ] unit-test -[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode-w/stream ] unit-test +[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test +[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test -[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode-w/stream ] unit-test - -[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode-w/stream ] unit-test -[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode-w/stream ] unit-test - -[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode-w/stream ] unit-test +[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test diff --git a/extra/io/encodings/utf16/utf16.factor b/extra/io/encodings/utf16/utf16.factor index 8815d588ad..a501fad0bd 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/extra/io/encodings/utf16/utf16.factor @@ -106,25 +106,28 @@ M: utf16le init-decoder nip begin over set-utf16le-state ; : char>utf16be ( char -- ) dup HEX: FFFF > [ HEX: 10000 - - dup encode-first swap , , - encode-second swap , , - ] [ h>b/b , , ] if ; + dup encode-first swap write1 write1 + encode-second swap write1 write1 + ] [ h>b/b write1 write1 ] if ; -: encode-utf16be ( str -- seq ) - [ [ char>utf16be ] each ] B{ } make ; +: stream-write-utf16be ( string stream -- ) + [ [ char>utf16be ] each ] with-stream* ; + +M: utf16be stream-write-encoded ( string stream encoding -- ) + drop stream-write-utf16be ; : char>utf16le ( char -- ) dup HEX: FFFF > [ HEX: 10000 - - dup encode-first , , - encode-second , , - ] [ h>b/b swap , , ] if ; + dup encode-first write1 write1 + encode-second write1 write1 + ] [ h>b/b swap write1 write1 ] if ; -: encode-utf16le ( str -- seq ) - [ [ char>utf16le ] each ] B{ } make ; +: stream-write-utf16le ( string stream -- ) + [ [ char>utf16le ] each ] with-stream* ; -M: utf16le encode-string drop encode-utf16le ; -M: utf16be encode-string drop encode-utf16be ; +M: utf16le stream-write-encoded ( string stream encoding -- ) + drop stream-write-utf16le ; ! UTF-16 @@ -132,19 +135,16 @@ M: utf16be encode-string drop encode-utf16be ; : bom-be B{ HEX: fe HEX: ff } ; inline -: encode-utf16 ( str -- seq ) - encode-utf16le bom-le swap append ; - : start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ; : start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ; TUPLE: utf16 started? ; -M: utf16 encode-string - >r encode-utf16le r> +M: utf16 stream-write-encoded dup utf16-started? [ drop ] - [ t swap set-utf16-started? bom-le swap append ] if ; + [ t swap set-utf16-started? bom-le over stream-write ] if + stream-write-utf16le ; : bom>le/be ( bom -- le/be ) dup bom-le sequence= [ drop utf16le ] [ From 955387f5b7e59292ac36166b7a4a15795b9d4515 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 03:00:10 -0600 Subject: [PATCH 122/140] HTTP authorization framework, first cut --- extra/http/server/auth/auth.factor | 25 +++++++ extra/http/server/auth/basic/basic.factor | 41 +++++++++++ extra/http/server/auth/login/login.factor | 69 +++++++++++++++++++ extra/http/server/auth/login/login.fhtml | 25 +++++++ .../auth/providers/assoc/assoc-tests.factor | 18 +++++ .../server/auth/providers/assoc/assoc.factor | 23 +++++++ .../server/auth/providers/db/db-tests.factor | 24 +++++++ extra/http/server/auth/providers/db/db.factor | 53 ++++++++++++++ .../server/auth/providers/null/null.factor | 14 ++++ .../server/auth/providers/providers.factor | 18 +++++ .../server/sessions/sessions-tests.factor | 9 ++- extra/http/server/sessions/sessions.factor | 2 + .../http/server/templating/fhtml/fhtml.factor | 2 +- 13 files changed, 320 insertions(+), 3 deletions(-) create mode 100755 extra/http/server/auth/auth.factor create mode 100755 extra/http/server/auth/basic/basic.factor create mode 100755 extra/http/server/auth/login/login.factor create mode 100755 extra/http/server/auth/login/login.fhtml create mode 100755 extra/http/server/auth/providers/assoc/assoc-tests.factor create mode 100755 extra/http/server/auth/providers/assoc/assoc.factor create mode 100755 extra/http/server/auth/providers/db/db-tests.factor create mode 100755 extra/http/server/auth/providers/db/db.factor create mode 100755 extra/http/server/auth/providers/null/null.factor create mode 100755 extra/http/server/auth/providers/providers.factor diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor new file mode 100755 index 0000000000..a53905bce1 --- /dev/null +++ b/extra/http/server/auth/auth.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.auth +USING: new-slots accessors http.server.auth.providers.null +http.server.auth.strategies.null ; + +TUPLE: authentication responder provider strategy ; + +: ( responder -- authentication ) + null-auth-provider null-auth-strategy + authentication construct-boa ; + +SYMBOL: current-user-id +SYMBOL: auth-provider +SYMBOL: auth-strategy + +M: authentication call-responder ( request path responder -- response ) + dup provider>> auth-provider set + dup strategy>> auth-strategy set + pick auth-provider get logged-in? dup current-user-id set + [ + responder>> call-responder + ] [ + 2drop auth-provider get require-login + ] if* ; diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor new file mode 100755 index 0000000000..2ea74febba --- /dev/null +++ b/extra/http/server/auth/basic/basic.factor @@ -0,0 +1,41 @@ +! Copyright (c) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots quotations assocs kernel splitting +base64 html.elements io combinators http.server +http.server.auth.providers http.server.auth.providers.null +http sequences ; +IN: http.server.auth.basic + +TUPLE: basic-auth responder realm provider ; + +C: basic-auth + +: authorization-ok? ( provider header -- ? ) + #! Given the realm and the 'Authorization' header, + #! authenticate the user. + dup [ + " " split1 swap "Basic" = [ + base64> ":" split1 spin check-login + ] [ + 2drop f + ] if + ] [ + 2drop f + ] if ; + +: <401> ( realm -- response ) + 401 "Unauthorized" + "Basic realm=\"" rot "\"" 3append + "WWW-Authenticate" set-header + [ + + "Username or Password is invalid" write + + ] >>body ; + +: logged-in? ( request responder -- ? ) + provider>> swap "authorization" header authorization-ok? ; + +M: basic-auth call-responder ( request path responder -- response ) + pick over logged-in? + [ responder>> call-responder ] [ 2nip realm>> <401> ] if ; diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor new file mode 100755 index 0000000000..e2f9a3608a --- /dev/null +++ b/extra/http/server/auth/login/login.factor @@ -0,0 +1,69 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors new-slots quotations assocs kernel splitting +base64 html.elements io combinators http.server +http.server.auth.providers http.server.actions +http.server.sessions http.server.templating.fhtml http sequences +io.files namespaces ; +IN: http.server.auth.login + +TUPLE: login-auth responder provider ; + +C: (login-auth) login-auth + +SYMBOL: logged-in? +SYMBOL: provider +SYMBOL: post-login-url + +: login-page ( -- response ) + "text/html" [ + "extra/http/server/auth/login/login.fhtml" + resource-path run-template-file + ] >>body ; + +: + + [ login-page ] >>get + + { + { "name" [ ] } + { "password" [ ] } + } >>post-params + [ + "password" get + "name" get + provider sget check-login [ + t logged-in? sset + post-login-url sget + ] [ + login-page + ] if + ] >>post ; + +: + + [ + f logged-in? sset + request get "login" + ] >>post ; + +M: login-auth call-responder ( request path responder -- response ) + logged-in? sget + [ responder>> call-responder ] [ + pick method>> "GET" = [ + nip + provider>> provider sset + dup request-url post-login-url sset + "login" f session-link + ] [ + 3drop <400> + ] if + ] if ; + +: ( responder provider -- auth ) + (login-auth) + + swap >>default + "login" add-responder + "logout" add-responder + ; diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml new file mode 100755 index 0000000000..9bb1438588 --- /dev/null +++ b/extra/http/server/auth/login/login.fhtml @@ -0,0 +1,25 @@ + + +

Login required

+ + + + + + + + + + + + + + +
User name:
Password:
+ + + + + + + diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor new file mode 100755 index 0000000000..3270fe06e3 --- /dev/null +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -0,0 +1,18 @@ +IN: http.server.auth.providers.assoc.tests +USING: http.server.auth.providers +http.server.auth.providers.assoc tools.test +namespaces ; + + "provider" set + +"slava" "provider" get new-user + +[ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with + +[ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test + +[ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with + +"fdasf" "slava" "provider" get set-password + +[ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor new file mode 100755 index 0000000000..d57be622c7 --- /dev/null +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.auth.providers.assoc +USING: new-slots accessors assocs kernel +http.server.auth.providers ; + +TUPLE: assoc-auth-provider assoc ; + +: ( -- provider ) + H{ } clone assoc-auth-provider construct-boa ; + +M: assoc-auth-provider check-login + assoc>> at = ; + +M: assoc-auth-provider new-user + assoc>> + 2dup key? [ drop user-exists ] when + t -rot set-at ; + +M: assoc-auth-provider set-password + assoc>> + 2dup key? [ drop no-such-user ] unless + set-at ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor new file mode 100755 index 0000000000..384e094f39 --- /dev/null +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -0,0 +1,24 @@ +IN: http.server.auth.providers.db.tests +USING: http.server.auth.providers +http.server.auth.providers.db tools.test +namespaces db db.sqlite db.tuples continuations ; + +db-auth-provider "provider" set + +"auth-test.db" sqlite-db [ + + [ user drop-table ] ignore-errors + [ user create-table ] ignore-errors + + "slava" "provider" get new-user + + [ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with + + [ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test + + [ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with + + "fdasf" "slava" "provider" get set-password + + [ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test +] with-db diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor new file mode 100755 index 0000000000..9583122875 --- /dev/null +++ b/extra/http/server/auth/providers/db/db.factor @@ -0,0 +1,53 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: db db.tuples db.types new-slots accessors +http.server.auth.providers kernel ; +IN: http.server.auth.providers.db + +TUPLE: user name password ; + +: user construct-empty ; + +user "USERS" +{ + { "name" "NAME" { VARCHAR 256 } +assigned-id+ } + { "password" "PASSWORD" { VARCHAR 256 } +not-null+ } +} define-persistent + +: init-users-table ( -- ) + user create-table ; + +TUPLE: db-auth-provider ; + +: db-auth-provider T{ db-auth-provider } ; + +M: db-auth-provider check-login + drop + + swap >>name + swap >>password + select-tuple >boolean ; + +M: db-auth-provider new-user + drop + [ + + swap >>name + + dup select-tuple [ name>> user-exists ] when + + "unassigned" >>password + + insert-tuple + ] with-transaction ; + +M: db-auth-provider set-password + drop + [ + + swap >>name + + dup select-tuple [ ] [ no-such-user ] ?if + + swap >>password update-tuple + ] with-transaction ; diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/http/server/auth/providers/null/null.factor new file mode 100755 index 0000000000..702111972e --- /dev/null +++ b/extra/http/server/auth/providers/null/null.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: http.server.auth.providers kernel ; +IN: http.server.auth.providers.null + +TUPLE: null-auth-provider ; + +: null-auth-provider T{ null-auth-provider } ; + +M: null-auth-provider check-login 3drop f ; + +M: null-auth-provider new-user 3drop f ; + +M: null-auth-provider set-password 3drop f ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor new file mode 100755 index 0000000000..1e0fd33a67 --- /dev/null +++ b/extra/http/server/auth/providers/providers.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel ; +IN: http.server.auth.providers + +GENERIC: check-login ( password user provider -- ? ) + +GENERIC: new-user ( user provider -- ) + +GENERIC: set-password ( password user provider -- ) + +TUPLE: user-exists name ; + +: user-exists ( name -- * ) \ user-exists construct-boa throw ; + +TUPLE: no-such-user name ; + +: no-such-user ( name -- * ) \ no-such-user construct-boa throw ; diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor index 4c21ba3c8d..d771737c73 100755 --- a/extra/http/server/sessions/sessions-tests.factor +++ b/extra/http/server/sessions/sessions-tests.factor @@ -4,6 +4,12 @@ kernel accessors ; : with-session \ session swap with-variable ; inline +TUPLE: foo ; + +C: foo + +M: foo init-session drop 0 "x" sset ; + "1234" f [ [ ] [ 3 "x" sset ] unit-test @@ -18,8 +24,7 @@ kernel accessors ; [ t ] [ f cookie-sessions? ] unit-test [ ] [ - f - [ 0 "x" sset ] >>init + "manager" set ] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 2977e5938d..d7fed6bb64 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -11,6 +11,8 @@ IN: http.server.sessions GENERIC: init-session ( responder -- ) +M: dispatcher init-session drop ; + TUPLE: session-manager responder sessions ; : ( responder class -- responder' ) diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 37f4b85c51..e5770affc5 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -9,7 +9,7 @@ assocs ; IN: http.server.templating.fhtml -: templating-vocab ( -- vocab-name ) "http.server.templating" ; +: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ; ! See apps/http-server/test/ or libs/furnace/ for template usage ! examples From 3c5a959ff4053997a9e4c5ee361a1f3f097f44be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 03:02:01 -0600 Subject: [PATCH 123/140] Remove obsolete file --- extra/http/server/auth/auth.factor | 25 ------------------------- 1 file changed, 25 deletions(-) delete mode 100755 extra/http/server/auth/auth.factor diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor deleted file mode 100755 index a53905bce1..0000000000 --- a/extra/http/server/auth/auth.factor +++ /dev/null @@ -1,25 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -IN: http.server.auth -USING: new-slots accessors http.server.auth.providers.null -http.server.auth.strategies.null ; - -TUPLE: authentication responder provider strategy ; - -: ( responder -- authentication ) - null-auth-provider null-auth-strategy - authentication construct-boa ; - -SYMBOL: current-user-id -SYMBOL: auth-provider -SYMBOL: auth-strategy - -M: authentication call-responder ( request path responder -- response ) - dup provider>> auth-provider set - dup strategy>> auth-strategy set - pick auth-provider get logged-in? dup current-user-id set - [ - responder>> call-responder - ] [ - 2drop auth-provider get require-login - ] if* ; From 626334303c4d60501ffec5210aaebad7524f7dfb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 03:03:07 -0600 Subject: [PATCH 124/140] Fix build dir pollution in unit tests --- extra/db/sqlite/sqlite-tests.factor | 2 +- extra/db/sqlite/test.db | Bin 2048 -> 0 bytes extra/db/tuples/tuples-tests.factor | 2 +- .../server/auth/providers/db/db-tests.factor | 5 +++-- 4 files changed, 5 insertions(+), 4 deletions(-) delete mode 100644 extra/db/sqlite/test.db diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index 08139610a0..b30cb4ba80 100755 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -3,7 +3,7 @@ prettyprint tools.test db.sqlite db sequences continuations db.types db.tuples unicode.case ; IN: db.sqlite.tests -: db-path "extra/db/sqlite/test.db" resource-path ; +: db-path "test.db" temp-file ; : test.db db-path sqlite-db ; [ ] [ [ db-path delete-file ] ignore-errors ] unit-test diff --git a/extra/db/sqlite/test.db b/extra/db/sqlite/test.db deleted file mode 100644 index e483c47cea528c95f10fcf66fcbb67ffa351ffd1..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2048 zcmWFz^vNtqRY=P(%1ta$FlJz3U}R))P*7lCU|k diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 3a1e2c4f25..7d72a644bf 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -159,7 +159,7 @@ TUPLE: annotation n paste-id summary author mode contents ; ! ] with-db : test-sqlite ( quot -- ) - >r "tuples-test.db" resource-path sqlite-db r> with-db ; + >r "tuples-test.db" temp-file sqlite-db r> with-db ; : test-postgresql ( -- ) >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index 384e094f39..c4682c2051 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -1,11 +1,12 @@ IN: http.server.auth.providers.db.tests USING: http.server.auth.providers http.server.auth.providers.db tools.test -namespaces db db.sqlite db.tuples continuations ; +namespaces db db.sqlite db.tuples continuations +io.files ; db-auth-provider "provider" set -"auth-test.db" sqlite-db [ +"auth-test.db" temp-file sqlite-db [ [ user drop-table ] ignore-errors [ user create-table ] ignore-errors From 1b5d8d6a59c7185395ab98f7cb61b746eb546dcc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 09:52:56 -0600 Subject: [PATCH 125/140] add nmake to namespaces.lib --- extra/namespaces/lib/lib.factor | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 528e770558..8e7af02597 100644 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -2,7 +2,7 @@ ! USING: kernel quotations namespaces sequences assocs.lib ; USING: kernel namespaces namespaces.private quotations sequences - assocs.lib ; + assocs.lib math.parser math sequences.lib ; IN: namespaces.lib @@ -17,3 +17,30 @@ IN: namespaces.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : set* ( val var -- ) namestack* set-assoc-stack ; + +SYMBOL: building-seq +: get-building-seq ( n -- seq ) + building-seq get nth ; + +: n, get-building-seq push ; +: n% get-building-seq push-all ; +: n# >r number>string r> n% ; + +: 0, 0 n, ; +: 0% 0 n% ; +: 0# 0 n# ; +: 1, 1 n, ; +: 1% 1 n% ; +: 1# 1 n# ; +: 2, 2 n, ; +: 2% 2 n% ; +: 2# 2 n# ; + +: nmake ( quot exemplars -- seqs ) + dup length dup zero? [ 1+ ] when + [ + [ + [ drop 1024 swap new-resizable ] 2map + [ building-seq set call ] keep + ] 2keep >r [ like ] 2map r> firstn + ] with-scope ; From ca6fc5edc61696f11446e5cdd659beeff33bae43 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 10:18:46 -0600 Subject: [PATCH 126/140] default constructor was not sticking around after USEing a vocab --- extra/singleton/singleton.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor index 3a9af90071..b745e8f902 100644 --- a/extra/singleton/singleton.factor +++ b/extra/singleton/singleton.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel parser quotations tuples words ; +USING: kernel parser quotations prettyprint tuples words ; IN: singleton : SINGLETON: CREATE-CLASS dup { } define-tuple-class + dup unparse create-in reset-generic dup construct-empty 1quotation define ; parsing From f2463f34aed3a30839b60c1e24982bf9a19ec9ba Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 6 Mar 2008 11:28:49 -0600 Subject: [PATCH 127/140] hashtables: simplify (key@) --- core/hashtables/hashtables.factor | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 359bedd041..7d8c6f0b5f 100755 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private slots.private math assocs -math.private sequences sequences.private vectors ; + math.private sequences sequences.private vectors ; IN: hashtables Date: Thu, 6 Mar 2008 11:37:44 -0600 Subject: [PATCH 128/140] builder: fix stack effect --- extra/builder/builder.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 92cd5f5241..41096e863c 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -39,7 +39,7 @@ IN: builder : record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ; -: do-make-clean ( -- desc ) { "make" "clean" } try-process ; +: do-make-clean ( -- ) { "make" "clean" } try-process ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 9aa6219759fa25966212328d24a4d1420434de8f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 6 Mar 2008 12:04:20 -0600 Subject: [PATCH 129/140] unix.stat: add lstat* --- extra/unix/stat/stat.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/extra/unix/stat/stat.factor b/extra/unix/stat/stat.factor index 204321f30c..6d60caf987 100644 --- a/extra/unix/stat/stat.factor +++ b/extra/unix/stat/stat.factor @@ -74,3 +74,8 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ; "stat" dup >r stat check-status r> ; + +: lstat* ( pathname -- stat ) + "stat" dup >r + lstat check-status + r> ; From 56919b42af6d41a701c5ef55de51cd4b8a58ac72 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 6 Mar 2008 12:04:54 -0600 Subject: [PATCH 130/140] io.files: link-info --- core/io/files/files.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index b51d767069..899a1be006 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -54,6 +54,7 @@ TUPLE: no-parent-directory path ; TUPLE: file-info type size permissions modified ; HOOK: file-info io-backend ( path -- info ) +HOOK: link-info io-backend ( path -- info ) SYMBOL: +regular-file+ SYMBOL: +directory+ From 724041c31d5ea3525ef9aa397ed621273c06937e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 6 Mar 2008 12:05:47 -0600 Subject: [PATCH 131/140] io.unix.files: add link-info unix backend --- extra/io/unix/files/files.factor | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index db3cf674c7..4142c4be77 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -89,3 +89,12 @@ M: unix-io file-info ( path -- info ) [ stat-st_mtim timespec-sec seconds unix-1970 time+ ] } cleave \ file-info construct-boa ; + +M: unix-io link-info ( path -- info ) + lstat* { + [ stat>type ] + [ stat-st_size ] + [ stat-st_mode ] + [ stat-st_mtim timespec-sec seconds unix-1970 time+ ] + } cleave + \ file-info construct-boa ; From a336cb7570db38c343b863fca05df740b2f2b407 Mon Sep 17 00:00:00 2001 From: dharmatech Date: Thu, 6 Mar 2008 13:46:15 -0600 Subject: [PATCH 132/140] Unit test fixes --- core/words/words-tests.factor | 6 +- extra/db/tuples/tuples-tests.factor | 6 +- extra/html/parser/analyzer/analyzer.factor | 9 +- extra/io/sniffer/bsd/bsd.factor | 2 +- extra/io/unix/kqueue/kqueue.factor | 3 +- extra/ldap/ldap-tests.factor | 5 +- extra/ldap/libldap/libldap.factor | 4 +- extra/openssl/libssl/libssl.factor | 4 +- extra/pdf/libhpdf/libhpdf.factor | 4 +- extra/pdf/pdf-tests.factor | 2 +- extra/pdf/test/font_test.pdf | 300 ------------------ extra/peg/search/search-tests.factor | 3 +- .../safe-words/safe-words.factor | 1 - extra/smtp/smtp-tests.factor | 3 +- extra/unix/unix.factor | 1 + extra/webapps/callback/authors.txt | 2 - extra/webapps/callback/callback.factor | 126 -------- extra/webapps/continuation/authors.txt | 1 - .../webapps/continuation/continuation.factor | 151 --------- .../webapps/continuation/examples/authors.txt | 1 - .../continuation/examples/examples.factor | 115 ------- 21 files changed, 31 insertions(+), 718 deletions(-) delete mode 100644 extra/pdf/test/font_test.pdf delete mode 100755 extra/webapps/callback/authors.txt delete mode 100644 extra/webapps/callback/callback.factor delete mode 100755 extra/webapps/continuation/authors.txt delete mode 100644 extra/webapps/continuation/continuation.factor delete mode 100755 extra/webapps/continuation/examples/authors.txt delete mode 100644 extra/webapps/continuation/examples/examples.factor diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 06f3c7a782..4d9933147b 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -141,7 +141,11 @@ SYMBOL: quot-uses-b [ { + } ] [ \ quot-uses-b uses ] unit-test -[ "IN: words.tests FORGET: undef-test : undef-test ; << undef-test >>" eval ] +"undef-test" "words.tests" lookup [ + [ forget ] with-compilation-unit +] when* + +[ "IN: words.tests : undef-test ; << undef-test >>" eval ] [ [ undefined? ] is? ] must-fail-with [ ] [ diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 7d72a644bf..5913f053da 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.tuples -db.types continuations namespaces db.postgresql math +db.types continuations namespaces math prettyprint tools.walker db.sqlite calendar math.intervals ; IN: db.tuples.tests @@ -161,8 +161,8 @@ TUPLE: annotation n paste-id summary author mode contents ; : test-sqlite ( quot -- ) >r "tuples-test.db" temp-file sqlite-db r> with-db ; -: test-postgresql ( -- ) - >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; +! : test-postgresql ( -- ) +! >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ; [ native-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-tuples ] test-sqlite diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index fca15d9b07..8fc45ec486 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,6 +1,5 @@ USING: assocs html.parser kernel math sequences strings ascii -arrays shuffle unicode.case namespaces splitting -http.server.responders ; +arrays shuffle unicode.case namespaces splitting http ; IN: html.parser.analyzer : remove-blank-text ( vector -- vector' ) @@ -82,8 +81,8 @@ IN: html.parser.analyzer : href-contains? ( str tag -- ? ) tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ; -: query>hash* ( str -- hash ) - "?" split1 nip query>hash ; +: query>assoc* ( str -- hash ) + "?" split1 nip query>assoc ; ! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map @@ -91,5 +90,5 @@ IN: html.parser.analyzer ! "a" over find-opening-tags-by-name ! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset ! first first 8 + over nth -! tag-attributes "href" swap at query>hash* +! tag-attributes "href" swap at query>assoc* ! "lat" over at "lon" rot at diff --git a/extra/io/sniffer/bsd/bsd.factor b/extra/io/sniffer/bsd/bsd.factor index 1c72a4780c..1456965858 100644 --- a/extra/io/sniffer/bsd/bsd.factor +++ b/extra/io/sniffer/bsd/bsd.factor @@ -7,7 +7,7 @@ sequences io.sniffer.backend ; QUALIFIED: unix IN: io.sniffer.bsd -M: unix-io destruct-handle ( obj -- ) unix:close drop ; +M: unix-io destruct-handle ( obj -- ) unix:close ; C-UNION: ifreq_props "sockaddr-in" "short" "int" "caddr_t" ; C-STRUCT: ifreq { { "char" 16 } "name" } { "ifreq_props" "props" } ; diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index 60e3754ec6..c5dc964a7a 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -31,7 +31,8 @@ M: output-task io-task-filter drop EVFILT_WRITE ; swap io-task-filter over set-kevent-filter ; : register-kevent ( kevent mx -- ) - mx-fd swap 1 f 0 f kevent io-error ; + mx-fd swap 1 f 0 f kevent + 0 < [ err_no ESRCH = [ (io-error) ] unless ] when ; M: kqueue-mx register-io-task ( task mx -- ) over EV_ADD make-kevent over register-kevent diff --git a/extra/ldap/ldap-tests.factor b/extra/ldap/ldap-tests.factor index e4338615ce..42e51c782a 100644 --- a/extra/ldap/ldap-tests.factor +++ b/extra/ldap/ldap-tests.factor @@ -5,10 +5,12 @@ tools.test ; get-ldp LDAP_OPT_PROTOCOL_VERSION LDAP_VERSION3 set-option -[ B{ 0 0 0 3 } ] [ +[ 3 ] [ get-ldp LDAP_OPT_PROTOCOL_VERSION "int*" [ get-option ] keep + *int ] unit-test +[ get-ldp "cn=jimbob,dc=example,dc=com" "secret" [ ! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0 @@ -52,3 +54,4 @@ get-ldp "cn=jimbob,dc=example,dc=com" "secret" [ get-ldp get-message next-message msgtype result-type ] with-bind +] drop diff --git a/extra/ldap/libldap/libldap.factor b/extra/ldap/libldap/libldap.factor index 492aed1a54..ae613bd461 100755 --- a/extra/ldap/libldap/libldap.factor +++ b/extra/ldap/libldap/libldap.factor @@ -9,11 +9,11 @@ USING: alien alien.syntax combinators kernel system ; IN: ldap.libldap -"libldap" { +<< "libldap" { { [ win32? ] [ "libldap.dll" "stdcall" ] } { [ macosx? ] [ "libldap.dylib" "cdecl" ] } { [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] } -} cond add-library +} cond add-library >> : LDAP_VERSION1 1 ; inline : LDAP_VERSION2 2 ; inline diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index 29016f6d57..8d1b3b5247 100644 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -9,11 +9,11 @@ USING: alien alien.syntax combinators kernel system ; IN: openssl.libssl -"libssl" { +<< "libssl" { { [ win32? ] [ "ssleay32.dll" "stdcall" ] } { [ macosx? ] [ "libssl.dylib" "cdecl" ] } { [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] } -} cond add-library +} cond add-library >> : X509_FILETYPE_PEM 1 ; inline : X509_FILETYPE_ASN1 2 ; inline diff --git a/extra/pdf/libhpdf/libhpdf.factor b/extra/pdf/libhpdf/libhpdf.factor index 85ccc70c25..a40b7cddee 100644 --- a/extra/pdf/libhpdf/libhpdf.factor +++ b/extra/pdf/libhpdf/libhpdf.factor @@ -9,11 +9,11 @@ USING: alien alien.syntax combinators system ; IN: pdf.libhpdf -"libhpdf" { +<< "libhpdf" { { [ win32? ] [ "libhpdf.dll" "stdcall" ] } { [ macosx? ] [ "libhpdf.dylib" "cdecl" ] } { [ unix? ] [ "$LD_LIBRARY_PATH/libhpdf.so" "cdecl" ] } -} cond add-library +} cond add-library >> ! compression mode : HPDF_COMP_NONE HEX: 00 ; inline ! No contents are compressed diff --git a/extra/pdf/pdf-tests.factor b/extra/pdf/pdf-tests.factor index dc42874d2a..097f671d9a 100644 --- a/extra/pdf/pdf-tests.factor +++ b/extra/pdf/pdf-tests.factor @@ -92,6 +92,6 @@ SYMBOL: twidth ] with-text - "extra/pdf/test/font_test.pdf" resource-path save-to-file + "font_test.pdf" temp-file save-to-file ] with-pdf diff --git a/extra/pdf/test/font_test.pdf b/extra/pdf/test/font_test.pdf deleted file mode 100644 index 4360cf349f..0000000000 --- a/extra/pdf/test/font_test.pdf +++ /dev/null @@ -1,300 +0,0 @@ -%PDF-1.3 -%·¾­ª -1 0 obj -<< -/Type /Catalog -/Pages 2 0 R ->> -endobj -2 0 obj -<< -/Type /Pages -/Kids [ 4 0 R ] -/Count 1 ->> -endobj -3 0 obj -<< -/Producer (Haru\040Free\040PDF\040Library\0402.0.8) ->> -endobj -4 0 obj -<< -/Type /Page -/MediaBox [ 0 0 595 841 ] -/Contents 5 0 R -/Resources << -/ProcSet [ /PDF /Text /ImageB /ImageC /ImageI ] -/Font << -/F1 7 0 R -/F2 8 0 R -/F3 9 0 R -/F4 10 0 R -/F5 11 0 R -/F6 12 0 R -/F7 13 0 R -/F8 14 0 R -/F9 15 0 R -/F10 16 0 R -/F11 17 0 R -/F12 18 0 R -/F13 19 0 R -/F14 20 0 R ->> ->> -/Parent 2 0 R ->> -endobj -5 0 obj -<< -/Length 6 0 R ->> -stream -1 w -50 50 495 731 re -S -/F1 24 Tf -BT -238.148 791 Td -(Font\040Demo) Tj -ET -BT -/F1 16 Tf -60 761 Td -(\074Standard\040Type1\040font\040samples\076) Tj -ET -BT -60 736 Td -/F2 9 Tf -(Courier) Tj -0 -18 Td -/F2 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F3 9 Tf -(Courier-Bold) Tj -0 -18 Td -/F3 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F4 9 Tf -(Courier-Oblique) Tj -0 -18 Td -/F4 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F5 9 Tf -(Courier-BoldOblique) Tj -0 -18 Td -/F5 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F1 9 Tf -(Helvetica) Tj -0 -18 Td -/F1 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F6 9 Tf -(Helvetica-Bold) Tj -0 -18 Td -/F6 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F7 9 Tf -(Helvetica-Oblique) Tj -0 -18 Td -/F7 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F8 9 Tf -(Helvetica-BoldOblique) Tj -0 -18 Td -/F8 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F9 9 Tf -(Times-Roman) Tj -0 -18 Td -/F9 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F10 9 Tf -(Times-Bold) Tj -0 -18 Td -/F10 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F11 9 Tf -(Times-Italic) Tj -0 -18 Td -/F11 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F12 9 Tf -(Times-BoldItalic) Tj -0 -18 Td -/F12 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F13 9 Tf -(Symbol) Tj -0 -18 Td -/F13 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -/F14 9 Tf -(ZapfDingbats) Tj -0 -18 Td -/F14 20 Tf -(abcdefgABCDEFG12345!\043$\045&+-@?) Tj -0 -20 Td -ET - -endstream -endobj -6 0 obj -1517 -endobj -7 0 obj -<< -/Type /Font -/BaseFont /Helvetica -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -8 0 obj -<< -/Type /Font -/BaseFont /Courier -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -9 0 obj -<< -/Type /Font -/BaseFont /Courier-Bold -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -10 0 obj -<< -/Type /Font -/BaseFont /Courier-Oblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -11 0 obj -<< -/Type /Font -/BaseFont /Courier-BoldOblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -12 0 obj -<< -/Type /Font -/BaseFont /Helvetica-Bold -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -13 0 obj -<< -/Type /Font -/BaseFont /Helvetica-Oblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -14 0 obj -<< -/Type /Font -/BaseFont /Helvetica-BoldOblique -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -15 0 obj -<< -/Type /Font -/BaseFont /Times-Roman -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -16 0 obj -<< -/Type /Font -/BaseFont /Times-Bold -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -17 0 obj -<< -/Type /Font -/BaseFont /Times-Italic -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -18 0 obj -<< -/Type /Font -/BaseFont /Times-BoldItalic -/Subtype /Type1 -/Encoding /StandardEncoding ->> -endobj -19 0 obj -<< -/Type /Font -/BaseFont /Symbol -/Subtype /Type1 ->> -endobj -20 0 obj -<< -/Type /Font -/BaseFont /ZapfDingbats -/Subtype /Type1 ->> -endobj -xref -0 21 -0000000000 65535 f -0000000015 00000 n -0000000064 00000 n -0000000123 00000 n -0000000196 00000 n -0000000518 00000 n -0000002089 00000 n -0000002109 00000 n -0000002207 00000 n -0000002303 00000 n -0000002404 00000 n -0000002509 00000 n -0000002618 00000 n -0000002722 00000 n -0000002829 00000 n -0000002940 00000 n -0000003041 00000 n -0000003141 00000 n -0000003243 00000 n -0000003349 00000 n -0000003417 00000 n -trailer -<< -/Root 1 0 R -/Info 3 0 R -/Size 21 ->> -startxref -3491 -%%EOF diff --git a/extra/peg/search/search-tests.factor b/extra/peg/search/search-tests.factor index c65001be09..b22a5ef0d0 100755 --- a/extra/peg/search/search-tests.factor +++ b/extra/peg/search/search-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel math math.parser arrays tools.test peg peg.search ; +USING: kernel math math.parser arrays tools.test peg peg.parsers +peg.search ; IN: peg.search.tests { V{ 123 456 } } [ diff --git a/extra/random-tester/safe-words/safe-words.factor b/extra/random-tester/safe-words/safe-words.factor index ab528786bb..f7eac4c32d 100755 --- a/extra/random-tester/safe-words/safe-words.factor +++ b/extra/random-tester/safe-words/safe-words.factor @@ -54,7 +54,6 @@ IN: random-tester.safe-words : method-words { - method-def forget-word } ; diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index c1afeced3d..32b2f3be14 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -84,6 +84,7 @@ IN: smtp.tests [ ] [ [ + "localhost" smtp-host set 4321 smtp-port set "Hi guys\nBye guys" @@ -96,4 +97,4 @@ IN: smtp.tests send-simple-message ] with-scope -] unit-test \ No newline at end of file +] unit-test diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 9cc8552f98..e1d49b8c6c 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -21,6 +21,7 @@ TYPEDEF: ulong size_t : MAP_FAILED -1 ; inline +: ESRCH 3 ; inline : EEXIST 17 ; inline ! ! ! Unix functions diff --git a/extra/webapps/callback/authors.txt b/extra/webapps/callback/authors.txt deleted file mode 100755 index a8fb961d36..0000000000 --- a/extra/webapps/callback/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Chris Double -Slava Pestov diff --git a/extra/webapps/callback/callback.factor b/extra/webapps/callback/callback.factor deleted file mode 100644 index 6bdc84bfa6..0000000000 --- a/extra/webapps/callback/callback.factor +++ /dev/null @@ -1,126 +0,0 @@ -! Copyright (C) 2004 Chris Double. -! Copyright (C) 2006 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: html http http.server.responders io kernel math -namespaces prettyprint continuations random system sequences -assocs ; -IN: webapps.callback - -#! Name of the variable holding the continuation used to exit -#! back to the httpd responder. -SYMBOL: exit-continuation - -#! Tuple to hold global request data. This gets passed to -#! the continuation when resumed so it can restore things -#! like 'stdio' so it writes to the correct socket. -TUPLE: request stream exitcc method url raw-query query header response ; - -: ( -- request ) - stdio get - exit-continuation get - "method" get - "request" get - "raw-query" get - "query" get - "header" get - "response" get - request construct-boa ; - -: restore-request ( -- ) - request get - dup request-stream stdio set - dup request-method "method" set - dup request-raw-query "raw-query" set - dup request-query "query" set - dup request-header "header" set - dup request-response "response" set - request-exitcc exit-continuation set ; - -: update-request ( request new-request -- ) - [ request-stream over set-request-stream ] keep - [ request-method over set-request-method ] keep - [ request-url over set-request-url ] keep - [ request-raw-query over set-request-raw-query ] keep - [ request-query over set-request-query ] keep - [ request-header over set-request-header ] keep - [ request-response over set-request-response ] keep - request-exitcc swap set-request-exitcc ; - -: with-exit-continuation ( quot -- ) - #! Call the quotation with the variable exit-continuation bound - #! such that when the exit continuation is called, computation - #! will resume from the end of this 'with-exit-continuation' call. - [ - exit-continuation set call exit-continuation get continue - ] callcc0 drop ; - -: expiry-timeout ( -- ms ) 900 1000 * ; - -: get-random-id ( -- id ) - #! Generate a random id to use for continuation URL's - 4 big-random unparse ; - -: callback-table ( -- ) - #! Return the global table of continuations - \ callback-table get-global ; - -: reset-callback-table ( -- ) - #! Create the initial global table - H{ } clone \ callback-table set-global ; - -reset-callback-table - -#! Tuple for holding data related to a callback. -TUPLE: item quot expire? request id time-added ; - -: ( quot expire? request id -- item ) - millis item construct-boa ; - -: expired? ( item -- ? ) - #! Return true if the callback item is expirable - #! and has expired (ie. was added to the table more than - #! timeout milliseconds ago). - [ item-time-added expiry-timeout + millis < ] keep - item-expire? and ; - -: expire-callbacks ( -- ) - #! Expire all continuations in the continuation table - #! if they are 'timeout-seconds' old (ie. were added - #! more than 'timeout-seconds' ago. - callback-table clone [ - expired? [ callback-table delete-at ] [ drop ] if - ] assoc-each ; - -: id>url ( id -- string ) - #! Convert the continuation id to an URL suitable for - #! embedding in an HREF or other HTML. - "/responder/callback/?id=" swap url-encode append ; - -: register-callback ( quot expire? -- url ) - #! Store a continuation in the table and associate it with - #! a random id. That continuation will be expired after - #! a certain period of time if 'expire?' is true. - request get get-random-id [ ] keep - [ callback-table set-at ] keep - id>url ; - -: register-html-callback ( quot expire? -- url ) - >r [ serving-html ] swap append r> register-callback ; - -: callback-responder ( -- ) - expire-callbacks - "id" query-param callback-table at [ - [ - dup item-request [ - update-request - ] when* - item-quot call - exit-continuation get continue - ] with-exit-continuation drop - ] [ - "404 Callback not available" httpd-error - ] if* ; - -global [ - "callback" [ callback-responder ] add-simple-responder -] bind diff --git a/extra/webapps/continuation/authors.txt b/extra/webapps/continuation/authors.txt deleted file mode 100755 index 44b06f94bc..0000000000 --- a/extra/webapps/continuation/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/webapps/continuation/continuation.factor b/extra/webapps/continuation/continuation.factor deleted file mode 100644 index 6b6838d89f..0000000000 --- a/extra/webapps/continuation/continuation.factor +++ /dev/null @@ -1,151 +0,0 @@ -! Copyright (C) 2004 Chris Double. -! See http://factorcode.org/license.txt for BSD license. - -USING: http math namespaces io strings kernel html html.elements -hashtables continuations quotations parser generic sequences -webapps.callback http.server.responders ; -IN: webapps.continuation - -#! Used inside the session state of responders to indicate whether the -#! next request should use the post-refresh-get pattern. It is set to -#! true after each request. -SYMBOL: post-refresh-get? - -: >callable ( quot|interp|f -- interp ) - dup continuation? [ - [ continue ] curry - ] when ; - -: forward-to-url ( url -- ) - #! When executed inside a 'show' call, this will force a - #! HTTP 302 to occur to instruct the browser to forward to - #! the request URL. - [ - "HTTP/1.1 302 Document Moved\nLocation: " % % - "\nContent-Length: 0\nContent-Type: text/plain\n\n" % - ] "" make write exit-continuation get continue ; - -: forward-to-id ( id -- ) - #! When executed inside a 'show' call, this will force a - #! HTTP 302 to occur to instruct the browser to forward to - #! the request URL. - >r "request" get r> id>url append forward-to-url ; - -SYMBOL: current-show - -: store-current-show ( -- ) - #! Store the current continuation in the variable 'current-show' - #! so it can be returned to later by href callbacks. Note that it - #! recalls itself when the continuation is called to ensure that - #! it resets its value back to the most recent show call. - [ ( 0 -- ) - [ ( 0 1 -- ) - current-show set ( 0 -- ) - continue - ] callcc1 - nip - restore-request - call - store-current-show - ] callcc0 restore-request ; - -: redirect-to-here ( -- ) - #! Force a redirect to the client browser so that the browser - #! goes to the current point in the code. This forces an URL - #! change on the browser so that refreshing that URL will - #! immediately run from this code point. This prevents the - #! "this request will issue a POST" warning from the browser - #! and prevents re-running the previous POST logic. This is - #! known as the 'post-refresh-get' pattern. - post-refresh-get? get [ - [ - >callable t register-callback forward-to-url - ] callcc0 restore-request - ] [ - t post-refresh-get? set - ] if ; - -: (show) ( quot -- hashtable ) - #! See comments for show. The difference is the - #! quotation MUST set the content-type using 'serving-html' - #! or similar. - store-current-show redirect-to-here - [ - >callable t register-callback swap with-scope - exit-continuation get continue - ] callcc0 drop restore-request "response" get ; - -: show ( quot -- namespace ) - #! Call the quotation with the URL associated with the current - #! continuation. All output from the quotation goes to the client - #! browser. When the URL is later referenced then - #! computation will resume from this 'show' call with a hashtable on - #! the stack containing any query or post parameters. - #! 'quot' has stack effect ( url -- ) - #! NOTE: On return from 'show' the stack is exactly the same as - #! initial entry with 'quot' popped off and the hashtable pushed on. Even - #! if the quotation consumes items on the stack. - [ serving-html ] swap append (show) ; - -: (show-final) ( quot -- namespace ) - #! See comments for show-final. The difference is the - #! quotation MUST set the content-type using 'serving-html' - #! or similar. - store-current-show redirect-to-here - with-scope exit-continuation get continue ; - -: show-final ( quot -- namespace ) - #! Similar to 'show', except the quotation does not receive the URL - #! to resume computation following 'show-final'. No continuation is - #! stored for this resumption. As a result, 'show-final' is for use - #! when a page is to be displayed with no further action to occur. Its - #! use is an optimisation to save having to generate and save a continuation - #! in that special case. - #! 'quot' has stack effect ( -- ). - [ serving-html ] swap compose (show-final) ; - -#! Name of variable for holding initial continuation id that starts -#! the responder. -SYMBOL: root-callback - -: cont-get/post-responder ( id-or-f -- ) - #! httpd responder that handles the root continuation request. - #! The requests for actual continuation are processed by the - #! 'callback-responder'. - [ - [ f post-refresh-get? set request set root-callback get call ] with-scope - exit-continuation get continue - ] with-exit-continuation drop ; - -: quot-url ( quot -- url ) - current-show get [ continue-with ] 2curry t register-callback ; - -: quot-href ( text quot -- ) - #! Write to standard output an HTML HREF where the href, - #! when referenced, will call the quotation and then return - #! back to the most recent 'show' call (via the callback-cc). - #! The text of the link will be the 'text' argument on the - #! stack. - write ; - -: install-cont-responder ( name quot -- ) - #! Install a cont-responder with the given name - #! that will initially run the given quotation. - #! - #! Convert the quotation so it is run within a session namespace - #! and that namespace is initialized first. - [ - [ cont-get/post-responder ] "get" set - [ cont-get/post-responder ] "post" set - swap "responder" set - root-callback set - ] make-responder ; - -: show-message-page ( message -- ) - #! Display the message in an HTML page with an OK button. - [ - "Press OK to Continue" [ - swap paragraph - "OK" write - ] simple-page - ] show 2drop ; diff --git a/extra/webapps/continuation/examples/authors.txt b/extra/webapps/continuation/examples/authors.txt deleted file mode 100755 index 44b06f94bc..0000000000 --- a/extra/webapps/continuation/examples/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/webapps/continuation/examples/examples.factor b/extra/webapps/continuation/examples/examples.factor deleted file mode 100644 index 2899562503..0000000000 --- a/extra/webapps/continuation/examples/examples.factor +++ /dev/null @@ -1,115 +0,0 @@ -! Copyright (C) 2004 Chris Double. -! -! 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. -! -! Simple test applications -USING: hashtables html kernel io html html.elements strings math -assocs quotations webapps.continuation namespaces prettyprint -sequences ; - -IN: webapps.continuation.examples - -: display-page ( title -- ) - #! Display a page with some text to test the cont-responder. - #! The page has a link to the 'next' continuation. - [ -

over write

- swap [ - "Next" write - ] simple-html-document - ] show 2drop ; - -: display-get-name-page ( -- name ) - #! Display a page prompting for input of a name and return that name. - [ - "Enter your name" [ -

swap write

-
- "Name: " write - - -
- ] simple-html-document - ] show "name" swap at ; - -: test-cont-responder ( -- ) - #! Test the cont-responder responder by displaying a few pages in a row. - "Page one" display-page - "Hello " display-get-name-page append display-page - "Page three" display-page ; - -: test-cont-responder2 ( -- ) - #! Test the cont-responder responder by displaying a few pages in a loop. - [ "one" "two" "three" "four" ] [ display-page ] each - "Done!" display-page ; - -: test-cont-responder3 ( -- ) - #! Test the quot-href word by displaying a menu of the current - #! test words. Note that we use show-final as we don't link to a 'next' page. - [ - "Menu" [ -

"Menu" write

-
    -
  1. "Test responder1" [ test-cont-responder ] quot-href
    2. -
  2. "Test responder2" [ test-cont-responder2 ] quot-href
    3. -
- ] simple-html-document - ] show-final ; - -: counter-example ( count -- ) - #! Display a counter which can be incremented or decremented - #! using anchors. - #! - #! Don't need the original alist - [ - #! And we don't need the 'url' argument - drop - "Counter: " over unparse append [ - dup

unparse write

- "++" over 1quotation [ f ] swap append [ 1 + counter-example ] append quot-href - "--" over 1quotation [ f ] swap append [ 1 - counter-example ] append quot-href - drop - ] simple-html-document - ] show drop ; - -: counter-example2 ( -- ) - #! Display a counter which can be incremented or decremented - #! using anchors. - #! - 0 "counter" set - [ - #! We don't need the 'url' argument - drop - "Counter: " "counter" get unparse append [ -

"counter" get unparse write

- "++" [ "counter" get 1 + "counter" set ] quot-href - "--" [ "counter" get 1 - "counter" set ] quot-href - ] simple-html-document - ] show - drop ; - -! Install the examples -"counter1" [ drop 0 counter-example ] install-cont-responder -"counter2" [ drop counter-example2 ] install-cont-responder -"test1" [ test-cont-responder ] install-cont-responder -"test2" [ drop test-cont-responder2 ] install-cont-responder -"test3" [ drop test-cont-responder3 ] install-cont-responder From b32276d1da218ac28a1354205a1b950a5961e0f8 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 6 Mar 2008 14:46:11 -0600 Subject: [PATCH 133/140] Stupid bug fix --- core/io/encodings/utf8/utf8-docs.factor | 2 +- extra/io/encodings/ascii/ascii.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/io/encodings/utf8/utf8-docs.factor b/core/io/encodings/utf8/utf8-docs.factor index 3e901ec83b..dbbc193a02 100755 --- a/core/io/encodings/utf8/utf8-docs.factor +++ b/core/io/encodings/utf8/utf8-docs.factor @@ -6,6 +6,6 @@ ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data" { $subsection utf8 } ; HELP: utf8 -{ $class-description "This is the class of encoding tuples which denote a UTF-8 encoding. You can pass this class symbol as an encoding descriptor to words like " { $link } " and " { $link encode-string } ". This conforms to the " { $link "encodings-protocol" } "." } ; +{ $class-description "This is the class of encoding tuples which denote a UTF-8 encoding. This conforms to the " { $link "encodings-protocol" } "." } ; ABOUT: "io.encodings.utf8" diff --git a/extra/io/encodings/ascii/ascii.factor b/extra/io/encodings/ascii/ascii.factor index f310f53e29..fdefc35634 100644 --- a/extra/io/encodings/ascii/ascii.factor +++ b/extra/io/encodings/ascii/ascii.factor @@ -4,7 +4,7 @@ USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ; IN: io.encodings.ascii : encode-check<= ( string stream max -- ) - [ pick > [ encode-error ] [ stream-write1 ] if ] 2curry each ; + [ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ; TUPLE: ascii ; From 549a7538c7d94349106c24b6ff083b5339512c62 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 15:58:05 -0600 Subject: [PATCH 134/140] Clean up some of Dan's code after merge --- core/bootstrap/primitives.factor | 1 + core/inference/known-words/known-words.factor | 2 + core/io/io-tests.factor | 9 +++-- core/io/streams/c/c-tests.factor | 4 +- core/io/streams/c/c.factor | 17 ++++---- extra/http/server/server.factor | 4 +- extra/io/nonblocking/nonblocking.factor | 22 ++++++----- extra/io/sockets/sockets.factor | 8 ++-- extra/io/unix/sockets/sockets.factor | 16 ++++---- extra/io/windows/nt/sockets/sockets.factor | 29 +++++--------- vm/io.c | 39 +++++++++++++++---- vm/io.h | 5 ++- vm/primitives.c | 1 + 13 files changed, 92 insertions(+), 65 deletions(-) mode change 100644 => 100755 core/io/io-tests.factor diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index f3f233ea0b..ab0e1cebe0 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -623,6 +623,7 @@ builtins get num-tags get tail f union-class define-class { "fopen" "io.streams.c" } { "fgetc" "io.streams.c" } { "fread" "io.streams.c" } + { "fputc" "io.streams.c" } { "fwrite" "io.streams.c" } { "fflush" "io.streams.c" } { "fclose" "io.streams.c" } diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 8e8251ff62..5e150e66b7 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -538,6 +538,8 @@ set-primitive-effect \ fwrite { string alien } { } set-primitive-effect +\ fputc { object alien } { } set-primitive-effect + \ fread { integer string } { object } set-primitive-effect \ fflush { alien } { } set-primitive-effect diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor old mode 100644 new mode 100755 index 8b5e763e45..22c942d2d9 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,5 +1,6 @@ USING: arrays io io.files kernel math parser strings system -tools.test words namespaces io.encodings.ascii io.encodings.binary ; +tools.test words namespaces io.encodings.latin1 +io.encodings.binary ; IN: io.tests [ f ] [ @@ -8,7 +9,7 @@ IN: io.tests ] unit-test : ( resource -- stream ) - resource-path binary ; + resource-path latin1 ; [ "This is a line.\rThis is another line.\r" @@ -31,10 +32,10 @@ IN: io.tests ! [ ] [ "123" write 9000 CHAR: x write flush ] unit-test -[ "" ] [ +[ "/core/io/test/binary.txt" [ 0.2 read ] with-stream -] unit-test +] must-fail [ { diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 6c7e57cabb..321cad4d19 100755 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -1,4 +1,5 @@ -USING: tools.test io.files io io.streams.c io.encodings.ascii ; +USING: tools.test io.files io io.streams.c +io.encodings.ascii strings ; IN: io.streams.c.tests [ "hello world" ] [ @@ -7,4 +8,5 @@ IN: io.streams.c.tests ] with-file-writer "test.txt" temp-file "rb" fopen contents + >string ] unit-test diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index de49e0dfe6..372acbe0c1 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private namespaces io io.encodings -strings sequences math generic threads.private classes -io.backend io.streams.duplex io.files continuations -io.encodings.utf8 ; +sequences math generic threads.private classes io.backend +io.streams.duplex io.files continuations byte-arrays ; IN: io.streams.c TUPLE: c-writer handle ; @@ -11,10 +10,10 @@ TUPLE: c-writer handle ; C: c-writer M: c-writer stream-write1 - >r 1string r> stream-write ; + c-writer-handle fputc ; M: c-writer stream-write - >r >string r> c-writer-handle fwrite ; + c-writer-handle fwrite ; M: c-writer stream-flush c-writer-handle fflush ; @@ -27,7 +26,7 @@ TUPLE: c-reader handle ; C: c-reader M: c-reader stream-read - >r >fixnum r> c-reader-handle fread ; + c-reader-handle fread ; M: c-reader stream-read-partial stream-read ; @@ -43,7 +42,7 @@ M: c-reader stream-read1 ] if ; M: c-reader stream-read-until - [ swap read-until-loop ] "" make swap + [ swap read-until-loop ] B{ } make swap over empty? over not and [ 2drop f f ] when ; M: c-reader dispose @@ -76,4 +75,6 @@ M: object (file-appender) #! print stuff from contexts where the I/O system would #! otherwise not work (tools.deploy.shaker, the I/O #! multiplexer thread). - "\r\n" append stdout-handle fwrite stdout-handle fflush ; + "\r\n" append >byte-array + stdout-handle fwrite + stdout-handle fflush ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 858ccd1009..133783114d 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -4,7 +4,7 @@ USING: assocs kernel namespaces io io.timeouts strings splitting threads http sequences prettyprint io.server logging calendar new-slots html.elements accessors math.parser combinators.lib vocabs.loader debugger html continuations random combinators -destructors ; +destructors io.encodings.latin1 ; IN: http.server GENERIC: call-responder ( request path responder -- response ) @@ -165,7 +165,7 @@ LOG: httpd-hit NOTICE : httpd ( port -- ) internet-server "http.server" - binary [ handle-client ] with-server ; + latin1 [ handle-client ] with-server ; : httpd-main ( -- ) 8888 httpd ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index b0ce1fcc12..6eee3739d9 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.nonblocking USING: math kernel io sequences io.buffers io.timeouts generic -sbufs system io.streams.duplex io.encodings +byte-vectors system io.streams.duplex io.encodings io.backend continuations debugger classes byte-arrays namespaces splitting dlists assocs io.encodings.binary ; @@ -71,7 +71,7 @@ GENERIC: (wait-to-read) ( port -- ) M: input-port stream-read1 dup wait-to-read1 [ buffer-pop ] unless-eof ; -: read-step ( count port -- string/f ) +: read-step ( count port -- byte-array/f ) [ wait-to-read ] 2keep [ dupd buffer> ] unless-eof nip ; @@ -90,10 +90,10 @@ M: input-port stream-read >r 0 max >fixnum r> 2dup read-step dup [ pick over length > [ - pick + pick [ push-all ] keep [ read-loop ] keep - "" like + B{ } like ] [ 2nip ] if @@ -101,7 +101,7 @@ M: input-port stream-read 2nip ] if ; -: read-until-step ( separators port -- string/f separator/f ) +: read-until-step ( separators port -- byte-array/f separator/f ) dup wait-to-read1 dup port-eof? [ f swap set-port-eof? drop f f @@ -109,7 +109,7 @@ M: input-port stream-read buffer-until ] if ; -: read-until-loop ( seps port sbuf -- separator/f ) +: read-until-loop ( seps port byte-vector -- separator/f ) 2over read-until-step over [ >r over push-all r> dup [ >r 3drop r> @@ -120,18 +120,20 @@ M: input-port stream-read >r 2drop 2drop r> ] if ; -M: input-port stream-read-until ( seps port -- str/f sep/f ) +M: input-port stream-read-until ( seps port -- byte-array/f sep/f ) 2dup read-until-step dup [ >r 2nip r> ] [ over [ - drop >sbuf [ read-until-loop ] keep "" like swap + drop >byte-vector + [ read-until-loop ] keep + B{ } like swap ] [ >r 2nip r> ] if ] if ; -M: input-port stream-read-partial ( max stream -- string/f ) +M: input-port stream-read-partial ( max stream -- byte-array/f ) >r 0 max >fixnum r> read-step ; : can-write? ( len writer -- ? ) @@ -169,7 +171,7 @@ M: port dispose [ dup port-type >r closed over set-port-type r> close-port ] if ; -TUPLE: server-port addr client encoding ; +TUPLE: server-port addr client client-addr encoding ; : ( handle addr encoding -- server ) rot f server-port diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index c10d7e963c..1dc7f4883d 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -33,17 +33,19 @@ M: array client* [ (client) 2array ] attempt-all first2 ; M: object client* (client) ; : ( addrspec encoding -- stream ) - over client* rot ; + >r client* r> ; HOOK: (server) io-backend ( addrspec -- handle ) : ( addrspec encoding -- server ) >r [ (server) ] keep r> ; -HOOK: (accept) io-backend ( server -- stream-in stream-out ) +HOOK: (accept) io-backend ( server -- addrspec handle ) : accept ( server -- client ) - [ (accept) ] keep server-port-encoding ; + [ (accept) dup ] keep + server-port-encoding + ; HOOK: io-backend ( addrspec -- datagram ) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 2af77e83c4..bd7dfd9ce1 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -42,7 +42,7 @@ M: connect-task do-io-task : wait-to-connect ( port -- ) [ add-io-task ] with-port-continuation drop ; -M: unix-io (client) ( addrspec -- stream ) +M: unix-io (client) ( addrspec -- client-in client-out ) dup make-sockaddr/size >r >r protocol-family SOCK_STREAM socket-fd dup r> r> connect @@ -71,10 +71,10 @@ TUPLE: accept-task ; dup [ swap heap-size accept ] keep ; inline : do-accept ( port fd sockaddr -- ) - rot [ - server-port-addr parse-sockaddr - swap dup - ] keep set-server-port-client ; + rot + [ server-port-addr parse-sockaddr ] keep + [ set-server-port-client-addr ] keep + set-server-port-client ; M: accept-task do-io-task io-task-port dup accept-sockaddr @@ -95,13 +95,13 @@ M: unix-io (server) ( addrspec -- handle ) SOCK_STREAM server-fd dup 10 listen zero? [ dup close (io-error) ] unless ; -M: unix-io (accept) ( server -- client-in client-out ) +M: unix-io (accept) ( server -- addrspec handle ) #! Wait for a client connection. dup check-server-port dup wait-to-accept dup pending-error - server-port-client - { duplex-stream-in duplex-stream-out } get-slots ; + dup server-port-client-addr + swap server-port-client ; ! Datagram sockets - UDP and Unix domain M: unix-io diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 7af7df9bef..a63a533ba1 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -45,13 +45,12 @@ TUPLE: ConnectEx-args port "stdcall" alien-indirect drop winsock-error-string [ throw ] when* ; -: connect-continuation ( ConnectEx -- ) - dup ConnectEx-args-lpOverlapped* - swap ConnectEx-args-port duplex-stream-in - [ save-callback ] 2keep +: connect-continuation ( ConnectEx port -- ) + >r ConnectEx-args-lpOverlapped* r> + 2dup save-callback get-overlapped-result drop ; -M: windows-nt-io (client) ( addrspec -- duplex-stream ) +M: windows-nt-io (client) ( addrspec -- client-in client-out ) [ \ ConnectEx-args construct-empty over make-sockaddr/size pick init-connect @@ -61,14 +60,8 @@ M: windows-nt-io (client) ( addrspec -- duplex-stream ) dup ConnectEx-args-s* INADDR_ANY roll bind-socket dup (ConnectEx) - dup ConnectEx-args-s* - dup - over set-ConnectEx-args-port - - dup connect-continuation - ConnectEx-args-port - [ duplex-stream-in pending-error ] keep - [ duplex-stream-out pending-error ] keep + dup ConnectEx-args-s* dup + >r [ connect-continuation ] keep [ pending-error ] keep r> ] with-destructors ; TUPLE: AcceptEx-args port @@ -118,17 +111,15 @@ TUPLE: AcceptEx-args port ] keep *void* ] keep AcceptEx-args-port server-port-addr parse-sockaddr ; -: accept-continuation ( AcceptEx -- client ) +: accept-continuation ( AcceptEx -- addrspec client ) [ make-accept-continuation ] keep [ check-accept-error ] keep [ extract-remote-host ] keep ! addrspec AcceptEx - [ - AcceptEx-args-sAcceptSocket* add-completion - ] keep + [ AcceptEx-args-sAcceptSocket* add-completion ] keep AcceptEx-args-sAcceptSocket* ; -M: windows-nt-io (accept) ( server -- client-in client-out ) +M: windows-nt-io (accept) ( server -- addrspec handle ) [ [ dup check-server-port @@ -137,8 +128,6 @@ M: windows-nt-io (accept) ( server -- client-in client-out ) [ ((accept)) ] keep [ accept-continuation ] keep AcceptEx-args-port pending-error - dup duplex-stream-in pending-error - dup duplex-stream-out pending-error ] with-timeout ] with-destructors ; diff --git a/vm/io.c b/vm/io.c index d3a29abe72..faf681bbef 100755 --- a/vm/io.c +++ b/vm/io.c @@ -102,21 +102,46 @@ DEFINE_PRIMITIVE(fread) } else { - dpush(tag_object(memory_to_char_string( - (char *)(buf + 1),c))); + if(c != size) + { + REGISTER_UNTAGGED(buf); + F_BYTE_ARRAY *new_buf = allot_byte_array(c); + UNREGISTER_UNTAGGED(buf); + memcpy(new_buf + 1, buf + 1,c); + buf = new_buf; + } + dpush(tag_object(buf)); break; } } } +DEFINE_PRIMITIVE(fputc) +{ + FILE *file = unbox_alien(); + F_FIXNUM ch = to_fixnum(dpop()); + + for(;;) + { + if(fputc(ch,file) == EOF) + { + io_error(); + + /* Still here? EINTR */ + } + else + break; + } +} + DEFINE_PRIMITIVE(fwrite) { - FILE* file = unbox_alien(); - F_STRING* text = untag_string(dpop()); - F_FIXNUM length = untag_fixnum_fast(text->length); - char* string = to_char_string(text,false); + FILE *file = unbox_alien(); + F_BYTE_ARRAY *text = untag_byte_array(dpop()); + F_FIXNUM length = array_capacity(text); + char *string = (char *)(text + 1); - if(string_capacity(text) == 0) + if(length == 0) return; for(;;) diff --git a/vm/io.h b/vm/io.h index 39e7390c3e..a19da3887c 100755 --- a/vm/io.h +++ b/vm/io.h @@ -3,11 +3,12 @@ void io_error(void); int err_no(void); DECLARE_PRIMITIVE(fopen); +DECLARE_PRIMITIVE(fgetc); +DECLARE_PRIMITIVE(fread); +DECLARE_PRIMITIVE(fputc); DECLARE_PRIMITIVE(fwrite); DECLARE_PRIMITIVE(fflush); DECLARE_PRIMITIVE(fclose); -DECLARE_PRIMITIVE(fgetc); -DECLARE_PRIMITIVE(fread); /* Platform specific primitives */ DECLARE_PRIMITIVE(open_file); diff --git a/vm/primitives.c b/vm/primitives.c index a5cdb4f1ef..1b29dc65b7 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -162,6 +162,7 @@ void *primitives[] = { primitive_fopen, primitive_fgetc, primitive_fread, + primitive_fputc, primitive_fwrite, primitive_fflush, primitive_fclose, From 62568770a9fad32a8b911f2ec19de0979f640b0b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 16:07:30 -0600 Subject: [PATCH 135/140] Fix --- core/io/binary/binary.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 core/io/binary/binary.factor diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor old mode 100644 new mode 100755 index c4d3abefce..9f6231b643 --- a/core/io/binary/binary.factor +++ b/core/io/binary/binary.factor @@ -10,7 +10,7 @@ IN: io.binary : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline -: >le ( x n -- str ) [ nth-byte ] with "" map-as ; +: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ; : >be ( x n -- str ) >le dup reverse-here ; : d>w/w ( d -- w1 w2 ) From e6d4afa1c1c7a71845b3f1516fe9cc74f21166cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 17:03:44 -0600 Subject: [PATCH 136/140] remove unique from core/ docs --- core/io/files/files-docs.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index f68d5eafbd..9609cd123b 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -89,7 +89,6 @@ ARTICLE: "io.files" "Basic file operations" { $subsection "fs-meta" } { $subsection "directories" } { $subsection "delete-move-copy" } -{ $subsection "unique" } { $see-also "os" } ; ABOUT: "io.files" From 488579e1c0f6493977b605e78635afbe559d0bde Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 17:09:48 -0600 Subject: [PATCH 137/140] add some more find words --- extra/html/parser/analyzer/analyzer.factor | 74 ++++++++++++++++++---- 1 file changed, 60 insertions(+), 14 deletions(-) diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index fca15d9b07..511730efb4 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,8 +1,50 @@ USING: assocs html.parser kernel math sequences strings ascii arrays shuffle unicode.case namespaces splitting -http.server.responders ; +http.server.responders sequences.lib ; IN: html.parser.analyzer +: multi-find* ( n seq quots -- i elt ) + ; + +: multi-find ( seq quots -- i elt ) + 0 -rot ; + +: (find-relative) + [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; + +: find-relative ( seq quot n -- i elt ) + >r over [ find drop ] dip r> swap pick + (find-relative) ; + +: (find-all) ( n seq quot -- ) + 2dup >r >r find* [ + dupd 2array , 1+ r> r> (find-all) + ] [ + r> r> 3drop + ] if* ; + +: find-all ( seq quot -- alist ) + [ 0 -rot (find-all) ] { } make ; + +: (find-nth) ( offset seq quot n count -- obj ) + >r >r [ find* ] 2keep 4 npick [ + r> r> 1+ 2dup <= [ + 4drop + ] [ + >r >r >r >r drop 1+ r> r> r> r> + (find-nth) + ] if + ] [ + 2drop r> r> 2drop + ] if ; + +: find-nth ( seq quot n -- i elt ) + 0 -roll 0 (find-nth) ; + +: find-nth-relative ( seq quot n offest -- i elt ) + >r [ find-nth ] 3keep 2drop nip r> swap pick + (find-relative) ; + : remove-blank-text ( vector -- vector' ) [ dup tag-name text = [ @@ -52,29 +94,33 @@ IN: html.parser.analyzer >r >lower r> [ tag-attributes at over = ] with find rot drop ; -: find-between ( i/f tag/f vector -- vector ) +: find-between* ( i/f tag/f vector -- vector ) pick integer? [ - rot 1+ tail-slice + rot tail-slice >r tag-name r> - [ find-matching-close drop ] keep swap head + [ find-matching-close drop 1+ ] keep swap head ] [ 3drop V{ } clone ] if ; + +: find-between ( i/f tag/f vector -- vector ) + find-between* dup length 3 >= [ + [ 1 tail-slice 1 head-slice* ] keep like + ] when ; + +: find-between-first ( string vector -- vector' ) + [ find-first-name ] keep find-between ; + +: tag-link ( tag -- link/f ) + tag-attributes [ "href" swap at ] [ f ] if* ; : find-links ( vector -- vector ) [ tag-name "a" = ] subset - [ tag-attributes "href" swap at ] map - [ ] subset ; + [ tag-link ] subset ; -: (find-all) ( n seq quot -- ) - 2dup >r >r find* [ - dupd 2array , 1+ r> r> (find-all) - ] [ - r> r> 3drop - ] if* ; -: find-all ( seq quot -- alist ) - [ 0 -rot (find-all) ] { } make ; +: find-by-text ( seq quot -- tag ) + [ dup tag-name text = ] swap compose find drop ; : find-opening-tags-by-name ( name seq -- seq ) [ [ tag-name = ] keep tag-closing? not and ] with find-all ; From 635749a50b87da69393346d740318bb6b04fc648 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 17:10:17 -0600 Subject: [PATCH 138/140] move nmake to namespaces.lib --- extra/db/types/types.factor | 27 --------------------------- 1 file changed, 27 deletions(-) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index c2aa825db8..023c72cd2d 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -153,33 +153,6 @@ TUPLE: no-sql-modifier ; [ lookup-modifier ] map " " join dup empty? [ " " swap append ] unless ; -SYMBOL: building-seq -: get-building-seq ( n -- seq ) - building-seq get nth ; - -: n, get-building-seq push ; -: n% get-building-seq push-all ; -: n# >r number>string r> n% ; - -: 0, 0 n, ; -: 0% 0 n% ; -: 0# 0 n# ; -: 1, 1 n, ; -: 1% 1 n% ; -: 1# 1 n# ; -: 2, 2 n, ; -: 2% 2 n% ; -: 2# 2 n# ; - -: nmake ( quot exemplars -- seqs ) - dup length dup zero? [ 1+ ] when - [ - [ - [ drop 1024 swap new-resizable ] 2map - [ building-seq set call ] keep - ] 2keep >r [ like ] 2map r> firstn - ] with-scope ; - HOOK: bind% db ( spec -- ) TUPLE: no-slot-named ; From 61c77e616f6100933774062cf4e1aa5d9f51f439 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 17:10:56 -0600 Subject: [PATCH 139/140] rename nths to switches add ?nth* and nths to sequences.lib --- extra/sequences/lib/lib.factor | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index c02932a020..050de0ae1c 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -140,13 +140,13 @@ PRIVATE> : strings ( alphabet length -- seqs ) >r dup length r> number-strings map-alphabet ; -: nths ( nths seq -- subseq ) - ! nths is a sequence of ones and zeroes +: switches ( seq1 seq -- subseq ) + ! seq1 is a sequence of ones and zeroes >r [ length ] keep [ nth 1 = ] curry subset r> [ nth ] curry { } map-as ; : power-set ( seq -- subsets ) - 2 over length exact-number-strings swap [ nths ] curry map ; + 2 over length exact-number-strings swap [ switches ] curry map ; : push-either ( elt quot accum1 accum2 -- ) >r >r keep swap r> r> ? push ; inline @@ -214,3 +214,9 @@ PRIVATE> : attempt-each ( seq quot -- result ) (each) iterate-prep (attempt-each-integer) ; inline + +: ?nth* ( n seq -- elt/f ? ) + 2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable + +: nths ( indices seq -- seq' ) + [ swap nth ] with map ; From 68f1b9432f67d49c7c8127adbac8d56ffb78126d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 6 Mar 2008 17:55:18 -0600 Subject: [PATCH 140/140] load file-info on windows by default fix the file type add commented out file times --- extra/io/windows/ce/ce.factor | 1 + extra/io/windows/files/files.factor | 20 +++++++++++--------- extra/io/windows/nt/nt.factor | 1 + 3 files changed, 13 insertions(+), 9 deletions(-) diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor index a5e0cb6b4a..878f5899f6 100755 --- a/extra/io/windows/ce/ce.factor +++ b/extra/io/windows/ce/ce.factor @@ -3,4 +3,5 @@ io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher namespaces io.windows.mmap ; IN: io.windows.ce +USE: io.windows.files T{ windows-ce-io } set-io-backend diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index fdd574d00e..d107f80723 100644 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -50,17 +50,20 @@ SYMBOL: +encrypted+ { +encrypted+ FILE_ATTRIBUTE_ENCRYPTED } } get-flags ; +: win32-file-type ( n -- symbol ) + FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; + : WIN32_FIND_DATA>file-info { - [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ] + [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ] [ [ WIN32_FIND_DATA-nFileSizeLow ] [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit ] [ WIN32_FIND_DATA-dwFileAttributes ] - [ - WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp - ] + ! [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp ] + [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ] + ! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ] } cleave \ file-info construct-boa ; @@ -73,16 +76,15 @@ SYMBOL: +encrypted+ : BY_HANDLE_FILE_INFORMATION>file-info { - [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type ] [ [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit ] [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ] - [ - BY_HANDLE_FILE_INFORMATION-ftLastWriteTime - FILETIME>timestamp - ] + ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ] + [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ] + ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ] } cleave \ file-info construct-boa ; diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index be57a398a2..9bc587e00e 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -9,6 +9,7 @@ USE: io.windows.nt.launcher USE: io.windows.nt.monitors USE: io.windows.nt.sockets USE: io.windows.mmap +USE: io.windows.files USE: io.backend T{ windows-nt-io } set-io-backend