Merge branch 'master' of git://factorcode.org/git/factor

Conflicts:

	extra/combinators/lib/lib.factor
	extra/io/windows/files/files.factor
	extra/opengl/demo-support/demo-support.factor
	extra/opengl/shaders/shaders.factor
db4
Joe Groff 2008-03-15 20:39:43 -07:00
commit 6f89d7921b
160 changed files with 2454 additions and 1429 deletions

View File

@ -46,10 +46,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
EXE_OBJS = $(PLAF_EXE_OBJS)
default: misc/wordsize
make `./misc/target`
$(MAKE) `./misc/target`
help:
@echo "Run 'make' with one of the following parameters:"
@echo "Run '$(MAKE)' with one of the following parameters:"
@echo ""
@echo "freebsd-x86-32"
@echo "freebsd-x86-64"

View File

@ -98,26 +98,36 @@ H{ } clone class<map set
H{ } clone update-map set
! Builtin classes
: builtin-predicate ( class predicate -- )
: builtin-predicate-quot ( class -- quot )
[
over "type" word-prop dup
"type" word-prop dup
\ tag-mask get < \ tag \ type ? , , \ eq? ,
] [ ] make define-predicate* ;
] [ ] make ;
: register-builtin ( class -- )
dup "type" word-prop builtins get set-nth ;
: define-builtin-predicate ( class -- )
dup
dup builtin-predicate-quot define-predicate
predicate-word make-inline ;
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
: define-builtin ( symbol predicate slotspec -- )
>r dup make-inline >r
dup dup lookup-type-number "type" set-word-prop
: register-builtin ( class -- )
dup
dup lookup-type-number "type" set-word-prop
dup "type" word-prop builtins get set-nth ;
: define-builtin-slots ( symbol slotspec -- )
dupd 1 simple-slots
2dup "slots" set-word-prop
define-slots ;
: define-builtin ( symbol slotspec -- )
>r
dup register-builtin
dup f f builtin-class define-class
dup r> builtin-predicate
dup r> 1 simple-slots 2dup "slots" set-word-prop
dupd define-slots
register-builtin ;
dup define-builtin-predicate
r> define-builtin-slots ;
H{ } clone typemap set
num-types get f <array> builtins set
@ -128,17 +138,15 @@ num-types get f <array> builtins set
"null" "kernel" create drop
"fixnum" "math" create "fixnum?" "math" create { } define-builtin
"fixnum" "math" create { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
"bignum" "math" create "bignum?" "math" create { } define-builtin
"bignum" "math" create { } define-builtin
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
"tuple" "kernel" create "tuple?" "kernel" create
{ } define-builtin
"tuple" "kernel" create { } define-builtin
"ratio" "math" create "ratio?" "math" create
{
"ratio" "math" create {
{
{ "integer" "math" }
"numerator"
@ -153,11 +161,10 @@ num-types get f <array> builtins set
}
} define-builtin
"float" "math" create "float?" "math" create { } define-builtin
"float" "math" create { } define-builtin
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
"complex" "math" create "complex?" "math" create
{
"complex" "math" create {
{
{ "real" "math" }
"real-part"
@ -172,14 +179,13 @@ num-types get f <array> builtins set
}
} define-builtin
"f" "syntax" lookup "not" "kernel" create
{ } define-builtin
"f" "syntax" lookup { } define-builtin
"array" "arrays" create "array?" "arrays" create
{ } define-builtin
! do not word...
"wrapper" "kernel" create "wrapper?" "kernel" create
{
"array" "arrays" create { } define-builtin
"wrapper" "kernel" create {
{
{ "object" "kernel" }
"wrapped"
@ -188,8 +194,7 @@ num-types get f <array> builtins set
}
} define-builtin
"string" "strings" create "string?" "strings" create
{
"string" "strings" create {
{
{ "array-capacity" "sequences.private" }
"length"
@ -203,8 +208,7 @@ num-types get f <array> builtins set
}
} define-builtin
"quotation" "quotations" create "quotation?" "quotations" create
{
"quotation" "quotations" create {
{
{ "object" "kernel" }
"array"
@ -219,8 +223,7 @@ num-types get f <array> builtins set
}
} define-builtin
"dll" "alien" create "dll?" "alien" create
{
"dll" "alien" create {
{
{ "byte-array" "byte-arrays" }
"path"
@ -230,8 +233,7 @@ num-types get f <array> builtins set
}
define-builtin
"alien" "alien" create "alien?" "alien" create
{
"alien" "alien" create {
{
{ "c-ptr" "alien" }
"alien"
@ -246,8 +248,7 @@ define-builtin
}
define-builtin
"word" "words" create "word?" "words" create
{
"word" "words" create {
f
{
{ "object" "kernel" }
@ -287,26 +288,25 @@ define-builtin
}
} define-builtin
"byte-array" "byte-arrays" create
"byte-array?" "byte-arrays" create
{ } define-builtin
"byte-array" "byte-arrays" create { } define-builtin
"bit-array" "bit-arrays" create
"bit-array?" "bit-arrays" create
{ } define-builtin
"bit-array" "bit-arrays" create { } define-builtin
"float-array" "float-arrays" create
"float-array?" "float-arrays" create
{ } define-builtin
"float-array" "float-arrays" create { } define-builtin
"callstack" "kernel" create "callstack?" "kernel" create
{ } define-builtin
"callstack" "kernel" create { } define-builtin
! Define general-t type, which is any object that is not f.
"general-t" "kernel" create
"f" "syntax" lookup builtins get remove [ ] subset f union-class
define-class
"f" "syntax" create [ not ] "predicate" set-word-prop
"f?" "syntax" create "syntax" vocab-words delete-at
"general-t" "kernel" create [ ] "predicate" set-word-prop
"general-t?" "kernel" create "syntax" vocab-words delete-at
! Catch-all class for providing a default method.
"object" "kernel" create [ drop t ] "predicate" set-word-prop
"object" "kernel" create

View File

@ -1,7 +1,7 @@
USING: help.markup help.syntax kernel kernel.private
namespaces sequences words arrays layouts help effects math
layouts classes.private classes.union classes.mixin
classes.predicate ;
classes.predicate quotations ;
IN: classes
ARTICLE: "builtin-classes" "Built-in classes"
@ -114,24 +114,9 @@ HELP: predicate-word
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
{ $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;
HELP: define-predicate*
{ $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } }
{ $description
"Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:"
{ $list
{ "the class word's " { $snippet "\"predicate\"" } " property is set to a quotation that calls the predicate" }
{ "the predicate word's " { $snippet "\"predicating\"" } " property is set to the class word" }
{ "the predicate word's " { $snippet "\"declared-effect\"" } " word property is set to a descriptive " { $link effect } }
}
"These properties are used by method dispatch and the help system."
}
$low-level-note ;
HELP: define-predicate
{ $values { "class" class } { "quot" "a quotation" } }
{ $description
"Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "."
}
{ $values { "class" class } { "quot" quotation } }
{ $description "Defines a predicate word for a class." }
$low-level-note ;
HELP: superclass

View File

@ -178,39 +178,39 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ;
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
DEFER: mixin-forget-test-g
[ "mixin-forget-test" forget-source ] with-compilation-unit
[ ] [
{
"USING: sequences ;"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } ] [ { } mixin-forget-test-g ] unit-test
[ H{ } mixin-forget-test-g ] must-fail
[ ] [
{
"USING: hashtables ;"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } mixin-forget-test-g ] must-fail
[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
2 [
[ "mixin-forget-test" forget-source ] with-compilation-unit
[ ] [
{
"USING: sequences ;"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } ] [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
[ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
[ ] [
{
"USING: hashtables ;"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
[ H{ } ] [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
] times
! Method flattening interfered with mixin update
MIXIN: flat-mx-1

View File

@ -31,17 +31,9 @@ PREDICATE: class tuple-class
PREDICATE: word predicate "predicating" word-prop >boolean ;
: define-predicate* ( class predicate quot -- )
over [
dupd predicate-effect define-declared
2dup 1quotation "predicate" set-word-prop
swap "predicating" set-word-prop
] [ 3drop ] if ;
: define-predicate ( class quot -- )
over "forgotten" word-prop [ 2drop ] [
>r dup predicate-word r> define-predicate*
] if ;
>r "predicate" word-prop first
r> predicate-effect define-declared ;
: superclass ( class -- super )
"superclass" word-prop ;
@ -257,6 +249,8 @@ PRIVATE>
over reset-class
over deferred? [ over define-symbol ] when
>r dup word-props r> union over set-word-props
dup predicate-word 2dup 1quotation "predicate" set-word-prop
over "predicating" set-word-prop
t "class" set-word-prop ;
GENERIC: update-predicate ( class -- )

View File

@ -9,7 +9,7 @@ ARTICLE: "compiler-errors" "Compiler warnings and errors"
{ $subsection :errors }
{ $subsection :warnings }
{ $subsection :linkage }
"Words such as " { $link require } " and " { $link refresh-all } " use a combinator which counts errors and prints a report at the end:"
"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:"
{ $link with-compiler-errors } ;
HELP: compiler-errors

View File

@ -29,7 +29,9 @@ $nl
{ $subsection ignore-errors }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
{ $subsection "errors-post-mortem" } ;
{ $subsection "errors-post-mortem" }
"When Factor encouters a critical error, it calls the following word:"
{ $subsection die } ;
ARTICLE: "continuations.private" "Continuation implementation details"
"A continuation is simply a tuple holding the contents of the five stacks:"

View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io io.styles strings
io.backend io.files.private quotations ;
io.backend io.files.private quotations ;
IN: io.files
ARTICLE: "file-streams" "Reading and writing files"
@ -43,13 +43,19 @@ ARTICLE: "directories" "Directories"
{ $subsection make-directory }
{ $subsection make-directories } ;
! ARTICLE: "file-types" "File Types"
! { $table { +directory+ "" } }
! ;
ARTICLE: "fs-meta" "File meta-data"
{ $subsection file-info }
{ $subsection link-info }
{ $subsection exists? }
{ $subsection directory? }
{ $subsection file-length }
{ $subsection file-modified }
! { $subsection file-modified }
{ $subsection stat } ;
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
@ -119,11 +125,26 @@ HELP: file-name
! need a $class-description file-info
HELP: file-info
{ $values { "path" "a pathname string" }
{ "info" "a file-info tuple" } }
{ "info" file-info } }
{ $description "Queries the file system for meta data. "
"If path refers to a symbolic link, it is followed."
"If the file does not exist, an exception is thrown." } ;
"If the file does not exist, an exception is thrown." }
{ $class-description "File meta data" }
{ $table
{ "type" { "One of the following:"
{ $list { $link +regular-file+ }
{ $link +directory+ }
{ $link +symbolic-link+ } } } }
{ "size" "Size of the file in bytes" }
{ "modified" "Last modification timestamp." } }
;
! need a see also to link-info
HELP: link-info
@ -135,6 +156,8 @@ HELP: link-info
"If the file does not exist, an exception is thrown." } ;
! need a see also to file-info
{ file-info link-info } related-words
HELP: <file-reader>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
{ "stream" "an input stream" } }
@ -199,7 +222,7 @@ HELP: stat ( path -- directory? permissions length modified )
"Queries the file system for file meta data. If the file does not exist, outputs " { $link f } " for all four values."
} ;
{ stat exists? directory? file-length file-modified } related-words
{ stat exists? directory? } related-words
HELP: path+
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
@ -227,13 +250,9 @@ HELP: directory*
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." }
{ $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ;
HELP: file-length
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
{ $description "Outputs the length of the file in bytes, or " { $link f } " if it does not exist." } ;
HELP: file-modified
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
{ $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
! HELP: file-modified
! { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
! { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }

View File

@ -1,6 +1,10 @@
IN: io.files.tests
USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
[ t ] [ "blahblah" temp-file directory? ] unit-test
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
@ -123,3 +127,7 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
[ ] [ "append-test" ascii <file-appender> dispose ] unit-test

View File

@ -86,15 +86,17 @@ SYMBOL: +unknown+
: stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ;
: file-length ( path -- n ) stat drop 2nip ;
! : file-length ( path -- n ) stat drop 2nip ;
: file-modified ( path -- n ) stat >r 3drop r> ;
: file-permissions ( path -- perm ) stat 2drop nip ;
! : file-permissions ( path -- perm ) stat 2drop nip ;
: exists? ( path -- ? ) file-modified >boolean ;
: directory? ( path -- ? ) stat 3drop ;
! : directory? ( path -- ? ) stat 3drop ;
: directory? ( path -- ? ) file-info file-info-type +directory+ = ;
! Current working directory
HOOK: cd io-backend ( path -- )
@ -220,7 +222,10 @@ M: pathname <=> [ pathname-string ] compare ;
>r <file-reader> r> with-stream ; inline
: file-contents ( path encoding -- str )
dupd [ file-length read ] with-file-reader ;
dupd [ file-info file-info-size read ] with-file-reader ;
! : file-contents ( path encoding -- str )
! dupd [ file-length read ] with-file-reader ;
: with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline

View File

@ -429,7 +429,14 @@ $nl
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ;
HELP: die
{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." } ;
{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." }
{ $notes
"The term FEP originates from the Lisp machines of old. According to the Jargon File,"
$nl
{ $strong "fepped out" } " /fept owt/ " { $emphasis "adj." } " The Symbolics 3600 LISP Machine has a Front-End Processor called a `FEP' (compare sense 2 of box). When the main processor gets wedged, the FEP takes control of the keyboard and screen. Such a machine is said to have `fepped out' or `dropped into the fep'."
$nl
{ $url "http://www.jargon.net/jargonfile/f/feppedout.html" }
} ;
HELP: (clone) ( obj -- newobj )
{ $values { "obj" object } { "newobj" "a shallow copy" } }

View File

@ -430,3 +430,20 @@ IN: parser.tests
[ "resource:core/parser/test/assert-depth.factor" run-file ]
[ relative-overflow-stack { 1 2 3 } sequence= ]
must-fail-with
2 [
[ ] [
"IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s"
<string-reader> "d-f-s-test" parse-stream drop
] unit-test
[ ] [
"IN: parser.tests DEFER: d-f-s d-f-s FORGET: d-f-s SYMBOL: d-f-s d-f-s"
<string-reader> "d-f-s-test" parse-stream drop
] unit-test
[ ] [
"IN: parser.tests DEFER: d-f-s d-f-s SYMBOL: d-f-s d-f-s"
<string-reader> "d-f-s-test" parse-stream drop
] unit-test
] times

View File

@ -416,6 +416,7 @@ SYMBOL: interactive-vocabs
"tools.test"
"tools.threads"
"tools.time"
"tools.vocabs"
"vocabs"
"vocabs.loader"
"words"
@ -483,7 +484,6 @@ SYMBOL: interactive-vocabs
: finish-parsing ( lines quot -- )
file get
[ record-form ] keep
[ record-modified ] keep
[ record-definitions ] keep
record-checksum ;

View File

@ -3,16 +3,13 @@ definitions quotations compiler.units ;
IN: source-files
ARTICLE: "source-files" "Source files"
"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement features such as " { $link refresh-all } "."
"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "tools.vocabs" } "."
$nl
"The source file database:"
{ $subsection source-files }
"The class of source files:"
{ $subsection source-file }
"Testing if a source file has been changed on disk:"
{ $subsection source-modified? }
"Words intended for the parser:"
{ $subsection record-modified }
{ $subsection record-checksum }
{ $subsection record-form }
{ $subsection xref-source }
@ -34,22 +31,12 @@ HELP: source-file
{ $class-description "Instances retain information about loaded source files, and have the following slots:"
{ $list
{ { $link source-file-path } " - a pathname string." }
{ { $link source-file-modified } " - the result of " { $link file-modified } " at the time the source file was most recently loaded." }
{ { $link source-file-checksum } " - the CRC32 checksum of the source file's contents at the time it was most recently loaded." }
{ { $link source-file-uses } " - an assoc whose keys are words referenced from this source file's top level form." }
{ { $link source-file-definitions } " - a pair of assocs, containing definitions and classes defined in this source file, respectively" }
}
} ;
HELP: source-modified?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's modification time and CRC32 checksum of the file's contents against previously-recorded values." } ;
HELP: record-modified
{ $values { "source-file" source-file } }
{ $description "Records the modification time of the source file." }
$low-level-note ;
HELP: record-checksum
{ $values { "source-file" source-file } { "lines" "a sequence of strings" } }
{ $description "Records the CRC32 checksm of the source file's contents." }
@ -75,7 +62,7 @@ HELP: record-form
$low-level-note ;
HELP: reset-checksums
{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link refresh } "." } ;
{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ;
HELP: forget-source
{ $values { "path" "a pathname string" } }

View File

@ -1,44 +1,25 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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 vocabs
hashtables graphs compiler.units io.encodings.utf8 ;
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 vocabs hashtables
graphs compiler.units io.encodings.utf8 ;
IN: source-files
SYMBOL: source-files
TUPLE: source-file
path
modified checksum
checksum
uses definitions ;
: (source-modified?) ( path modified checksum -- ? )
pick file-modified rot [ 0 or ] 2apply >
[ swap utf8 file-lines lines-crc32 = not ] [ 2drop f ] if ;
: source-modified? ( path -- ? )
dup source-files get at [
dup source-file-path ?resource-path
over source-file-modified
rot source-file-checksum
(source-modified?)
] [
resource-exists?
] ?if ;
: record-modified ( source-file -- )
dup source-file-path ?resource-path file-modified
swap set-source-file-modified ;
: record-checksum ( lines source-file -- )
swap lines-crc32 swap set-source-file-checksum ;
>r lines-crc32 r> set-source-file-checksum ;
: (xref-source) ( source-file -- pathname uses )
dup source-file-path <pathname> swap source-file-uses
[ crossref? ] subset ;
dup source-file-path <pathname>
swap source-file-uses [ crossref? ] subset ;
: xref-source ( source-file -- )
(xref-source) crossref get add-vertex ;
@ -67,9 +48,7 @@ uses definitions ;
: reset-checksums ( -- )
source-files get [
swap ?resource-path dup exists?
[
over record-modified
swap ?resource-path dup exists? [
utf8 file-lines swap record-checksum
] [ 2drop ] if
] assoc-each ;

View File

@ -23,9 +23,6 @@ $nl
"Application vocabularies can define a main entry point, giving the user a convenient way to run the application:"
{ $subsection POSTPONE: MAIN: }
{ $subsection run }
"Reloading source files changed on disk:"
{ $subsection refresh }
{ $subsection refresh-all }
{ $see-also "vocabularies" "parser-files" "source-files" } ;
ABOUT: "vocabs.loader"
@ -42,20 +39,12 @@ HELP: vocab-main
HELP: vocab-roots
{ $var-description "A sequence of pathname strings to search for vocabularies." } ;
HELP: vocab-tests
{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
HELP: find-vocab-root
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
{ $description "Searches for a vocabulary in the vocabulary roots." } ;
{ vocab-root find-vocab-root } related-words
HELP: vocab-files
{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }
{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;
HELP: no-vocab
{ $values { "name" "a vocabulary name" } }
{ $description "Throws a " { $link no-vocab } "." }
@ -80,7 +69,7 @@ HELP: reload
HELP: require
{ $values { "vocab" "a vocabulary specifier" } }
{ $description "Loads a vocabulary if it has not already been loaded." }
{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files, use " { $link refresh } " or " { $link refresh-all } "." } ;
{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "tools.vocabs" } "." } ;
HELP: run
{ $values { "vocab" "a vocabulary specifier" } }
@ -93,12 +82,3 @@ HELP: vocab-source-path
HELP: vocab-docs-path
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } }
{ $description "Outputs a pathname where the documentation for " { $snippet "vocab" } " might be found. Outputs " { $link f } " if the vocabulary does not have a directory on disk." } ;
HELP: refresh
{ $values { "prefix" string } }
{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
HELP: refresh-all
{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;
{ refresh refresh-all } related-words

View File

@ -3,7 +3,7 @@ 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
debugger compiler.units ;
debugger compiler.units tools.vocabs ;
! This vocab should not exist, but just in case...
[ ] [

View File

@ -48,27 +48,6 @@ M: string vocab-root
M: vocab-link vocab-root
vocab-link-root ;
: vocab-tests ( vocab -- tests )
dup vocab-root [
[
f >vocab-link dup
dup "-tests.factor" vocab-dir+ vocab-path+
dup resource-exists? [ , ] [ drop ] if
dup vocab-dir "tests" path+ vocab-path+ dup
?resource-path directory keys [ ".factor" tail? ] subset
[ path+ , ] with each
] { } make
] [ drop f ] if ;
: vocab-files ( vocab -- seq )
f >vocab-link [
dup vocab-source-path [ , ] when*
dup vocab-docs-path [ , ] when*
vocab-tests %
] { } make ;
SYMBOL: load-help?
: source-was-loaded t swap set-vocab-source-loaded? ;
@ -119,68 +98,7 @@ SYMBOL: load-help?
"To define one, refer to \\ MAIN: help" print
] ?if ;
: modified ( seq quot -- seq )
[ dup ] swap compose { } map>assoc
[ nip ] assoc-subset
[ nip source-modified? ] assoc-subset keys ; inline
: modified-sources ( vocabs -- seq )
[ vocab-source-path ] modified ;
: modified-docs ( vocabs -- seq )
[ vocab-docs-path ] modified ;
: update-roots ( vocabs -- )
[ dup find-vocab-root swap vocab set-vocab-root ] each ;
: to-refresh ( prefix -- modified-sources modified-docs )
child-vocabs
dup update-roots
dup modified-sources swap modified-docs ;
: vocab-heading. ( vocab -- )
nl
"==== " write
dup vocab-name swap vocab write-object ":" print
nl ;
: load-error. ( triple -- )
dup first vocab-heading.
dup second print-error
drop ;
: load-failures. ( failures -- )
[ load-error. nl ] each ;
SYMBOL: blacklist
SYMBOL: failures
: require-all ( vocabs -- failures )
[
V{ } clone blacklist set
V{ } clone failures set
[
[ require ]
[ swap vocab-name failures get set-at ]
recover
] each
failures get
] with-compiler-errors ;
: do-refresh ( modified-sources modified-docs -- )
2dup
[ f swap set-vocab-docs-loaded? ] each
[ f swap set-vocab-source-loaded? ] each
append prune require-all load-failures. ;
: refresh ( prefix -- ) to-refresh do-refresh ;
SYMBOL: sources-changed?
[ t sources-changed? set-global ] "vocabs.loader" add-init-hook
: refresh-all ( -- )
"" refresh f sources-changed? set-global ;
GENERIC: (load-vocab) ( name -- vocab )

View File

@ -1,4 +1,5 @@
USING: assocs kernel vectors sequences namespaces ;
USING: arrays assocs kernel vectors sequences namespaces
random math.parser ;
IN: assocs.lib
: >set ( seq -- hash )
@ -35,3 +36,13 @@ IN: assocs.lib
[ with each ] curry assoc-each ; inline
: insert ( value variable -- ) namespace insert-at ;
: 2seq>assoc ( keys values exemplar -- assoc )
>r 2array flip r> assoc-like ;
: generate-key ( assoc -- str )
>r random-256 >hex r>
2dup key? [ nip generate-key ] [ drop ] if ;
: set-at-unique ( value assoc -- key )
dup generate-key [ swap set-at ] keep ;

View File

@ -1,28 +1,28 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time tools.browser
USING: kernel vocabs vocabs.loader tools.time tools.vocabs
arrays assocs io.styles io help.markup prettyprint sequences
continuations debugger ;
continuations debugger combinators.cleave ;
IN: benchmark
: run-benchmark ( vocab -- result )
[ dup require [ run ] benchmark ] [ error. drop f f ] recover 2array ;
[ [ require ] [ [ run ] benchmark nip ] bi ] curry
[ error. f ] recover ;
: run-benchmarks ( -- assoc )
"benchmark" all-child-vocabs values concat [ vocab-name ] map
"benchmark" all-child-vocabs-seq
[ dup run-benchmark ] { } map>assoc ;
: benchmarks. ( assoc -- )
standard-table-style [
[
[ "Benchmark" write ] with-cell
[ "Run time (ms)" write ] with-cell
[ "GC time (ms)" write ] with-cell
[ "Time (ms)" write ] with-cell
] with-row
[
[
swap [ dup ($vocab-link) ] with-cell
first2 pprint-cell pprint-cell
[ [ 1array $vocab-link ] with-cell ]
[ pprint-cell ] bi*
] with-row
] assoc-each
] tabular-output ;

4
extra/benchmark/fasta/fasta.factor Normal file → Executable file
View File

@ -51,7 +51,7 @@ HINTS: random fixnum ;
dup keys >byte-array
swap values >float-array unclip [ + ] accumulate swap add ;
:: select-random ( seed chars floats -- elt )
:: select-random ( seed chars floats -- seed elt )
floats seed random -rot
[ >= ] curry find drop
chars nth-unsafe ; inline
@ -71,7 +71,7 @@ HINTS: random fixnum ;
write-description
[ make-random-fasta ] 2curry split-lines ; inline
:: make-repeat-fasta ( k len alu -- )
:: make-repeat-fasta ( k len alu -- k' )
[let | kn [ alu length ] |
len [ k + kn mod alu nth-unsafe ] B{ } map-as print
k len +

View File

@ -11,5 +11,7 @@ USING: vocabs.loader sequences ;
"tools.test"
"tools.time"
"tools.threads"
"tools.vocabs"
"tools.vocabs.browser"
"editors"
} [ require ] each

View File

@ -21,7 +21,7 @@ IN: builder.benchmark
[ benchmark-difference ] with map ;
: benchmark-deltas ( -- table )
"../../benchmarks" "../benchmarks" [ eval-file ] 2apply
"../benchmarks" "benchmarks" [ eval-file ] 2apply
compare-tables
sort-values ;

6
extra/builder/builder.factor Executable file → Normal file
View File

@ -4,6 +4,7 @@ USING: kernel namespaces sequences splitting system combinators continuations
bootstrap.image benchmark vars bake smtp builder.util accessors
io.encodings.utf8
calendar
tools.test
builder.common
builder.benchmark
builder.release ;
@ -131,7 +132,12 @@ SYMBOL: build-status
"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
"test-failures" cat
! "test-failures" eval-file test-failures.
"help-lint results:" print "help-lint" cat
"Benchmarks: " print "benchmarks" eval-file benchmarks.

View File

@ -4,7 +4,7 @@ USING: kernel namespaces sequences assocs builder continuations
io
io.files
prettyprint
tools.browser
tools.vocabs
tools.test
io.encodings.utf8
combinators.cleave
@ -21,13 +21,19 @@ IN: builder.test
: do-tests ( -- )
run-all-tests
"../test-all-vocabs" utf8
[
[ keys . ]
[ test-failures. ]
bi
]
with-file-writer ;
[ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ]
[ "../test-failures" utf8 [ test-failures. ] with-file-writer ]
bi ;
! : do-tests ( -- )
! run-all-tests
! "../test-all-vocabs" utf8
! [
! [ keys . ]
! [ test-failures. ]
! bi
! ]
! with-file-writer ;
: do-help-lint ( -- )
"" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;

View File

@ -1,12 +1,14 @@
USING: tools.deploy.config ;
V{
H{
{ deploy-math? t }
{ deploy-reflection 1 }
{ deploy-name "Bunny" }
{ deploy-threads? t }
{ deploy-word-props? f }
{ "stop-after-last-window?" t }
{ deploy-ui? t }
{ deploy-io 3 }
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
{ deploy-name "Bunny" }
}

2
extra/bunny/outlined/outlined.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
USING: arrays bunny.model bunny.cel-shaded
combinators.cleave continuations kernel math multiline
opengl opengl.shaders opengl.framebuffers opengl.gl
opengl.capabilities sequences ui.gadgets ;
opengl.capabilities sequences ui.gadgets combinators.cleave ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source

View File

@ -6,7 +6,7 @@
! http://cairographics.org/samples/text/
USING: cairo math math.constants byte-arrays kernel ui ui.render
USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render
ui.gadgets opengl.gl ;
IN: cairo-demo
@ -22,14 +22,16 @@ IN: cairo-demo
TUPLE: cairo-gadget image-array cairo-t ;
M: cairo-gadget draw-gadget* ( gadget -- )
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
>r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
cairo-gadget-image-array glDrawPixels ;
! M: cairo-gadget draw-gadget* ( gadget -- )
! 0 0 glRasterPos2i
! 1.0 -1.0 glPixelZoom
! >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
! cairo-gadget-image-array glDrawPixels ;
: create-surface ( gadget -- cairo_surface_t )
make-image-array dup >r swap set-cairo-gadget-image-array r> convert-array-to-surface ;
make-image-array
[ swap set-cairo-gadget-image-array ] keep
convert-array-to-surface ;
: init-cairo ( gadget -- cairo_t )
create-surface cairo_create ;
@ -56,10 +58,10 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ;
cairo_fill ;
M: cairo-gadget graft* ( gadget -- )
dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
M: cairo-gadget ungraft* ( gadget -- )
cairo-gadget-cairo-t cairo_destroy ;
! M: cairo-gadget ungraft* ( gadget -- )
! cairo-gadget-cairo-t cairo_destroy ;
: <cairo-gadget> ( -- gadget )
cairo-gadget construct-gadget ;

View File

@ -1 +1,2 @@
Sampo Vuori
Doug Coleman

View File

@ -10,7 +10,7 @@
USING: alien alien.syntax combinators system ;
IN: cairo
IN: cairo.ffi
<< "cairo" {
{ [ win32? ] [ "cairo.dll" ] }

View File

@ -0,0 +1,40 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types cairo.ffi continuations destructors
kernel libc locals math combinators.cleave shuffle new-slots
accessors ;
IN: cairo.lib
TUPLE: cairo-t alien ;
C: <cairo-t> cairo-t
M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
: cairo-t-destroy-always ( alien -- ) <cairo-t> add-always-destructor ;
: cairo-t-destroy-later ( alien -- ) <cairo-t> add-error-destructor ;
TUPLE: cairo-surface-t alien ;
C: <cairo-surface-t> cairo-surface-t
M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
: cairo-surface-t-destroy-always ( alien -- )
<cairo-surface-t> add-always-destructor ;
: cairo-surface-t-destroy-later ( alien -- )
<cairo-surface-t> add-error-destructor ;
: cairo-surface>array ( surface -- cairo-t byte-array )
[
dup
[ drop CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_get_width ]
[ cairo_image_surface_get_height ] tri
over 4 *
2dup * [
malloc dup free-always [
5 -nrot cairo_image_surface_create_for_data
dup cairo-surface-t-destroy-always
cairo_create dup cairo-t-destroy-later
[ swap 0 0 cairo_set_source_surface ] keep
dup cairo_paint
] keep
] keep memory>byte-array
] with-destructors ;

View File

@ -0,0 +1,45 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators.cleave kernel new-slots
accessors math ui.gadgets ui.render opengl.gl byte-arrays
namespaces opengl cairo.ffi cairo.lib ;
IN: cairo.png
TUPLE: png surface width height cairo-t array ;
TUPLE: png-gadget png ;
: <png> ( path -- png )
cairo_image_surface_create_from_png
dup [ cairo_image_surface_get_width ]
[ cairo_image_surface_get_height ] [ ] tri
cairo-surface>array png construct-boa ;
: write-png ( png path -- )
>r png-surface r>
cairo_surface_write_to_png
zero? [ "write png failed" throw ] unless ;
: <png-gadget> ( path -- gadget )
png-gadget construct-gadget swap
<png> >>png ;
M: png-gadget pref-dim* ( gadget -- )
png>>
[ width>> ] [ height>> ] bi 2array ;
M: png-gadget draw-gadget* ( gadget -- )
origin get [
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
png>>
[ width>> ]
[ height>> GL_RGBA GL_UNSIGNED_BYTE ]
[ array>> ] tri
glDrawPixels
] with-translation ;
M: png-gadget graft* ( gadget -- )
drop ;
M: png-gadget ungraft* ( gadget -- )
png>> surface>> cairo_destroy ;

View File

@ -7,9 +7,18 @@ IN: combinators.cleave
ARTICLE: "cleave-combinators" "Cleave Combinators"
"Basic cleavers:"
{ $subsection bi }
{ $subsection tri }
"General cleave: "
{ $subsection cleave }
"Cleave combinators for quotations with arity 2:"
{ $subsection 2bi }
{ $subsection 2tri }
{ $notes
"From the Merriam-Webster Dictionary: "
$nl
@ -49,10 +58,21 @@ HELP: tri
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
HELP: cleave
{ $code "( obj { q1 q2 ... qN } -- q1(obj) q2(obj) ... qN(obj) )" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
{ bi tri cleave 2bi 2tri } related-words
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "spread-combinators" "Spread Combinators"
{ $subsection bi* }
{ $subsection tri* } ;
{ $subsection tri* }
{ $subsection spread } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -80,3 +100,9 @@ HELP: tri*
{ "p(x)" "p applied to x" }
{ "q(y)" "q applied to y" }
{ "r(z)" "r applied to z" } } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
HELP: spread
{ $code "( v1 v2 ... vN { q1 q2 ... qN } -- q1(v1) q2(v2) ... qN(vN) )" } ;

View File

@ -15,7 +15,10 @@ IN: combinators.cleave
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline
: 2bi ( x y p q -- p(x,y) q(x,y) ) >r 2keep r> call ; inline
: 2tri ( x y z p q r -- p(x,y,z) q(x,y,z) r(x,y,z) )
>r >r 2keep r> 2keep r> call ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -33,6 +36,18 @@ MACRO: cleave ( seq -- )
[ drop ]
append ;
MACRO: 2cleave ( seq -- )
dup
[ drop [ 2dup ] ] map concat
swap
dup
[ drop [ >r >r ] ] map concat
swap
[ [ r> r> ] append ] map concat
3append
[ 2drop ]
append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! The spread family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -55,3 +70,29 @@ MACRO: spread ( seq -- )
swap
[ [ r> ] swap append ] map concat
append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Cleave into array
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: words quotations fry arrays.lib ;
: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
: >quots ( seq -- seq ) [ >quot ] map ;
MACRO: <arr> ( seq -- )
[ >quots ] [ length ] bi
'[ , cleave , narray ] ;
MACRO: <2arr> ( seq -- )
[ >quots ] [ length ] bi
'[ , 2cleave , narray ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Spread into array
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: <arr*> ( seq -- )
[ >quots ] [ length ] bi
'[ , spread , narray ] ;

View File

@ -130,8 +130,15 @@ MACRO: parallel-call ( quots -- )
! map-call and friends
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (make-call-with) ( quots -- quot )
[ [ keep ] curry ] map concat [ drop ] append ;
MACRO: map-call-with ( quots -- )
[ [ [ keep ] curry ] map concat [ drop ] append ] keep length [ narray ] curry compose ;
[ (make-call-with) ] keep length [ narray ] curry compose ;
: (make-call-with2) ( quots -- quot )
[ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
[ 2drop ] append ;
MACRO: map-call-with2 ( quots -- )
[

5
extra/db/db-tests.factor Executable file
View File

@ -0,0 +1,5 @@
IN: db.tests
USING: tools.test db kernel ;
{ 1 0 } [ [ drop ] query-each ] must-infer-as
{ 1 1 } [ [ ] query-map ] must-infer-as

View File

@ -119,8 +119,8 @@ M: postgresql-db bind% ( spec -- )
: postgresql-make ( class quot -- )
>r sql-props r>
[ postgresql-counter off ] swap compose
{ "" { } { } } nmake <postgresql-statement> ;
[ postgresql-counter off call ] { "" { } { } } nmake
<postgresql-statement> ; inline
: create-table-sql ( class -- statement )
[

View File

@ -127,6 +127,6 @@ FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;

View File

@ -102,17 +102,10 @@ IN: db.sqlite.lib
[ no-sql-type ]
} case ;
: sqlite-finalize ( handle -- )
sqlite3_finalize sqlite-check-result ;
: sqlite-reset ( handle -- )
sqlite3_reset sqlite-check-result ;
: sqlite-#columns ( query -- int )
sqlite3_column_count ;
: sqlite-column ( handle index -- string )
sqlite3_column_text ;
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
: sqlite-column ( handle index -- string ) sqlite3_column_text ;
: sqlite-column-blob ( handle index -- byte-array/f )
[ sqlite3_column_bytes ] 2keep

View File

@ -17,16 +17,11 @@ M: sqlite-db db-open ( db -- )
dup sqlite-db-path sqlite-open <db>
swap set-delegate ;
M: sqlite-db db-close ( handle -- )
sqlite-close ;
M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
: with-sqlite ( path quot -- )
sqlite-db swap with-db ; inline
: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
TUPLE: sqlite-statement ;
TUPLE: sqlite-result-set has-more? ;
M: sqlite-db <simple-statement> ( str in out -- obj )
@ -51,8 +46,7 @@ M: sqlite-result-set dispose ( result-set -- )
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
: reset-statement ( statement -- )
statement-handle sqlite-reset ;
: reset-statement ( statement -- ) statement-handle sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
dup statement-bound? [ dup reset-statement ] when
@ -98,18 +92,13 @@ M: sqlite-statement query-results ( query -- result-set )
dup statement-handle sqlite-result-set <result-set>
dup advance-row ;
M: sqlite-db begin-transaction ( -- )
"BEGIN" sql-command ;
M: sqlite-db commit-transaction ( -- )
"COMMIT" sql-command ;
M: sqlite-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ;
M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
: sqlite-make ( class quot -- )
>r sql-props r>
{ "" { } { } } nmake <simple-statement> ;
{ "" { } { } } nmake <simple-statement> ; inline
M: sqlite-db create-sql-statement ( class -- statement )
[
@ -123,9 +112,7 @@ M: sqlite-db create-sql-statement ( class -- statement )
] sqlite-make ;
M: sqlite-db drop-sql-statement ( class -- statement )
[
"drop table " 0% 0% ";" 0% drop
] sqlite-make ;
[ "drop table " 0% 0% ";" 0% drop ] sqlite-make ;
M: sqlite-db <insert-native-statement> ( tuple -- statement )
[
@ -195,10 +182,9 @@ M: sqlite-db modifier-table ( -- hashtable )
{ +not-null+ "not null" }
} ;
M: sqlite-db compound-modifier ( str obj -- newstr )
compound-type ;
M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ;
M: sqlite-db compound-type ( str seq -- newstr )
M: sqlite-db compound-type ( str seq -- str' )
over {
{ "default" [ first number>string join-space ] }
[ 2drop ] ! "no sqlite compound data type" 3array throw ]
@ -219,5 +205,4 @@ M: sqlite-db type-table ( -- assoc )
{ FACTOR-BLOB "blob" }
} ;
M: sqlite-db create-type-table
type-table ;
M: sqlite-db create-type-table ( symbol -- str ) type-table ;

View File

@ -30,9 +30,11 @@ SYMBOL: person3
SYMBOL: person4
: test-tuples ( -- )
[ person drop-table ] [ drop ] recover
[ ] [ person ensure-table ] unit-test
[ ] [ person drop-table ] unit-test
[ ] [ person create-table ] unit-test
[ person create-table ] must-fail
[ ] [ person ensure-table ] unit-test
[ ] [ person1 get insert-tuple ] unit-test
@ -191,8 +193,8 @@ TUPLE: annotation n paste-id summary author mode contents ;
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
[ native-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-tuples ] test-postgresql
! [ native-person-schema test-tuples ] test-postgresql
! [ assigned-person-schema test-tuples ] test-postgresql
TUPLE: serialize-me id data ;
@ -211,7 +213,7 @@ TUPLE: serialize-me id data ;
] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
[ test-serialize ] test-sqlite
[ test-serialize ] test-postgresql
! [ test-serialize ] test-postgresql
TUPLE: exam id name score ;
@ -237,3 +239,9 @@ TUPLE: exam id name score ;
;
! [ test-ranges ] test-sqlite
\ insert-tuple must-infer
\ update-tuple must-infer
\ delete-tuple must-infer
\ select-tuple must-infer
\ define-persistent must-infer

View File

@ -3,7 +3,8 @@
USING: arrays assocs classes db kernel namespaces
tuples words sequences slots math
math.parser io prettyprint db.types continuations
mirrors sequences.lib tools.walker combinators.lib ;
mirrors sequences.lib tools.walker combinators.lib
combinators.cleave ;
IN: db.tuples
: define-persistent ( class table columns -- )
@ -35,7 +36,7 @@ HOOK: <update-tuples-statement> db ( class -- obj )
HOOK: <delete-tuple-statement> db ( class -- obj )
HOOK: <delete-tuples-statement> db ( class -- obj )
HOOK: <select-by-slots-statement> db ( tuple -- tuple )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
HOOK: insert-tuple* db ( tuple statement -- )
@ -73,6 +74,9 @@ HOOK: insert-tuple* db ( tuple statement -- )
: drop-table ( class -- )
drop-sql-statement [ execute-statement ] with-disposals ;
: ensure-table ( class -- )
[ dup drop-table ] ignore-errors create-table ;
: insert-native ( tuple -- )
dup class
db get db-insert-statements [ <insert-native-statement> ] cache

View File

@ -26,11 +26,14 @@ M: destructor dispose
: add-always-destructor ( obj -- )
<destructor> always-destructors get push ;
: dispose-each ( seq -- )
<reversed> [ dispose ] each ;
: do-always-destructors ( -- )
always-destructors get [ dispose ] each ;
always-destructors get dispose-each ;
: do-error-destructors ( -- )
error-destructors get [ dispose ] each ;
error-destructors get dispose-each ;
: with-destructors ( quot -- )
[

View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel namespaces sequences definitions io.files
inspector continuations tuples tools.crossref tools.browser
inspector continuations tuples tools.crossref tools.vocabs
io prettyprint source-files assocs vocabs vocabs.loader ;
IN: editors
@ -13,8 +13,7 @@ M: no-edit-hook summary
SYMBOL: edit-hook
: available-editors ( -- seq )
"editors" all-child-vocabs
values concat [ vocab-name ] map ;
"editors" all-child-vocabs-seq [ vocab-name ] map ;
: editor-restarts ( -- alist )
available-editors

View File

@ -0,0 +1,10 @@
! Generate a new factor.vim file for syntax highlighting
USING: http.server.templating.fhtml io.files ;
IN: editors.vim.generate-syntax
: generate-vim-syntax ( -- )
"misc/factor.vim.fgen" resource-path
"misc/factor.vim" resource-path
template-convert ;
MAIN: generate-vim-syntax

View File

@ -1,10 +0,0 @@
! Generate a new factor.vim file for syntax highlighting
REQUIRES: apps/http-server ;
IN: vim
USING: embedded io ;
"extras/factor.vim.fgen" resource-path
"extras/factor.vim" resource-path
embedded-convert

View File

@ -52,7 +52,12 @@ IN: farkup.tests
[ "<h2>foo</h2>" ] [ "==foo==" convert-farkup ] unit-test
[ "<h2>foo</h2>" ] [ "==foo==" convert-farkup ] unit-test
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
[ "<span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test

View File

@ -55,10 +55,31 @@ MEMO: eq ( -- parser )
>r string-lines r>
[ [ htmlize-lines ] with-html-stream ] with-string-writer ;
: escape-link ( href text -- href-esc text-esc )
>r escape-quoted-string r> escape-string ;
: make-link ( href text -- seq )
>r escape-quoted-string r> escape-string
escape-link
[ "<a href=\"" , >r , r> "\">" , [ , ] when* "</a>" , ] { } make ;
: make-image-link ( href alt -- seq )
escape-link
[
"<img src=\"" , swap , "\"" ,
dup empty? [ drop ] [ " alt=\"" , , "\"" , ] if
"/>" , ]
{ } make ;
MEMO: image-link ( -- parser )
[
"[[image:" token hide ,
[ "|]" member? not ] satisfy repeat1 [ >string ] action ,
"|" token hide
[ CHAR: ] = not ] satisfy repeat0 2seq
[ first >string ] action optional ,
"]]" token hide ,
] seq* [ first2 make-image-link ] action ;
MEMO: simple-link ( -- parser )
[
"[[" token hide ,
@ -75,7 +96,7 @@ MEMO: labelled-link ( -- parser )
"]]" token hide ,
] seq* [ first2 make-link ] action ;
MEMO: link ( -- parser ) [ simple-link , labelled-link , ] choice* ;
MEMO: link ( -- parser ) [ image-link , simple-link , labelled-link , ] choice* ;
DEFER: line
MEMO: list-item ( -- parser )
@ -101,13 +122,10 @@ MEMO: table ( -- parser )
MEMO: code ( -- parser )
[
"[" token hide ,
[ "{" member? not ] satisfy repeat1 optional [ >string ] action ,
[ CHAR: { = not ] satisfy repeat1 optional [ >string ] action ,
"{" token hide ,
[
[ any-char , "}]" token ensure-not , ] seq*
repeat1 [ concat >string ] action ,
[ any-char , "}]" token hide , ] seq* optional [ >string ] action ,
] seq* [ concat ] action ,
"}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action ,
"}]" token hide ,
] seq* [ first2 swap render-code ] action ;
MEMO: line ( -- parser )

View File

@ -1,14 +1,14 @@
USING: tools.deploy.config ;
H{
{ deploy-io 2 }
{ deploy-math? f }
{ deploy-threads? f }
{ deploy-compiler? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-name "Hello world (console)" }
{ deploy-reflection 2 }
{ deploy-threads? f }
{ deploy-c-types? f }
{ deploy-compiler? f }
{ deploy-ui? f }
{ deploy-math? f }
{ deploy-reflection 1 }
{ deploy-word-defs? f }
{ deploy-io 2 }
{ deploy-word-props? f }
{ "stop-after-last-window?" t }
}

View File

@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
}
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
"\"mydata.dat\" dup file-length ["
"\"mydata.dat\" dup file-info file-info-length ["
" 4 <sliced-groups> [ reverse-here ] change-each"
"] with-mapped-file"
}

View File

@ -196,6 +196,7 @@ ARTICLE: "io" "Input and output"
{ $subsection "io.timeouts" } ;
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" }
"Exploratory tools:"
{ $subsection "editor" }
{ $subsection "tools.crossref" }

2
extra/help/lint/lint.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences parser kernel help help.markup help.topics
words strings classes tools.browser namespaces io
words strings classes tools.vocabs namespaces io
io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate

View File

@ -169,7 +169,8 @@ M: f print-element drop ;
] if
] ($subsection) ;
: $vocab-link ( element -- ) first dup ($vocab-link) ;
: $vocab-link ( element -- )
first dup vocab-name swap ($vocab-link) ;
: $vocabulary ( element -- )
first word-vocabulary [

4
extra/help/topics/topics.factor Normal file → Executable file
View File

@ -7,6 +7,10 @@ IN: help.topics
TUPLE: link name ;
MIXIN: topic
INSTANCE: link topic
INSTANCE: word topic
GENERIC: >link ( obj -- obj )
M: link >link ;
M: vocab-spec >link ;

View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax ui.commands ui.operations
ui.tools.search ui.tools.workspace editors vocabs.loader
kernel sequences prettyprint tools.test strings
kernel sequences prettyprint tools.test tools.vocabs strings
unicode.categories unicode.case ;
IN: help.tutorial

View File

@ -18,6 +18,7 @@ tuple-syntax namespaces ;
port: 80
version: "1.1"
cookies: V{ }
header: H{ }
}
] [
[

View File

@ -95,5 +95,4 @@ PRIVATE>
swap >>post-data-type ;
: http-post ( content-type content url -- response string )
#! The content is URL encoded for you.
>r url-encode r> <post-request> http-request contents ;
<post-request> http-request contents ;

View File

@ -4,7 +4,8 @@ USING: fry hashtables io io.streams.string kernel math
namespaces math.parser assocs sequences strings splitting ascii
io.encodings.utf8 io.encodings.string namespaces unicode.case
combinators vectors sorting new-slots accessors calendar
calendar.format quotations arrays ;
calendar.format quotations arrays combinators.cleave
combinators.lib byte-arrays ;
IN: http
: http-port 80 ; inline
@ -12,18 +13,21 @@ IN: http
: 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
{
[ dup letter? ]
[ dup LETTER? ]
[ dup digit? ]
[ dup "/_-.:" member? ]
} || nip ; foldable
: push-utf8 ( ch -- )
1string utf8 encode [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
1string utf8 encode
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str )
[ [
dup url-quotable? [ , ] [ push-utf8 ] if
] each ] "" make ;
[
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
: url-decode-hex ( index str -- )
2dup length 2 - >= [
@ -108,7 +112,12 @@ IN: http
] when ;
: assoc>query ( hash -- str )
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
[
[ url-encode ]
[ dup number? [ number>string ] when url-encode ]
bi*
"=" swap 3append
] { } assoc>map
"&" join ;
TUPLE: cookie name value path domain expires http-only ;
@ -169,10 +178,11 @@ cookies ;
: <request>
request construct-empty
"1.1" >>version
http-port >>port
H{ } clone >>query
V{ } clone >>cookies ;
"1.1" >>version
http-port >>port
H{ } clone >>header
H{ } clone >>query
V{ } clone >>cookies ;
: query-param ( request key -- value )
swap query>> at ;
@ -245,6 +255,10 @@ SYMBOL: max-post-request
: extract-post-data-type ( request -- request )
dup "content-type" header >>post-data-type ;
: parse-post-data ( request -- request )
dup post-data-type>> "application/x-www-form-urlencoded" =
[ dup post-data>> query>assoc >>post-data ] when ;
: extract-cookies ( request -- request )
dup "cookie" header [ parse-cookies >>cookies ] when* ;
@ -257,24 +271,31 @@ SYMBOL: max-post-request
read-post-data
extract-host
extract-post-data-type
parse-post-data
extract-cookies ;
: 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 ;
: (link>string) ( url query -- url' )
[ url-encode ] [ assoc>query ] bi*
dup empty? [ drop ] [ "?" swap 3append ] if ;
: write-url ( request -- )
[ path>> ] [ query>> ] bi (link>string) write ;
: write-request-url ( request -- request )
write-url bl ;
dup write-url bl ;
: write-version ( request -- request )
"HTTP/" write dup request-version write crlf ;
: unparse-post-data ( request -- request )
dup post-data>> dup sequence? [ drop ] [
assoc>query >>post-data
"application/x-www-form-urlencoded" >>post-data-type
] if ;
: write-request-header ( request -- request )
dup header>> >hashtable
over host>> [ "host" pick set-at ] when*
@ -287,6 +308,7 @@ SYMBOL: max-post-request
dup post-data>> [ write ] when* ;
: write-request ( request -- )
unparse-post-data
write-method
write-request-url
write-version
@ -297,15 +319,16 @@ SYMBOL: max-post-request
: request-url ( request -- url )
[
dup host>> [
"http://" write
dup host>> url-encode write
":" write
dup port>> number>string write
] when
dup path>> "/" head? [ "/" write ] unless
write-url
drop
[
dup host>> [
[ "http://" write host>> url-encode write ]
[ ":" write port>> number>string write ]
bi
] [ drop ] if
]
[ path>> "/" head? [ "/" write ] unless ]
[ write-url ]
tri
] with-string-writer ;
: set-header ( request/response value key -- request/response )

View File

@ -1,11 +1,16 @@
IN: http.server.actions.tests
USING: http.server.actions tools.test math math.parser
multiline namespaces http io.streams.string http.server
sequences accessors ;
USING: http.server.actions http.server.validators
tools.test math math.parser multiline namespaces http
io.streams.string http.server sequences accessors ;
[
"a" [ v-number ] { { "a" "123" } } validate-param
[ 123 ] [ "a" get ] unit-test
] with-scope
<action>
[ "a" get "b" get + ] >>display
{ { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params
{ { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
"action-1" set
STRING: action-request-test-1
@ -23,12 +28,13 @@ blah
<action>
[ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
{ { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
{ { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params
"action-2" set
STRING: action-request-test-2
POST http://foo/bar/baz HTTP/1.1
content-length: 5
content-type: application/x-www-form-urlencoded
xxx=4
;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors new-slots sequences kernel assocs combinators
http.server http.server.validators http hashtables namespaces
combinators.cleave fry continuations ;
combinators.cleave fry continuations locals ;
IN: http.server.actions
SYMBOL: +path+
@ -17,25 +17,13 @@ TUPLE: action init display submit get-params post-params ;
[ <400> ] >>display
[ <400> ] >>submit ;
: extract-params ( path -- assoc )
+path+ associate
request get dup method>> {
{ "GET" [ query>> ] }
{ "HEAD" [ query>> ] }
{ "POST" [ post-data>> query>assoc ] }
} case union ;
: with-validator ( string quot -- result error? )
'[ , @ f ] [
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-param ( name validator assoc -- )
name assoc at validator with-validator name set ; inline
: action-params ( validators -- error? )
[ params get validate-param ] { } assoc>map [ ] contains? ;
validation-failed? off
params get '[ , validate-param ] assoc-each
validation-failed? get ;
: handle-get ( -- response )
action get get-params>> action-params [ <400> ] [
@ -50,12 +38,10 @@ TUPLE: action init display submit get-params post-params ;
action get display>> call exit-with ;
M: action call-responder ( path action -- response )
[ extract-params params set ]
[
action set
request get method>> {
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case
] bi* ;
[ +path+ associate request-params union params set ]
[ action set ] bi*
request get method>> {
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case ;

View File

@ -0,0 +1,77 @@
<% USING: http.server.components http.server.auth.login
http.server namespaces kernel combinators ; %>
<html>
<body>
<h1>Edit profile</h1>
<form method="POST" action="edit-profile">
<% hidden-form-field %>
<table>
<tr>
<td>User name:</td>
<td><% "username" component render-view %></td>
</tr>
<tr>
<td>Real name:</td>
<td><% "realname" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying a real name is optional.</td>
</tr>
<tr>
<td>Current password:</td>
<td><% "password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>If you don't want to change your current password, leave this field blank.</td>
</tr>
<tr>
<td>New password:</td>
<td><% "new-password" component render-edit %></td>
</tr>
<tr>
<td>Verify:</td>
<td><% "verify-password" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>If you are changing your password, enter it twice to ensure it is correct.</td>
</tr>
<tr>
<td>E-mail:</td>
<td><% "email" component render-edit %></td>
</tr>
<tr>
<td></td>
<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
</tr>
</table>
<p><input type="submit" value="Update" />
<% {
{ [ login-failed? get ] [ "invalid password" render-error ] }
{ [ password-mismatch? get ] [ "passwords do not match" render-error ] }
{ [ t ] [ ] }
} cond %>
</p>
</form>
</body>
</html>

View File

@ -13,6 +13,8 @@ QUALIFIED: smtp
TUPLE: login users ;
: users login get users>> ;
SYMBOL: post-login-url
SYMBOL: login-failed?
@ -30,7 +32,8 @@ SYMBOL: login-failed?
: successful-login ( user -- response )
logged-in-user sset
post-login-url sget f <permanent-redirect> ;
post-login-url sget "" or f <permanent-redirect>
f post-login-url sset ;
:: <login-action> ( -- action )
[let | form [ <login-form> ] |
@ -48,7 +51,7 @@ SYMBOL: login-failed?
form validate-form
"password" value "username" value
login get users>> check-login [
users check-login [
successful-login
] [
login-failed? on
@ -66,7 +69,7 @@ SYMBOL: login-failed?
t >>required
add-field
"realname" <string> add-field
"password" <password>
"new-password" <password>
t >>required
add-field
"verify-password" <password>
@ -79,7 +82,7 @@ SYMBOL: password-mismatch?
SYMBOL: user-exists?
: same-password-twice ( -- )
"password" value "verify-password" value = [
"new-password" value "verify-password" value = [
password-mismatch? on
validation-failed
] unless ;
@ -101,14 +104,13 @@ SYMBOL: user-exists?
same-password-twice
<user> values get [
"username" get >>username
"realname" get >>realname
"password" get >>password
"email" get >>email
] bind
<user>
"username" value >>username
"realname" value >>realname
"new-password" value >>password
"email" value >>email
login get users>> new-user [
users new-user [
user-exists? on
validation-failed
] unless*
@ -117,6 +119,64 @@ SYMBOL: user-exists?
] >>submit
] ;
! ! ! Editing user profile
: <edit-profile-form> ( -- form )
"edit-profile" <form>
"resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template
"username" <username> add-field
"realname" <string> add-field
"password" <password> add-field
"new-password" <password> add-field
"verify-password" <password> add-field
"email" <email> add-field ;
SYMBOL: previous-page
:: <edit-profile-action> ( -- action )
[let | form [ <edit-profile-form> ] |
<action>
[
blank-values
logged-in-user sget
dup username>> "username" set-value
dup realname>> "realname" set-value
dup email>> "email" set-value
] >>init
[
"text/html" <content>
[ form edit-form ] >>body
] >>display
[
blank-values
uid "username" set-value
form validate-form
"password" value empty? [
logged-in-user sget
] [
same-password-twice
"password" value uid users check-login
[ login-failed? on validation-failed ] unless
"new-password" value uid users set-password
[ "User deleted" throw ] unless*
] if
"realname" value >>realname
"email" value >>email
dup users update-user
logged-in-user sset
previous-page sget f <permanent-redirect>
] >>submit
] ;
! ! ! Password recovery
SYMBOL: lost-password-from
@ -185,7 +245,7 @@ SYMBOL: lost-password-from
form validate-form
"email" value "username" value
login get users>> issue-ticket [
users issue-ticket [
send-password-email
] when*
@ -199,7 +259,7 @@ SYMBOL: lost-password-from
"username" <username> <hidden>
t >>required
add-field
"password" <password>
"new-password" <password>
t >>required
add-field
"verify-password" <password>
@ -238,9 +298,9 @@ SYMBOL: lost-password-from
"ticket" value
"username" value
login get users>> claim-ticket [
"password" value >>password
login get users>> update-user
users claim-ticket [
"new-password" value >>password
users update-user
"resource:extra/http/server/auth/login/recover-4.fhtml"
serve-template
@ -264,13 +324,18 @@ TUPLE: protected responder ;
C: <protected> protected
: show-login-page ( -- response )
request get request-url post-login-url sset
"login" f <permanent-redirect> ;
M: protected call-responder ( path responder -- response )
logged-in-user sget [ responder>> call-responder ] [
logged-in-user sget [
request get request-url previous-page sset
responder>> call-responder
] [
2drop
request get method>> { "GET" "HEAD" } member? [
request get request-url post-login-url sset
"login" f <permanent-redirect>
] [ <400> ] if
request get method>> { "GET" "HEAD" } member?
[ show-login-page ] [ <400> ] if
] if ;
M: login call-responder ( path responder -- response )
@ -282,10 +347,13 @@ M: login call-responder ( path responder -- response )
swap <protected> >>default
<login-action> "login" add-responder
<logout-action> "logout" add-responder
no >>users ;
no-users >>users ;
! ! ! Configuration
: allow-edit-profile ( login -- login )
<edit-profile-action> <protected> "edit-profile" add-responder ;
: allow-registration ( login -- login )
<register-action> "register" add-responder ;
@ -293,6 +361,9 @@ M: login call-responder ( path responder -- response )
<recover-action-1> "recover-password" add-responder
<recover-action-3> "new-password" add-responder ;
: allow-edit-profile? ( -- ? )
login get responders>> "edit-profile" swap key? ;
: allow-registration? ( -- ? )
login get responders>> "register" swap key? ;

View File

@ -1,10 +1,13 @@
<% USING: http.server.auth.login http.server.components kernel
namespaces ; %>
<% USING: http.server.auth.login http.server.components http.server
kernel namespaces ; %>
<html>
<body>
<h1>Login required</h1>
<form method="POST" action="login">
<% hidden-form-field %>
<table>
<tr>
@ -30,10 +33,12 @@ login-failed? get
<p>
<% allow-registration? [ %>
<a href="register">Register</a>
<a href="<% "register" f write-link %>">Register</a>
<% ] when %>
<% allow-password-recovery? [ %>
<a href="recover-password">Recover Password</a>
<a href="<% "recover-password" f write-link %>">
Recover Password
</a>
<% ] when %>
</p>

View File

@ -1,4 +1,4 @@
<% USING: http.server.components ; %>
<% USING: http.server.components http.server ; %>
<html>
<body>
<h1>Recover lost password: step 1 of 4</h1>
@ -6,6 +6,9 @@
<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
<form method="POST" action="recover-password">
<% hidden-form-field %>
<table>
<tr>

View File

@ -1,4 +1,4 @@
<% USING: http.server.components http.server.auth.login
<% USING: http.server.components http.server.auth.login http.server
namespaces kernel combinators ; %>
<html>
<body>
@ -7,6 +7,9 @@ namespaces kernel combinators ; %>
<p>Choose a new password for your account.</p>
<form method="POST" action="new-password">
<% hidden-form-field %>
<table>
<% "username" component render-edit %>
@ -14,7 +17,7 @@ namespaces kernel combinators ; %>
<tr>
<td>Password:</td>
<td><% "password" component render-edit %></td>
<td><% "new-password" component render-edit %></td>
</tr>
<tr>
@ -32,7 +35,7 @@ namespaces kernel combinators ; %>
<p><input type="submit" value="Set password" />
<% password-mismatch? get [
"passwords do not match" render-error
"passwords do not match" render-error
] when %>
</p>

View File

@ -1,10 +1,10 @@
<% USING: http.server.components http.server.auth.login
namespaces kernel combinators ; %>
<% USING: http.server ; %>
<html>
<body>
<h1>Recover lost password: step 4 of 4</h1>
<p>Your password has been reset. You may now <a href="login">log in</a>.</p>
<p>Your password has been reset.
You may now <a href="<% "login" f write-link %>">log in</a>.</p>
</body>
</html>

View File

@ -1,10 +1,12 @@
<% USING: http.server.components http.server.auth.login
namespaces kernel combinators ; %>
http.server namespaces kernel combinators ; %>
<html>
<body>
<h1>New user registration</h1>
<form method="POST" action="register">
<% hidden-form-field %>
<table>
<tr>
@ -24,7 +26,7 @@ namespaces kernel combinators ; %>
<tr>
<td>Password:</td>
<td><% "password" component render-edit %></td>
<td><% "new-password" component render-edit %></td>
</tr>
<tr>

View File

@ -3,7 +3,7 @@ USING: http.server.auth.providers
http.server.auth.providers.assoc tools.test
namespaces accessors kernel ;
<in-memory> "provider" set
<users-in-memory> "provider" set
[ t ] [
<user>
@ -26,7 +26,7 @@ namespaces accessors kernel ;
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test
[ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test

View File

@ -4,16 +4,16 @@ IN: http.server.auth.providers.assoc
USING: new-slots accessors assocs kernel
http.server.auth.providers ;
TUPLE: in-memory assoc ;
TUPLE: users-in-memory assoc ;
: <in-memory> ( -- provider )
H{ } clone in-memory construct-boa ;
: <users-in-memory> ( -- provider )
H{ } clone users-in-memory construct-boa ;
M: in-memory get-user ( username provider -- user/f )
M: users-in-memory get-user ( username provider -- user/f )
assoc>> at ;
M: in-memory update-user ( user provider -- ) 2drop ;
M: users-in-memory update-user ( user provider -- ) 2drop ;
M: in-memory new-user ( user provider -- user/f )
M: users-in-memory new-user ( user provider -- user/f )
>r dup username>> r> assoc>>
2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;

View File

@ -4,12 +4,11 @@ http.server.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations
io.files accessors kernel ;
from-db "provider" set
users-in-db "provider" set
"auth-test.db" temp-file sqlite-db [
[ user drop-table ] ignore-errors
[ user create-table ] ignore-errors
init-users-table
[ t ] [
<user>
@ -32,7 +31,7 @@ from-db "provider" set
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test
[ t ] [ "fdasf" "slava" "provider" get set-password >boolean ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test

View File

@ -1,7 +1,8 @@
! 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 continuations ;
http.server.auth.providers kernel continuations
singleton ;
IN: http.server.auth.providers.db
user "USERS"
@ -14,24 +15,20 @@ user "USERS"
{ "profile" "PROFILE" FACTOR-BLOB }
} define-persistent
: init-users-table ( -- )
[ user drop-table ] ignore-errors
user create-table ;
: init-users-table user ensure-table ;
TUPLE: from-db ;
: from-db T{ from-db } ;
SINGLETON: users-in-db
: find-user ( username -- user )
<user>
swap >>username
select-tuple ;
M: from-db get-user
M: users-in-db get-user
drop
find-user ;
M: from-db new-user
M: users-in-db new-user
drop
[
dup username>> find-user [
@ -41,5 +38,5 @@ M: from-db new-user
] if
] with-transaction ;
M: from-db update-user
M: users-in-db update-user
drop update-tuple ;

View File

@ -3,14 +3,12 @@
USING: http.server.auth.providers kernel ;
IN: http.server.auth.providers.null
! Named "no" because we can say no >>users
TUPLE: no-users ;
TUPLE: no ;
: no-users T{ no-users } ;
: no T{ no } ;
M: no-users get-user 2drop f ;
M: no get-user 2drop f ;
M: no-users new-user 2drop f ;
M: no new-user 2drop f ;
M: no update-user 2drop ;
M: no-users update-user 2drop ;

View File

@ -17,12 +17,12 @@ GENERIC: new-user ( user provider -- user/f )
: check-login ( password username provider -- user/f )
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
:: set-password ( password username provider -- ? )
:: set-password ( password username provider -- user/f )
[let | user [ username provider get-user ] |
user [
user
password >>password
provider update-user t
dup provider update-user
] [ f ] if
] ;

View File

@ -4,7 +4,7 @@
USING: html http http.server io kernel math namespaces
continuations calendar sequences assocs new-slots hashtables
accessors arrays alarms quotations combinators
combinators.cleave fry ;
combinators.cleave fry assocs.lib ;
IN: http.server.callbacks
SYMBOL: responder

View File

@ -86,3 +86,24 @@ TUPLE: test-tuple text number more-text ;
[ t ] [ "number" value validation-error? ] unit-test
] with-scope
[
[ ] [
"n" <number>
0 >>min-value
10 >>max-value
"n" set
] unit-test
[ "123" ] [
"123" "n" get validate value>>
] unit-test
[ ] [ "n" get t >>integer drop ] unit-test
[ 3 ] [
"3" "n" get validate
] unit-test
] with-scope
[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test

View File

@ -7,8 +7,6 @@ http.server.actions splitting mirrors hashtables
combinators.cleave fry continuations math ;
IN: http.server.components
SYMBOL: validation-failed?
SYMBOL: components
TUPLE: component id required default ;
@ -30,16 +28,13 @@ SYMBOL: values
: validate ( value component -- result )
'[
, ,
,
over empty? [
[ default>> [ v-default ] when* ]
[ required>> [ v-required ] when ]
bi
] [ validate* ] if
] [
dup validation-error?
[ validation-failed? on ] [ rethrow ] if
] recover ;
] with-validator ;
: render-view ( component -- )
[ id>> value ] [ render-view* ] bi ;
@ -192,15 +187,16 @@ M: password render-error*
render-edit* render-error ;
! Number fields
TUPLE: number min-value max-value ;
TUPLE: number min-value max-value integer ;
: <number> ( id -- component ) number <component> ;
M: number validate*
[ v-number ] [
[ integer>> [ v-integer ] when ]
[ min-value>> [ v-min-value ] when* ]
[ max-value>> [ v-max-value ] when* ]
bi
tri
] bi* ;
M: number render-view*
@ -215,7 +211,12 @@ M: number render-error*
! Text areas
TUPLE: text ;
: <text> ( id -- component ) <string> text construct-delegate ;
: <text> ( id -- component ) text <component> ;
M: text validate* drop ;
M: text render-view*
drop write ;
: render-textarea
<textarea

View File

@ -3,15 +3,23 @@
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
tools.vocabs debugger html continuations random combinators
destructors io.encodings.latin1 fry combinators.cleave ;
IN: http.server
GENERIC: call-responder ( path responder -- response )
: request-params ( -- assoc )
request get dup method>> {
{ "GET" [ query>> ] }
{ "HEAD" [ query>> ] }
{ "POST" [ post-data>> ] }
} case ;
: <content> ( content-type -- response )
<response>
200 >>code
"Document follows" >>message
swap set-content-type ;
TUPLE: trivial-responder response ;
@ -44,19 +52,27 @@ SYMBOL: 404-responder
[ <404> ] <trivial-responder> 404-responder set-global
: url-redirect ( to query -- url )
#! Different host.
dup assoc-empty? [
drop
] [
assoc>query "?" swap 3append
] if ;
SYMBOL: link-hook
: modify-query ( query -- query )
link-hook get [ ] or call ;
: link>string ( url query -- url' )
modify-query (link>string) ;
: write-link ( url query -- )
link>string write ;
SYMBOL: form-hook
: hidden-form-field ( -- )
form-hook get [ ] or call ;
: absolute-redirect ( to query -- url )
#! Same host.
request get clone
swap [ >>query ] when*
swap >>path
swap url-encode >>path
request-url ;
: replace-last-component ( path with -- path' )
@ -66,11 +82,12 @@ SYMBOL: 404-responder
request get clone
swap [ >>query ] when*
swap [ '[ , replace-last-component ] change-path ] when*
dup query>> modify-query >>query
request-url ;
: derive-url ( to query -- url )
{
{ [ over "http://" head? ] [ url-redirect ] }
{ [ over "http://" head? ] [ link>string ] }
{ [ over "/" head? ] [ absolute-redirect ] }
{ [ t ] [ relative-redirect ] }
} cond ;
@ -91,10 +108,6 @@ TUPLE: dispatcher default responders ;
: <dispatcher> ( -- dispatcher )
404-responder get H{ } clone dispatcher construct-boa ;
: set-main ( dispatcher name -- dispatcher )
'[ , f <permanent-redirect> ] <trivial-responder>
>>default ;
: split-path ( path -- rest first )
[ CHAR: / = ] left-trim "/" split1 swap ;
@ -107,28 +120,36 @@ TUPLE: dispatcher default responders ;
M: dispatcher call-responder ( path dispatcher -- response )
over [
2dup find-responder call-responder [
2nip
] [
default>> [
call-responder
] [
drop f
] if*
] if*
find-responder call-responder
] [
2drop redirect-with-/
] if ;
: <webapp> ( class -- dispatcher )
<dispatcher> swap construct-delegate ; inline
TUPLE: vhost-dispatcher default responders ;
: <vhost-dispatcher> ( -- dispatcher )
404-responder get H{ } clone vhost-dispatcher construct-boa ;
: find-vhost ( dispatcher -- responder )
request get host>> over responders>> at*
[ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder ( path dispatcher -- response )
find-vhost call-responder ;
: set-main ( dispatcher name -- dispatcher )
'[ , f <permanent-redirect> ] <trivial-responder>
>>default ;
: add-responder ( dispatcher responder path -- dispatcher )
pick responders>> set-at ;
: add-main-responder ( dispatcher responder path -- dispatcher )
[ add-responder ] keep set-main ;
: <webapp> ( class -- dispatcher )
<dispatcher> swap construct-delegate ; inline
SYMBOL: main-responder
main-responder global
@ -202,11 +223,3 @@ SYMBOL: exit-continuation
: httpd-main ( -- ) 8888 httpd ;
MAIN: httpd-main
! Utility
: generate-key ( assoc -- str )
>r random-256 >hex r>
2dup key? [ nip generate-key ] [ drop ] if ;
: set-at-unique ( value assoc -- key )
dup generate-key [ swap set-at ] keep ;

View File

@ -1,6 +1,10 @@
IN: http.server.sessions.tests
USING: tools.test http.server.sessions math namespaces
kernel accessors ;
USING: tools.test http http.server.sessions
http.server.sessions.storage http.server.sessions.storage.assoc
http.server math namespaces kernel accessors prettyprint
io.streams.string splitting destructors ;
[ H{ } ] [ H{ } add-session-id ] unit-test
: with-session \ session swap with-variable ; inline
@ -10,7 +14,18 @@ C: <foo> foo
M: foo init-session* drop 0 "x" sset ;
f <session> [
M: foo call-responder
2drop
"x" [ 1+ ] schange
"text/html" <content> [ "x" sget pprint ] >>body ;
[
"123" session-id set
H{ } clone session set
session-changed? off
[ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test
[ ] [ 3 "x" sset ] unit-test
[ 9 ] [ "x" sget sq ] unit-test
@ -18,22 +33,88 @@ f <session> [
[ ] [ "x" [ 1- ] schange ] unit-test
[ 4 ] [ "x" sget sq ] unit-test
] with-session
[ t ] [ session-changed? get ] unit-test
] with-scope
[ t ] [ f <url-sessions> url-sessions? ] unit-test
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
[ ] [
<foo> <url-sessions>
<sessions-in-memory> >>sessions
"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
"manager" get begin-session drop
dup "manager" get sessions>> get-session [ 5 "a" sset ] with-session
dup "manager" get sessions>> get-session [ "a" sget , ] with-session
dup "manager" get sessions>> get-session [ "x" sget , ] with-session
"manager" get sessions>> get-session
"manager" get sessions>> delete-session
] { } make
] unit-test
[ ] [
<request>
"GET" >>method
request set
"/etc" "manager" get call-responder
response set
] unit-test
[ 307 ] [ response get code>> ] unit-test
[ ] [ response get "location" header "=" split1 nip "id" set ] unit-test
: url-responder-mock-test
[
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
request set
"/" "manager" get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
[ "1" ] [ url-responder-mock-test ] unit-test
[ "2" ] [ url-responder-mock-test ] unit-test
[ "3" ] [ url-responder-mock-test ] unit-test
[ "4" ] [ url-responder-mock-test ] unit-test
[ ] [
<foo> <cookie-sessions>
<sessions-in-memory> >>sessions
"manager" set
] unit-test
[
<request>
"GET" >>method
"/" >>path
request set
"/etc" "manager" get call-responder response set
[ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
response get
] with-destructors
response set
[ ] [ response get cookies>> "cookies" set ] unit-test
: cookie-responder-mock-test
[
<request>
"GET" >>method
"cookies" get >>cookies
"/" >>path
request set
"/" "manager" get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
[ "2" ] [ cookie-responder-mock-test ] unit-test
[ "3" ] [ cookie-responder-mock-test ] unit-test
[ "4" ] [ cookie-responder-mock-test ] unit-test

View File

@ -1,8 +1,10 @@
! 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 fry combinators.cleave ;
new-slots accessors http http.server
http.server.sessions.storage http.server.sessions.storage.assoc
quotations hashtables sequences fry combinators.cleave
html.elements symbols continuations destructors ;
IN: http.server.sessions
! ! ! ! ! !
@ -16,62 +18,48 @@ M: dispatcher init-session* drop ;
TUPLE: session-manager responder sessions ;
: <session-manager> ( responder class -- responder' )
>r H{ } clone session-manager construct-boa r>
construct-delegate ; inline
>r <sessions-in-memory> session-manager construct-boa
r> construct-delegate ; inline
TUPLE: session manager id namespace alarm ;
SYMBOLS: session session-id session-changed? ;
: <session> ( manager -- session )
f H{ } clone <box> \ session construct-boa ;
: sget ( key -- value )
session get at ;
: timeout ( -- dt ) 20 minutes ;
: sset ( value key -- )
session get set-at
session-changed? on ;
: cancel-timeout ( session -- )
alarm>> [ cancel-alarm ] if-box? ;
: schange ( key quot -- )
session get swap change-at
session-changed? on ; inline
: delete-session ( session -- )
[ cancel-timeout ]
[ dup manager>> sessions>> delete-at ]
bi ;
: sessions session-manager get sessions>> ;
: touch-session ( session -- session )
[ cancel-timeout ]
[ [ '[ , delete-session ] timeout later ] keep alarm>> >box ]
[ ]
tri ;
: managed-responder session-manager get responder>> ;
: session ( -- assoc ) \ session get namespace>> ;
: init-session ( managed -- session )
H{ } clone [ session [ init-session* ] with-variable ] keep ;
: sget ( key -- value ) session at ;
: begin-session ( responder -- id session )
[ responder>> init-session ] [ sessions>> ] bi
[ new-session ] [ drop ] 2bi ;
: sset ( value key -- ) session set-at ;
! Destructor
TUPLE: session-saver id session ;
: schange ( key quot -- ) session swap change-at ; inline
C: <session-saver> session-saver
: init-session ( session -- session )
dup dup \ session [
manager>> responder>> init-session*
] with-variable ;
M: session-saver dispose
session-changed? get [
[ session>> ] [ id>> ] bi
sessions update-session
] [ drop ] if ;
: new-session ( responder -- id )
[ <session> init-session touch-session ]
[ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ]
bi id>> ;
: get-session ( id responder -- session/f )
sessions>> at* [ touch-session ] when ;
: call-responder/session ( path responder session -- response )
\ session set responder>> call-responder ;
: 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* ;
: call-responder/session ( path responder id session -- response )
[ <session-saver> add-always-destructor ]
[ [ session-id set ] [ session set ] bi* ] 2bi
[ session-manager set ] [ responder>> call-responder ] bi ;
TUPLE: null-sessions ;
@ -79,49 +67,64 @@ TUPLE: null-sessions ;
null-sessions <session-manager> ;
M: null-sessions call-responder ( path responder -- response )
dup <session> call-responder/session ;
H{ } clone f call-responder/session ;
TUPLE: url-sessions ;
: <url-sessions> ( responder -- responder' )
url-sessions <session-manager> ;
: sess-id "factorsessid" ;
: session-id-key "factorsessid" ;
: current-session ( responder request -- session )
sess-id query-param swap get-session ;
: current-url-session ( responder -- id/f session/f )
[ request-params session-id-key swap at ] [ sessions>> ] bi*
[ drop ] [ get-session ] 2bi ;
: add-session-id ( query -- query' )
session-id get [ session-id-key associate union ] when* ;
: session-form-field ( -- )
<input
"hidden" =type
session-id-key =id
session-id-key =name
session-id get =value
input/> ;
: new-url-session ( responder -- response )
[ f ] [ begin-session drop session-id-key associate ] bi*
<temporary-redirect> ;
M: url-sessions call-responder ( path responder -- response )
dup request get current-session [
[ add-session-id ] link-hook set
[ session-form-field ] form-hook set
dup current-url-session dup [
call-responder/session
] [
nip
f swap new-session sess-id associate <temporary-redirect>
] if* ;
M: url-sessions session-link*
drop
url-encode
\ session get id>> sess-id associate union assoc>query
dup assoc-empty? [ drop ] [ "?" swap 3append ] if ;
2drop nip new-url-session
] if ;
TUPLE: cookie-sessions ;
: <cookie-sessions> ( responder -- responder' )
cookie-sessions <session-manager> ;
: get-session-cookie ( responder -- cookie )
request get sess-id get-cookie
[ value>> swap get-session ] [ drop f ] if* ;
: current-cookie-session ( responder -- id namespace/f )
request get session-id-key get-cookie dup
[ value>> dup rot sessions>> get-session ] [ 2drop f f ] if ;
: <session-cookie> ( id -- cookie )
sess-id <cookie> ;
session-id-key <cookie> ;
: call-responder/new-session ( path responder -- response )
dup begin-session
[ call-responder/session ]
[ drop <session-cookie> ] 2bi
put-cookie ;
M: cookie-sessions call-responder ( path responder -- response )
dup get-session-cookie [
dup current-cookie-session dup [
call-responder/session
] [
dup new-session
[ over get-session call-responder/session ] keep
<session-cookie> put-cookie
] if* ;
2drop call-responder/new-session
] if ;

View File

@ -0,0 +1,38 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs assocs.lib new-slots accessors
http.server.sessions.storage combinators.cleave alarms kernel
fry http.server ;
IN: http.server.sessions.storage.assoc
TUPLE: sessions-in-memory sessions alarms ;
: <sessions-in-memory> ( -- storage )
H{ } clone H{ } clone sessions-in-memory construct-boa ;
: cancel-session-timeout ( id storage -- )
alarms>> at [ cancel-alarm ] when* ;
: touch-session ( id storage -- )
[ cancel-session-timeout ]
[ '[ , , delete-session ] timeout later ]
[ alarms>> set-at ]
2tri ;
M: sessions-in-memory get-session ( id storage -- namespace )
[ sessions>> at ] [ touch-session ] 2bi ;
M: sessions-in-memory update-session ( namespace id storage -- )
[ sessions>> set-at ]
[ touch-session ]
2bi ;
M: sessions-in-memory delete-session ( id storage -- )
[ sessions>> delete-at ]
[ cancel-session-timeout ]
2bi ;
M: sessions-in-memory new-session ( namespace storage -- id )
[ sessions>> set-at-unique ]
[ [ touch-session ] [ drop ] 2bi ]
bi ;

View File

@ -0,0 +1,24 @@
IN: http.server.sessions.storage.db
USING: http.server.sessions.storage
http.server.sessions.storage.db namespaces io.files
db.sqlite db accessors math tools.test kernel assocs
sequences ;
sessions-in-db "storage" set
"auth-test.db" temp-file sqlite-db [
[ ] [ init-sessions-table ] unit-test
[ f ] [ H{ } "storage" get new-session empty? ] unit-test
H{ } "storage" get new-session "id" set
"id" get "storage" get get-session "session" set
"a" "b" "session" get set-at
"session" get "id" get "storage" get update-session
[ H{ { "b" "a" } } ] [
"id" get "storage" get get-session
] unit-test
] with-db

View File

@ -0,0 +1,52 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs new-slots accessors http.server.sessions.storage
alarms kernel http.server db.tuples db.types singleton
combinators.cleave math.parser ;
IN: http.server.sessions.storage.db
SINGLETON: sessions-in-db
TUPLE: session id namespace ;
session "SESSIONS"
{
{ "id" "ID" INTEGER +native-id+ }
{ "namespace" "NAMESPACE" FACTOR-BLOB }
} define-persistent
: init-sessions-table session ensure-table ;
: <session> ( id -- session )
session construct-empty
swap dup [ string>number ] when >>id ;
USING: namespaces io prettyprint ;
M: sessions-in-db get-session ( id storage -- namespace/f )
global [ "get " write over print flush ] bind
drop
dup [
<session>
select-tuple dup [ namespace>> ] when global [ dup . ] bind
] when ;
M: sessions-in-db update-session ( namespace id storage -- )
global [ "update " write over print flush ] bind
drop
<session>
swap global [ dup . ] bind >>namespace
dup update-tuple
id>> <session> select-tuple global [ . flush ] bind
;
M: sessions-in-db delete-session ( id storage -- )
drop
<session>
delete-tuple ;
M: sessions-in-db new-session ( namespace storage -- id )
global [ "new " print flush ] bind
drop
f <session>
swap global [ dup . ] bind >>namespace
[ insert-tuple ] [ id>> number>string ] bi ;

View File

@ -0,0 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar ;
IN: http.server.sessions.storage
: timeout 20 minutes ;
GENERIC: get-session ( id storage -- namespace )
GENERIC: update-session ( namespace id storage -- )
GENERIC: delete-session ( id storage -- )
GENERIC: new-session ( namespace storage -- id )

View File

@ -7,16 +7,11 @@ calendar.format new-slots accessors io.encodings.binary
combinators.cleave fry ;
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 ;
file-info file-info-modified timestamp>http-string ;
: last-modified-matches? ( filename -- ? )
file-http-date dup [
@ -33,7 +28,7 @@ TUPLE: file-responder root hook special ;
[
<content>
swap
[ file-length "content-length" set-header ]
[ file-info file-info-size "content-length" set-header ]
[ file-http-date "last-modified" set-header ]
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]
tri

View File

@ -2,7 +2,8 @@ IN: http.server.validators.tests
USING: kernel sequences tools.test http.server.validators
accessors ;
[ "foo" v-number ] [ validation-error? ] must-fail-with
[ "foo" v-number ] must-fail
[ 123 ] [ "123" v-number ] unit-test
[ "slava@factorcode.org" ] [
"slava@factorcode.org" v-email
@ -13,10 +14,10 @@ accessors ;
] unit-test
[ "slava@factorcode.o" v-email ]
[ reason>> "invalid e-mail" = ] must-fail-with
[ "invalid e-mail" = ] must-fail-with
[ "sla@@factorcode.o" v-email ]
[ reason>> "invalid e-mail" = ] must-fail-with
[ "invalid e-mail" = ] must-fail-with
[ "slava@factorcodeorg" v-email ]
[ reason>> "invalid e-mail" = ] must-fail-with
[ "invalid e-mail" = ] must-fail-with

View File

@ -5,21 +5,26 @@ math.parser assocs new-slots regexp fry unicode.categories
combinators.cleave sequences ;
IN: http.server.validators
SYMBOL: validation-failed?
TUPLE: validation-error value reason ;
: validation-error ( value reason -- * )
\ validation-error construct-boa throw ;
C: <validation-error> validation-error
: with-validator ( value quot -- result )
[ validation-failed? on <validation-error> ] recover ;
inline
: v-default ( str def -- str )
over empty? spin ? ;
: v-required ( str -- str )
dup empty? [ "required" validation-error ] when ;
dup empty? [ "required" throw ] when ;
: v-min-length ( str n -- str )
over length over < [
[ "must be at least " % # " characters" % ] "" make
validation-error
throw
] [
drop
] if ;
@ -27,35 +32,34 @@ TUPLE: validation-error value reason ;
: v-max-length ( str n -- str )
over length over > [
[ "must be no more than " % # " characters" % ] "" make
validation-error
throw
] [
drop
] if ;
: v-number ( str -- n )
dup string>number [ ] [
"must be a number" validation-error
] ?if ;
dup string>number [ ] [ "must be a number" throw ] ?if ;
: v-integer ( n -- n )
dup integer? [ "must be an integer" throw ] unless ;
: v-min-value ( x n -- x )
2dup < [
[ "must be at least " % # ] "" make
validation-error
[ "must be at least " % # ] "" make throw
] [
drop
] if ;
: v-max-value ( x n -- x )
2dup > [
[ "must be no more than " % # ] "" make
validation-error
[ "must be no more than " % # ] "" make throw
] [
drop
] if ;
: v-regexp ( str what regexp -- str )
>r over r> matches?
[ drop ] [ "invalid " swap append validation-error ] if ;
[ drop ] [ "invalid " swap append throw ] if ;
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
@ -64,12 +68,12 @@ TUPLE: validation-error value reason ;
v-regexp ;
: v-captcha ( str -- str )
dup empty? [ "must remain blank" validation-error ] unless ;
dup empty? [ "must remain blank" throw ] unless ;
: v-one-line ( str -- str )
dup "\r\n" seq-intersect empty?
[ "must be a single line" validation-error ] unless ;
[ "must be a single line" throw ] unless ;
: v-one-word ( str -- str )
dup [ alpha? ] all?
[ "must be a single word" validation-error ] unless ;
[ "must be a single word" throw ] unless ;

View File

@ -0,0 +1,9 @@
USING: io.encodings.string io.encodings.ascii tools.test strings arrays ;
IN: io.encodings.ascii.tests
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test
[ { 128 } >string ascii encode ] must-fail
[ B{ 127 } ] [ { 127 } ascii encode ] unit-test
[ "bar" ] [ "bar" ascii decode ] unit-test
[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test

View File

@ -3,13 +3,16 @@
USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ;
IN: io.encodings.ascii
: encode-check<= ( string stream max -- )
: encode-check< ( string stream max -- )
[ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ;
: push-if< ( sbuf character max -- )
over <= [ drop HEX: fffd ] when swap push ;
TUPLE: ascii ;
M: ascii stream-write-encoded ( string stream encoding -- )
drop 128 encode-check<= ;
drop 128 encode-check< ;
M: ascii decode-step
drop dup 128 >= [ decode-error ] [ swap push ] if ;
drop 128 push-if< ;

View File

@ -0,0 +1,9 @@
USING: io.encodings.string io.encodings.latin1 tools.test strings arrays ;
IN: io.encodings.latin1.tests
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
[ { 256 } >string latin1 encode ] must-fail
[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test
[ "bar" ] [ "bar" latin1 decode ] unit-test
[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test

View File

@ -6,7 +6,7 @@ IN: io.encodings.latin1
TUPLE: latin1 ;
M: latin1 stream-write-encoded
drop 256 encode-check<= ;
drop 256 encode-check< ;
M: latin1 decode-step
drop swap push ;

4
extra/io/mmap/mmap-tests.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ IN: io.mmap.tests
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] 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
[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors

View File

@ -1,15 +1,15 @@
! 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
io.encodings.binary ;
unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators combinators.cleave
calendar io.encodings.binary ;
IN: io.unix.files
M: unix-io cwd
MAXPATHLEN dup <byte-array> swap
getcwd [ (io-error) ] unless* ;
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
[ (io-error) ] unless* ;
M: unix-io cd
chdir io-error ;
@ -68,7 +68,9 @@ M: unix-io delete-directory ( path -- )
] with-disposal ;
M: unix-io copy-file ( from to -- )
[ (copy-file) ] 2keep swap file-permissions chmod io-error ;
[ (copy-file) ]
[ swap file-info file-info-permissions chmod io-error ]
2bi ;
: stat>type ( stat -- type )
stat-st_mode {
@ -82,8 +84,8 @@ M: unix-io copy-file ( from to -- )
{ [ t ] [ +unknown+ ] }
} cond nip ;
M: unix-io file-info ( path -- info )
stat* {
: stat>file-info ( stat -- info )
{
[ stat>type ]
[ stat-st_size ]
[ stat-st_mode ]
@ -91,11 +93,8 @@ M: unix-io file-info ( path -- info )
} cleave
\ file-info construct-boa ;
M: unix-io file-info ( path -- info )
stat* stat>file-info ;
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 ;
lstat* stat>file-info ;

View File

@ -1,5 +1,5 @@
IN: io.unix.freebsd
USING: io.unix.bsd io.backend core-foundation.fsevents ;
USING: io.unix.bsd io.backend ;
TUPLE: freebsd-io ;

View File

@ -4,4 +4,4 @@ combinators namespaces system vocabs.loader sequences ;
"io.unix." os append require
"vocabs.monitor" require
"tools.vocabs.monitor" require

50
extra/io/windows/files/files.factor Normal file → Executable file
View File

@ -3,43 +3,35 @@
USING: alien.c-types io.files io.windows kernel
math windows windows.kernel32 combinators.cleave
windows.time calendar combinators math.functions
sequences combinators.lib combinators.cleave
namespaces words symbols ;
sequences namespaces words symbols ;
IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+
+directory+ +archive+ +device+ +normal+ +temporary+
+archive+ +device+ +normal+ +temporary+
+sparse-file+ +reparse-point+ +compressed+ +offline+
+not-content-indexed+ +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 cleave
] { } make ;
: win32-file-attribute ( n attr symbol -- n )
>r dupd mask? [ r> , ] [ r> drop ] if ;
: 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 ;
[
FILE_ATTRIBUTE_READONLY +read-only+ win32-file-attribute
FILE_ATTRIBUTE_HIDDEN +hidden+ win32-file-attribute
FILE_ATTRIBUTE_SYSTEM +system+ win32-file-attribute
FILE_ATTRIBUTE_DIRECTORY +directory+ win32-file-attribute
FILE_ATTRIBUTE_ARCHIVE +archive+ win32-file-attribute
FILE_ATTRIBUTE_DEVICE +device+ win32-file-attribute
FILE_ATTRIBUTE_NORMAL +normal+ win32-file-attribute
FILE_ATTRIBUTE_TEMPORARY +temporary+ win32-file-attribute
FILE_ATTRIBUTE_SPARSE_FILE +sparse-file+ win32-file-attribute
FILE_ATTRIBUTE_REPARSE_POINT +reparse-point+ win32-file-attribute
FILE_ATTRIBUTE_COMPRESSED +compressed+ win32-file-attribute
FILE_ATTRIBUTE_OFFLINE +offline+ win32-file-attribute
FILE_ATTRIBUTE_NOT_CONTENT_INDEXED +not-content-indexed+ win32-file-attribute
FILE_ATTRIBUTE_ENCRYPTED +encrypted+ win32-file-attribute
drop
] { } make ;
: win32-file-type ( n -- symbol )
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;

View File

@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking
io.streams.duplex windows.types math windows.kernel32 windows
namespaces io.launcher kernel sequences windows.errors assocs
splitting system threads init strings combinators
io.backend new-slots accessors ;
io.backend new-slots accessors concurrency.flags ;
IN: io.windows.launcher
TUPLE: CreateProcess-args
@ -137,18 +137,18 @@ M: windows-io kill-process* ( handle -- )
dup HEX: ffffffff = [ win32-error ] when
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
SYMBOL: wait-flag
: wait-loop ( -- )
processes get dup assoc-empty?
[ drop f sleep-until ]
[ drop wait-flag get-global lower-flag ]
[ wait-for-processes [ 100 sleep ] when ] if ;
SYMBOL: wait-thread
: start-wait-thread ( -- )
[ wait-loop t ] "Process wait" spawn-server
wait-thread set-global ;
<flag> wait-flag set-global
[ wait-loop t ] "Process wait" spawn-server drop ;
M: windows-io register-process
drop wait-thread get-global interrupt ;
drop wait-flag get-global raise-flag ;
[ start-wait-thread ] "io.windows.launcher" add-init-hook

View File

@ -14,4 +14,4 @@ USE: io.backend
T{ windows-nt-io } set-io-backend
"vocabs.monitor" require
"tools.vocabs.monitor" require

View File

@ -76,11 +76,8 @@ M: win32-file close-handle ( handle -- )
] when drop ;
: open-append ( path -- handle length )
dup file-length dup [
>r (open-append) r> 2dup set-file-pointer
] [
drop open-write
] if ;
[ dup file-info file-info-size ] [ drop 0 ] recover
>r (open-append) r> 2dup set-file-pointer ;
TUPLE: FileArgs
hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;

2
extra/jamshred/jamshred.factor Normal file → Executable file
View File

@ -59,7 +59,7 @@ M: jamshred-gadget ungraft* ( gadget -- )
USE: vocabs.loader
jamshred-gadget H{
{ T{ key-down f f "r" } [ jamshred-restart refresh-all ] }
{ T{ key-down f f "r" } [ jamshred-restart ] }
{ T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] }
{ T{ motion } [ handle-mouse-motion ] }
} set-gestures

View File

@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ;
IN: ldap.libldap
<< "libldap" {
{ [ win32? ] [ "libldap.dll" "stdcall" ] }
{ [ win32? ] [ "libldap.dll" "stdcall" ] }
{ [ macosx? ] [ "libldap.dylib" "cdecl" ] }
{ [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] }
{ [ unix? ] [ "libldap.so" "cdecl" ] }
} cond add-library >>
: LDAP_VERSION1 1 ; inline

Some files were not shown because too many files have changed in this diff Show More