diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 475cf72d28..95b29ee50b 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -65,8 +65,7 @@ HELP: dlclose ( dll -- ) HELP: load-library { $values { "name" "a string" } { "dll" "a DLL handle" } } -{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } -{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ; +{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ; HELP: add-library { $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } } diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 0369d55fb3..bce2e16d73 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -57,7 +57,7 @@ TUPLE: library path abi dll ; over dup [ dlopen ] when \ library construct-boa ; : load-library ( name -- dll ) - library library-dll ; + library dup [ library-dll ] when ; : add-library ( name path abi -- ) swap libraries get set-at ; diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index c3f5c64b29..f1d8abdc1e 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -262,8 +262,8 @@ M: long-long-type box-return ( type -- ) r> add* ] when ; -: malloc-file-contents ( path -- alien ) - binary file-contents malloc-byte-array ; +: malloc-file-contents ( path -- alien len ) + binary file-contents dup malloc-byte-array swap length ; [ [ alien-cell ] diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 0e038d0a10..74b4d03cbb 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -47,6 +47,7 @@ vocabs.loader system debugger continuations ; "listener" vocab [ restarts. vocab-main execute ] [ die ] if* + 1 exit ] recover ] [ "Cannot find " write write "." print diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 81063031f9..7209b7ec4d 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -29,7 +29,9 @@ $nl { $subsection ignore-errors } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } -{ $subsection "errors-post-mortem" } ; +{ $subsection "errors-post-mortem" } +"When Factor encouters a critical error, it calls the following word:" +{ $subsection die } ; ARTICLE: "continuations.private" "Continuation implementation details" "A continuation is simply a tuple holding the contents of the five stacks:" diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 40bcbe78b1..ad2fa14954 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -214,7 +214,7 @@ M: check-closed summary drop "Attempt to perform I/O on closed stream" ; M: check-method summary - drop "Invalid parameters for define-method" ; + drop "Invalid parameters for create-method" ; M: check-tuple summary drop "Invalid class for define-constructor" ; diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index 4e8fb255dd..ebbce4d7e2 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -1,10 +1,10 @@ IN: definitions.tests USING: tools.test generic kernel definitions sequences -compiler.units ; +compiler.units words ; TUPLE: combination-1 ; -M: combination-1 perform-combination 2drop { } [ ] each [ ] ; +M: combination-1 perform-combination 2drop [ ] ; M: combination-1 make-default-method 2drop [ "No method" throw ] ; @@ -13,7 +13,7 @@ SYMBOL: generic-1 [ generic-1 T{ combination-1 } define-generic - [ ] object \ generic-1 define-method + object \ generic-1 create-method [ ] define ] with-compilation-unit [ ] [ diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 9b799d9143..62b85dde3a 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -34,7 +34,7 @@ $nl { $subsection define-generic } { $subsection define-simple-generic } "Methods can be added to existing generic words:" -{ $subsection define-method } +{ $subsection create-method } "Method definitions can be looked up:" { $subsection method } { $subsection methods } @@ -123,7 +123,7 @@ HELP: method { $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } } { $description "Looks up a method definition." } ; -{ method define-method POSTPONE: M: } related-words +{ method create-method POSTPONE: M: } related-words HELP: { $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } } @@ -140,16 +140,17 @@ HELP: order HELP: check-method { $values { "class" class } { "generic" generic } } { $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." } -{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ; +{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ; HELP: with-methods { $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } } { $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." } $low-level-note ; -HELP: define-method -{ $values { "quot" quotation } { "class" class } { "generic" generic } } -{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ; +HELP: create-method +{ $values { "class" class } { "generic" generic } { "method" method-body } } +{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." } +{ $notes "To define a method, pass the output value to " { $link define } "." } ; HELP: implementors { $values { "class" class } { "seq" "a sequence of generic words" } } diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 3c83b87d49..ad31831e94 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -17,10 +17,6 @@ M: object perform-combination #! the method will throw an error. We don't want that. nip [ "Invalid method combination" throw ] curry [ ] like ; -GENERIC: method-prologue ( class combination -- quot ) - -M: object method-prologue 2drop [ ] ; - GENERIC: make-default-method ( generic combination -- method ) PREDICATE: word generic "combination" word-prop >boolean ; @@ -50,55 +46,49 @@ TUPLE: check-method class generic ; : check-method ( class generic -- class generic ) over class? over generic? and [ \ check-method construct-boa throw - ] unless ; + ] unless ; inline -: with-methods ( word quot -- ) +: with-methods ( generic quot -- ) swap [ "methods" word-prop swap call ] keep make-generic ; inline : method-word-name ( class word -- string ) word-name "/" rot word-name 3append ; -: make-method-def ( quot class generic -- quot ) - "combination" word-prop method-prologue swap append ; - -PREDICATE: word method-body "method-def" word-prop >boolean ; +PREDICATE: word method-body + "method-generic" word-prop >boolean ; M: method-body stack-effect "method-generic" word-prop stack-effect ; -: method-word-props ( quot class generic -- assoc ) +: method-word-props ( class generic -- assoc ) [ "method-generic" set "method-class" set - "method-def" set ] H{ } make-assoc ; -: ( quot class generic -- method ) +: ( class generic -- method ) check-method - [ make-method-def ] 3keep [ method-word-props ] 2keep method-word-name f - tuck set-word-props - dup rot define ; + [ set-word-props ] keep ; -: redefine-method ( quot class generic -- ) - [ method swap "method-def" set-word-prop ] 3keep - [ make-method-def ] 2keep - method swap define ; +: reveal-method ( method class generic -- ) + [ set-at ] with-methods ; -: define-method ( quot class generic -- ) - >r bootstrap-word r> - 2dup method [ - redefine-method +: create-method ( class generic -- method ) + 2dup method dup [ + 2nip ] [ - [ ] 2keep - [ set-at ] with-methods + drop [ dup ] 2keep reveal-method ] if ; +: ( generic combination -- method ) + object bootstrap-word pick + [ -rot make-default-method define ] keep ; + : define-default-method ( generic combination -- ) - dupd make-default-method object bootstrap-word pick - "default-method" set-word-prop ; + dupd "default-method" set-word-prop ; ! Definition protocol M: method-spec where @@ -108,11 +98,10 @@ M: method-spec set-where first2 method set-where ; M: method-spec definer - drop \ M: \ ; ; + first2 method definer ; M: method-spec definition - first2 method dup - [ "method-def" word-prop ] when ; + first2 method definition ; : forget-method ( class generic -- ) check-method @@ -125,9 +114,6 @@ M: method-spec forget* M: method-body definer drop \ M: \ ; ; -M: method-body definition - "method-def" word-prop ; - M: method-body forget* dup "method-class" word-prop swap "method-generic" word-prop diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 27b0ddb7a2..9fd5481a39 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ; : applicable-method ( generic class -- quot ) over method - [ word-def ] + [ 1quotation ] [ default-math-method ] ?if ; : object-method ( generic -- quot ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 313f487c99..c634e02e75 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -8,10 +8,6 @@ IN: generic.standard TUPLE: standard-combination # ; -M: standard-combination method-prologue - standard-combination-# object - swap add* [ declare ] curry ; - C: standard-combination SYMBOL: (dispatch#) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index e2eeef6528..e347e3e3d6 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,6 +1,10 @@ IN: io.files.tests USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; +[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test +[ ] [ "blahblah" temp-file make-directory ] unit-test +[ t ] [ "blahblah" temp-file directory? ] unit-test + [ "passwd" ] [ "/etc/passwd" file-name ] unit-test [ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test @@ -123,3 +127,7 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ; [ ] [ "copy-tree-test" temp-file delete-tree ] unit-test [ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test + +[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test + +[ ] [ "append-test" ascii dispose ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 3ab489739b..a6320a7507 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -86,15 +86,11 @@ SYMBOL: +unknown+ : stat ( path -- directory? permissions length modified ) normalize-pathname (stat) ; -! : file-length ( path -- n ) stat drop 2nip ; - : file-modified ( path -- n ) stat >r 3drop r> ; -! : file-permissions ( path -- perm ) stat 2drop nip ; - : exists? ( path -- ? ) file-modified >boolean ; -: directory? ( path -- ? ) stat 3drop ; +: directory? ( path -- ? ) file-info file-info-type +directory+ = ; ! Current working directory HOOK: cd io-backend ( path -- ) @@ -220,10 +216,7 @@ M: pathname <=> [ pathname-string ] compare ; >r r> with-stream ; inline : file-contents ( path encoding -- str ) - dupd [ file-info file-info-size read ] with-file-reader ; - -! : file-contents ( path encoding -- str ) -! dupd [ file-length read ] with-file-reader ; + contents ; : with-file-writer ( path encoding quot -- ) >r r> with-stream ; inline diff --git a/core/io/io.factor b/core/io/io.factor index 2d927d088a..ef9eae7902 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables generic kernel math namespaces sequences strings - continuations assocs io.styles sbufs ; +USING: hashtables generic kernel math namespaces sequences +continuations assocs io.styles ; IN: io GENERIC: stream-readln ( stream -- str ) @@ -88,4 +88,6 @@ SYMBOL: stderr [ [ readln dup ] [ ] [ drop ] unfold ] with-stream ; : contents ( stream -- str ) - 2048 [ stream-copy ] keep >string ; + [ + [ 65536 read dup ] [ ] [ drop ] unfold concat f like + ] with-stream ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 8e107975bb..0babb14fa7 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -429,7 +429,14 @@ $nl { $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ; HELP: die -{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." } ; +{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." } +{ $notes + "The term FEP originates from the Lisp machines of old. According to the Jargon File," + $nl + { $strong "fepped out" } " /fept owt/ " { $emphasis "adj." } " The Symbolics 3600 LISP Machine has a Front-End Processor called a `FEP' (compare sense 2 of box). When the main processor gets wedged, the FEP takes control of the keyboard and screen. Such a machine is said to have `fepped out' or `dropped into the fep'." + $nl + { $url "http://www.jargon.net/jargonfile/f/feppedout.html" } +} ; HELP: (clone) ( obj -- newobj ) { $values { "obj" object } { "newobj" "a shallow copy" } } diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 10a9fda3ea..5153d84c7f 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -24,20 +24,40 @@ IN: optimizer.specializers \ dispatch , ] [ ] make ; -: specializer-methods ( quot word -- default alist ) +: specializer-cases ( quot word -- default alist ) dup [ array? ] all? [ 1array ] unless [ [ make-specializer ] keep [ declare ] curry pick append ] { } map>assoc ; +: method-declaration ( method -- quot ) + dup "method-generic" word-prop dispatch# object + swap "method-class" word-prop add* ; + +: specialize-method ( quot method -- quot' ) + method-declaration [ declare ] curry swap append ; + +: specialize-quot ( quot specializer -- quot' ) + dup { number } = [ + drop tag-specializer + ] [ + specializer-cases alist>quot + ] if ; + +: standard-method? ( method -- ? ) + dup method-body? [ + "method-generic" word-prop standard-generic? + ] [ drop f ] if ; + : specialized-def ( word -- quot ) - dup word-def swap "specializer" word-prop [ - dup { number } = [ - drop tag-specializer - ] [ - specializer-methods alist>quot - ] if - ] when* ; + dup word-def swap { + { [ dup standard-method? ] [ specialize-method ] } + { + [ dup "specializer" word-prop ] + [ "specializer" word-prop specialize-quot ] + } + { [ t ] [ drop ] } + } cond ; : specialized-length ( specializer -- n ) dup [ array? ] all? [ first ] when length ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 50f8f582d3..cf31c16662 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -215,9 +215,6 @@ SYMBOL: in : set-in ( name -- ) check-vocab-string dup in set create-vocab (use+) ; -: create-in ( string -- word ) - in get create dup set-word dup save-location ; - TUPLE: unexpected want got ; : unexpected ( want got -- * ) @@ -238,8 +235,15 @@ PREDICATE: unexpected unexpected-eof : parse-tokens ( end -- seq ) 100 swap (parse-tokens) >array ; +: create-in ( string -- word ) + in get create dup set-word dup save-location ; + : CREATE ( -- word ) scan create-in ; +: CREATE-GENERIC ( -- word ) CREATE dup reset-word ; + +: CREATE-WORD ( -- word ) CREATE dup reset-generic ; + : create-class-in ( word -- word ) in get create dup save-class-location @@ -284,6 +288,12 @@ M: no-word summary ] ?if ] when ; +: create-method-in ( class generic -- method ) + create-method f set-word dup save-location ; + +: CREATE-METHOD ( -- method ) + scan-word bootstrap-word scan-word create-method-in ; + TUPLE: staging-violation word ; : staging-violation ( word -- * ) @@ -355,7 +365,9 @@ TUPLE: bad-number ; : parse-definition ( -- quot ) \ ; parse-until >quotation ; -: (:) CREATE dup reset-generic parse-definition ; +: (:) CREATE-WORD parse-definition ; + +: (M:) CREATE-METHOD parse-definition ; GENERIC: expected>string ( obj -- str ) diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 92d22247bd..7e9046573f 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -10,7 +10,8 @@ TUPLE: slot-spec type name offset reader writer ; C: slot-spec : define-typecheck ( class generic quot -- ) - over define-simple-generic -rot define-method ; + over define-simple-generic + >r create-method r> define ; : define-slot-word ( class slot word quot -- ) rot >fixnum add* define-typecheck ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 79a5553228..d9870b08da 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -97,7 +97,7 @@ IN: bootstrap.syntax "parsing" [ word t "parsing" set-word-prop ] define-syntax "SYMBOL:" [ - CREATE dup reset-generic define-symbol + CREATE-WORD define-symbol ] define-syntax "DEFER:" [ @@ -111,31 +111,26 @@ IN: bootstrap.syntax ] define-syntax "GENERIC:" [ - CREATE dup reset-word - define-simple-generic + CREATE-GENERIC define-simple-generic ] define-syntax "GENERIC#" [ - CREATE dup reset-word + CREATE-GENERIC scan-word define-generic ] define-syntax "MATH:" [ - CREATE dup reset-word + CREATE-GENERIC T{ math-combination } define-generic ] define-syntax "HOOK:" [ - CREATE dup reset-word scan-word + CREATE-GENERIC scan-word define-generic ] define-syntax "M:" [ - f set-word - location >r - scan-word bootstrap-word scan-word - [ parse-definition -rot define-method ] 2keep - 2array r> remember-definition + (M:) define ] define-syntax "UNION:" [ @@ -163,7 +158,7 @@ IN: bootstrap.syntax ] define-syntax "C:" [ - CREATE dup reset-generic + CREATE-WORD scan-word dup check-tuple [ construct-boa ] curry define-inline ] define-syntax diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index c2e627e7bf..d746404cba 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -14,3 +14,5 @@ yield [ 3 ] [ [ 3 swap resume-with ] "Test suspend" suspend ] unit-test + +[ f ] [ f get-global ] unit-test diff --git a/core/threads/threads.factor b/core/threads/threads.factor index b4fd6eee60..d7d7988893 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -32,8 +32,6 @@ mailbox variables sleep-entry ; : threads 41 getenv ; -threads global [ H{ } assoc-like ] change-at - : thread ( id -- thread ) threads at ; : thread-registered? ( thread -- ? ) diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index c03b9784ee..3af7d27d86 100755 --- a/core/tuples/tuples-docs.factor +++ b/core/tuples/tuples-docs.factor @@ -12,6 +12,22 @@ ARTICLE: "tuple-constructors" "Constructors and slots" $nl "A shortcut for defining BOA constructors:" { $subsection POSTPONE: C: } +"Examples of constructors:" +{ $code + "TUPLE: color red green blue alpha ;" + "" + "C: rgba" + ": color construct-boa ; ! identical to above" + "" + ": " + " { set-color-red set-color-green set-color-blue }" + " color construct ;" + ": f ; ! identical to above" + "" + ": construct-empty ;" + ": { } color construct ; ! identical to above" + ": f f f f ; ! identical to above" +} "After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ; ARTICLE: "tuple-delegation" "Delegation" @@ -48,8 +64,8 @@ ARTICLE: "tuples" "Tuples" "Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:" { $subsection POSTPONE: TUPLE: } "An example:" -{ $code "TUPLE: person name address phone ;" } -"This defines a class word named " { $snippet "person" } ", along with a predicate " { $snippet "person?" } ", and the following reader/writer words:" +{ $code "TUPLE: person name address phone ;" "C: person" } +"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "" } ", and the following reader/writer words:" { $table { "Reader" "Writer" } { { $snippet "person-name" } { $snippet "set-person-name" } } diff --git a/core/words/words.factor b/core/words/words.factor index ce69c1ff2e..73b877fdbb 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -68,7 +68,7 @@ SYMBOL: bootstrapping? : crossref? ( word -- ? ) { { [ dup "forgotten" word-prop ] [ f ] } - { [ dup "method-def" word-prop ] [ t ] } + { [ dup "method-generic" word-prop ] [ t ] } { [ dup word-vocabulary ] [ t ] } { [ t ] [ f ] } } cond nip ; diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 88095759e6..2500940373 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -1,4 +1,5 @@ -USING: assocs kernel vectors sequences namespaces ; +USING: arrays assocs kernel vectors sequences namespaces +random math.parser ; IN: assocs.lib : >set ( seq -- hash ) @@ -35,3 +36,13 @@ IN: assocs.lib [ with each ] curry assoc-each ; inline : insert ( value variable -- ) namespace insert-at ; + +: 2seq>assoc ( keys values exemplar -- assoc ) + >r 2array flip r> assoc-like ; + +: generate-key ( assoc -- str ) + >r random-256 >hex r> + 2dup key? [ nip generate-key ] [ drop ] if ; + +: set-at-unique ( value assoc -- key ) + dup generate-key [ swap set-at ] keep ; diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor index 0bf7a032ee..670bca4903 100755 --- a/extra/bootstrap/tools/tools.factor +++ b/extra/bootstrap/tools/tools.factor @@ -13,5 +13,6 @@ USING: vocabs.loader sequences ; "tools.threads" "tools.vocabs" "tools.vocabs.browser" + "tools.vocabs.monitor" "editors" } [ require ] each diff --git a/extra/builder/benchmark/benchmark.factor b/extra/builder/benchmark/benchmark.factor index 444e5b6ea7..2f38462976 100644 --- a/extra/builder/benchmark/benchmark.factor +++ b/extra/builder/benchmark/benchmark.factor @@ -4,10 +4,12 @@ USING: kernel continuations arrays assocs sequences sorting math IN: builder.benchmark -: passing-benchmarks ( table -- table ) - [ second first2 number? swap number? and ] subset ; +! : passing-benchmarks ( table -- table ) +! [ second first2 number? swap number? and ] subset ; -: simplify-table ( table -- table ) [ first2 second 2array ] map ; +: passing-benchmarks ( table -- table ) [ second number? ] subset ; + +! : simplify-table ( table -- table ) [ first2 second 2array ] map ; : benchmark-difference ( old-table benchmark-result -- result-diff ) first2 >r @@ -17,7 +19,7 @@ IN: builder.benchmark 2array ; : compare-tables ( old new -- table ) - [ passing-benchmarks simplify-table ] 2apply + [ passing-benchmarks ] 2apply [ benchmark-difference ] with map ; : benchmark-deltas ( -- table ) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 52150b07a8..7d95ce2409 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -134,7 +134,9 @@ SYMBOL: build-status "Did not pass load-everything: " print "load-everything-vocabs" cat "Did not pass test-all: " print "test-all-vocabs" cat - "test-all-vocabs" eval-file test-failures. + "test-failures" cat + +! "test-failures" eval-file test-failures. "help-lint results:" print "help-lint" cat diff --git a/extra/cairo-demo/cairo-demo.factor b/extra/cairo-demo/cairo-demo.factor index 316479d53c..29fb99a301 100644 --- a/extra/cairo-demo/cairo-demo.factor +++ b/extra/cairo-demo/cairo-demo.factor @@ -6,7 +6,7 @@ ! http://cairographics.org/samples/text/ -USING: cairo math math.constants byte-arrays kernel ui ui.render +USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render ui.gadgets opengl.gl ; IN: cairo-demo @@ -23,13 +23,15 @@ IN: cairo-demo TUPLE: cairo-gadget image-array cairo-t ; M: cairo-gadget draw-gadget* ( gadget -- ) - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r> - cairo-gadget-image-array glDrawPixels ; + 0 0 glRasterPos2i + 1.0 -1.0 glPixelZoom + >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r> + cairo-gadget-image-array glDrawPixels ; : create-surface ( gadget -- cairo_surface_t ) - make-image-array dup >r swap set-cairo-gadget-image-array r> convert-array-to-surface ; + make-image-array + [ swap set-cairo-gadget-image-array ] keep + convert-array-to-surface ; : init-cairo ( gadget -- cairo_t ) create-surface cairo_create ; @@ -56,7 +58,7 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ; cairo_fill ; M: cairo-gadget graft* ( gadget -- ) - dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ; + dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ; M: cairo-gadget ungraft* ( gadget -- ) cairo-gadget-cairo-t cairo_destroy ; diff --git a/extra/cairo/authors.txt b/extra/cairo/authors.txt index 4a2736dd93..68d35d192b 100644 --- a/extra/cairo/authors.txt +++ b/extra/cairo/authors.txt @@ -1 +1,2 @@ Sampo Vuori +Doug Coleman diff --git a/extra/cairo/cairo.factor b/extra/cairo/ffi/ffi.factor similarity index 99% rename from extra/cairo/cairo.factor rename to extra/cairo/ffi/ffi.factor index 0d3e0c27e6..d7aa90c464 100644 --- a/extra/cairo/cairo.factor +++ b/extra/cairo/ffi/ffi.factor @@ -10,7 +10,7 @@ USING: alien alien.syntax combinators system ; -IN: cairo +IN: cairo.ffi << "cairo" { { [ win32? ] [ "cairo.dll" ] } diff --git a/extra/cairo/lib/lib.factor b/extra/cairo/lib/lib.factor new file mode 100644 index 0000000000..9e226ee47a --- /dev/null +++ b/extra/cairo/lib/lib.factor @@ -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 +M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ; +: cairo-t-destroy-always ( alien -- ) add-always-destructor ; +: cairo-t-destroy-later ( alien -- ) add-error-destructor ; + +TUPLE: cairo-surface-t alien ; +C: cairo-surface-t +M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ; + +: cairo-surface-t-destroy-always ( alien -- ) + add-always-destructor ; + +: cairo-surface-t-destroy-later ( alien -- ) + 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 ; diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor new file mode 100644 index 0000000000..b9da14088c --- /dev/null +++ b/extra/cairo/png/png.factor @@ -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 ; + +: ( 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 ; + +: ( path -- gadget ) + png-gadget construct-gadget swap + >>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 ; diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index fd66536c12..049c8bf2a9 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -70,3 +70,29 @@ MACRO: spread ( seq -- ) swap [ [ r> ] swap append ] map concat append ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Cleave into array +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: words quotations fry arrays.lib ; + +: >quot ( obj -- quot ) dup word? [ 1quotation ] when ; + +: >quots ( seq -- seq ) [ >quot ] map ; + +MACRO: ( seq -- ) + [ >quots ] [ length ] bi + '[ , cleave , narray ] ; + +MACRO: <2arr> ( seq -- ) + [ >quots ] [ length ] bi + '[ , 2cleave , narray ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Spread into array +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MACRO: ( seq -- ) + [ >quots ] [ length ] bi + '[ , spread , narray ] ; diff --git a/extra/db/db-tests.factor b/extra/db/db-tests.factor new file mode 100755 index 0000000000..9c32f9e326 --- /dev/null +++ b/extra/db/db-tests.factor @@ -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 diff --git a/extra/db/db.factor b/extra/db/db.factor index 309847209f..ac46be4422 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -33,6 +33,19 @@ HOOK: db-close db ( handle -- ) TUPLE: statement handle sql in-params out-params bind-params bound? ; TUPLE: simple-statement ; TUPLE: prepared-statement ; +TUPLE: nonthrowable-statement ; +: make-nonthrowable ( obj -- obj' ) + dup sequence? [ + [ make-nonthrowable ] map + ] [ + nonthrowable-statement construct-delegate + ] if ; + +MIXIN: throwable-statement +INSTANCE: statement throwable-statement +INSTANCE: simple-statement throwable-statement +INSTANCE: prepared-statement throwable-statement + TUPLE: result-set sql in-params out-params handle n max ; : ( sql in out -- statement ) { (>>sql) (>>in-params) (>>out-params) } statement construct ; @@ -50,13 +63,22 @@ GENERIC# row-column-typed 1 ( result-set column -- sql ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) -: execute-statement ( statement -- ) +GENERIC: execute-statement ( statement -- ) + +M: throwable-statement execute-statement ( statement -- ) dup sequence? [ [ execute-statement ] each ] [ query-results dispose ] if ; +M: nonthrowable-statement execute-statement ( statement -- ) + dup sequence? [ + [ execute-statement ] each + ] [ + [ query-results dispose ] [ 2drop ] recover + ] if ; + : bind-statement ( obj statement -- ) swap >>bind-params [ bind-statement* ] keep diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index b48c87f0ca..928b51dc59 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -73,7 +73,7 @@ IN: db.postgresql.lib sql-spec-type { { FACTOR-BLOB [ dup [ - binary [ serialize ] with-byte-writer + object>bytes malloc-byte-array/length ] [ 0 ] if ] } { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] } @@ -164,7 +164,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) { BLOB [ pq-get-blob ] } { FACTOR-BLOB [ pq-get-blob - dup [ binary [ deserialize ] with-byte-reader ] when ] } + dup [ bytes>object ] when ] } [ no-sql-type ] } case ; ! PQgetlength PQgetisnull diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 26b6cbe75c..8a6f8632ec 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -10,6 +10,7 @@ IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; TUPLE: postgresql-statement ; +INSTANCE: postgresql-statement throwable-statement TUPLE: postgresql-result-set ; : ( statement in out -- postgresql-statement ) @@ -119,8 +120,8 @@ M: postgresql-db bind% ( spec -- ) : postgresql-make ( class quot -- ) >r sql-props r> - [ postgresql-counter off ] swap compose - { "" { } { } } nmake ; + [ postgresql-counter off call ] { "" { } { } } nmake + ; inline : create-table-sql ( class -- statement ) [ @@ -194,7 +195,7 @@ M: postgresql-db ( class -- statement ) ");" 0% ] postgresql-make ; -M: postgresql-db ( class -- statement ) +M: postgresql-db ( class -- statement ) [ "insert into " 0% 0% "(" 0% diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 63bce0a8c3..1d356b1592 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -127,6 +127,6 @@ FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index dbada854fb..f81d7de4b8 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -94,7 +94,7 @@ IN: db.sqlite.lib { TIMESTAMP [ sqlite-bind-text-by-name ] } { BLOB [ sqlite-bind-blob-by-name ] } { FACTOR-BLOB [ - binary [ serialize ] with-byte-writer + object>bytes sqlite-bind-blob-by-name ] } { +native-id+ [ sqlite-bind-int-by-name ] } @@ -102,17 +102,12 @@ IN: db.sqlite.lib [ no-sql-type ] } case ; -: sqlite-finalize ( handle -- ) - sqlite3_finalize sqlite-check-result ; - -: sqlite-reset ( handle -- ) - sqlite3_reset sqlite-check-result ; - -: sqlite-#columns ( query -- int ) - sqlite3_column_count ; - -: sqlite-column ( handle index -- string ) - sqlite3_column_text ; +: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ; +: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ; +: sqlite-#columns ( query -- int ) sqlite3_column_count ; +: sqlite-column ( handle index -- string ) sqlite3_column_text ; +: sqlite-column-name ( handle index -- string ) sqlite3_column_name ; +: sqlite-column-type ( handle index -- string ) sqlite3_column_type ; : sqlite-column-blob ( handle index -- byte-array/f ) [ sqlite3_column_bytes ] 2keep @@ -126,6 +121,7 @@ IN: db.sqlite.lib dup array? [ first ] when { { +native-id+ [ sqlite3_column_int64 ] } + { +random-id+ [ sqlite3_column_int64 ] } { INTEGER [ sqlite3_column_int ] } { BIG-INTEGER [ sqlite3_column_int64 ] } { DOUBLE [ sqlite3_column_double ] } @@ -138,7 +134,7 @@ IN: db.sqlite.lib { BLOB [ sqlite-column-blob ] } { FACTOR-BLOB [ sqlite-column-blob - dup [ binary [ deserialize ] with-byte-reader ] when + dup [ bytes>object ] when ] } ! { NULL [ 2drop f ] } [ no-sql-type ] @@ -147,7 +143,7 @@ IN: db.sqlite.lib : sqlite-row ( handle -- seq ) dup sqlite-#columns [ sqlite-column ] with map ; -: sqlite-step-has-more-rows? ( step-result -- bool ) +: sqlite-step-has-more-rows? ( prepared -- bool ) dup SQLITE_ROW = [ drop t ] [ diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index b72d788605..bca904279b 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -6,6 +6,7 @@ prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators combinators.cleave io namespaces.lib ; +USE: tools.walker IN: db.sqlite TUPLE: sqlite-db path ; @@ -17,15 +18,12 @@ M: sqlite-db db-open ( db -- ) dup sqlite-db-path sqlite-open swap set-delegate ; -M: sqlite-db db-close ( handle -- ) - sqlite-close ; - +M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db dispose ( db -- ) dispose-db ; - -: with-sqlite ( path quot -- ) - sqlite-db swap with-db ; inline +: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline TUPLE: sqlite-statement ; +INSTANCE: sqlite-statement throwable-statement TUPLE: sqlite-result-set has-more? ; @@ -38,12 +36,20 @@ M: sqlite-db ( str in out -- obj ) set-statement-in-params set-statement-out-params } statement construct - db get db-handle over statement-sql sqlite-prepare - over set-statement-handle sqlite-statement construct-delegate ; +: sqlite-maybe-prepare ( statement -- statement ) + dup statement-handle [ + [ + delegate + db get db-handle over statement-sql sqlite-prepare + swap set-statement-handle + ] keep + ] unless ; + M: sqlite-statement dispose ( statement -- ) - statement-handle sqlite-finalize ; + statement-handle + [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ; M: sqlite-result-set dispose ( result-set -- ) f swap set-result-set-handle ; @@ -52,9 +58,11 @@ M: sqlite-result-set dispose ( result-set -- ) swap [ first3 sqlite-bind-type ] with each ; : reset-statement ( statement -- ) + sqlite-maybe-prepare statement-handle sqlite-reset ; M: sqlite-statement bind-statement* ( statement -- ) + sqlite-maybe-prepare dup statement-bound? [ dup reset-statement ] when [ statement-bind-params ] [ statement-handle ] bi sqlite-bind ; @@ -95,21 +103,17 @@ M: sqlite-result-set more-rows? ( result-set -- ? ) sqlite-result-set-has-more? ; M: sqlite-statement query-results ( query -- result-set ) + sqlite-maybe-prepare dup statement-handle sqlite-result-set dup advance-row ; -M: sqlite-db begin-transaction ( -- ) - "BEGIN" sql-command ; - -M: sqlite-db commit-transaction ( -- ) - "COMMIT" sql-command ; - -M: sqlite-db rollback-transaction ( -- ) - "ROLLBACK" sql-command ; +M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; +M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ; +M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; : sqlite-make ( class quot -- ) >r sql-props r> - { "" { } { } } nmake ; + { "" { } { } } nmake ; inline M: sqlite-db create-sql-statement ( class -- statement ) [ @@ -123,9 +127,7 @@ M: sqlite-db create-sql-statement ( class -- statement ) ] sqlite-make ; M: sqlite-db drop-sql-statement ( class -- statement ) - [ - "drop table " 0% 0% ";" 0% drop - ] sqlite-make ; + [ "drop table " 0% 0% ";" 0% drop ] sqlite-make ; M: sqlite-db ( tuple -- statement ) [ @@ -138,7 +140,7 @@ M: sqlite-db ( tuple -- statement ) ");" 0% ] sqlite-make ; -M: sqlite-db ( tuple -- statement ) +M: sqlite-db ( tuple -- statement ) ; : where-primary-key% ( specs -- ) @@ -188,6 +190,8 @@ M: sqlite-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } { +assigned-id+ "primary key" } + { +random-id+ "primary key" } + ! { +nonnative-id+ "primary key" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } { +default+ "default" } @@ -195,10 +199,9 @@ M: sqlite-db modifier-table ( -- hashtable ) { +not-null+ "not null" } } ; -M: sqlite-db compound-modifier ( str obj -- newstr ) - compound-type ; +M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ; -M: sqlite-db compound-type ( str seq -- newstr ) +M: sqlite-db compound-type ( str seq -- str' ) over { { "default" [ first number>string join-space ] } [ 2drop ] ! "no sqlite compound data type" 3array throw ] @@ -207,6 +210,7 @@ M: sqlite-db compound-type ( str seq -- newstr ) M: sqlite-db type-table ( -- assoc ) H{ { +native-id+ "integer primary key" } + { +random-id+ "integer primary key" } { INTEGER "integer" } { TEXT "text" } { VARCHAR "text" } @@ -219,5 +223,4 @@ M: sqlite-db type-table ( -- assoc ) { FACTOR-BLOB "blob" } } ; -M: sqlite-db create-type-table - type-table ; +M: sqlite-db create-type-table ( symbol -- str ) type-table ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 4c47066d35..6b61981119 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -9,7 +9,7 @@ IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real ts date time blob factor-blob ; -: ( name age real ts date time blob -- person ) +: ( name age real ts date time blob factor-blob -- person ) { set-person-the-name set-person-the-number @@ -190,11 +190,11 @@ TUPLE: annotation n paste-id summary author mode contents ; : test-postgresql ( -- ) >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; -[ native-person-schema test-tuples ] test-sqlite -[ assigned-person-schema test-tuples ] test-sqlite - -! [ native-person-schema test-tuples ] test-postgresql -! [ assigned-person-schema test-tuples ] test-postgresql +: test-repeated-insert + [ ] [ person ensure-table ] unit-test + + [ ] [ person1 get insert-tuple ] unit-test + [ person1 get insert-tuple ] must-fail ; TUPLE: serialize-me id data ; @@ -239,3 +239,34 @@ TUPLE: exam id name score ; ; ! [ test-ranges ] test-sqlite + +TUPLE: secret n message ; +C: secret + +: test-random-id + secret "SECRET" + { + { "n" "ID" +random-id+ } + { "message" "MESSAGE" TEXT } + } define-persistent + + [ ] [ secret ensure-table ] unit-test + [ ] [ f "kilroy was here" insert-tuple ] unit-test + [ ] [ T{ secret } select-tuples ] unit-test + ; + + + +! [ test-random-id ] test-sqlite + [ native-person-schema test-tuples ] test-sqlite + [ assigned-person-schema test-tuples ] test-sqlite +! [ assigned-person-schema test-repeated-insert ] test-sqlite +! [ native-person-schema test-tuples ] test-postgresql +! [ assigned-person-schema test-tuples ] test-postgresql +! [ assigned-person-schema test-repeated-insert ] test-postgresql + +! \ insert-tuple must-infer +! \ update-tuple must-infer +! \ delete-tuple must-infer +! \ select-tuple must-infer +! \ define-persistent must-infer diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 82147a2efa..0f69b0fafb 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -28,7 +28,7 @@ HOOK: create-sql-statement db ( class -- obj ) HOOK: drop-sql-statement db ( class -- obj ) HOOK: db ( class -- obj ) -HOOK: db ( class -- obj ) +HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) @@ -36,7 +36,7 @@ HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) -HOOK: db ( tuple -- tuple ) +HOOK: db ( tuple class -- tuple ) HOOK: insert-tuple* db ( tuple statement -- ) @@ -75,21 +75,25 @@ HOOK: insert-tuple* db ( tuple statement -- ) drop-sql-statement [ execute-statement ] with-disposals ; : ensure-table ( class -- ) - [ dup drop-table ] ignore-errors create-table ; + [ + drop-sql-statement make-nonthrowable + [ execute-statement ] with-disposals + ] [ create-table ] bi ; : insert-native ( tuple -- ) dup class db get db-insert-statements [ ] cache [ bind-tuple ] 2keep insert-tuple* ; -: insert-assigned ( tuple -- ) +: insert-nonnative ( tuple -- ) +! TODO logic here for unique ids dup class - db get db-insert-statements [ ] cache + db get db-insert-statements [ ] cache [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) - dup class db-columns find-primary-key assigned-id? [ - insert-assigned + dup class db-columns find-primary-key nonnative-id? [ + insert-nonnative ] [ insert-native ] if ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 7014aaa943..a0414f334d 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -3,7 +3,8 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes -mirrors tuples combinators calendar.format symbols ; +mirrors tuples combinators calendar.format symbols +singleton ; IN: db.types HOOK: modifier-table db ( -- hash ) @@ -14,22 +15,30 @@ HOOK: compound-type db ( str n -- hash ) TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; -SYMBOLS: +native-id+ +assigned-id+ +autoincrement+ -+serial+ +unique+ +default+ +null+ +not-null+ +SINGLETON: +native-id+ +SINGLETON: +assigned-id+ +SINGLETON: +random-id+ +UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ; +UNION: +nonnative-id+ +random-id+ +assigned-id+ ; + +SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ +foreign-id+ +has-many+ ; -: (primary-key?) ( obj -- ? ) - { +native-id+ +assigned-id+ } member? ; - : primary-key? ( spec -- ? ) - sql-spec-primary-key (primary-key?) ; + sql-spec-primary-key +primary-key+? ; + +: native-id? ( spec -- ? ) + sql-spec-primary-key +native-id+? ; + +: nonnative-id? ( spec -- ? ) + sql-spec-primary-key +nonnative-id+? ; : normalize-spec ( spec -- ) - dup sql-spec-type dup (primary-key?) [ + dup sql-spec-type dup +primary-key+? [ swap set-sql-spec-primary-key ] [ drop dup sql-spec-modifiers [ - (primary-key?) + +primary-key+? ] deep-find [ swap set-sql-spec-primary-key ] [ drop ] if* ] if ; @@ -37,12 +46,6 @@ SYMBOLS: +native-id+ +assigned-id+ +autoincrement+ : find-primary-key ( specs -- obj ) [ sql-spec-primary-key ] find nip ; -: native-id? ( spec -- ? ) - sql-spec-primary-key +native-id+ = ; - -: assigned-id? ( spec -- ? ) - sql-spec-primary-key +assigned-id+ = ; - : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR @@ -69,7 +72,7 @@ TUPLE: no-sql-modifier ; dup number? [ number>string ] when ; : maybe-remove-id ( specs -- obj ) - [ native-id? not ] subset ; + [ +native-id+? not ] subset ; : remove-relations ( specs -- newcolumns ) [ relation? not ] subset ; diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 654d096b26..67b8a39320 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -7,7 +7,7 @@ IN: delegate swap { } like "protocol-words" set-word-prop ; : PROTOCOL: - CREATE dup reset-generic dup define-symbol + CREATE-WORD dup define-symbol parse-definition swap define-protocol ; parsing PREDICATE: word protocol "protocol-words" word-prop ; @@ -27,11 +27,11 @@ M: tuple-class group-words swap [ slot-spec-writer ] map append ; : define-consult-method ( word class quot -- ) - pick add spin define-method ; + pick add >r swap create-method r> define ; : define-consult ( class group quot -- ) - >r group-words r> - swapd [ define-consult-method ] 2curry each ; + >r group-words swap r> + [ define-consult-method ] 2curry each ; : CONSULT: scan-word scan-word parse-definition swapd define-consult ; parsing @@ -39,7 +39,7 @@ M: tuple-class group-words : define-mimic ( group mimicker mimicked -- ) >r >r group-words r> r> [ pick "methods" word-prop at dup - [ "method-def" word-prop spin define-method ] + [ >r swap create-method r> word-def define ] [ 3drop ] if ] 2curry each ; diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor index b2561c7439..1b98d2ee0d 100755 --- a/extra/destructors/destructors.factor +++ b/extra/destructors/destructors.factor @@ -26,11 +26,14 @@ M: destructor dispose : add-always-destructor ( obj -- ) always-destructors get push ; +: dispose-each ( seq -- ) + [ dispose ] each ; + : do-always-destructors ( -- ) - always-destructors get [ dispose ] each ; + always-destructors get dispose-each ; : do-error-destructors ( -- ) - error-destructors get [ dispose ] each ; + error-destructors get dispose-each ; : with-destructors ( quot -- ) [ diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 45d19cb891..2341aabc9d 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,14 +1,14 @@ USING: tools.deploy.config ; H{ - { deploy-io 2 } - { deploy-math? f } - { deploy-threads? f } - { deploy-compiler? f } - { deploy-word-props? f } - { deploy-word-defs? f } { deploy-name "Hello world (console)" } - { deploy-reflection 2 } + { deploy-threads? f } { deploy-c-types? f } + { deploy-compiler? f } { deploy-ui? f } + { deploy-math? f } + { deploy-reflection 1 } + { deploy-word-defs? f } + { deploy-io 2 } + { deploy-word-props? f } { "stop-after-last-window?" t } } diff --git a/extra/help/help-tests.factor b/extra/help/help-tests.factor new file mode 100644 index 0000000000..e38f2fc15d --- /dev/null +++ b/extra/help/help-tests.factor @@ -0,0 +1,5 @@ +IN: help.tests +USING: tools.test help kernel ; + +[ 3 throw ] must-fail +[ ] [ :help ] unit-test diff --git a/extra/help/help.factor b/extra/help/help.factor index 85f5a35a5c..34e90b2ccf 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -136,7 +136,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ":edit - jump to source location (parse errors only)" print ":get ( var -- value ) accesses variables at time of the error" print - ":vars - list all variables at error time"; + ":vars - list all variables at error time" print ; : :help ( -- ) error get delegates [ error-help ] map [ ] subset diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 661f63ab59..0f684f782a 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -18,6 +18,7 @@ tuple-syntax namespaces ; port: 80 version: "1.1" cookies: V{ } + header: H{ } } ] [ [ diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 66182b10ae..2e7370bc39 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -5,8 +5,8 @@ IN: http.tests [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test [ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test -[ "" ] [ "%XX%XX%XX" url-decode ] unit-test -[ "" ] [ "%XX%XX%X" url-decode ] unit-test +[ f ] [ "%XX%XX%XX" url-decode ] unit-test +[ f ] [ "%XX%XX%X" url-decode ] unit-test [ "hello world" ] [ "hello+world" url-decode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 4dd433f85d..421a409639 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -180,6 +180,7 @@ cookies ; request construct-empty "1.1" >>version http-port >>port + H{ } clone >>header H{ } clone >>query V{ } clone >>cookies ; diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index 45f7ff385d..c604b8a427 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -1,11 +1,16 @@ IN: http.server.actions.tests -USING: http.server.actions tools.test math math.parser -multiline namespaces http io.streams.string http.server -sequences accessors ; +USING: http.server.actions http.server.validators +tools.test math math.parser multiline namespaces http +io.streams.string http.server sequences accessors ; + +[ + "a" [ v-number ] { { "a" "123" } } validate-param + [ 123 ] [ "a" get ] unit-test +] with-scope [ "a" get "b" get + ] >>display - { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params + { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params "action-1" set STRING: action-request-test-1 @@ -23,7 +28,7 @@ blah [ +path+ get "xxx" get "X" concat append ] >>submit - { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params + { { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params "action-2" set STRING: action-request-test-2 diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor index 72c2d2df8e..52567ed352 100755 --- a/extra/http/server/actions/actions.factor +++ b/extra/http/server/actions/actions.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors new-slots sequences kernel assocs combinators http.server http.server.validators http hashtables namespaces -combinators.cleave fry continuations ; +combinators.cleave fry continuations locals ; IN: http.server.actions SYMBOL: +path+ @@ -17,17 +17,13 @@ TUPLE: action init display submit get-params post-params ; [ <400> ] >>display [ <400> ] >>submit ; -: with-validator ( string quot -- result error? ) - '[ , @ f ] [ - dup validation-error? [ t ] [ rethrow ] if - ] recover ; inline - -: validate-param ( name validator assoc -- error? ) - swap pick - >r >r at r> with-validator swap r> set ; +:: validate-param ( name validator assoc -- ) + name assoc at validator with-validator name set ; inline : action-params ( validators -- error? ) - [ params get validate-param ] { } assoc>map [ ] contains? ; + validation-failed? off + params get '[ , validate-param ] assoc-each + validation-failed? get ; : handle-get ( -- response ) action get get-params>> action-params [ <400> ] [ @@ -42,10 +38,13 @@ TUPLE: action init display submit get-params post-params ; action get display>> call exit-with ; M: action call-responder ( path action -- response ) - [ +path+ associate request-params union params set ] - [ action set ] bi* - request get method>> { - { "GET" [ handle-get ] } - { "HEAD" [ handle-get ] } - { "POST" [ handle-post ] } - } case ; + '[ + , , + [ +path+ associate request-params union params set ] + [ action set ] bi* + request get method>> { + { "GET" [ handle-get ] } + { "HEAD" [ handle-get ] } + { "POST" [ handle-post ] } + } case + ] with-exit-continuation ; diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor index 1b1534b85e..69a3c76c2b 100755 --- a/extra/http/server/auth/auth.factor +++ b/extra/http/server/auth/auth.factor @@ -1,9 +1,26 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: http.server.sessions accessors -http.server.auth.providers ; +http.server.auth.providers assocs namespaces kernel ; IN: http.server.auth SYMBOL: logged-in-user +SYMBOL: user-profile-changed? + +GENERIC: init-user-profile ( responder -- ) + +M: object init-user-profile drop ; : uid ( -- string ) logged-in-user sget username>> ; + +: profile ( -- assoc ) logged-in-user sget profile>> ; + +: uget ( key -- value ) + profile at ; + +: uset ( value key -- ) + profile set-at user-profile-changed? on ; + +: uchange ( quot key -- ) + profile swap change-at + user-profile-changed? on ; inline diff --git a/extra/http/server/auth/login/edit-profile.fhtml b/extra/http/server/auth/login/edit-profile.fhtml new file mode 100755 index 0000000000..7d94ca1791 --- /dev/null +++ b/extra/http/server/auth/login/edit-profile.fhtml @@ -0,0 +1,77 @@ +<% USING: http.server.components http.server.auth.login +http.server namespaces kernel combinators ; %> + + +

Edit profile

+ +
+<% hidden-form-field %> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
User name:<% "username" component render-view %>
Real name:<% "realname" component render-edit %>
Specifying a real name is optional.
Current password:<% "password" component render-edit %>
If you don't want to change your current password, leave this field blank.
New password:<% "new-password" component render-edit %>
Verify:<% "verify-password" component render-edit %>
If you are changing your password, enter it twice to ensure it is correct.
E-mail:<% "email" component render-edit %>
Specifying an e-mail address is optional. It enables the "recover password" feature.
+ +

+ +<% { + { [ login-failed? get ] [ "invalid password" render-error ] } + { [ password-mismatch? get ] [ "passwords do not match" render-error ] } + { [ t ] [ ] } +} cond %> + +

+ +
+ + + diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 9b2648158d..275fb0ff63 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -7,15 +7,30 @@ http.server.actions http.server.components http.server.sessions http.server.templating.fhtml http.server.validators http.server.auth http sequences io.files namespaces hashtables fry io.sockets combinators.cleave arrays threads locals -qualified ; +qualified continuations destructors ; IN: http.server.auth.login QUALIFIED: smtp -TUPLE: login users ; - SYMBOL: post-login-url SYMBOL: login-failed? +TUPLE: login users ; + +: users login get users>> ; + +! Destructor +TUPLE: user-saver user ; + +C: user-saver + +M: user-saver dispose + user-profile-changed? get [ + user>> users update-user + ] [ drop ] if ; + +: save-user-after ( user -- ) + add-always-destructor ; + ! ! ! Login : @@ -49,7 +64,7 @@ SYMBOL: login-failed? form validate-form "password" value "username" value - login get users>> check-login [ + users check-login [ successful-login ] [ login-failed? on @@ -67,7 +82,7 @@ SYMBOL: login-failed? t >>required add-field "realname" add-field - "password" + "new-password" t >>required add-field "verify-password" @@ -80,7 +95,7 @@ SYMBOL: password-mismatch? SYMBOL: user-exists? : same-password-twice ( -- ) - "password" value "verify-password" value = [ + "new-password" value "verify-password" value = [ password-mismatch? on validation-failed ] unless ; @@ -102,19 +117,76 @@ SYMBOL: user-exists? same-password-twice - values get [ - "username" get >>username - "realname" get >>realname - "password" get >>password - "email" get >>email - ] bind + + "username" value >>username + "realname" value >>realname + "new-password" value >>password + "email" value >>email - login get users>> new-user [ + users new-user [ user-exists? on validation-failed ] unless* successful-login + + login get responder>> init-user-profile + ] >>submit + ] ; + +! ! ! Editing user profile + +: ( -- form ) + "edit-profile"
+ "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template + "username" add-field + "realname" add-field + "password" add-field + "new-password" add-field + "verify-password" add-field + "email" add-field ; + +SYMBOL: previous-page + +:: ( -- action ) + [let | form [ ] | + + [ + blank-values + logged-in-user sget + dup username>> "username" set-value + dup realname>> "realname" set-value + dup email>> "email" set-value + ] >>init + + [ + "text/html" + [ form edit-form ] >>body + ] >>display + + [ + blank-values + uid "username" set-value + + form validate-form + + logged-in-user sget + + "password" value empty? [ + same-password-twice + + "password" value uid users check-login + [ login-failed? on validation-failed ] unless + + "new-password" value set-password + ] unless + + "realname" value >>realname + "email" value >>email + + user-profile-changed? on + + previous-page sget f ] >>submit ] ; @@ -186,7 +258,7 @@ SYMBOL: lost-password-from form validate-form "email" value "username" value - login get users>> issue-ticket [ + users issue-ticket [ send-password-email ] when* @@ -200,7 +272,7 @@ SYMBOL: lost-password-from "username" t >>required add-field - "password" + "new-password" t >>required add-field "verify-password" @@ -239,9 +311,9 @@ SYMBOL: lost-password-from "ticket" value "username" value - login get users>> claim-ticket [ - "password" value >>password - login get users>> update-user + users claim-ticket [ + "new-password" value >>password + users update-user "resource:extra/http/server/auth/login/recover-4.fhtml" serve-template @@ -265,13 +337,19 @@ TUPLE: protected responder ; C: protected +: show-login-page ( -- response ) + request get request-url post-login-url sset + "login" f ; + M: protected call-responder ( path responder -- response ) - logged-in-user sget [ responder>> call-responder ] [ + logged-in-user sget [ + dup save-user-after + request get request-url previous-page sset + responder>> call-responder + ] [ 2drop - request get method>> { "GET" "HEAD" } member? [ - request get request-url post-login-url sset - "login" f - ] [ <400> ] if + request get method>> { "GET" "HEAD" } member? + [ show-login-page ] [ <400> ] if ] if ; M: login call-responder ( path responder -- response ) @@ -283,10 +361,13 @@ M: login call-responder ( path responder -- response ) swap >>default "login" add-responder "logout" add-responder - no >>users ; + no-users >>users ; ! ! ! Configuration +: allow-edit-profile ( login -- login ) + "edit-profile" add-responder ; + : allow-registration ( login -- login ) "register" add-responder ; @@ -294,6 +375,9 @@ M: login call-responder ( path responder -- response ) "recover-password" add-responder "new-password" add-responder ; +: allow-edit-profile? ( -- ? ) + login get responders>> "edit-profile" swap key? ; + : allow-registration? ( -- ? ) login get responders>> "register" swap key? ; diff --git a/extra/http/server/auth/login/recover-3.fhtml b/extra/http/server/auth/login/recover-3.fhtml index edd32fffe8..ca4823baab 100755 --- a/extra/http/server/auth/login/recover-3.fhtml +++ b/extra/http/server/auth/login/recover-3.fhtml @@ -17,7 +17,7 @@ namespaces kernel combinators ; %> Password: -<% "password" component render-edit %> +<% "new-password" component render-edit %> diff --git a/extra/http/server/auth/login/register.fhtml b/extra/http/server/auth/login/register.fhtml index 99d1547d03..9106497def 100755 --- a/extra/http/server/auth/login/register.fhtml +++ b/extra/http/server/auth/login/register.fhtml @@ -26,7 +26,7 @@ http.server namespaces kernel combinators ; %> Password: -<% "password" component render-edit %> +<% "new-password" component render-edit %> diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor index 12c799816d..f99e4d3d2e 100755 --- a/extra/http/server/auth/providers/assoc/assoc-tests.factor +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -3,7 +3,7 @@ USING: http.server.auth.providers http.server.auth.providers.assoc tools.test namespaces accessors kernel ; - "provider" set + "provider" set [ t ] [ @@ -22,11 +22,11 @@ namespaces accessors kernel ; [ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test -[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test +[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test -[ f ] [ "xx" "blah" "provider" get set-password ] unit-test +[ t ] [ "user" get >boolean ] unit-test -[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test +[ ] [ "user" get "fdasf" set-password drop ] unit-test [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor index 8433e54fda..e8ab908406 100755 --- a/extra/http/server/auth/providers/assoc/assoc.factor +++ b/extra/http/server/auth/providers/assoc/assoc.factor @@ -4,16 +4,16 @@ IN: http.server.auth.providers.assoc USING: new-slots accessors assocs kernel http.server.auth.providers ; -TUPLE: in-memory assoc ; +TUPLE: users-in-memory assoc ; -: ( -- provider ) - H{ } clone in-memory construct-boa ; +: ( -- provider ) + H{ } clone users-in-memory construct-boa ; -M: in-memory get-user ( username provider -- user/f ) +M: users-in-memory get-user ( username provider -- user/f ) assoc>> at ; -M: in-memory update-user ( user provider -- ) 2drop ; +M: users-in-memory update-user ( user provider -- ) 2drop ; -M: in-memory new-user ( user provider -- user/f ) +M: users-in-memory new-user ( user provider -- user/f ) >r dup username>> r> assoc>> 2dup key? [ 3drop f ] [ pick >r set-at r> ] if ; diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index 247359aea4..340e1bb35d 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -4,35 +4,36 @@ http.server.auth.providers.db tools.test namespaces db db.sqlite db.tuples continuations io.files accessors kernel ; -from-db "provider" set +users-in-db "provider" set "auth-test.db" temp-file sqlite-db [ - [ user drop-table ] ignore-errors - [ user create-table ] ignore-errors + init-users-table [ t ] [ - "slava" >>username - "foobar" >>password - "slava@factorcode.org" >>email - "provider" get new-user - username>> "slava" = + "slava" >>username + "foobar" >>password + "slava@factorcode.org" >>email + "provider" get new-user + username>> "slava" = ] unit-test [ f ] [ - "slava" >>username + "slava" >>username "provider" get new-user ] unit-test [ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test - [ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test + [ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test - [ f ] [ "xx" "blah" "provider" get set-password ] unit-test + [ t ] [ "user" get >boolean ] unit-test - [ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test + [ ] [ "user" get "fdasf" set-password drop ] unit-test + + [ ] [ "user" get "provider" get update-user ] unit-test [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor index c9e1328052..aec64d3384 100755 --- a/extra/http/server/auth/providers/db/db.factor +++ b/extra/http/server/auth/providers/db/db.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: db db.tuples db.types new-slots accessors -http.server.auth.providers kernel continuations ; +http.server.auth.providers kernel continuations +singleton ; IN: http.server.auth.providers.db user "USERS" @@ -16,20 +17,18 @@ user "USERS" : init-users-table user ensure-table ; -TUPLE: from-db ; - -: from-db T{ from-db } ; +SINGLETON: users-in-db : find-user ( username -- user ) swap >>username select-tuple ; -M: from-db get-user +M: users-in-db get-user drop find-user ; -M: from-db new-user +M: users-in-db new-user drop [ dup username>> find-user [ @@ -39,5 +38,5 @@ M: from-db new-user ] if ] with-transaction ; -M: from-db update-user +M: users-in-db update-user drop update-tuple ; diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/http/server/auth/providers/null/null.factor index 7b8bfc627c..30f6dbd06e 100755 --- a/extra/http/server/auth/providers/null/null.factor +++ b/extra/http/server/auth/providers/null/null.factor @@ -3,14 +3,12 @@ USING: http.server.auth.providers kernel ; IN: http.server.auth.providers.null -! Named "no" because we can say no >>users +TUPLE: no-users ; -TUPLE: no ; +: no-users T{ no-users } ; -: no T{ no } ; +M: no-users get-user 2drop f ; -M: no get-user 2drop f ; +M: no-users new-user 2drop f ; -M: no new-user 2drop f ; - -M: no update-user 2drop ; +M: no-users update-user 2drop ; diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index 0aa27f870d..d51679016e 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel new-slots accessors random math.parser locals -sequences math ; +sequences math crypto.sha2 ; IN: http.server.auth.providers TUPLE: user username realname password email ticket profile ; @@ -17,14 +17,7 @@ GENERIC: new-user ( user provider -- user/f ) : check-login ( password username provider -- user/f ) get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ; -:: set-password ( password username provider -- ? ) - [let | user [ username provider get-user ] | - user [ - user - password >>password - provider update-user t - ] [ f ] if - ] ; +: set-password ( user password -- user ) >>password ; ! Password recovery support diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor index ac03e0efc8..eb264279cb 100755 --- a/extra/http/server/callbacks/callbacks.factor +++ b/extra/http/server/callbacks/callbacks.factor @@ -4,7 +4,7 @@ USING: html http http.server io kernel math namespaces continuations calendar sequences assocs new-slots hashtables accessors arrays alarms quotations combinators -combinators.cleave fry ; +combinators.cleave fry assocs.lib ; IN: http.server.callbacks SYMBOL: responder @@ -98,11 +98,18 @@ SYMBOL: current-show cont-id query-param swap callbacks>> at ; M: callback-responder call-responder ( path responder -- response ) - [ callback-responder set ] - [ request get resuming-callback ] bi + '[ + , , - [ invoke-callback ] - [ callback-responder get responder>> call-responder ] ?if ; + [ callback-responder set ] + [ request get resuming-callback ] bi + + [ + invoke-callback + ] [ + callback-responder get responder>> call-responder + ] ?if + ] with-exit-continuation ; : show-page ( quot -- ) >r redirect-to-here store-current-show r> diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index 2a507e6416..09d31202c5 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -86,3 +86,24 @@ TUPLE: test-tuple text number more-text ; [ t ] [ "number" value validation-error? ] unit-test ] with-scope + +[ + [ ] [ + "n" + 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" validate = ] unit-test diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index bb0fc4b3dd..02c992651a 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -7,8 +7,6 @@ http.server.actions splitting mirrors hashtables combinators.cleave fry continuations math ; IN: http.server.components -SYMBOL: validation-failed? - SYMBOL: components TUPLE: component id required default ; @@ -30,16 +28,13 @@ SYMBOL: values : validate ( value component -- result ) '[ - , , + , over empty? [ [ default>> [ v-default ] when* ] [ required>> [ v-required ] when ] bi ] [ validate* ] if - ] [ - dup validation-error? - [ validation-failed? on ] [ rethrow ] if - ] recover ; + ] with-validator ; : render-view ( component -- ) [ id>> value ] [ render-view* ] bi ; @@ -192,15 +187,16 @@ M: password render-error* render-edit* render-error ; ! Number fields -TUPLE: number min-value max-value ; +TUPLE: number min-value max-value integer ; : ( id -- component ) number ; M: number validate* [ v-number ] [ + [ integer>> [ v-integer ] when ] [ min-value>> [ v-min-value ] when* ] [ max-value>> [ v-max-value ] when* ] - bi + tri ] bi* ; M: number render-view* @@ -215,7 +211,12 @@ M: number render-error* ! Text areas TUPLE: text ; -: ( id -- component ) text construct-delegate ; +: ( id -- component ) text ; + +M: text validate* drop ; + +M: text render-view* + drop write ; : render-textarea