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.factordb4
Joe Groff
commit
6f89d7921b
4
Makefile
4
Makefile
|
|
@ -46,10 +46,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||||
EXE_OBJS = $(PLAF_EXE_OBJS)
|
EXE_OBJS = $(PLAF_EXE_OBJS)
|
||||||
|
|
||||||
default: misc/wordsize
|
default: misc/wordsize
|
||||||
make `./misc/target`
|
$(MAKE) `./misc/target`
|
||||||
|
|
||||||
help:
|
help:
|
||||||
@echo "Run 'make' with one of the following parameters:"
|
@echo "Run '$(MAKE)' with one of the following parameters:"
|
||||||
@echo ""
|
@echo ""
|
||||||
@echo "freebsd-x86-32"
|
@echo "freebsd-x86-32"
|
||||||
@echo "freebsd-x86-64"
|
@echo "freebsd-x86-64"
|
||||||
|
|
|
||||||
|
|
@ -98,26 +98,36 @@ H{ } clone class<map set
|
||||||
H{ } clone update-map set
|
H{ } clone update-map set
|
||||||
|
|
||||||
! Builtin classes
|
! 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? ,
|
\ tag-mask get < \ tag \ type ? , , \ eq? ,
|
||||||
] [ ] make define-predicate* ;
|
] [ ] make ;
|
||||||
|
|
||||||
: register-builtin ( class -- )
|
: define-builtin-predicate ( class -- )
|
||||||
dup "type" word-prop builtins get set-nth ;
|
dup
|
||||||
|
dup builtin-predicate-quot define-predicate
|
||||||
|
predicate-word make-inline ;
|
||||||
|
|
||||||
: lookup-type-number ( word -- n )
|
: lookup-type-number ( word -- n )
|
||||||
global [ target-word ] bind type-number ;
|
global [ target-word ] bind type-number ;
|
||||||
|
|
||||||
: define-builtin ( symbol predicate slotspec -- )
|
: register-builtin ( class -- )
|
||||||
>r dup make-inline >r
|
dup
|
||||||
dup dup lookup-type-number "type" set-word-prop
|
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 f f builtin-class define-class
|
||||||
dup r> builtin-predicate
|
dup define-builtin-predicate
|
||||||
dup r> 1 simple-slots 2dup "slots" set-word-prop
|
r> define-builtin-slots ;
|
||||||
dupd define-slots
|
|
||||||
register-builtin ;
|
|
||||||
|
|
||||||
H{ } clone typemap set
|
H{ } clone typemap set
|
||||||
num-types get f <array> builtins set
|
num-types get f <array> builtins set
|
||||||
|
|
@ -128,17 +138,15 @@ num-types get f <array> builtins set
|
||||||
|
|
||||||
"null" "kernel" create drop
|
"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
|
"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
|
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
|
||||||
|
|
||||||
"tuple" "kernel" create "tuple?" "kernel" create
|
"tuple" "kernel" create { } define-builtin
|
||||||
{ } define-builtin
|
|
||||||
|
|
||||||
"ratio" "math" create "ratio?" "math" create
|
"ratio" "math" create {
|
||||||
{
|
|
||||||
{
|
{
|
||||||
{ "integer" "math" }
|
{ "integer" "math" }
|
||||||
"numerator"
|
"numerator"
|
||||||
|
|
@ -153,11 +161,10 @@ num-types get f <array> builtins set
|
||||||
}
|
}
|
||||||
} define-builtin
|
} 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
|
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
|
||||||
|
|
||||||
"complex" "math" create "complex?" "math" create
|
"complex" "math" create {
|
||||||
{
|
|
||||||
{
|
{
|
||||||
{ "real" "math" }
|
{ "real" "math" }
|
||||||
"real-part"
|
"real-part"
|
||||||
|
|
@ -172,14 +179,13 @@ num-types get f <array> builtins set
|
||||||
}
|
}
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
"f" "syntax" lookup "not" "kernel" create
|
"f" "syntax" lookup { } define-builtin
|
||||||
{ } define-builtin
|
|
||||||
|
|
||||||
"array" "arrays" create "array?" "arrays" create
|
! do not word...
|
||||||
{ } define-builtin
|
|
||||||
|
|
||||||
"wrapper" "kernel" create "wrapper?" "kernel" create
|
"array" "arrays" create { } define-builtin
|
||||||
{
|
|
||||||
|
"wrapper" "kernel" create {
|
||||||
{
|
{
|
||||||
{ "object" "kernel" }
|
{ "object" "kernel" }
|
||||||
"wrapped"
|
"wrapped"
|
||||||
|
|
@ -188,8 +194,7 @@ num-types get f <array> builtins set
|
||||||
}
|
}
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
"string" "strings" create "string?" "strings" create
|
"string" "strings" create {
|
||||||
{
|
|
||||||
{
|
{
|
||||||
{ "array-capacity" "sequences.private" }
|
{ "array-capacity" "sequences.private" }
|
||||||
"length"
|
"length"
|
||||||
|
|
@ -203,8 +208,7 @@ num-types get f <array> builtins set
|
||||||
}
|
}
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
"quotation" "quotations" create "quotation?" "quotations" create
|
"quotation" "quotations" create {
|
||||||
{
|
|
||||||
{
|
{
|
||||||
{ "object" "kernel" }
|
{ "object" "kernel" }
|
||||||
"array"
|
"array"
|
||||||
|
|
@ -219,8 +223,7 @@ num-types get f <array> builtins set
|
||||||
}
|
}
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
"dll" "alien" create "dll?" "alien" create
|
"dll" "alien" create {
|
||||||
{
|
|
||||||
{
|
{
|
||||||
{ "byte-array" "byte-arrays" }
|
{ "byte-array" "byte-arrays" }
|
||||||
"path"
|
"path"
|
||||||
|
|
@ -230,8 +233,7 @@ num-types get f <array> builtins set
|
||||||
}
|
}
|
||||||
define-builtin
|
define-builtin
|
||||||
|
|
||||||
"alien" "alien" create "alien?" "alien" create
|
"alien" "alien" create {
|
||||||
{
|
|
||||||
{
|
{
|
||||||
{ "c-ptr" "alien" }
|
{ "c-ptr" "alien" }
|
||||||
"alien"
|
"alien"
|
||||||
|
|
@ -246,8 +248,7 @@ define-builtin
|
||||||
}
|
}
|
||||||
define-builtin
|
define-builtin
|
||||||
|
|
||||||
"word" "words" create "word?" "words" create
|
"word" "words" create {
|
||||||
{
|
|
||||||
f
|
f
|
||||||
{
|
{
|
||||||
{ "object" "kernel" }
|
{ "object" "kernel" }
|
||||||
|
|
@ -287,26 +288,25 @@ define-builtin
|
||||||
}
|
}
|
||||||
} 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
|
"callstack" "kernel" create { } define-builtin
|
||||||
{ } define-builtin
|
|
||||||
|
|
||||||
! Define general-t type, which is any object that is not f.
|
! Define general-t type, which is any object that is not f.
|
||||||
"general-t" "kernel" create
|
"general-t" "kernel" create
|
||||||
"f" "syntax" lookup builtins get remove [ ] subset f union-class
|
"f" "syntax" lookup builtins get remove [ ] subset f union-class
|
||||||
define-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.
|
! Catch-all class for providing a default method.
|
||||||
"object" "kernel" create [ drop t ] "predicate" set-word-prop
|
"object" "kernel" create [ drop t ] "predicate" set-word-prop
|
||||||
"object" "kernel" create
|
"object" "kernel" create
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
USING: help.markup help.syntax kernel kernel.private
|
USING: help.markup help.syntax kernel kernel.private
|
||||||
namespaces sequences words arrays layouts help effects math
|
namespaces sequences words arrays layouts help effects math
|
||||||
layouts classes.private classes.union classes.mixin
|
layouts classes.private classes.union classes.mixin
|
||||||
classes.predicate ;
|
classes.predicate quotations ;
|
||||||
IN: classes
|
IN: classes
|
||||||
|
|
||||||
ARTICLE: "builtin-classes" "Built-in classes"
|
ARTICLE: "builtin-classes" "Built-in classes"
|
||||||
|
|
@ -114,24 +114,9 @@ HELP: predicate-word
|
||||||
{ $values { "word" "a word" } { "predicate" "a 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." } ;
|
{ $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
|
HELP: define-predicate
|
||||||
{ $values { "class" class } { "quot" "a quotation" } }
|
{ $values { "class" class } { "quot" quotation } }
|
||||||
{ $description
|
{ $description "Defines a predicate word for a class." }
|
||||||
"Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "."
|
|
||||||
}
|
|
||||||
$low-level-note ;
|
$low-level-note ;
|
||||||
|
|
||||||
HELP: superclass
|
HELP: superclass
|
||||||
|
|
|
||||||
|
|
@ -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
|
[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
|
||||||
|
|
||||||
DEFER: mixin-forget-test-g
|
2 [
|
||||||
|
[ "mixin-forget-test" forget-source ] with-compilation-unit
|
||||||
|
|
||||||
[ "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: 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" "classes.tests" lookup execute ] must-fail
|
||||||
{
|
[ H{ } ] [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
|
||||||
"USING: hashtables ;"
|
] times
|
||||||
"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
|
|
||||||
|
|
||||||
! Method flattening interfered with mixin update
|
! Method flattening interfered with mixin update
|
||||||
MIXIN: flat-mx-1
|
MIXIN: flat-mx-1
|
||||||
|
|
|
||||||
|
|
@ -31,17 +31,9 @@ PREDICATE: class tuple-class
|
||||||
|
|
||||||
PREDICATE: word predicate "predicating" word-prop >boolean ;
|
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 -- )
|
: define-predicate ( class quot -- )
|
||||||
over "forgotten" word-prop [ 2drop ] [
|
>r "predicate" word-prop first
|
||||||
>r dup predicate-word r> define-predicate*
|
r> predicate-effect define-declared ;
|
||||||
] if ;
|
|
||||||
|
|
||||||
: superclass ( class -- super )
|
: superclass ( class -- super )
|
||||||
"superclass" word-prop ;
|
"superclass" word-prop ;
|
||||||
|
|
@ -257,6 +249,8 @@ PRIVATE>
|
||||||
over reset-class
|
over reset-class
|
||||||
over deferred? [ over define-symbol ] when
|
over deferred? [ over define-symbol ] when
|
||||||
>r dup word-props r> union over set-word-props
|
>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 ;
|
t "class" set-word-prop ;
|
||||||
|
|
||||||
GENERIC: update-predicate ( class -- )
|
GENERIC: update-predicate ( class -- )
|
||||||
|
|
|
||||||
|
|
@ -9,7 +9,7 @@ ARTICLE: "compiler-errors" "Compiler warnings and errors"
|
||||||
{ $subsection :errors }
|
{ $subsection :errors }
|
||||||
{ $subsection :warnings }
|
{ $subsection :warnings }
|
||||||
{ $subsection :linkage }
|
{ $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 } ;
|
{ $link with-compiler-errors } ;
|
||||||
|
|
||||||
HELP: compiler-errors
|
HELP: compiler-errors
|
||||||
|
|
|
||||||
|
|
@ -29,7 +29,9 @@ $nl
|
||||||
{ $subsection ignore-errors }
|
{ $subsection ignore-errors }
|
||||||
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
|
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
|
||||||
{ $subsection "errors-restartable" }
|
{ $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"
|
ARTICLE: "continuations.private" "Continuation implementation details"
|
||||||
"A continuation is simply a tuple holding the contents of the five stacks:"
|
"A continuation is simply a tuple holding the contents of the five stacks:"
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
USING: help.markup help.syntax io io.styles strings
|
USING: help.markup help.syntax io io.styles strings
|
||||||
io.backend io.files.private quotations ;
|
io.backend io.files.private quotations ;
|
||||||
IN: io.files
|
IN: io.files
|
||||||
|
|
||||||
ARTICLE: "file-streams" "Reading and writing files"
|
ARTICLE: "file-streams" "Reading and writing files"
|
||||||
|
|
@ -43,13 +43,19 @@ ARTICLE: "directories" "Directories"
|
||||||
{ $subsection make-directory }
|
{ $subsection make-directory }
|
||||||
{ $subsection make-directories } ;
|
{ $subsection make-directories } ;
|
||||||
|
|
||||||
|
! ARTICLE: "file-types" "File Types"
|
||||||
|
|
||||||
|
! { $table { +directory+ "" } }
|
||||||
|
|
||||||
|
! ;
|
||||||
|
|
||||||
ARTICLE: "fs-meta" "File meta-data"
|
ARTICLE: "fs-meta" "File meta-data"
|
||||||
|
|
||||||
{ $subsection file-info }
|
{ $subsection file-info }
|
||||||
{ $subsection link-info }
|
{ $subsection link-info }
|
||||||
{ $subsection exists? }
|
{ $subsection exists? }
|
||||||
{ $subsection directory? }
|
{ $subsection directory? }
|
||||||
{ $subsection file-length }
|
! { $subsection file-modified }
|
||||||
{ $subsection file-modified }
|
|
||||||
{ $subsection stat } ;
|
{ $subsection stat } ;
|
||||||
|
|
||||||
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
|
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
|
||||||
|
|
@ -119,11 +125,26 @@ HELP: file-name
|
||||||
! need a $class-description file-info
|
! need a $class-description file-info
|
||||||
|
|
||||||
HELP: file-info
|
HELP: file-info
|
||||||
|
|
||||||
{ $values { "path" "a pathname string" }
|
{ $values { "path" "a pathname string" }
|
||||||
{ "info" "a file-info tuple" } }
|
{ "info" file-info } }
|
||||||
{ $description "Queries the file system for meta data. "
|
{ $description "Queries the file system for meta data. "
|
||||||
"If path refers to a symbolic link, it is followed."
|
"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
|
! need a see also to link-info
|
||||||
|
|
||||||
HELP: link-info
|
HELP: link-info
|
||||||
|
|
@ -135,6 +156,8 @@ HELP: link-info
|
||||||
"If the file does not exist, an exception is thrown." } ;
|
"If the file does not exist, an exception is thrown." } ;
|
||||||
! need a see also to file-info
|
! need a see also to file-info
|
||||||
|
|
||||||
|
{ file-info link-info } related-words
|
||||||
|
|
||||||
HELP: <file-reader>
|
HELP: <file-reader>
|
||||||
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
|
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
|
||||||
{ "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."
|
"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+
|
HELP: path+
|
||||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
|
{ $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" } "." }
|
{ $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." } ;
|
{ $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ;
|
||||||
|
|
||||||
HELP: file-length
|
! HELP: file-modified
|
||||||
{ $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
|
! { $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." } ;
|
! { $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
|
HELP: resource-path
|
||||||
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
|
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,10 @@
|
||||||
IN: io.files.tests
|
IN: io.files.tests
|
||||||
USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
|
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
|
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
|
||||||
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
|
[ "awk" ] [ "/usr/libexec/awk/" 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
|
[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
|
||||||
|
|
||||||
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] 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
|
||||||
|
|
|
||||||
|
|
@ -86,15 +86,17 @@ SYMBOL: +unknown+
|
||||||
: stat ( path -- directory? permissions length modified )
|
: stat ( path -- directory? permissions length modified )
|
||||||
normalize-pathname (stat) ;
|
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-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 ;
|
: exists? ( path -- ? ) file-modified >boolean ;
|
||||||
|
|
||||||
: directory? ( path -- ? ) stat 3drop ;
|
! : directory? ( path -- ? ) stat 3drop ;
|
||||||
|
|
||||||
|
: directory? ( path -- ? ) file-info file-info-type +directory+ = ;
|
||||||
|
|
||||||
! Current working directory
|
! Current working directory
|
||||||
HOOK: cd io-backend ( path -- )
|
HOOK: cd io-backend ( path -- )
|
||||||
|
|
@ -220,7 +222,10 @@ M: pathname <=> [ pathname-string ] compare ;
|
||||||
>r <file-reader> r> with-stream ; inline
|
>r <file-reader> r> with-stream ; inline
|
||||||
|
|
||||||
: file-contents ( path encoding -- str )
|
: 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 -- )
|
: with-file-writer ( path encoding quot -- )
|
||||||
>r <file-writer> r> with-stream ; inline
|
>r <file-writer> r> with-stream ; inline
|
||||||
|
|
|
||||||
|
|
@ -429,7 +429,14 @@ $nl
|
||||||
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ;
|
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ;
|
||||||
|
|
||||||
HELP: die
|
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 )
|
HELP: (clone) ( obj -- newobj )
|
||||||
{ $values { "obj" object } { "newobj" "a shallow copy" } }
|
{ $values { "obj" object } { "newobj" "a shallow copy" } }
|
||||||
|
|
|
||||||
|
|
@ -430,3 +430,20 @@ IN: parser.tests
|
||||||
[ "resource:core/parser/test/assert-depth.factor" run-file ]
|
[ "resource:core/parser/test/assert-depth.factor" run-file ]
|
||||||
[ relative-overflow-stack { 1 2 3 } sequence= ]
|
[ relative-overflow-stack { 1 2 3 } sequence= ]
|
||||||
must-fail-with
|
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
|
||||||
|
|
|
||||||
|
|
@ -416,6 +416,7 @@ SYMBOL: interactive-vocabs
|
||||||
"tools.test"
|
"tools.test"
|
||||||
"tools.threads"
|
"tools.threads"
|
||||||
"tools.time"
|
"tools.time"
|
||||||
|
"tools.vocabs"
|
||||||
"vocabs"
|
"vocabs"
|
||||||
"vocabs.loader"
|
"vocabs.loader"
|
||||||
"words"
|
"words"
|
||||||
|
|
@ -483,7 +484,6 @@ SYMBOL: interactive-vocabs
|
||||||
: finish-parsing ( lines quot -- )
|
: finish-parsing ( lines quot -- )
|
||||||
file get
|
file get
|
||||||
[ record-form ] keep
|
[ record-form ] keep
|
||||||
[ record-modified ] keep
|
|
||||||
[ record-definitions ] keep
|
[ record-definitions ] keep
|
||||||
record-checksum ;
|
record-checksum ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -3,16 +3,13 @@ definitions quotations compiler.units ;
|
||||||
IN: source-files
|
IN: source-files
|
||||||
|
|
||||||
ARTICLE: "source-files" "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
|
$nl
|
||||||
"The source file database:"
|
"The source file database:"
|
||||||
{ $subsection source-files }
|
{ $subsection source-files }
|
||||||
"The class of source files:"
|
"The class of source files:"
|
||||||
{ $subsection source-file }
|
{ $subsection source-file }
|
||||||
"Testing if a source file has been changed on disk:"
|
|
||||||
{ $subsection source-modified? }
|
|
||||||
"Words intended for the parser:"
|
"Words intended for the parser:"
|
||||||
{ $subsection record-modified }
|
|
||||||
{ $subsection record-checksum }
|
{ $subsection record-checksum }
|
||||||
{ $subsection record-form }
|
{ $subsection record-form }
|
||||||
{ $subsection xref-source }
|
{ $subsection xref-source }
|
||||||
|
|
@ -34,22 +31,12 @@ HELP: source-file
|
||||||
{ $class-description "Instances retain information about loaded source files, and have the following slots:"
|
{ $class-description "Instances retain information about loaded source files, and have the following slots:"
|
||||||
{ $list
|
{ $list
|
||||||
{ { $link source-file-path } " - a pathname string." }
|
{ { $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-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-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" }
|
{ { $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
|
HELP: record-checksum
|
||||||
{ $values { "source-file" source-file } { "lines" "a sequence of strings" } }
|
{ $values { "source-file" source-file } { "lines" "a sequence of strings" } }
|
||||||
{ $description "Records the CRC32 checksm of the source file's contents." }
|
{ $description "Records the CRC32 checksm of the source file's contents." }
|
||||||
|
|
@ -75,7 +62,7 @@ HELP: record-form
|
||||||
$low-level-note ;
|
$low-level-note ;
|
||||||
|
|
||||||
HELP: reset-checksums
|
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
|
HELP: forget-source
|
||||||
{ $values { "path" "a pathname string" } }
|
{ $values { "path" "a pathname string" } }
|
||||||
|
|
|
||||||
|
|
@ -1,44 +1,25 @@
|
||||||
! Copyright (C) 2007 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays definitions generic assocs kernel math
|
USING: arrays definitions generic assocs kernel math namespaces
|
||||||
namespaces prettyprint sequences strings vectors words
|
prettyprint sequences strings vectors words quotations inspector
|
||||||
quotations inspector io.styles io combinators sorting
|
io.styles io combinators sorting splitting math.parser effects
|
||||||
splitting math.parser effects continuations debugger
|
continuations debugger io.files io.crc32 vocabs hashtables
|
||||||
io.files io.crc32 io.streams.string vocabs
|
graphs compiler.units io.encodings.utf8 ;
|
||||||
hashtables graphs compiler.units io.encodings.utf8 ;
|
|
||||||
IN: source-files
|
IN: source-files
|
||||||
|
|
||||||
SYMBOL: source-files
|
SYMBOL: source-files
|
||||||
|
|
||||||
TUPLE: source-file
|
TUPLE: source-file
|
||||||
path
|
path
|
||||||
modified checksum
|
checksum
|
||||||
uses definitions ;
|
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 -- )
|
: 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 )
|
: (xref-source) ( source-file -- pathname uses )
|
||||||
dup source-file-path <pathname> swap source-file-uses
|
dup source-file-path <pathname>
|
||||||
[ crossref? ] subset ;
|
swap source-file-uses [ crossref? ] subset ;
|
||||||
|
|
||||||
: xref-source ( source-file -- )
|
: xref-source ( source-file -- )
|
||||||
(xref-source) crossref get add-vertex ;
|
(xref-source) crossref get add-vertex ;
|
||||||
|
|
@ -67,9 +48,7 @@ uses definitions ;
|
||||||
|
|
||||||
: reset-checksums ( -- )
|
: reset-checksums ( -- )
|
||||||
source-files get [
|
source-files get [
|
||||||
swap ?resource-path dup exists?
|
swap ?resource-path dup exists? [
|
||||||
[
|
|
||||||
over record-modified
|
|
||||||
utf8 file-lines swap record-checksum
|
utf8 file-lines swap record-checksum
|
||||||
] [ 2drop ] if
|
] [ 2drop ] if
|
||||||
] assoc-each ;
|
] assoc-each ;
|
||||||
|
|
|
||||||
|
|
@ -23,9 +23,6 @@ $nl
|
||||||
"Application vocabularies can define a main entry point, giving the user a convenient way to run the application:"
|
"Application vocabularies can define a main entry point, giving the user a convenient way to run the application:"
|
||||||
{ $subsection POSTPONE: MAIN: }
|
{ $subsection POSTPONE: MAIN: }
|
||||||
{ $subsection run }
|
{ $subsection run }
|
||||||
"Reloading source files changed on disk:"
|
|
||||||
{ $subsection refresh }
|
|
||||||
{ $subsection refresh-all }
|
|
||||||
{ $see-also "vocabularies" "parser-files" "source-files" } ;
|
{ $see-also "vocabularies" "parser-files" "source-files" } ;
|
||||||
|
|
||||||
ABOUT: "vocabs.loader"
|
ABOUT: "vocabs.loader"
|
||||||
|
|
@ -42,20 +39,12 @@ HELP: vocab-main
|
||||||
HELP: vocab-roots
|
HELP: vocab-roots
|
||||||
{ $var-description "A sequence of pathname strings to search for vocabularies." } ;
|
{ $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
|
HELP: find-vocab-root
|
||||||
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
|
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
|
||||||
{ $description "Searches for a vocabulary in the vocabulary roots." } ;
|
{ $description "Searches for a vocabulary in the vocabulary roots." } ;
|
||||||
|
|
||||||
{ vocab-root find-vocab-root } related-words
|
{ 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
|
HELP: no-vocab
|
||||||
{ $values { "name" "a vocabulary name" } }
|
{ $values { "name" "a vocabulary name" } }
|
||||||
{ $description "Throws a " { $link no-vocab } "." }
|
{ $description "Throws a " { $link no-vocab } "." }
|
||||||
|
|
@ -80,7 +69,7 @@ HELP: reload
|
||||||
HELP: require
|
HELP: require
|
||||||
{ $values { "vocab" "a vocabulary specifier" } }
|
{ $values { "vocab" "a vocabulary specifier" } }
|
||||||
{ $description "Loads a vocabulary if it has not already been loaded." }
|
{ $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
|
HELP: run
|
||||||
{ $values { "vocab" "a vocabulary specifier" } }
|
{ $values { "vocab" "a vocabulary specifier" } }
|
||||||
|
|
@ -93,12 +82,3 @@ HELP: vocab-source-path
|
||||||
HELP: vocab-docs-path
|
HELP: vocab-docs-path
|
||||||
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string or " { $link f } } }
|
{ $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." } ;
|
{ $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
|
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@ IN: vocabs.loader.tests
|
||||||
USING: vocabs.loader tools.test continuations vocabs math
|
USING: vocabs.loader tools.test continuations vocabs math
|
||||||
kernel arrays sequences namespaces io.streams.string
|
kernel arrays sequences namespaces io.streams.string
|
||||||
parser source-files words assocs tuples definitions
|
parser source-files words assocs tuples definitions
|
||||||
debugger compiler.units ;
|
debugger compiler.units tools.vocabs ;
|
||||||
|
|
||||||
! This vocab should not exist, but just in case...
|
! This vocab should not exist, but just in case...
|
||||||
[ ] [
|
[ ] [
|
||||||
|
|
|
||||||
|
|
@ -48,27 +48,6 @@ M: string vocab-root
|
||||||
M: vocab-link vocab-root
|
M: vocab-link vocab-root
|
||||||
vocab-link-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?
|
SYMBOL: load-help?
|
||||||
|
|
||||||
: source-was-loaded t swap set-vocab-source-loaded? ;
|
: source-was-loaded t swap set-vocab-source-loaded? ;
|
||||||
|
|
@ -119,68 +98,7 @@ SYMBOL: load-help?
|
||||||
"To define one, refer to \\ MAIN: help" print
|
"To define one, refer to \\ MAIN: help" print
|
||||||
] ?if ;
|
] ?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: 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 )
|
GENERIC: (load-vocab) ( name -- vocab )
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
USING: assocs kernel vectors sequences namespaces ;
|
USING: arrays assocs kernel vectors sequences namespaces
|
||||||
|
random math.parser ;
|
||||||
IN: assocs.lib
|
IN: assocs.lib
|
||||||
|
|
||||||
: >set ( seq -- hash )
|
: >set ( seq -- hash )
|
||||||
|
|
@ -35,3 +36,13 @@ IN: assocs.lib
|
||||||
[ with each ] curry assoc-each ; inline
|
[ with each ] curry assoc-each ; inline
|
||||||
|
|
||||||
: insert ( value variable -- ) namespace insert-at ;
|
: 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 ;
|
||||||
|
|
|
||||||
|
|
@ -1,28 +1,28 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
arrays assocs io.styles io help.markup prettyprint sequences
|
||||||
continuations debugger ;
|
continuations debugger combinators.cleave ;
|
||||||
IN: benchmark
|
IN: benchmark
|
||||||
|
|
||||||
: run-benchmark ( vocab -- result )
|
: 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 )
|
: run-benchmarks ( -- assoc )
|
||||||
"benchmark" all-child-vocabs values concat [ vocab-name ] map
|
"benchmark" all-child-vocabs-seq
|
||||||
[ dup run-benchmark ] { } map>assoc ;
|
[ dup run-benchmark ] { } map>assoc ;
|
||||||
|
|
||||||
: benchmarks. ( assoc -- )
|
: benchmarks. ( assoc -- )
|
||||||
standard-table-style [
|
standard-table-style [
|
||||||
[
|
[
|
||||||
[ "Benchmark" write ] with-cell
|
[ "Benchmark" write ] with-cell
|
||||||
[ "Run time (ms)" write ] with-cell
|
[ "Time (ms)" write ] with-cell
|
||||||
[ "GC time (ms)" write ] with-cell
|
|
||||||
] with-row
|
] with-row
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
swap [ dup ($vocab-link) ] with-cell
|
[ [ 1array $vocab-link ] with-cell ]
|
||||||
first2 pprint-cell pprint-cell
|
[ pprint-cell ] bi*
|
||||||
] with-row
|
] with-row
|
||||||
] assoc-each
|
] assoc-each
|
||||||
] tabular-output ;
|
] tabular-output ;
|
||||||
|
|
|
||||||
|
|
@ -51,7 +51,7 @@ HINTS: random fixnum ;
|
||||||
dup keys >byte-array
|
dup keys >byte-array
|
||||||
swap values >float-array unclip [ + ] accumulate swap add ;
|
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
|
floats seed random -rot
|
||||||
[ >= ] curry find drop
|
[ >= ] curry find drop
|
||||||
chars nth-unsafe ; inline
|
chars nth-unsafe ; inline
|
||||||
|
|
@ -71,7 +71,7 @@ HINTS: random fixnum ;
|
||||||
write-description
|
write-description
|
||||||
[ make-random-fasta ] 2curry split-lines ; inline
|
[ make-random-fasta ] 2curry split-lines ; inline
|
||||||
|
|
||||||
:: make-repeat-fasta ( k len alu -- )
|
:: make-repeat-fasta ( k len alu -- k' )
|
||||||
[let | kn [ alu length ] |
|
[let | kn [ alu length ] |
|
||||||
len [ k + kn mod alu nth-unsafe ] B{ } map-as print
|
len [ k + kn mod alu nth-unsafe ] B{ } map-as print
|
||||||
k len +
|
k len +
|
||||||
|
|
|
||||||
|
|
@ -11,5 +11,7 @@ USING: vocabs.loader sequences ;
|
||||||
"tools.test"
|
"tools.test"
|
||||||
"tools.time"
|
"tools.time"
|
||||||
"tools.threads"
|
"tools.threads"
|
||||||
|
"tools.vocabs"
|
||||||
|
"tools.vocabs.browser"
|
||||||
"editors"
|
"editors"
|
||||||
} [ require ] each
|
} [ require ] each
|
||||||
|
|
|
||||||
|
|
@ -21,7 +21,7 @@ IN: builder.benchmark
|
||||||
[ benchmark-difference ] with map ;
|
[ benchmark-difference ] with map ;
|
||||||
|
|
||||||
: benchmark-deltas ( -- table )
|
: benchmark-deltas ( -- table )
|
||||||
"../../benchmarks" "../benchmarks" [ eval-file ] 2apply
|
"../benchmarks" "benchmarks" [ eval-file ] 2apply
|
||||||
compare-tables
|
compare-tables
|
||||||
sort-values ;
|
sort-values ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -4,6 +4,7 @@ USING: kernel namespaces sequences splitting system combinators continuations
|
||||||
bootstrap.image benchmark vars bake smtp builder.util accessors
|
bootstrap.image benchmark vars bake smtp builder.util accessors
|
||||||
io.encodings.utf8
|
io.encodings.utf8
|
||||||
calendar
|
calendar
|
||||||
|
tools.test
|
||||||
builder.common
|
builder.common
|
||||||
builder.benchmark
|
builder.benchmark
|
||||||
builder.release ;
|
builder.release ;
|
||||||
|
|
@ -131,7 +132,12 @@ SYMBOL: build-status
|
||||||
"Test time: " write "test-time" eval-file milli-seconds>time print nl
|
"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 load-everything: " print "load-everything-vocabs" cat
|
||||||
|
|
||||||
"Did not pass test-all: " print "test-all-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
|
"help-lint results:" print "help-lint" cat
|
||||||
|
|
||||||
"Benchmarks: " print "benchmarks" eval-file benchmarks.
|
"Benchmarks: " print "benchmarks" eval-file benchmarks.
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@ USING: kernel namespaces sequences assocs builder continuations
|
||||||
io
|
io
|
||||||
io.files
|
io.files
|
||||||
prettyprint
|
prettyprint
|
||||||
tools.browser
|
tools.vocabs
|
||||||
tools.test
|
tools.test
|
||||||
io.encodings.utf8
|
io.encodings.utf8
|
||||||
combinators.cleave
|
combinators.cleave
|
||||||
|
|
@ -21,13 +21,19 @@ IN: builder.test
|
||||||
|
|
||||||
: do-tests ( -- )
|
: do-tests ( -- )
|
||||||
run-all-tests
|
run-all-tests
|
||||||
"../test-all-vocabs" utf8
|
[ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ]
|
||||||
[
|
[ "../test-failures" utf8 [ test-failures. ] with-file-writer ]
|
||||||
[ keys . ]
|
bi ;
|
||||||
[ test-failures. ]
|
|
||||||
bi
|
! : do-tests ( -- )
|
||||||
]
|
! run-all-tests
|
||||||
with-file-writer ;
|
! "../test-all-vocabs" utf8
|
||||||
|
! [
|
||||||
|
! [ keys . ]
|
||||||
|
! [ test-failures. ]
|
||||||
|
! bi
|
||||||
|
! ]
|
||||||
|
! with-file-writer ;
|
||||||
|
|
||||||
: do-help-lint ( -- )
|
: do-help-lint ( -- )
|
||||||
"" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
|
"" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
|
||||||
|
|
|
||||||
|
|
@ -1,12 +1,14 @@
|
||||||
USING: tools.deploy.config ;
|
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-ui? t }
|
||||||
{ deploy-io 3 }
|
{ deploy-io 3 }
|
||||||
{ deploy-reflection 1 }
|
|
||||||
{ deploy-compiler? t }
|
{ deploy-compiler? t }
|
||||||
{ deploy-math? t }
|
{ deploy-word-defs? f }
|
||||||
{ deploy-word-props? f }
|
|
||||||
{ deploy-c-types? f }
|
{ deploy-c-types? f }
|
||||||
{ "stop-after-last-window?" t }
|
|
||||||
{ deploy-name "Bunny" }
|
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
USING: arrays bunny.model bunny.cel-shaded
|
USING: arrays bunny.model bunny.cel-shaded
|
||||||
combinators.cleave continuations kernel math multiline
|
combinators.cleave continuations kernel math multiline
|
||||||
opengl opengl.shaders opengl.framebuffers opengl.gl
|
opengl opengl.shaders opengl.framebuffers opengl.gl
|
||||||
opengl.capabilities sequences ui.gadgets ;
|
opengl.capabilities sequences ui.gadgets combinators.cleave ;
|
||||||
IN: bunny.outlined
|
IN: bunny.outlined
|
||||||
|
|
||||||
STRING: outlined-pass1-fragment-shader-main-source
|
STRING: outlined-pass1-fragment-shader-main-source
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,7 @@
|
||||||
! http://cairographics.org/samples/text/
|
! 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 ;
|
ui.gadgets opengl.gl ;
|
||||||
|
|
||||||
IN: cairo-demo
|
IN: cairo-demo
|
||||||
|
|
@ -22,14 +22,16 @@ IN: cairo-demo
|
||||||
|
|
||||||
TUPLE: cairo-gadget image-array cairo-t ;
|
TUPLE: cairo-gadget image-array cairo-t ;
|
||||||
|
|
||||||
M: cairo-gadget draw-gadget* ( gadget -- )
|
! M: cairo-gadget draw-gadget* ( gadget -- )
|
||||||
0 0 glRasterPos2i
|
! 0 0 glRasterPos2i
|
||||||
1.0 -1.0 glPixelZoom
|
! 1.0 -1.0 glPixelZoom
|
||||||
>r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
|
! >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
|
||||||
cairo-gadget-image-array glDrawPixels ;
|
! cairo-gadget-image-array glDrawPixels ;
|
||||||
|
|
||||||
: create-surface ( gadget -- cairo_surface_t )
|
: 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 )
|
: init-cairo ( gadget -- cairo_t )
|
||||||
create-surface cairo_create ;
|
create-surface cairo_create ;
|
||||||
|
|
@ -56,10 +58,10 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ;
|
||||||
cairo_fill ;
|
cairo_fill ;
|
||||||
|
|
||||||
M: cairo-gadget graft* ( gadget -- )
|
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 -- )
|
! M: cairo-gadget ungraft* ( gadget -- )
|
||||||
cairo-gadget-cairo-t cairo_destroy ;
|
! cairo-gadget-cairo-t cairo_destroy ;
|
||||||
|
|
||||||
: <cairo-gadget> ( -- gadget )
|
: <cairo-gadget> ( -- gadget )
|
||||||
cairo-gadget construct-gadget ;
|
cairo-gadget construct-gadget ;
|
||||||
|
|
|
||||||
|
|
@ -1 +1,2 @@
|
||||||
Sampo Vuori
|
Sampo Vuori
|
||||||
|
Doug Coleman
|
||||||
|
|
|
||||||
|
|
@ -10,7 +10,7 @@
|
||||||
|
|
||||||
USING: alien alien.syntax combinators system ;
|
USING: alien alien.syntax combinators system ;
|
||||||
|
|
||||||
IN: cairo
|
IN: cairo.ffi
|
||||||
|
|
||||||
<< "cairo" {
|
<< "cairo" {
|
||||||
{ [ win32? ] [ "cairo.dll" ] }
|
{ [ win32? ] [ "cairo.dll" ] }
|
||||||
|
|
@ -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 ;
|
||||||
|
|
@ -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 ;
|
||||||
|
|
@ -7,9 +7,18 @@ IN: combinators.cleave
|
||||||
|
|
||||||
ARTICLE: "cleave-combinators" "Cleave Combinators"
|
ARTICLE: "cleave-combinators" "Cleave Combinators"
|
||||||
|
|
||||||
|
"Basic cleavers:"
|
||||||
|
|
||||||
{ $subsection bi }
|
{ $subsection bi }
|
||||||
{ $subsection tri }
|
{ $subsection tri }
|
||||||
|
|
||||||
|
"General cleave: "
|
||||||
|
{ $subsection cleave }
|
||||||
|
|
||||||
|
"Cleave combinators for quotations with arity 2:"
|
||||||
|
{ $subsection 2bi }
|
||||||
|
{ $subsection 2tri }
|
||||||
|
|
||||||
{ $notes
|
{ $notes
|
||||||
"From the Merriam-Webster Dictionary: "
|
"From the Merriam-Webster Dictionary: "
|
||||||
$nl
|
$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"
|
ARTICLE: "spread-combinators" "Spread Combinators"
|
||||||
|
|
||||||
{ $subsection bi* }
|
{ $subsection bi* }
|
||||||
{ $subsection tri* } ;
|
{ $subsection tri* }
|
||||||
|
{ $subsection spread } ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
|
@ -80,3 +100,9 @@ HELP: tri*
|
||||||
{ "p(x)" "p applied to x" }
|
{ "p(x)" "p applied to x" }
|
||||||
{ "q(y)" "q applied to y" }
|
{ "q(y)" "q applied to y" }
|
||||||
{ "r(z)" "r applied to z" } } ;
|
{ "r(z)" "r applied to z" } } ;
|
||||||
|
|
||||||
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
HELP: spread
|
||||||
|
|
||||||
|
{ $code "( v1 v2 ... vN { q1 q2 ... qN } -- q1(v1) q2(v2) ... qN(vN) )" } ;
|
||||||
|
|
@ -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 ]
|
[ drop ]
|
||||||
append ;
|
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
|
! The spread family
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
@ -55,3 +70,29 @@ MACRO: spread ( seq -- )
|
||||||
swap
|
swap
|
||||||
[ [ r> ] swap append ] map concat
|
[ [ r> ] swap append ] map concat
|
||||||
append ;
|
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 ] ;
|
||||||
|
|
|
||||||
|
|
@ -130,8 +130,15 @@ MACRO: parallel-call ( quots -- )
|
||||||
! map-call and friends
|
! map-call and friends
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
: (make-call-with) ( quots -- quot )
|
||||||
|
[ [ keep ] curry ] map concat [ drop ] append ;
|
||||||
|
|
||||||
MACRO: map-call-with ( quots -- )
|
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 -- )
|
MACRO: map-call-with2 ( quots -- )
|
||||||
[
|
[
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
@ -119,8 +119,8 @@ M: postgresql-db bind% ( spec -- )
|
||||||
|
|
||||||
: postgresql-make ( class quot -- )
|
: postgresql-make ( class quot -- )
|
||||||
>r sql-props r>
|
>r sql-props r>
|
||||||
[ postgresql-counter off ] swap compose
|
[ postgresql-counter off call ] { "" { } { } } nmake
|
||||||
{ "" { } { } } nmake <postgresql-statement> ;
|
<postgresql-statement> ; inline
|
||||||
|
|
||||||
: create-table-sql ( class -- statement )
|
: create-table-sql ( class -- statement )
|
||||||
[
|
[
|
||||||
|
|
|
||||||
|
|
@ -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: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
|
||||||
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( 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: 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: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
|
||||||
FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;
|
FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;
|
||||||
|
|
|
||||||
|
|
@ -102,17 +102,10 @@ IN: db.sqlite.lib
|
||||||
[ no-sql-type ]
|
[ no-sql-type ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: sqlite-finalize ( handle -- )
|
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
|
||||||
sqlite3_finalize sqlite-check-result ;
|
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
|
||||||
|
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
|
||||||
: sqlite-reset ( handle -- )
|
: sqlite-column ( handle index -- string ) sqlite3_column_text ;
|
||||||
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 )
|
: sqlite-column-blob ( handle index -- byte-array/f )
|
||||||
[ sqlite3_column_bytes ] 2keep
|
[ sqlite3_column_bytes ] 2keep
|
||||||
|
|
|
||||||
|
|
@ -17,16 +17,11 @@ M: sqlite-db db-open ( db -- )
|
||||||
dup sqlite-db-path sqlite-open <db>
|
dup sqlite-db-path sqlite-open <db>
|
||||||
swap set-delegate ;
|
swap set-delegate ;
|
||||||
|
|
||||||
M: sqlite-db db-close ( handle -- )
|
M: sqlite-db db-close ( handle -- ) sqlite-close ;
|
||||||
sqlite-close ;
|
|
||||||
|
|
||||||
M: sqlite-db dispose ( db -- ) dispose-db ;
|
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-statement ;
|
||||||
|
|
||||||
TUPLE: sqlite-result-set has-more? ;
|
TUPLE: sqlite-result-set has-more? ;
|
||||||
|
|
||||||
M: sqlite-db <simple-statement> ( str in out -- obj )
|
M: sqlite-db <simple-statement> ( str in out -- obj )
|
||||||
|
|
@ -51,8 +46,7 @@ M: sqlite-result-set dispose ( result-set -- )
|
||||||
: sqlite-bind ( triples handle -- )
|
: sqlite-bind ( triples handle -- )
|
||||||
swap [ first3 sqlite-bind-type ] with each ;
|
swap [ first3 sqlite-bind-type ] with each ;
|
||||||
|
|
||||||
: reset-statement ( statement -- )
|
: reset-statement ( statement -- ) statement-handle sqlite-reset ;
|
||||||
statement-handle sqlite-reset ;
|
|
||||||
|
|
||||||
M: sqlite-statement bind-statement* ( statement -- )
|
M: sqlite-statement bind-statement* ( statement -- )
|
||||||
dup statement-bound? [ dup reset-statement ] when
|
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 statement-handle sqlite-result-set <result-set>
|
||||||
dup advance-row ;
|
dup advance-row ;
|
||||||
|
|
||||||
M: sqlite-db begin-transaction ( -- )
|
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
|
||||||
"BEGIN" sql-command ;
|
M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ;
|
||||||
|
M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
|
||||||
M: sqlite-db commit-transaction ( -- )
|
|
||||||
"COMMIT" sql-command ;
|
|
||||||
|
|
||||||
M: sqlite-db rollback-transaction ( -- )
|
|
||||||
"ROLLBACK" sql-command ;
|
|
||||||
|
|
||||||
: sqlite-make ( class quot -- )
|
: sqlite-make ( class quot -- )
|
||||||
>r sql-props r>
|
>r sql-props r>
|
||||||
{ "" { } { } } nmake <simple-statement> ;
|
{ "" { } { } } nmake <simple-statement> ; inline
|
||||||
|
|
||||||
M: sqlite-db create-sql-statement ( class -- statement )
|
M: sqlite-db create-sql-statement ( class -- statement )
|
||||||
[
|
[
|
||||||
|
|
@ -123,9 +112,7 @@ M: sqlite-db create-sql-statement ( class -- statement )
|
||||||
] sqlite-make ;
|
] sqlite-make ;
|
||||||
|
|
||||||
M: sqlite-db drop-sql-statement ( class -- statement )
|
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 )
|
M: sqlite-db <insert-native-statement> ( tuple -- statement )
|
||||||
[
|
[
|
||||||
|
|
@ -195,10 +182,9 @@ M: sqlite-db modifier-table ( -- hashtable )
|
||||||
{ +not-null+ "not null" }
|
{ +not-null+ "not null" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
M: sqlite-db compound-modifier ( str obj -- newstr )
|
M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ;
|
||||||
compound-type ;
|
|
||||||
|
|
||||||
M: sqlite-db compound-type ( str seq -- newstr )
|
M: sqlite-db compound-type ( str seq -- str' )
|
||||||
over {
|
over {
|
||||||
{ "default" [ first number>string join-space ] }
|
{ "default" [ first number>string join-space ] }
|
||||||
[ 2drop ] ! "no sqlite compound data type" 3array throw ]
|
[ 2drop ] ! "no sqlite compound data type" 3array throw ]
|
||||||
|
|
@ -219,5 +205,4 @@ M: sqlite-db type-table ( -- assoc )
|
||||||
{ FACTOR-BLOB "blob" }
|
{ FACTOR-BLOB "blob" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
M: sqlite-db create-type-table
|
M: sqlite-db create-type-table ( symbol -- str ) type-table ;
|
||||||
type-table ;
|
|
||||||
|
|
|
||||||
|
|
@ -30,9 +30,11 @@ SYMBOL: person3
|
||||||
SYMBOL: person4
|
SYMBOL: person4
|
||||||
|
|
||||||
: test-tuples ( -- )
|
: 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 ] unit-test
|
||||||
[ person create-table ] must-fail
|
[ person create-table ] must-fail
|
||||||
|
[ ] [ person ensure-table ] unit-test
|
||||||
|
|
||||||
[ ] [ person1 get insert-tuple ] 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
|
[ native-person-schema test-tuples ] test-sqlite
|
||||||
[ assigned-person-schema test-tuples ] test-sqlite
|
[ assigned-person-schema test-tuples ] test-sqlite
|
||||||
|
|
||||||
[ native-person-schema test-tuples ] test-postgresql
|
! [ native-person-schema test-tuples ] test-postgresql
|
||||||
[ assigned-person-schema test-tuples ] test-postgresql
|
! [ assigned-person-schema test-tuples ] test-postgresql
|
||||||
|
|
||||||
TUPLE: serialize-me id data ;
|
TUPLE: serialize-me id data ;
|
||||||
|
|
||||||
|
|
@ -211,7 +213,7 @@ TUPLE: serialize-me id data ;
|
||||||
] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
|
] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
|
||||||
|
|
||||||
[ test-serialize ] test-sqlite
|
[ test-serialize ] test-sqlite
|
||||||
[ test-serialize ] test-postgresql
|
! [ test-serialize ] test-postgresql
|
||||||
|
|
||||||
TUPLE: exam id name score ;
|
TUPLE: exam id name score ;
|
||||||
|
|
||||||
|
|
@ -237,3 +239,9 @@ TUPLE: exam id name score ;
|
||||||
;
|
;
|
||||||
|
|
||||||
! [ test-ranges ] test-sqlite
|
! [ test-ranges ] test-sqlite
|
||||||
|
|
||||||
|
\ insert-tuple must-infer
|
||||||
|
\ update-tuple must-infer
|
||||||
|
\ delete-tuple must-infer
|
||||||
|
\ select-tuple must-infer
|
||||||
|
\ define-persistent must-infer
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,8 @@
|
||||||
USING: arrays assocs classes db kernel namespaces
|
USING: arrays assocs classes db kernel namespaces
|
||||||
tuples words sequences slots math
|
tuples words sequences slots math
|
||||||
math.parser io prettyprint db.types continuations
|
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
|
IN: db.tuples
|
||||||
|
|
||||||
: define-persistent ( class table columns -- )
|
: 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-tuple-statement> db ( class -- obj )
|
||||||
HOOK: <delete-tuples-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 -- )
|
HOOK: insert-tuple* db ( tuple statement -- )
|
||||||
|
|
||||||
|
|
@ -73,6 +74,9 @@ HOOK: insert-tuple* db ( tuple statement -- )
|
||||||
: drop-table ( class -- )
|
: drop-table ( class -- )
|
||||||
drop-sql-statement [ execute-statement ] with-disposals ;
|
drop-sql-statement [ execute-statement ] with-disposals ;
|
||||||
|
|
||||||
|
: ensure-table ( class -- )
|
||||||
|
[ dup drop-table ] ignore-errors create-table ;
|
||||||
|
|
||||||
: insert-native ( tuple -- )
|
: insert-native ( tuple -- )
|
||||||
dup class
|
dup class
|
||||||
db get db-insert-statements [ <insert-native-statement> ] cache
|
db get db-insert-statements [ <insert-native-statement> ] cache
|
||||||
|
|
|
||||||
|
|
@ -26,11 +26,14 @@ M: destructor dispose
|
||||||
: add-always-destructor ( obj -- )
|
: add-always-destructor ( obj -- )
|
||||||
<destructor> always-destructors get push ;
|
<destructor> always-destructors get push ;
|
||||||
|
|
||||||
|
: dispose-each ( seq -- )
|
||||||
|
<reversed> [ dispose ] each ;
|
||||||
|
|
||||||
: do-always-destructors ( -- )
|
: do-always-destructors ( -- )
|
||||||
always-destructors get [ dispose ] each ;
|
always-destructors get dispose-each ;
|
||||||
|
|
||||||
: do-error-destructors ( -- )
|
: do-error-destructors ( -- )
|
||||||
error-destructors get [ dispose ] each ;
|
error-destructors get dispose-each ;
|
||||||
|
|
||||||
: with-destructors ( quot -- )
|
: with-destructors ( quot -- )
|
||||||
[
|
[
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2005, 2007 Slava Pestov.
|
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: parser kernel namespaces sequences definitions io.files
|
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 ;
|
io prettyprint source-files assocs vocabs vocabs.loader ;
|
||||||
IN: editors
|
IN: editors
|
||||||
|
|
||||||
|
|
@ -13,8 +13,7 @@ M: no-edit-hook summary
|
||||||
SYMBOL: edit-hook
|
SYMBOL: edit-hook
|
||||||
|
|
||||||
: available-editors ( -- seq )
|
: available-editors ( -- seq )
|
||||||
"editors" all-child-vocabs
|
"editors" all-child-vocabs-seq [ vocab-name ] map ;
|
||||||
values concat [ vocab-name ] map ;
|
|
||||||
|
|
||||||
: editor-restarts ( -- alist )
|
: editor-restarts ( -- alist )
|
||||||
available-editors
|
available-editors
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -52,7 +52,12 @@ IN: farkup.tests
|
||||||
[ "<h2>foo</h2>" ] [ "==foo==" convert-farkup ] unit-test
|
[ "<h2>foo</h2>" ] [ "==foo==" convert-farkup ] unit-test
|
||||||
[ "<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
|
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
|
||||||
|
|
||||||
|
|
||||||
[ "<h1>foo</h1><p>=</p>" ] [ "=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
|
||||||
|
|
|
||||||
|
|
@ -55,10 +55,31 @@ MEMO: eq ( -- parser )
|
||||||
>r string-lines r>
|
>r string-lines r>
|
||||||
[ [ htmlize-lines ] with-html-stream ] with-string-writer ;
|
[ [ 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 )
|
: make-link ( href text -- seq )
|
||||||
>r escape-quoted-string r> escape-string
|
escape-link
|
||||||
[ "<a href=\"" , >r , r> "\">" , [ , ] when* "</a>" , ] { } make ;
|
[ "<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 )
|
MEMO: simple-link ( -- parser )
|
||||||
[
|
[
|
||||||
"[[" token hide ,
|
"[[" token hide ,
|
||||||
|
|
@ -75,7 +96,7 @@ MEMO: labelled-link ( -- parser )
|
||||||
"]]" token hide ,
|
"]]" token hide ,
|
||||||
] seq* [ first2 make-link ] action ;
|
] 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
|
DEFER: line
|
||||||
MEMO: list-item ( -- parser )
|
MEMO: list-item ( -- parser )
|
||||||
|
|
@ -101,13 +122,10 @@ MEMO: table ( -- parser )
|
||||||
MEMO: code ( -- parser )
|
MEMO: code ( -- parser )
|
||||||
[
|
[
|
||||||
"[" token hide ,
|
"[" token hide ,
|
||||||
[ "{" member? not ] satisfy repeat1 optional [ >string ] action ,
|
[ CHAR: { = not ] satisfy repeat1 optional [ >string ] action ,
|
||||||
"{" token hide ,
|
"{" token hide ,
|
||||||
[
|
"}]" token ensure-not any-char 2seq repeat0 [ concat >string ] action ,
|
||||||
[ any-char , "}]" token ensure-not , ] seq*
|
"}]" token hide ,
|
||||||
repeat1 [ concat >string ] action ,
|
|
||||||
[ any-char , "}]" token hide , ] seq* optional [ >string ] action ,
|
|
||||||
] seq* [ concat ] action ,
|
|
||||||
] seq* [ first2 swap render-code ] action ;
|
] seq* [ first2 swap render-code ] action ;
|
||||||
|
|
||||||
MEMO: line ( -- parser )
|
MEMO: line ( -- parser )
|
||||||
|
|
|
||||||
|
|
@ -1,14 +1,14 @@
|
||||||
USING: tools.deploy.config ;
|
USING: tools.deploy.config ;
|
||||||
H{
|
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-name "Hello world (console)" }
|
||||||
{ deploy-reflection 2 }
|
{ deploy-threads? f }
|
||||||
{ deploy-c-types? f }
|
{ deploy-c-types? f }
|
||||||
|
{ deploy-compiler? f }
|
||||||
{ deploy-ui? 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 }
|
{ "stop-after-last-window?" t }
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -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:"
|
"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
|
{ $code
|
||||||
"\"mydata.dat\" dup file-length ["
|
"\"mydata.dat\" dup file-info file-info-length ["
|
||||||
" 4 <sliced-groups> [ reverse-here ] change-each"
|
" 4 <sliced-groups> [ reverse-here ] change-each"
|
||||||
"] with-mapped-file"
|
"] with-mapped-file"
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -196,6 +196,7 @@ ARTICLE: "io" "Input and output"
|
||||||
{ $subsection "io.timeouts" } ;
|
{ $subsection "io.timeouts" } ;
|
||||||
|
|
||||||
ARTICLE: "tools" "Developer tools"
|
ARTICLE: "tools" "Developer tools"
|
||||||
|
{ $subsection "tools.vocabs" }
|
||||||
"Exploratory tools:"
|
"Exploratory tools:"
|
||||||
{ $subsection "editor" }
|
{ $subsection "editor" }
|
||||||
{ $subsection "tools.crossref" }
|
{ $subsection "tools.crossref" }
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2006, 2007 Slava Pestov.
|
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: sequences parser kernel help help.markup help.topics
|
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
|
io.streams.string prettyprint definitions arrays vectors
|
||||||
combinators splitting debugger hashtables sorting effects vocabs
|
combinators splitting debugger hashtables sorting effects vocabs
|
||||||
vocabs.loader assocs editors continuations classes.predicate
|
vocabs.loader assocs editors continuations classes.predicate
|
||||||
|
|
|
||||||
|
|
@ -169,7 +169,8 @@ M: f print-element drop ;
|
||||||
] if
|
] if
|
||||||
] ($subsection) ;
|
] ($subsection) ;
|
||||||
|
|
||||||
: $vocab-link ( element -- ) first dup ($vocab-link) ;
|
: $vocab-link ( element -- )
|
||||||
|
first dup vocab-name swap ($vocab-link) ;
|
||||||
|
|
||||||
: $vocabulary ( element -- )
|
: $vocabulary ( element -- )
|
||||||
first word-vocabulary [
|
first word-vocabulary [
|
||||||
|
|
|
||||||
|
|
@ -7,6 +7,10 @@ IN: help.topics
|
||||||
|
|
||||||
TUPLE: link name ;
|
TUPLE: link name ;
|
||||||
|
|
||||||
|
MIXIN: topic
|
||||||
|
INSTANCE: link topic
|
||||||
|
INSTANCE: word topic
|
||||||
|
|
||||||
GENERIC: >link ( obj -- obj )
|
GENERIC: >link ( obj -- obj )
|
||||||
M: link >link ;
|
M: link >link ;
|
||||||
M: vocab-spec >link ;
|
M: vocab-spec >link ;
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
USING: help.markup help.syntax ui.commands ui.operations
|
USING: help.markup help.syntax ui.commands ui.operations
|
||||||
ui.tools.search ui.tools.workspace editors vocabs.loader
|
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 ;
|
unicode.categories unicode.case ;
|
||||||
IN: help.tutorial
|
IN: help.tutorial
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -18,6 +18,7 @@ tuple-syntax namespaces ;
|
||||||
port: 80
|
port: 80
|
||||||
version: "1.1"
|
version: "1.1"
|
||||||
cookies: V{ }
|
cookies: V{ }
|
||||||
|
header: H{ }
|
||||||
}
|
}
|
||||||
] [
|
] [
|
||||||
[
|
[
|
||||||
|
|
|
||||||
|
|
@ -95,5 +95,4 @@ PRIVATE>
|
||||||
swap >>post-data-type ;
|
swap >>post-data-type ;
|
||||||
|
|
||||||
: http-post ( content-type content url -- response string )
|
: http-post ( content-type content url -- response string )
|
||||||
#! The content is URL encoded for you.
|
<post-request> http-request contents ;
|
||||||
>r url-encode r> <post-request> http-request contents ;
|
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,8 @@ USING: fry hashtables io io.streams.string kernel math
|
||||||
namespaces math.parser assocs sequences strings splitting ascii
|
namespaces math.parser assocs sequences strings splitting ascii
|
||||||
io.encodings.utf8 io.encodings.string namespaces unicode.case
|
io.encodings.utf8 io.encodings.string namespaces unicode.case
|
||||||
combinators vectors sorting new-slots accessors calendar
|
combinators vectors sorting new-slots accessors calendar
|
||||||
calendar.format quotations arrays ;
|
calendar.format quotations arrays combinators.cleave
|
||||||
|
combinators.lib byte-arrays ;
|
||||||
IN: http
|
IN: http
|
||||||
|
|
||||||
: http-port 80 ; inline
|
: http-port 80 ; inline
|
||||||
|
|
@ -12,18 +13,21 @@ IN: http
|
||||||
: url-quotable? ( ch -- ? )
|
: url-quotable? ( ch -- ? )
|
||||||
#! In a URL, can this character be used without
|
#! In a URL, can this character be used without
|
||||||
#! URL-encoding?
|
#! URL-encoding?
|
||||||
dup letter?
|
{
|
||||||
over LETTER? or
|
[ dup letter? ]
|
||||||
over digit? or
|
[ dup LETTER? ]
|
||||||
swap "/_-." member? or ; foldable
|
[ dup digit? ]
|
||||||
|
[ dup "/_-.:" member? ]
|
||||||
|
} || nip ; foldable
|
||||||
|
|
||||||
: push-utf8 ( ch -- )
|
: 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 )
|
: url-encode ( str -- str )
|
||||||
[ [
|
[
|
||||||
dup url-quotable? [ , ] [ push-utf8 ] if
|
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
|
||||||
] each ] "" make ;
|
] "" make ;
|
||||||
|
|
||||||
: url-decode-hex ( index str -- )
|
: url-decode-hex ( index str -- )
|
||||||
2dup length 2 - >= [
|
2dup length 2 - >= [
|
||||||
|
|
@ -108,7 +112,12 @@ IN: http
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: assoc>query ( hash -- str )
|
: 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 ;
|
"&" join ;
|
||||||
|
|
||||||
TUPLE: cookie name value path domain expires http-only ;
|
TUPLE: cookie name value path domain expires http-only ;
|
||||||
|
|
@ -169,10 +178,11 @@ cookies ;
|
||||||
|
|
||||||
: <request>
|
: <request>
|
||||||
request construct-empty
|
request construct-empty
|
||||||
"1.1" >>version
|
"1.1" >>version
|
||||||
http-port >>port
|
http-port >>port
|
||||||
H{ } clone >>query
|
H{ } clone >>header
|
||||||
V{ } clone >>cookies ;
|
H{ } clone >>query
|
||||||
|
V{ } clone >>cookies ;
|
||||||
|
|
||||||
: query-param ( request key -- value )
|
: query-param ( request key -- value )
|
||||||
swap query>> at ;
|
swap query>> at ;
|
||||||
|
|
@ -245,6 +255,10 @@ SYMBOL: max-post-request
|
||||||
: extract-post-data-type ( request -- request )
|
: extract-post-data-type ( request -- request )
|
||||||
dup "content-type" header >>post-data-type ;
|
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 )
|
: extract-cookies ( request -- request )
|
||||||
dup "cookie" header [ parse-cookies >>cookies ] when* ;
|
dup "cookie" header [ parse-cookies >>cookies ] when* ;
|
||||||
|
|
||||||
|
|
@ -257,24 +271,31 @@ SYMBOL: max-post-request
|
||||||
read-post-data
|
read-post-data
|
||||||
extract-host
|
extract-host
|
||||||
extract-post-data-type
|
extract-post-data-type
|
||||||
|
parse-post-data
|
||||||
extract-cookies ;
|
extract-cookies ;
|
||||||
|
|
||||||
: write-method ( request -- request )
|
: write-method ( request -- request )
|
||||||
dup method>> write bl ;
|
dup method>> write bl ;
|
||||||
|
|
||||||
: write-url ( request -- request )
|
: (link>string) ( url query -- url' )
|
||||||
dup path>> url-encode write
|
[ url-encode ] [ assoc>query ] bi*
|
||||||
dup query>> dup assoc-empty? [ drop ] [
|
dup empty? [ drop ] [ "?" swap 3append ] if ;
|
||||||
"?" write
|
|
||||||
assoc>query write
|
: write-url ( request -- )
|
||||||
] if ;
|
[ path>> ] [ query>> ] bi (link>string) write ;
|
||||||
|
|
||||||
: write-request-url ( request -- request )
|
: write-request-url ( request -- request )
|
||||||
write-url bl ;
|
dup write-url bl ;
|
||||||
|
|
||||||
: write-version ( request -- request )
|
: write-version ( request -- request )
|
||||||
"HTTP/" write dup request-version write crlf ;
|
"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 )
|
: write-request-header ( request -- request )
|
||||||
dup header>> >hashtable
|
dup header>> >hashtable
|
||||||
over host>> [ "host" pick set-at ] when*
|
over host>> [ "host" pick set-at ] when*
|
||||||
|
|
@ -287,6 +308,7 @@ SYMBOL: max-post-request
|
||||||
dup post-data>> [ write ] when* ;
|
dup post-data>> [ write ] when* ;
|
||||||
|
|
||||||
: write-request ( request -- )
|
: write-request ( request -- )
|
||||||
|
unparse-post-data
|
||||||
write-method
|
write-method
|
||||||
write-request-url
|
write-request-url
|
||||||
write-version
|
write-version
|
||||||
|
|
@ -297,15 +319,16 @@ SYMBOL: max-post-request
|
||||||
|
|
||||||
: request-url ( request -- url )
|
: request-url ( request -- url )
|
||||||
[
|
[
|
||||||
dup host>> [
|
[
|
||||||
"http://" write
|
dup host>> [
|
||||||
dup host>> url-encode write
|
[ "http://" write host>> url-encode write ]
|
||||||
":" write
|
[ ":" write port>> number>string write ]
|
||||||
dup port>> number>string write
|
bi
|
||||||
] when
|
] [ drop ] if
|
||||||
dup path>> "/" head? [ "/" write ] unless
|
]
|
||||||
write-url
|
[ path>> "/" head? [ "/" write ] unless ]
|
||||||
drop
|
[ write-url ]
|
||||||
|
tri
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
: set-header ( request/response value key -- request/response )
|
: set-header ( request/response value key -- request/response )
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,16 @@
|
||||||
IN: http.server.actions.tests
|
IN: http.server.actions.tests
|
||||||
USING: http.server.actions tools.test math math.parser
|
USING: http.server.actions http.server.validators
|
||||||
multiline namespaces http io.streams.string http.server
|
tools.test math math.parser multiline namespaces http
|
||||||
sequences accessors ;
|
io.streams.string http.server sequences accessors ;
|
||||||
|
|
||||||
|
[
|
||||||
|
"a" [ v-number ] { { "a" "123" } } validate-param
|
||||||
|
[ 123 ] [ "a" get ] unit-test
|
||||||
|
] with-scope
|
||||||
|
|
||||||
<action>
|
<action>
|
||||||
[ "a" get "b" get + ] >>display
|
[ "a" get "b" get + ] >>display
|
||||||
{ { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params
|
{ { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
|
||||||
"action-1" set
|
"action-1" set
|
||||||
|
|
||||||
STRING: action-request-test-1
|
STRING: action-request-test-1
|
||||||
|
|
@ -23,12 +28,13 @@ blah
|
||||||
|
|
||||||
<action>
|
<action>
|
||||||
[ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
|
[ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
|
||||||
{ { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
|
{ { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params
|
||||||
"action-2" set
|
"action-2" set
|
||||||
|
|
||||||
STRING: action-request-test-2
|
STRING: action-request-test-2
|
||||||
POST http://foo/bar/baz HTTP/1.1
|
POST http://foo/bar/baz HTTP/1.1
|
||||||
content-length: 5
|
content-length: 5
|
||||||
|
content-type: application/x-www-form-urlencoded
|
||||||
|
|
||||||
xxx=4
|
xxx=4
|
||||||
;
|
;
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors new-slots sequences kernel assocs combinators
|
USING: accessors new-slots sequences kernel assocs combinators
|
||||||
http.server http.server.validators http hashtables namespaces
|
http.server http.server.validators http hashtables namespaces
|
||||||
combinators.cleave fry continuations ;
|
combinators.cleave fry continuations locals ;
|
||||||
IN: http.server.actions
|
IN: http.server.actions
|
||||||
|
|
||||||
SYMBOL: +path+
|
SYMBOL: +path+
|
||||||
|
|
@ -17,25 +17,13 @@ TUPLE: action init display submit get-params post-params ;
|
||||||
[ <400> ] >>display
|
[ <400> ] >>display
|
||||||
[ <400> ] >>submit ;
|
[ <400> ] >>submit ;
|
||||||
|
|
||||||
: extract-params ( path -- assoc )
|
:: validate-param ( name validator assoc -- )
|
||||||
+path+ associate
|
name assoc at validator with-validator name set ; inline
|
||||||
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 ;
|
|
||||||
|
|
||||||
: action-params ( validators -- error? )
|
: 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 )
|
: handle-get ( -- response )
|
||||||
action get get-params>> action-params [ <400> ] [
|
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 ;
|
action get display>> call exit-with ;
|
||||||
|
|
||||||
M: action call-responder ( path action -- response )
|
M: action call-responder ( path action -- response )
|
||||||
[ extract-params params set ]
|
[ +path+ associate request-params union params set ]
|
||||||
[
|
[ action set ] bi*
|
||||||
action set
|
request get method>> {
|
||||||
request get method>> {
|
{ "GET" [ handle-get ] }
|
||||||
{ "GET" [ handle-get ] }
|
{ "HEAD" [ handle-get ] }
|
||||||
{ "HEAD" [ handle-get ] }
|
{ "POST" [ handle-post ] }
|
||||||
{ "POST" [ handle-post ] }
|
} case ;
|
||||||
} case
|
|
||||||
] bi* ;
|
|
||||||
|
|
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -13,6 +13,8 @@ QUALIFIED: smtp
|
||||||
|
|
||||||
TUPLE: login users ;
|
TUPLE: login users ;
|
||||||
|
|
||||||
|
: users login get users>> ;
|
||||||
|
|
||||||
SYMBOL: post-login-url
|
SYMBOL: post-login-url
|
||||||
SYMBOL: login-failed?
|
SYMBOL: login-failed?
|
||||||
|
|
||||||
|
|
@ -30,7 +32,8 @@ SYMBOL: login-failed?
|
||||||
|
|
||||||
: successful-login ( user -- response )
|
: successful-login ( user -- response )
|
||||||
logged-in-user sset
|
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 )
|
:: <login-action> ( -- action )
|
||||||
[let | form [ <login-form> ] |
|
[let | form [ <login-form> ] |
|
||||||
|
|
@ -48,7 +51,7 @@ SYMBOL: login-failed?
|
||||||
form validate-form
|
form validate-form
|
||||||
|
|
||||||
"password" value "username" value
|
"password" value "username" value
|
||||||
login get users>> check-login [
|
users check-login [
|
||||||
successful-login
|
successful-login
|
||||||
] [
|
] [
|
||||||
login-failed? on
|
login-failed? on
|
||||||
|
|
@ -66,7 +69,7 @@ SYMBOL: login-failed?
|
||||||
t >>required
|
t >>required
|
||||||
add-field
|
add-field
|
||||||
"realname" <string> add-field
|
"realname" <string> add-field
|
||||||
"password" <password>
|
"new-password" <password>
|
||||||
t >>required
|
t >>required
|
||||||
add-field
|
add-field
|
||||||
"verify-password" <password>
|
"verify-password" <password>
|
||||||
|
|
@ -79,7 +82,7 @@ SYMBOL: password-mismatch?
|
||||||
SYMBOL: user-exists?
|
SYMBOL: user-exists?
|
||||||
|
|
||||||
: same-password-twice ( -- )
|
: same-password-twice ( -- )
|
||||||
"password" value "verify-password" value = [
|
"new-password" value "verify-password" value = [
|
||||||
password-mismatch? on
|
password-mismatch? on
|
||||||
validation-failed
|
validation-failed
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
@ -101,14 +104,13 @@ SYMBOL: user-exists?
|
||||||
|
|
||||||
same-password-twice
|
same-password-twice
|
||||||
|
|
||||||
<user> values get [
|
<user>
|
||||||
"username" get >>username
|
"username" value >>username
|
||||||
"realname" get >>realname
|
"realname" value >>realname
|
||||||
"password" get >>password
|
"new-password" value >>password
|
||||||
"email" get >>email
|
"email" value >>email
|
||||||
] bind
|
|
||||||
|
|
||||||
login get users>> new-user [
|
users new-user [
|
||||||
user-exists? on
|
user-exists? on
|
||||||
validation-failed
|
validation-failed
|
||||||
] unless*
|
] unless*
|
||||||
|
|
@ -117,6 +119,64 @@ SYMBOL: user-exists?
|
||||||
] >>submit
|
] >>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
|
! ! ! Password recovery
|
||||||
|
|
||||||
SYMBOL: lost-password-from
|
SYMBOL: lost-password-from
|
||||||
|
|
@ -185,7 +245,7 @@ SYMBOL: lost-password-from
|
||||||
form validate-form
|
form validate-form
|
||||||
|
|
||||||
"email" value "username" value
|
"email" value "username" value
|
||||||
login get users>> issue-ticket [
|
users issue-ticket [
|
||||||
send-password-email
|
send-password-email
|
||||||
] when*
|
] when*
|
||||||
|
|
||||||
|
|
@ -199,7 +259,7 @@ SYMBOL: lost-password-from
|
||||||
"username" <username> <hidden>
|
"username" <username> <hidden>
|
||||||
t >>required
|
t >>required
|
||||||
add-field
|
add-field
|
||||||
"password" <password>
|
"new-password" <password>
|
||||||
t >>required
|
t >>required
|
||||||
add-field
|
add-field
|
||||||
"verify-password" <password>
|
"verify-password" <password>
|
||||||
|
|
@ -238,9 +298,9 @@ SYMBOL: lost-password-from
|
||||||
|
|
||||||
"ticket" value
|
"ticket" value
|
||||||
"username" value
|
"username" value
|
||||||
login get users>> claim-ticket [
|
users claim-ticket [
|
||||||
"password" value >>password
|
"new-password" value >>password
|
||||||
login get users>> update-user
|
users update-user
|
||||||
|
|
||||||
"resource:extra/http/server/auth/login/recover-4.fhtml"
|
"resource:extra/http/server/auth/login/recover-4.fhtml"
|
||||||
serve-template
|
serve-template
|
||||||
|
|
@ -264,13 +324,18 @@ TUPLE: protected responder ;
|
||||||
|
|
||||||
C: <protected> protected
|
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 )
|
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
|
2drop
|
||||||
request get method>> { "GET" "HEAD" } member? [
|
request get method>> { "GET" "HEAD" } member?
|
||||||
request get request-url post-login-url sset
|
[ show-login-page ] [ <400> ] if
|
||||||
"login" f <permanent-redirect>
|
|
||||||
] [ <400> ] if
|
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: login call-responder ( path responder -- response )
|
M: login call-responder ( path responder -- response )
|
||||||
|
|
@ -282,10 +347,13 @@ M: login call-responder ( path responder -- response )
|
||||||
swap <protected> >>default
|
swap <protected> >>default
|
||||||
<login-action> "login" add-responder
|
<login-action> "login" add-responder
|
||||||
<logout-action> "logout" add-responder
|
<logout-action> "logout" add-responder
|
||||||
no >>users ;
|
no-users >>users ;
|
||||||
|
|
||||||
! ! ! Configuration
|
! ! ! Configuration
|
||||||
|
|
||||||
|
: allow-edit-profile ( login -- login )
|
||||||
|
<edit-profile-action> <protected> "edit-profile" add-responder ;
|
||||||
|
|
||||||
: allow-registration ( login -- login )
|
: allow-registration ( login -- login )
|
||||||
<register-action> "register" add-responder ;
|
<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-1> "recover-password" add-responder
|
||||||
<recover-action-3> "new-password" add-responder ;
|
<recover-action-3> "new-password" add-responder ;
|
||||||
|
|
||||||
|
: allow-edit-profile? ( -- ? )
|
||||||
|
login get responders>> "edit-profile" swap key? ;
|
||||||
|
|
||||||
: allow-registration? ( -- ? )
|
: allow-registration? ( -- ? )
|
||||||
login get responders>> "register" swap key? ;
|
login get responders>> "register" swap key? ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,10 +1,13 @@
|
||||||
<% USING: http.server.auth.login http.server.components kernel
|
<% USING: http.server.auth.login http.server.components http.server
|
||||||
namespaces ; %>
|
kernel namespaces ; %>
|
||||||
<html>
|
<html>
|
||||||
<body>
|
<body>
|
||||||
<h1>Login required</h1>
|
<h1>Login required</h1>
|
||||||
|
|
||||||
<form method="POST" action="login">
|
<form method="POST" action="login">
|
||||||
|
|
||||||
|
<% hidden-form-field %>
|
||||||
|
|
||||||
<table>
|
<table>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
|
|
@ -30,10 +33,12 @@ login-failed? get
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
<% allow-registration? [ %>
|
<% allow-registration? [ %>
|
||||||
<a href="register">Register</a>
|
<a href="<% "register" f write-link %>">Register</a>
|
||||||
<% ] when %>
|
<% ] when %>
|
||||||
<% allow-password-recovery? [ %>
|
<% allow-password-recovery? [ %>
|
||||||
<a href="recover-password">Recover Password</a>
|
<a href="<% "recover-password" f write-link %>">
|
||||||
|
Recover Password
|
||||||
|
</a>
|
||||||
<% ] when %>
|
<% ] when %>
|
||||||
</p>
|
</p>
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,4 @@
|
||||||
<% USING: http.server.components ; %>
|
<% USING: http.server.components http.server ; %>
|
||||||
<html>
|
<html>
|
||||||
<body>
|
<body>
|
||||||
<h1>Recover lost password: step 1 of 4</h1>
|
<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>
|
<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">
|
<form method="POST" action="recover-password">
|
||||||
|
|
||||||
|
<% hidden-form-field %>
|
||||||
|
|
||||||
<table>
|
<table>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
|
|
|
||||||
|
|
@ -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 ; %>
|
namespaces kernel combinators ; %>
|
||||||
<html>
|
<html>
|
||||||
<body>
|
<body>
|
||||||
|
|
@ -7,6 +7,9 @@ namespaces kernel combinators ; %>
|
||||||
<p>Choose a new password for your account.</p>
|
<p>Choose a new password for your account.</p>
|
||||||
|
|
||||||
<form method="POST" action="new-password">
|
<form method="POST" action="new-password">
|
||||||
|
|
||||||
|
<% hidden-form-field %>
|
||||||
|
|
||||||
<table>
|
<table>
|
||||||
|
|
||||||
<% "username" component render-edit %>
|
<% "username" component render-edit %>
|
||||||
|
|
@ -14,7 +17,7 @@ namespaces kernel combinators ; %>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<td>Password:</td>
|
<td>Password:</td>
|
||||||
<td><% "password" component render-edit %></td>
|
<td><% "new-password" component render-edit %></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
|
|
@ -32,7 +35,7 @@ namespaces kernel combinators ; %>
|
||||||
<p><input type="submit" value="Set password" />
|
<p><input type="submit" value="Set password" />
|
||||||
|
|
||||||
<% password-mismatch? get [
|
<% password-mismatch? get [
|
||||||
"passwords do not match" render-error
|
"passwords do not match" render-error
|
||||||
] when %>
|
] when %>
|
||||||
|
|
||||||
</p>
|
</p>
|
||||||
|
|
|
||||||
|
|
@ -1,10 +1,10 @@
|
||||||
<% USING: http.server.components http.server.auth.login
|
<% USING: http.server ; %>
|
||||||
namespaces kernel combinators ; %>
|
|
||||||
<html>
|
<html>
|
||||||
<body>
|
<body>
|
||||||
<h1>Recover lost password: step 4 of 4</h1>
|
<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>
|
</body>
|
||||||
</html>
|
</html>
|
||||||
|
|
|
||||||
|
|
@ -1,10 +1,12 @@
|
||||||
<% USING: http.server.components http.server.auth.login
|
<% USING: http.server.components http.server.auth.login
|
||||||
namespaces kernel combinators ; %>
|
http.server namespaces kernel combinators ; %>
|
||||||
<html>
|
<html>
|
||||||
<body>
|
<body>
|
||||||
<h1>New user registration</h1>
|
<h1>New user registration</h1>
|
||||||
|
|
||||||
<form method="POST" action="register">
|
<form method="POST" action="register">
|
||||||
|
<% hidden-form-field %>
|
||||||
|
|
||||||
<table>
|
<table>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
|
|
@ -24,7 +26,7 @@ namespaces kernel combinators ; %>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
<td>Password:</td>
|
<td>Password:</td>
|
||||||
<td><% "password" component render-edit %></td>
|
<td><% "new-password" component render-edit %></td>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<tr>
|
<tr>
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@ USING: http.server.auth.providers
|
||||||
http.server.auth.providers.assoc tools.test
|
http.server.auth.providers.assoc tools.test
|
||||||
namespaces accessors kernel ;
|
namespaces accessors kernel ;
|
||||||
|
|
||||||
<in-memory> "provider" set
|
<users-in-memory> "provider" set
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
<user>
|
<user>
|
||||||
|
|
@ -26,7 +26,7 @@ namespaces accessors kernel ;
|
||||||
|
|
||||||
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
|
[ 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
|
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -4,16 +4,16 @@ IN: http.server.auth.providers.assoc
|
||||||
USING: new-slots accessors assocs kernel
|
USING: new-slots accessors assocs kernel
|
||||||
http.server.auth.providers ;
|
http.server.auth.providers ;
|
||||||
|
|
||||||
TUPLE: in-memory assoc ;
|
TUPLE: users-in-memory assoc ;
|
||||||
|
|
||||||
: <in-memory> ( -- provider )
|
: <users-in-memory> ( -- provider )
|
||||||
H{ } clone in-memory construct-boa ;
|
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 ;
|
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>>
|
>r dup username>> r> assoc>>
|
||||||
2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;
|
2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;
|
||||||
|
|
|
||||||
|
|
@ -4,12 +4,11 @@ http.server.auth.providers.db tools.test
|
||||||
namespaces db db.sqlite db.tuples continuations
|
namespaces db db.sqlite db.tuples continuations
|
||||||
io.files accessors kernel ;
|
io.files accessors kernel ;
|
||||||
|
|
||||||
from-db "provider" set
|
users-in-db "provider" set
|
||||||
|
|
||||||
"auth-test.db" temp-file sqlite-db [
|
"auth-test.db" temp-file sqlite-db [
|
||||||
|
|
||||||
[ user drop-table ] ignore-errors
|
init-users-table
|
||||||
[ user create-table ] ignore-errors
|
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
<user>
|
<user>
|
||||||
|
|
@ -32,7 +31,7 @@ from-db "provider" set
|
||||||
|
|
||||||
[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
|
[ 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
|
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: db db.tuples db.types new-slots accessors
|
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
|
IN: http.server.auth.providers.db
|
||||||
|
|
||||||
user "USERS"
|
user "USERS"
|
||||||
|
|
@ -14,24 +15,20 @@ user "USERS"
|
||||||
{ "profile" "PROFILE" FACTOR-BLOB }
|
{ "profile" "PROFILE" FACTOR-BLOB }
|
||||||
} define-persistent
|
} define-persistent
|
||||||
|
|
||||||
: init-users-table ( -- )
|
: init-users-table user ensure-table ;
|
||||||
[ user drop-table ] ignore-errors
|
|
||||||
user create-table ;
|
|
||||||
|
|
||||||
TUPLE: from-db ;
|
SINGLETON: users-in-db
|
||||||
|
|
||||||
: from-db T{ from-db } ;
|
|
||||||
|
|
||||||
: find-user ( username -- user )
|
: find-user ( username -- user )
|
||||||
<user>
|
<user>
|
||||||
swap >>username
|
swap >>username
|
||||||
select-tuple ;
|
select-tuple ;
|
||||||
|
|
||||||
M: from-db get-user
|
M: users-in-db get-user
|
||||||
drop
|
drop
|
||||||
find-user ;
|
find-user ;
|
||||||
|
|
||||||
M: from-db new-user
|
M: users-in-db new-user
|
||||||
drop
|
drop
|
||||||
[
|
[
|
||||||
dup username>> find-user [
|
dup username>> find-user [
|
||||||
|
|
@ -41,5 +38,5 @@ M: from-db new-user
|
||||||
] if
|
] if
|
||||||
] with-transaction ;
|
] with-transaction ;
|
||||||
|
|
||||||
M: from-db update-user
|
M: users-in-db update-user
|
||||||
drop update-tuple ;
|
drop update-tuple ;
|
||||||
|
|
|
||||||
|
|
@ -3,14 +3,12 @@
|
||||||
USING: http.server.auth.providers kernel ;
|
USING: http.server.auth.providers kernel ;
|
||||||
IN: http.server.auth.providers.null
|
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-users update-user 2drop ;
|
||||||
|
|
||||||
M: no update-user 2drop ;
|
|
||||||
|
|
|
||||||
|
|
@ -17,12 +17,12 @@ GENERIC: new-user ( user provider -- user/f )
|
||||||
: check-login ( password username provider -- user/f )
|
: check-login ( password username provider -- user/f )
|
||||||
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
|
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 ] |
|
[let | user [ username provider get-user ] |
|
||||||
user [
|
user [
|
||||||
user
|
user
|
||||||
password >>password
|
password >>password
|
||||||
provider update-user t
|
dup provider update-user
|
||||||
] [ f ] if
|
] [ f ] if
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@
|
||||||
USING: html http http.server io kernel math namespaces
|
USING: html http http.server io kernel math namespaces
|
||||||
continuations calendar sequences assocs new-slots hashtables
|
continuations calendar sequences assocs new-slots hashtables
|
||||||
accessors arrays alarms quotations combinators
|
accessors arrays alarms quotations combinators
|
||||||
combinators.cleave fry ;
|
combinators.cleave fry assocs.lib ;
|
||||||
IN: http.server.callbacks
|
IN: http.server.callbacks
|
||||||
|
|
||||||
SYMBOL: responder
|
SYMBOL: responder
|
||||||
|
|
|
||||||
|
|
@ -86,3 +86,24 @@ TUPLE: test-tuple text number more-text ;
|
||||||
|
|
||||||
[ t ] [ "number" value validation-error? ] unit-test
|
[ t ] [ "number" value validation-error? ] unit-test
|
||||||
] with-scope
|
] 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
|
||||||
|
|
|
||||||
|
|
@ -7,8 +7,6 @@ http.server.actions splitting mirrors hashtables
|
||||||
combinators.cleave fry continuations math ;
|
combinators.cleave fry continuations math ;
|
||||||
IN: http.server.components
|
IN: http.server.components
|
||||||
|
|
||||||
SYMBOL: validation-failed?
|
|
||||||
|
|
||||||
SYMBOL: components
|
SYMBOL: components
|
||||||
|
|
||||||
TUPLE: component id required default ;
|
TUPLE: component id required default ;
|
||||||
|
|
@ -30,16 +28,13 @@ SYMBOL: values
|
||||||
|
|
||||||
: validate ( value component -- result )
|
: validate ( value component -- result )
|
||||||
'[
|
'[
|
||||||
, ,
|
,
|
||||||
over empty? [
|
over empty? [
|
||||||
[ default>> [ v-default ] when* ]
|
[ default>> [ v-default ] when* ]
|
||||||
[ required>> [ v-required ] when ]
|
[ required>> [ v-required ] when ]
|
||||||
bi
|
bi
|
||||||
] [ validate* ] if
|
] [ validate* ] if
|
||||||
] [
|
] with-validator ;
|
||||||
dup validation-error?
|
|
||||||
[ validation-failed? on ] [ rethrow ] if
|
|
||||||
] recover ;
|
|
||||||
|
|
||||||
: render-view ( component -- )
|
: render-view ( component -- )
|
||||||
[ id>> value ] [ render-view* ] bi ;
|
[ id>> value ] [ render-view* ] bi ;
|
||||||
|
|
@ -192,15 +187,16 @@ M: password render-error*
|
||||||
render-edit* render-error ;
|
render-edit* render-error ;
|
||||||
|
|
||||||
! Number fields
|
! Number fields
|
||||||
TUPLE: number min-value max-value ;
|
TUPLE: number min-value max-value integer ;
|
||||||
|
|
||||||
: <number> ( id -- component ) number <component> ;
|
: <number> ( id -- component ) number <component> ;
|
||||||
|
|
||||||
M: number validate*
|
M: number validate*
|
||||||
[ v-number ] [
|
[ v-number ] [
|
||||||
|
[ integer>> [ v-integer ] when ]
|
||||||
[ min-value>> [ v-min-value ] when* ]
|
[ min-value>> [ v-min-value ] when* ]
|
||||||
[ max-value>> [ v-max-value ] when* ]
|
[ max-value>> [ v-max-value ] when* ]
|
||||||
bi
|
tri
|
||||||
] bi* ;
|
] bi* ;
|
||||||
|
|
||||||
M: number render-view*
|
M: number render-view*
|
||||||
|
|
@ -215,7 +211,12 @@ M: number render-error*
|
||||||
! Text areas
|
! Text areas
|
||||||
TUPLE: text ;
|
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
|
: render-textarea
|
||||||
<textarea
|
<textarea
|
||||||
|
|
|
||||||
|
|
@ -3,15 +3,23 @@
|
||||||
USING: assocs kernel namespaces io io.timeouts strings splitting
|
USING: assocs kernel namespaces io io.timeouts strings splitting
|
||||||
threads http sequences prettyprint io.server logging calendar
|
threads http sequences prettyprint io.server logging calendar
|
||||||
new-slots html.elements accessors math.parser combinators.lib
|
new-slots html.elements accessors math.parser combinators.lib
|
||||||
vocabs.loader debugger html continuations random combinators
|
tools.vocabs debugger html continuations random combinators
|
||||||
destructors io.encodings.latin1 fry combinators.cleave ;
|
destructors io.encodings.latin1 fry combinators.cleave ;
|
||||||
IN: http.server
|
IN: http.server
|
||||||
|
|
||||||
GENERIC: call-responder ( path responder -- response )
|
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 )
|
: <content> ( content-type -- response )
|
||||||
<response>
|
<response>
|
||||||
200 >>code
|
200 >>code
|
||||||
|
"Document follows" >>message
|
||||||
swap set-content-type ;
|
swap set-content-type ;
|
||||||
|
|
||||||
TUPLE: trivial-responder response ;
|
TUPLE: trivial-responder response ;
|
||||||
|
|
@ -44,19 +52,27 @@ SYMBOL: 404-responder
|
||||||
|
|
||||||
[ <404> ] <trivial-responder> 404-responder set-global
|
[ <404> ] <trivial-responder> 404-responder set-global
|
||||||
|
|
||||||
: url-redirect ( to query -- url )
|
SYMBOL: link-hook
|
||||||
#! Different host.
|
|
||||||
dup assoc-empty? [
|
: modify-query ( query -- query )
|
||||||
drop
|
link-hook get [ ] or call ;
|
||||||
] [
|
|
||||||
assoc>query "?" swap 3append
|
: link>string ( url query -- url' )
|
||||||
] if ;
|
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 )
|
: absolute-redirect ( to query -- url )
|
||||||
#! Same host.
|
#! Same host.
|
||||||
request get clone
|
request get clone
|
||||||
swap [ >>query ] when*
|
swap [ >>query ] when*
|
||||||
swap >>path
|
swap url-encode >>path
|
||||||
request-url ;
|
request-url ;
|
||||||
|
|
||||||
: replace-last-component ( path with -- path' )
|
: replace-last-component ( path with -- path' )
|
||||||
|
|
@ -66,11 +82,12 @@ SYMBOL: 404-responder
|
||||||
request get clone
|
request get clone
|
||||||
swap [ >>query ] when*
|
swap [ >>query ] when*
|
||||||
swap [ '[ , replace-last-component ] change-path ] when*
|
swap [ '[ , replace-last-component ] change-path ] when*
|
||||||
|
dup query>> modify-query >>query
|
||||||
request-url ;
|
request-url ;
|
||||||
|
|
||||||
: derive-url ( to query -- url )
|
: derive-url ( to query -- url )
|
||||||
{
|
{
|
||||||
{ [ over "http://" head? ] [ url-redirect ] }
|
{ [ over "http://" head? ] [ link>string ] }
|
||||||
{ [ over "/" head? ] [ absolute-redirect ] }
|
{ [ over "/" head? ] [ absolute-redirect ] }
|
||||||
{ [ t ] [ relative-redirect ] }
|
{ [ t ] [ relative-redirect ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
@ -91,10 +108,6 @@ TUPLE: dispatcher default responders ;
|
||||||
: <dispatcher> ( -- dispatcher )
|
: <dispatcher> ( -- dispatcher )
|
||||||
404-responder get H{ } clone dispatcher construct-boa ;
|
404-responder get H{ } clone dispatcher construct-boa ;
|
||||||
|
|
||||||
: set-main ( dispatcher name -- dispatcher )
|
|
||||||
'[ , f <permanent-redirect> ] <trivial-responder>
|
|
||||||
>>default ;
|
|
||||||
|
|
||||||
: split-path ( path -- rest first )
|
: split-path ( path -- rest first )
|
||||||
[ CHAR: / = ] left-trim "/" split1 swap ;
|
[ CHAR: / = ] left-trim "/" split1 swap ;
|
||||||
|
|
||||||
|
|
@ -107,28 +120,36 @@ TUPLE: dispatcher default responders ;
|
||||||
|
|
||||||
M: dispatcher call-responder ( path dispatcher -- response )
|
M: dispatcher call-responder ( path dispatcher -- response )
|
||||||
over [
|
over [
|
||||||
2dup find-responder call-responder [
|
find-responder call-responder
|
||||||
2nip
|
|
||||||
] [
|
|
||||||
default>> [
|
|
||||||
call-responder
|
|
||||||
] [
|
|
||||||
drop f
|
|
||||||
] if*
|
|
||||||
] if*
|
|
||||||
] [
|
] [
|
||||||
2drop redirect-with-/
|
2drop redirect-with-/
|
||||||
] if ;
|
] 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 )
|
: add-responder ( dispatcher responder path -- dispatcher )
|
||||||
pick responders>> set-at ;
|
pick responders>> set-at ;
|
||||||
|
|
||||||
: add-main-responder ( dispatcher responder path -- dispatcher )
|
: add-main-responder ( dispatcher responder path -- dispatcher )
|
||||||
[ add-responder ] keep set-main ;
|
[ add-responder ] keep set-main ;
|
||||||
|
|
||||||
: <webapp> ( class -- dispatcher )
|
|
||||||
<dispatcher> swap construct-delegate ; inline
|
|
||||||
|
|
||||||
SYMBOL: main-responder
|
SYMBOL: main-responder
|
||||||
|
|
||||||
main-responder global
|
main-responder global
|
||||||
|
|
@ -202,11 +223,3 @@ SYMBOL: exit-continuation
|
||||||
: httpd-main ( -- ) 8888 httpd ;
|
: httpd-main ( -- ) 8888 httpd ;
|
||||||
|
|
||||||
MAIN: httpd-main
|
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 ;
|
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,10 @@
|
||||||
IN: http.server.sessions.tests
|
IN: http.server.sessions.tests
|
||||||
USING: tools.test http.server.sessions math namespaces
|
USING: tools.test http http.server.sessions
|
||||||
kernel accessors ;
|
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
|
: with-session \ session swap with-variable ; inline
|
||||||
|
|
||||||
|
|
@ -10,7 +14,18 @@ C: <foo> foo
|
||||||
|
|
||||||
M: foo init-session* drop 0 "x" sset ;
|
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
|
[ ] [ 3 "x" sset ] unit-test
|
||||||
|
|
||||||
[ 9 ] [ "x" sget sq ] unit-test
|
[ 9 ] [ "x" sget sq ] unit-test
|
||||||
|
|
@ -18,22 +33,88 @@ f <session> [
|
||||||
[ ] [ "x" [ 1- ] schange ] unit-test
|
[ ] [ "x" [ 1- ] schange ] unit-test
|
||||||
|
|
||||||
[ 4 ] [ "x" sget sq ] 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 <url-sessions> url-sessions? ] unit-test
|
||||||
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
|
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
<foo> <url-sessions>
|
<foo> <url-sessions>
|
||||||
|
<sessions-in-memory> >>sessions
|
||||||
"manager" set
|
"manager" set
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ { 5 0 } ] [
|
[ { 5 0 } ] [
|
||||||
[
|
[
|
||||||
"manager" get new-session
|
"manager" get begin-session drop
|
||||||
dup "manager" get get-session [ 5 "a" sset ] with-session
|
dup "manager" get sessions>> get-session [ 5 "a" sset ] with-session
|
||||||
dup "manager" get get-session [ "a" sget , ] with-session
|
dup "manager" get sessions>> get-session [ "a" sget , ] with-session
|
||||||
dup "manager" get get-session [ "x" sget , ] with-session
|
dup "manager" get sessions>> get-session [ "x" sget , ] with-session
|
||||||
"manager" get get-session delete-session
|
"manager" get sessions>> get-session
|
||||||
|
"manager" get sessions>> delete-session
|
||||||
] { } make
|
] { } make
|
||||||
] unit-test
|
] 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
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,10 @@
|
||||||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs calendar kernel math.parser namespaces random
|
USING: assocs calendar kernel math.parser namespaces random
|
||||||
boxes alarms new-slots accessors http http.server
|
new-slots accessors http http.server
|
||||||
quotations hashtables sequences fry combinators.cleave ;
|
http.server.sessions.storage http.server.sessions.storage.assoc
|
||||||
|
quotations hashtables sequences fry combinators.cleave
|
||||||
|
html.elements symbols continuations destructors ;
|
||||||
IN: http.server.sessions
|
IN: http.server.sessions
|
||||||
|
|
||||||
! ! ! ! ! !
|
! ! ! ! ! !
|
||||||
|
|
@ -16,62 +18,48 @@ M: dispatcher init-session* drop ;
|
||||||
TUPLE: session-manager responder sessions ;
|
TUPLE: session-manager responder sessions ;
|
||||||
|
|
||||||
: <session-manager> ( responder class -- responder' )
|
: <session-manager> ( responder class -- responder' )
|
||||||
>r H{ } clone session-manager construct-boa r>
|
>r <sessions-in-memory> session-manager construct-boa
|
||||||
construct-delegate ; inline
|
r> construct-delegate ; inline
|
||||||
|
|
||||||
TUPLE: session manager id namespace alarm ;
|
SYMBOLS: session session-id session-changed? ;
|
||||||
|
|
||||||
: <session> ( manager -- session )
|
: sget ( key -- value )
|
||||||
f H{ } clone <box> \ session construct-boa ;
|
session get at ;
|
||||||
|
|
||||||
: timeout ( -- dt ) 20 minutes ;
|
: sset ( value key -- )
|
||||||
|
session get set-at
|
||||||
|
session-changed? on ;
|
||||||
|
|
||||||
: cancel-timeout ( session -- )
|
: schange ( key quot -- )
|
||||||
alarm>> [ cancel-alarm ] if-box? ;
|
session get swap change-at
|
||||||
|
session-changed? on ; inline
|
||||||
|
|
||||||
: delete-session ( session -- )
|
: sessions session-manager get sessions>> ;
|
||||||
[ cancel-timeout ]
|
|
||||||
[ dup manager>> sessions>> delete-at ]
|
|
||||||
bi ;
|
|
||||||
|
|
||||||
: touch-session ( session -- session )
|
: managed-responder session-manager get responder>> ;
|
||||||
[ cancel-timeout ]
|
|
||||||
[ [ '[ , delete-session ] timeout later ] keep alarm>> >box ]
|
|
||||||
[ ]
|
|
||||||
tri ;
|
|
||||||
|
|
||||||
: 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 )
|
M: session-saver dispose
|
||||||
dup dup \ session [
|
session-changed? get [
|
||||||
manager>> responder>> init-session*
|
[ session>> ] [ id>> ] bi
|
||||||
] with-variable ;
|
sessions update-session
|
||||||
|
] [ drop ] if ;
|
||||||
|
|
||||||
: new-session ( responder -- id )
|
: call-responder/session ( path responder id session -- response )
|
||||||
[ <session> init-session touch-session ]
|
[ <session-saver> add-always-destructor ]
|
||||||
[ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ]
|
[ [ session-id set ] [ session set ] bi* ] 2bi
|
||||||
bi id>> ;
|
[ session-manager set ] [ responder>> call-responder ] bi ;
|
||||||
|
|
||||||
: 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* ;
|
|
||||||
|
|
||||||
TUPLE: null-sessions ;
|
TUPLE: null-sessions ;
|
||||||
|
|
||||||
|
|
@ -79,49 +67,64 @@ TUPLE: null-sessions ;
|
||||||
null-sessions <session-manager> ;
|
null-sessions <session-manager> ;
|
||||||
|
|
||||||
M: null-sessions call-responder ( path responder -- response )
|
M: null-sessions call-responder ( path responder -- response )
|
||||||
dup <session> call-responder/session ;
|
H{ } clone f call-responder/session ;
|
||||||
|
|
||||||
TUPLE: url-sessions ;
|
TUPLE: url-sessions ;
|
||||||
|
|
||||||
: <url-sessions> ( responder -- responder' )
|
: <url-sessions> ( responder -- responder' )
|
||||||
url-sessions <session-manager> ;
|
url-sessions <session-manager> ;
|
||||||
|
|
||||||
: sess-id "factorsessid" ;
|
: session-id-key "factorsessid" ;
|
||||||
|
|
||||||
: current-session ( responder request -- session )
|
: current-url-session ( responder -- id/f session/f )
|
||||||
sess-id query-param swap get-session ;
|
[ 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 )
|
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
|
call-responder/session
|
||||||
] [
|
] [
|
||||||
nip
|
2drop nip new-url-session
|
||||||
f swap new-session sess-id associate <temporary-redirect>
|
] if ;
|
||||||
] 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 ;
|
|
||||||
|
|
||||||
TUPLE: cookie-sessions ;
|
TUPLE: cookie-sessions ;
|
||||||
|
|
||||||
: <cookie-sessions> ( responder -- responder' )
|
: <cookie-sessions> ( responder -- responder' )
|
||||||
cookie-sessions <session-manager> ;
|
cookie-sessions <session-manager> ;
|
||||||
|
|
||||||
: get-session-cookie ( responder -- cookie )
|
: current-cookie-session ( responder -- id namespace/f )
|
||||||
request get sess-id get-cookie
|
request get session-id-key get-cookie dup
|
||||||
[ value>> swap get-session ] [ drop f ] if* ;
|
[ value>> dup rot sessions>> get-session ] [ 2drop f f ] if ;
|
||||||
|
|
||||||
: <session-cookie> ( id -- cookie )
|
: <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 )
|
M: cookie-sessions call-responder ( path responder -- response )
|
||||||
dup get-session-cookie [
|
dup current-cookie-session dup [
|
||||||
call-responder/session
|
call-responder/session
|
||||||
] [
|
] [
|
||||||
dup new-session
|
2drop call-responder/new-session
|
||||||
[ over get-session call-responder/session ] keep
|
] if ;
|
||||||
<session-cookie> put-cookie
|
|
||||||
] if* ;
|
|
||||||
|
|
|
||||||
|
|
@ -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 ;
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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 ;
|
||||||
|
|
@ -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 )
|
||||||
|
|
@ -7,16 +7,11 @@ calendar.format new-slots accessors io.encodings.binary
|
||||||
combinators.cleave fry ;
|
combinators.cleave fry ;
|
||||||
IN: http.server.static
|
IN: http.server.static
|
||||||
|
|
||||||
SYMBOL: responder
|
|
||||||
|
|
||||||
! special maps mime types to quots with effect ( path -- )
|
! special maps mime types to quots with effect ( path -- )
|
||||||
TUPLE: file-responder root hook special ;
|
TUPLE: file-responder root hook special ;
|
||||||
|
|
||||||
: unix-time>timestamp ( n -- timestamp )
|
|
||||||
>r unix-1970 r> seconds time+ ;
|
|
||||||
|
|
||||||
: file-http-date ( filename -- string )
|
: 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 -- ? )
|
: last-modified-matches? ( filename -- ? )
|
||||||
file-http-date dup [
|
file-http-date dup [
|
||||||
|
|
@ -33,7 +28,7 @@ TUPLE: file-responder root hook special ;
|
||||||
[
|
[
|
||||||
<content>
|
<content>
|
||||||
swap
|
swap
|
||||||
[ file-length "content-length" set-header ]
|
[ file-info file-info-size "content-length" set-header ]
|
||||||
[ file-http-date "last-modified" set-header ]
|
[ file-http-date "last-modified" set-header ]
|
||||||
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]
|
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]
|
||||||
tri
|
tri
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,8 @@ IN: http.server.validators.tests
|
||||||
USING: kernel sequences tools.test http.server.validators
|
USING: kernel sequences tools.test http.server.validators
|
||||||
accessors ;
|
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" ] [
|
||||||
"slava@factorcode.org" v-email
|
"slava@factorcode.org" v-email
|
||||||
|
|
@ -13,10 +14,10 @@ accessors ;
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "slava@factorcode.o" v-email ]
|
[ "slava@factorcode.o" v-email ]
|
||||||
[ reason>> "invalid e-mail" = ] must-fail-with
|
[ "invalid e-mail" = ] must-fail-with
|
||||||
|
|
||||||
[ "sla@@factorcode.o" v-email ]
|
[ "sla@@factorcode.o" v-email ]
|
||||||
[ reason>> "invalid e-mail" = ] must-fail-with
|
[ "invalid e-mail" = ] must-fail-with
|
||||||
|
|
||||||
[ "slava@factorcodeorg" v-email ]
|
[ "slava@factorcodeorg" v-email ]
|
||||||
[ reason>> "invalid e-mail" = ] must-fail-with
|
[ "invalid e-mail" = ] must-fail-with
|
||||||
|
|
|
||||||
|
|
@ -5,21 +5,26 @@ math.parser assocs new-slots regexp fry unicode.categories
|
||||||
combinators.cleave sequences ;
|
combinators.cleave sequences ;
|
||||||
IN: http.server.validators
|
IN: http.server.validators
|
||||||
|
|
||||||
|
SYMBOL: validation-failed?
|
||||||
|
|
||||||
TUPLE: validation-error value reason ;
|
TUPLE: validation-error value reason ;
|
||||||
|
|
||||||
: validation-error ( value reason -- * )
|
C: <validation-error> validation-error
|
||||||
\ validation-error construct-boa throw ;
|
|
||||||
|
: with-validator ( value quot -- result )
|
||||||
|
[ validation-failed? on <validation-error> ] recover ;
|
||||||
|
inline
|
||||||
|
|
||||||
: v-default ( str def -- str )
|
: v-default ( str def -- str )
|
||||||
over empty? spin ? ;
|
over empty? spin ? ;
|
||||||
|
|
||||||
: v-required ( str -- str )
|
: v-required ( str -- str )
|
||||||
dup empty? [ "required" validation-error ] when ;
|
dup empty? [ "required" throw ] when ;
|
||||||
|
|
||||||
: v-min-length ( str n -- str )
|
: v-min-length ( str n -- str )
|
||||||
over length over < [
|
over length over < [
|
||||||
[ "must be at least " % # " characters" % ] "" make
|
[ "must be at least " % # " characters" % ] "" make
|
||||||
validation-error
|
throw
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
@ -27,35 +32,34 @@ TUPLE: validation-error value reason ;
|
||||||
: v-max-length ( str n -- str )
|
: v-max-length ( str n -- str )
|
||||||
over length over > [
|
over length over > [
|
||||||
[ "must be no more than " % # " characters" % ] "" make
|
[ "must be no more than " % # " characters" % ] "" make
|
||||||
validation-error
|
throw
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: v-number ( str -- n )
|
: v-number ( str -- n )
|
||||||
dup string>number [ ] [
|
dup string>number [ ] [ "must be a number" throw ] ?if ;
|
||||||
"must be a number" validation-error
|
|
||||||
] ?if ;
|
: v-integer ( n -- n )
|
||||||
|
dup integer? [ "must be an integer" throw ] unless ;
|
||||||
|
|
||||||
: v-min-value ( x n -- x )
|
: v-min-value ( x n -- x )
|
||||||
2dup < [
|
2dup < [
|
||||||
[ "must be at least " % # ] "" make
|
[ "must be at least " % # ] "" make throw
|
||||||
validation-error
|
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: v-max-value ( x n -- x )
|
: v-max-value ( x n -- x )
|
||||||
2dup > [
|
2dup > [
|
||||||
[ "must be no more than " % # ] "" make
|
[ "must be no more than " % # ] "" make throw
|
||||||
validation-error
|
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: v-regexp ( str what regexp -- str )
|
: v-regexp ( str what regexp -- str )
|
||||||
>r over r> matches?
|
>r over r> matches?
|
||||||
[ drop ] [ "invalid " swap append validation-error ] if ;
|
[ drop ] [ "invalid " swap append throw ] if ;
|
||||||
|
|
||||||
: v-email ( str -- str )
|
: v-email ( str -- str )
|
||||||
#! From http://www.regular-expressions.info/email.html
|
#! From http://www.regular-expressions.info/email.html
|
||||||
|
|
@ -64,12 +68,12 @@ TUPLE: validation-error value reason ;
|
||||||
v-regexp ;
|
v-regexp ;
|
||||||
|
|
||||||
: v-captcha ( str -- str )
|
: v-captcha ( str -- str )
|
||||||
dup empty? [ "must remain blank" validation-error ] unless ;
|
dup empty? [ "must remain blank" throw ] unless ;
|
||||||
|
|
||||||
: v-one-line ( str -- str )
|
: v-one-line ( str -- str )
|
||||||
dup "\r\n" seq-intersect empty?
|
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 )
|
: v-one-word ( str -- str )
|
||||||
dup [ alpha? ] all?
|
dup [ alpha? ] all?
|
||||||
[ "must be a single word" validation-error ] unless ;
|
[ "must be a single word" throw ] unless ;
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
@ -3,13 +3,16 @@
|
||||||
USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ;
|
USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ;
|
||||||
IN: io.encodings.ascii
|
IN: io.encodings.ascii
|
||||||
|
|
||||||
: encode-check<= ( string stream max -- )
|
: encode-check< ( string stream max -- )
|
||||||
[ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ;
|
[ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ;
|
||||||
|
|
||||||
|
: push-if< ( sbuf character max -- )
|
||||||
|
over <= [ drop HEX: fffd ] when swap push ;
|
||||||
|
|
||||||
TUPLE: ascii ;
|
TUPLE: ascii ;
|
||||||
|
|
||||||
M: ascii stream-write-encoded ( string stream encoding -- )
|
M: ascii stream-write-encoded ( string stream encoding -- )
|
||||||
drop 128 encode-check<= ;
|
drop 128 encode-check< ;
|
||||||
|
|
||||||
M: ascii decode-step
|
M: ascii decode-step
|
||||||
drop dup 128 >= [ decode-error ] [ swap push ] if ;
|
drop 128 push-if< ;
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
@ -6,7 +6,7 @@ IN: io.encodings.latin1
|
||||||
TUPLE: latin1 ;
|
TUPLE: latin1 ;
|
||||||
|
|
||||||
M: latin1 stream-write-encoded
|
M: latin1 stream-write-encoded
|
||||||
drop 256 encode-check<= ;
|
drop 256 encode-check< ;
|
||||||
|
|
||||||
M: latin1 decode-step
|
M: latin1 decode-step
|
||||||
drop swap push ;
|
drop swap push ;
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@ IN: io.mmap.tests
|
||||||
|
|
||||||
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
||||||
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
|
[ ] [ "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
|
[ ] [ "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-length [ length ] 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
|
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
|
||||||
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
||||||
|
|
|
||||||
|
|
@ -1,15 +1,15 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io.backend io.nonblocking io.unix.backend io.files io
|
USING: io.backend io.nonblocking io.unix.backend io.files io
|
||||||
unix unix.stat unix.time kernel math continuations math.bitfields
|
unix unix.stat unix.time kernel math continuations
|
||||||
byte-arrays alien combinators combinators.cleave calendar
|
math.bitfields byte-arrays alien combinators combinators.cleave
|
||||||
io.encodings.binary ;
|
calendar io.encodings.binary ;
|
||||||
|
|
||||||
IN: io.unix.files
|
IN: io.unix.files
|
||||||
|
|
||||||
M: unix-io cwd
|
M: unix-io cwd
|
||||||
MAXPATHLEN dup <byte-array> swap
|
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
|
||||||
getcwd [ (io-error) ] unless* ;
|
[ (io-error) ] unless* ;
|
||||||
|
|
||||||
M: unix-io cd
|
M: unix-io cd
|
||||||
chdir io-error ;
|
chdir io-error ;
|
||||||
|
|
@ -68,7 +68,9 @@ M: unix-io delete-directory ( path -- )
|
||||||
] with-disposal ;
|
] with-disposal ;
|
||||||
|
|
||||||
M: unix-io copy-file ( from to -- )
|
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>type ( stat -- type )
|
||||||
stat-st_mode {
|
stat-st_mode {
|
||||||
|
|
@ -82,8 +84,8 @@ M: unix-io copy-file ( from to -- )
|
||||||
{ [ t ] [ +unknown+ ] }
|
{ [ t ] [ +unknown+ ] }
|
||||||
} cond nip ;
|
} cond nip ;
|
||||||
|
|
||||||
M: unix-io file-info ( path -- info )
|
: stat>file-info ( stat -- info )
|
||||||
stat* {
|
{
|
||||||
[ stat>type ]
|
[ stat>type ]
|
||||||
[ stat-st_size ]
|
[ stat-st_size ]
|
||||||
[ stat-st_mode ]
|
[ stat-st_mode ]
|
||||||
|
|
@ -91,11 +93,8 @@ M: unix-io file-info ( path -- info )
|
||||||
} cleave
|
} cleave
|
||||||
\ file-info construct-boa ;
|
\ file-info construct-boa ;
|
||||||
|
|
||||||
|
M: unix-io file-info ( path -- info )
|
||||||
|
stat* stat>file-info ;
|
||||||
|
|
||||||
M: unix-io link-info ( path -- info )
|
M: unix-io link-info ( path -- info )
|
||||||
lstat* {
|
lstat* stat>file-info ;
|
||||||
[ stat>type ]
|
|
||||||
[ stat-st_size ]
|
|
||||||
[ stat-st_mode ]
|
|
||||||
[ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
|
|
||||||
} cleave
|
|
||||||
\ file-info construct-boa ;
|
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
IN: io.unix.freebsd
|
IN: io.unix.freebsd
|
||||||
USING: io.unix.bsd io.backend core-foundation.fsevents ;
|
USING: io.unix.bsd io.backend ;
|
||||||
|
|
||||||
TUPLE: freebsd-io ;
|
TUPLE: freebsd-io ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -4,4 +4,4 @@ combinators namespaces system vocabs.loader sequences ;
|
||||||
|
|
||||||
"io.unix." os append require
|
"io.unix." os append require
|
||||||
|
|
||||||
"vocabs.monitor" require
|
"tools.vocabs.monitor" require
|
||||||
|
|
|
||||||
|
|
@ -3,43 +3,35 @@
|
||||||
USING: alien.c-types io.files io.windows kernel
|
USING: alien.c-types io.files io.windows kernel
|
||||||
math windows windows.kernel32 combinators.cleave
|
math windows windows.kernel32 combinators.cleave
|
||||||
windows.time calendar combinators math.functions
|
windows.time calendar combinators math.functions
|
||||||
sequences combinators.lib combinators.cleave
|
sequences namespaces words symbols ;
|
||||||
namespaces words symbols ;
|
|
||||||
IN: io.windows.files
|
IN: io.windows.files
|
||||||
|
|
||||||
SYMBOLS: +read-only+ +hidden+ +system+
|
SYMBOLS: +read-only+ +hidden+ +system+
|
||||||
+directory+ +archive+ +device+ +normal+ +temporary+
|
+archive+ +device+ +normal+ +temporary+
|
||||||
+sparse-file+ +reparse-point+ +compressed+ +offline+
|
+sparse-file+ +reparse-point+ +compressed+ +offline+
|
||||||
+not-content-indexed+ +encrypted+ ;
|
+not-content-indexed+ +encrypted+ ;
|
||||||
|
|
||||||
: expand-constants ( word/obj -- obj'/obj )
|
: win32-file-attribute ( n attr symbol -- n )
|
||||||
dup word? [ execute ] when ;
|
>r dupd mask? [ r> , ] [ r> drop ] if ;
|
||||||
|
|
||||||
: get-flags ( n seq -- seq' )
|
|
||||||
[
|
|
||||||
[
|
|
||||||
first2 expand-constants
|
|
||||||
[ swapd mask? [ , ] [ drop ] if ] 2curry
|
|
||||||
] map cleave
|
|
||||||
] { } make ;
|
|
||||||
|
|
||||||
: win32-file-attributes ( n -- seq )
|
: win32-file-attributes ( n -- seq )
|
||||||
{
|
[
|
||||||
{ +read-only+ FILE_ATTRIBUTE_READONLY }
|
FILE_ATTRIBUTE_READONLY +read-only+ win32-file-attribute
|
||||||
{ +hidden+ FILE_ATTRIBUTE_HIDDEN }
|
FILE_ATTRIBUTE_HIDDEN +hidden+ win32-file-attribute
|
||||||
{ +system+ FILE_ATTRIBUTE_SYSTEM }
|
FILE_ATTRIBUTE_SYSTEM +system+ win32-file-attribute
|
||||||
{ +directory+ FILE_ATTRIBUTE_DIRECTORY }
|
FILE_ATTRIBUTE_DIRECTORY +directory+ win32-file-attribute
|
||||||
{ +archive+ FILE_ATTRIBUTE_ARCHIVE }
|
FILE_ATTRIBUTE_ARCHIVE +archive+ win32-file-attribute
|
||||||
{ +device+ FILE_ATTRIBUTE_DEVICE }
|
FILE_ATTRIBUTE_DEVICE +device+ win32-file-attribute
|
||||||
{ +normal+ FILE_ATTRIBUTE_NORMAL }
|
FILE_ATTRIBUTE_NORMAL +normal+ win32-file-attribute
|
||||||
{ +temporary+ FILE_ATTRIBUTE_TEMPORARY }
|
FILE_ATTRIBUTE_TEMPORARY +temporary+ win32-file-attribute
|
||||||
{ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE }
|
FILE_ATTRIBUTE_SPARSE_FILE +sparse-file+ win32-file-attribute
|
||||||
{ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT }
|
FILE_ATTRIBUTE_REPARSE_POINT +reparse-point+ win32-file-attribute
|
||||||
{ +compressed+ FILE_ATTRIBUTE_COMPRESSED }
|
FILE_ATTRIBUTE_COMPRESSED +compressed+ win32-file-attribute
|
||||||
{ +offline+ FILE_ATTRIBUTE_OFFLINE }
|
FILE_ATTRIBUTE_OFFLINE +offline+ win32-file-attribute
|
||||||
{ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED }
|
FILE_ATTRIBUTE_NOT_CONTENT_INDEXED +not-content-indexed+ win32-file-attribute
|
||||||
{ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED }
|
FILE_ATTRIBUTE_ENCRYPTED +encrypted+ win32-file-attribute
|
||||||
} get-flags ;
|
drop
|
||||||
|
] { } make ;
|
||||||
|
|
||||||
: win32-file-type ( n -- symbol )
|
: win32-file-type ( n -- symbol )
|
||||||
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
|
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
|
||||||
|
|
|
||||||
|
|
@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking
|
||||||
io.streams.duplex windows.types math windows.kernel32 windows
|
io.streams.duplex windows.types math windows.kernel32 windows
|
||||||
namespaces io.launcher kernel sequences windows.errors assocs
|
namespaces io.launcher kernel sequences windows.errors assocs
|
||||||
splitting system threads init strings combinators
|
splitting system threads init strings combinators
|
||||||
io.backend new-slots accessors ;
|
io.backend new-slots accessors concurrency.flags ;
|
||||||
IN: io.windows.launcher
|
IN: io.windows.launcher
|
||||||
|
|
||||||
TUPLE: CreateProcess-args
|
TUPLE: CreateProcess-args
|
||||||
|
|
@ -137,18 +137,18 @@ M: windows-io kill-process* ( handle -- )
|
||||||
dup HEX: ffffffff = [ win32-error ] when
|
dup HEX: ffffffff = [ win32-error ] when
|
||||||
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
|
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
|
||||||
|
|
||||||
|
SYMBOL: wait-flag
|
||||||
|
|
||||||
: wait-loop ( -- )
|
: wait-loop ( -- )
|
||||||
processes get dup assoc-empty?
|
processes get dup assoc-empty?
|
||||||
[ drop f sleep-until ]
|
[ drop wait-flag get-global lower-flag ]
|
||||||
[ wait-for-processes [ 100 sleep ] when ] if ;
|
[ wait-for-processes [ 100 sleep ] when ] if ;
|
||||||
|
|
||||||
SYMBOL: wait-thread
|
|
||||||
|
|
||||||
: start-wait-thread ( -- )
|
: start-wait-thread ( -- )
|
||||||
[ wait-loop t ] "Process wait" spawn-server
|
<flag> wait-flag set-global
|
||||||
wait-thread set-global ;
|
[ wait-loop t ] "Process wait" spawn-server drop ;
|
||||||
|
|
||||||
M: windows-io register-process
|
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
|
[ start-wait-thread ] "io.windows.launcher" add-init-hook
|
||||||
|
|
|
||||||
|
|
@ -14,4 +14,4 @@ USE: io.backend
|
||||||
|
|
||||||
T{ windows-nt-io } set-io-backend
|
T{ windows-nt-io } set-io-backend
|
||||||
|
|
||||||
"vocabs.monitor" require
|
"tools.vocabs.monitor" require
|
||||||
|
|
|
||||||
|
|
@ -76,11 +76,8 @@ M: win32-file close-handle ( handle -- )
|
||||||
] when drop ;
|
] when drop ;
|
||||||
|
|
||||||
: open-append ( path -- handle length )
|
: open-append ( path -- handle length )
|
||||||
dup file-length dup [
|
[ dup file-info file-info-size ] [ drop 0 ] recover
|
||||||
>r (open-append) r> 2dup set-file-pointer
|
>r (open-append) r> 2dup set-file-pointer ;
|
||||||
] [
|
|
||||||
drop open-write
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
TUPLE: FileArgs
|
TUPLE: FileArgs
|
||||||
hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;
|
hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;
|
||||||
|
|
|
||||||
|
|
@ -59,7 +59,7 @@ M: jamshred-gadget ungraft* ( gadget -- )
|
||||||
|
|
||||||
USE: vocabs.loader
|
USE: vocabs.loader
|
||||||
jamshred-gadget H{
|
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{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] }
|
||||||
{ T{ motion } [ handle-mouse-motion ] }
|
{ T{ motion } [ handle-mouse-motion ] }
|
||||||
} set-gestures
|
} set-gestures
|
||||||
|
|
|
||||||
|
|
@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ;
|
||||||
IN: ldap.libldap
|
IN: ldap.libldap
|
||||||
|
|
||||||
<< "libldap" {
|
<< "libldap" {
|
||||||
{ [ win32? ] [ "libldap.dll" "stdcall" ] }
|
{ [ win32? ] [ "libldap.dll" "stdcall" ] }
|
||||||
{ [ macosx? ] [ "libldap.dylib" "cdecl" ] }
|
{ [ macosx? ] [ "libldap.dylib" "cdecl" ] }
|
||||||
{ [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] }
|
{ [ unix? ] [ "libldap.so" "cdecl" ] }
|
||||||
} cond add-library >>
|
} cond add-library >>
|
||||||
|
|
||||||
: LDAP_VERSION1 1 ; inline
|
: LDAP_VERSION1 1 ; inline
|
||||||
|
|
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue