From 2045f44ced34a546d215c872cda542171014a6dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 00:08:49 -0500 Subject: [PATCH 001/129] Fix RSS unit tests --- extra/rss/rss-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor index 7523d0509f..252defe99b 100755 --- a/extra/rss/rss-tests.factor +++ b/extra/rss/rss-tests.factor @@ -5,7 +5,7 @@ IN: rss.tests : load-news-file ( filename -- feed ) #! Load an news syndication file and process it, returning #! it as an feed tuple. - utf8 read-feed ; + utf8 file-contents read-feed ; [ T{ feed @@ -36,7 +36,7 @@ IN: rss.tests "http://example.org/2005/04/02/atom" "\n
\n

[Update: The Atom draft is finished.]

\n
\n " - T{ timestamp f 2003 12 13 8 29 29 -4 } + T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } } } } } ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test From 2f2d31a623785b936e7fc7b18fc72af34ab0792e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 00:53:42 -0500 Subject: [PATCH 002/129] Fix HTTP unit tests --- extra/http/http-tests.factor | 15 +++++++++------ extra/http/http.factor | 3 +-- extra/http/server/actions/actions-tests.factor | 10 +++++++--- 3 files changed, 17 insertions(+), 11 deletions(-) diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 9302045624..3a50630335 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -24,6 +24,8 @@ IN: http.tests [ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test [ "/bar" ] [ "/bar" url>path ] unit-test +: lf>crlf "\n" split "\r\n" join ; + STRING: read-request-test-1 GET http://foo/bar HTTP/1.1 Some-Header: 1 @@ -45,7 +47,7 @@ blah cookies: V{ } } ] [ - read-request-test-1 [ + read-request-test-1 lf>crlf [ read-request ] with-string-reader ] unit-test @@ -59,7 +61,7 @@ blah ; read-request-test-1' 1array [ - read-request-test-1 + read-request-test-1 lf>crlf [ read-request ] with-string-reader [ write-request ] with-string-writer ! normalize crlf @@ -69,6 +71,7 @@ read-request-test-1' 1array [ STRING: read-request-test-2 HEAD http://foo/bar HTTP/1.1 Host: www.sex.com + ; [ @@ -83,7 +86,7 @@ Host: www.sex.com cookies: V{ } } ] [ - read-request-test-2 [ + read-request-test-2 lf>crlf [ read-request ] with-string-reader ] unit-test @@ -104,7 +107,7 @@ blah cookies: V{ } } ] [ - read-response-test-1 + read-response-test-1 lf>crlf [ read-response ] with-string-reader ] unit-test @@ -117,7 +120,7 @@ content-type: text/html ; read-response-test-1' 1array [ - read-response-test-1 + read-response-test-1 lf>crlf [ read-response ] with-string-reader [ write-response ] with-string-writer ! normalize crlf @@ -162,7 +165,7 @@ io.encodings.ascii ; "localhost" 1237 ascii [ "GET nested HTTP/1.0\r\n" write flush "\r\n" write flush - readln drop + read-crlf drop read-header ] with-stream "location" swap at "/" head? ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 4aaab2205e..3e81fccd24 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -89,8 +89,7 @@ IN: http : read-crlf ( -- string ) "\r" read-until - CHAR: \r assert= - read1 CHAR: \n assert= ; + [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; : read-header-line ( -- ) read-crlf dup diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor index ebf8e8770b..90e632d7f5 100755 --- a/extra/http/server/actions/actions-tests.factor +++ b/extra/http/server/actions/actions-tests.factor @@ -1,7 +1,7 @@ IN: http.server.actions.tests USING: http.server.actions http.server.validators tools.test math math.parser multiline namespaces http -io.streams.string http.server sequences accessors ; +io.streams.string http.server sequences splitting accessors ; [ "a" [ v-number ] { { "a" "123" } } validate-param @@ -13,6 +13,8 @@ io.streams.string http.server sequences accessors ; { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params "action-1" set +: lf>crlf "\n" split "\r\n" join ; + STRING: action-request-test-1 GET http://foo/bar?a=12&b=13 HTTP/1.1 @@ -20,7 +22,8 @@ blah ; [ 25 ] [ - action-request-test-1 [ read-request ] with-string-reader + action-request-test-1 lf>crlf + [ read-request ] with-string-reader request set "/blah" "action-1" get call-responder @@ -40,7 +43,8 @@ xxx=4 ; [ "/blahXXXX" ] [ - action-request-test-2 [ read-request ] with-string-reader + action-request-test-2 lf>crlf + [ read-request ] with-string-reader request set "/blah" "action-2" get call-responder From 3be7f29b25c5a939521b0f1b61de480237dd921c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 00:54:41 -0500 Subject: [PATCH 003/129] Fix todo load error --- extra/webapps/todo/todo.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 08555b92ed..97af356dc5 100755 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -6,6 +6,7 @@ http.server.components http.server.components.farkup http.server.forms http.server.templating.chloe http.server.boilerplate http.server.crud http.server.auth http.server.actions http.server.db +http.server.auth.login http.server webapps.factor-website ; IN: webapps.todo @@ -78,8 +79,6 @@ TUPLE: todo-responder < dispatcher ; : init-todo ( -- ) test-db [ init-todo-table - init-users-table - init-sessions-table ] with-db From 04e9b1c37fb0c72f06e86e1ba2a42ae8e56a6ea2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 01:31:32 -0500 Subject: [PATCH 004/129] Fix Cocoa UI bug --- extra/ui/cocoa/views/views.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor index 5b975f40de..442eda90ef 100755 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -126,6 +126,13 @@ CLASS: { { +name+ "FactorView" } { +protocols+ { "NSTextInput" } } } + +! Rendering +! Rendering +{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" } + [ 3drop window relayout-1 ] +} + ! Events { "acceptsFirstMouse:" "bool" { "id" "SEL" "id" } [ 3drop 1 ] From 3a69c972980251af21c731f771d0e61625593bb9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 01:42:30 -0500 Subject: [PATCH 005/129] https:// is absolute --- extra/http/client/client.factor | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 8879a76a5c..cc356ca8e3 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -39,13 +39,16 @@ DEFER: http-request SYMBOL: redirects +: absolute-url? ( url -- ? ) + [ "http://" head? ] [ "https://" head? ] bi or ; + : do-redirect ( response -- response stream ) dup response-code 300 399 between? [ stdio get dispose redirects inc redirects get max-redirects < [ header>> "location" swap at - dup "http://" head? [ + dup absolute-url? [ absolute-redirect ] [ relative-redirect @@ -116,8 +119,12 @@ M: download-failed error. : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - swap http-get-stream swap check-response - [ swap latin1 stream-copy ] with-disposal ; + swap http-get-stream check-response + dup string? [ + latin1 [ write ] with-file-writer + ] [ + [ swap latin1 stream-copy ] with-disposal + ] if ; : download ( url -- ) dup download-name download-to ; From df41c8b68f44a04209ef484a8f689f358266159c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 23 Apr 2008 02:46:35 -0500 Subject: [PATCH 006/129] Fix documentation --- core/alien/strings/strings-docs.factor | 4 ++-- core/alien/strings/strings.factor | 2 +- extra/bit-vectors/bit-vectors-docs.factor | 4 ++-- extra/byte-vectors/byte-vectors-docs.factor | 2 +- extra/columns/columns-docs.factor | 2 +- extra/float-vectors/float-vectors-docs.factor | 4 ++-- 6 files changed, 9 insertions(+), 9 deletions(-) diff --git a/core/alien/strings/strings-docs.factor b/core/alien/strings/strings-docs.factor index 0dbb4ffd38..27b0122ebe 100644 --- a/core/alien/strings/strings-docs.factor +++ b/core/alien/strings/strings-docs.factor @@ -3,14 +3,14 @@ debugger ; IN: alien.strings HELP: string>alien -{ $values { "string" string } { "encoding" "an encoding descriptor" } { "array" byte-array } } +{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } } { $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." } { $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ; { string>alien alien>string malloc-string } related-words HELP: alien>string -{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string" string } } +{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } } { $description "Reads a null-terminated C string from the specified address with the given encoding." } ; HELP: malloc-string diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index 463fc11e0d..d69d8e9e8e 100644 --- a/core/alien/strings/strings.factor +++ b/core/alien/strings/strings.factor @@ -6,7 +6,7 @@ io.streams.byte-array io.streams.memory io.encodings.utf8 io.encodings.utf16 system alien strings cpu.architecture ; IN: alien.strings -GENERIC# alien>string 1 ( alien encoding -- string/f ) +GENERIC# alien>string 1 ( c-ptr encoding -- string/f ) M: c-ptr alien>string >r r> diff --git a/extra/bit-vectors/bit-vectors-docs.factor b/extra/bit-vectors/bit-vectors-docs.factor index 9ceb2df342..41f32b4cdb 100755 --- a/extra/bit-vectors/bit-vectors-docs.factor +++ b/extra/bit-vectors/bit-vectors-docs.factor @@ -3,7 +3,7 @@ bit-vectors.private combinators ; IN: bit-vectors ARTICLE: "bit-vectors" "Bit vectors" -"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary." +"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary." $nl "Bit vectors form a class:" { $subsection bit-vector } @@ -19,7 +19,7 @@ $nl ABOUT: "bit-vectors" HELP: bit-vector -{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ; +{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ; HELP: { $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } } diff --git a/extra/byte-vectors/byte-vectors-docs.factor b/extra/byte-vectors/byte-vectors-docs.factor index f34bc20219..139cbab822 100755 --- a/extra/byte-vectors/byte-vectors-docs.factor +++ b/extra/byte-vectors/byte-vectors-docs.factor @@ -19,7 +19,7 @@ $nl ABOUT: "byte-vectors" HELP: byte-vector -{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ; +{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ; HELP: { $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } } diff --git a/extra/columns/columns-docs.factor b/extra/columns/columns-docs.factor index 6b2adce9d9..a2f0cccf3b 100644 --- a/extra/columns/columns-docs.factor +++ b/extra/columns/columns-docs.factor @@ -14,7 +14,7 @@ HELP: ( seq n -- column ) { $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } { $examples { $example - "USING: arrays prettyprint sequences ;" + "USING: arrays prettyprint columns ;" "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 >array ." "{ 1 4 7 }" } diff --git a/extra/float-vectors/float-vectors-docs.factor b/extra/float-vectors/float-vectors-docs.factor index 8d25da54be..5e06f05a2b 100755 --- a/extra/float-vectors/float-vectors-docs.factor +++ b/extra/float-vectors/float-vectors-docs.factor @@ -3,7 +3,7 @@ float-vectors.private combinators ; IN: float-vectors ARTICLE: "float-vectors" "Float vectors" -"A float vector is a resizable mutable sequence of unsigned floats. The literal syntax is covered in " { $link "syntax-float-vectors" } ". Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary." +"A float vector is a resizable mutable sequence of unsigned floats. Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary." $nl "Float vectors form a class:" { $subsection float-vector } @@ -19,7 +19,7 @@ $nl ABOUT: "float-vectors" HELP: float-vector -{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ; +{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for information." } ; HELP: { $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } } From d2d2c5d84fbf6eaa2c5150067fd19dc8f6a314c6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 20:00:04 -0500 Subject: [PATCH 007/129] fix using in hardware-info --- extra/hardware-info/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index 10474c09f7..3162496974 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 words combinators vocabs.loader hardware-info.backend -system ; +system alien.strings ; IN: hardware-info.windows : system-info ( -- SYSTEM_INFO ) From 8a0909d84923ce59a47e5322e449eb1c149d2768 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 20:09:36 -0500 Subject: [PATCH 008/129] fix ffi test int ffi test 36 point 5 --- core/alien/compiler/compiler-tests.factor | 750 +++++++++++----------- vm/ffi_test.c | 2 +- 2 files changed, 376 insertions(+), 376 deletions(-) diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index 3d0f36e415..57bf163443 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -1,375 +1,375 @@ -IN: alien.compiler.tests -USING: alien alien.c-types alien.syntax compiler kernel -namespaces namespaces tools.test sequences inference words -arrays parser quotations continuations inference.backend effects -namespaces.private io io.streams.string memory system threads -tools.test math ; - -FUNCTION: void ffi_test_0 ; -[ ] [ ffi_test_0 ] unit-test - -FUNCTION: int ffi_test_1 ; -[ 3 ] [ ffi_test_1 ] unit-test - -FUNCTION: int ffi_test_2 int x int y ; -[ 5 ] [ 2 3 ffi_test_2 ] unit-test -[ "hi" 3 ffi_test_2 ] must-fail - -FUNCTION: int ffi_test_3 int x int y int z int t ; -[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test - -FUNCTION: float ffi_test_4 ; -[ 1.5 ] [ ffi_test_4 ] unit-test - -FUNCTION: double ffi_test_5 ; -[ 1.5 ] [ ffi_test_5 ] unit-test - -FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; -[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test -[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail -[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail - -C-STRUCT: foo - { "int" "x" } - { "int" "y" } -; - -: make-foo ( x y -- foo ) - "foo" [ set-foo-y ] keep [ set-foo-x ] keep ; - -FUNCTION: int ffi_test_11 int a foo b int c ; - -[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test - -FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ; - -[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test - -FUNCTION: foo ffi_test_14 int x int y ; - -[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test - -FUNCTION: char* ffi_test_15 char* x char* y ; - -[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test -[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test -[ 1 2 ffi_test_15 ] must-fail - -C-STRUCT: bar - { "long" "x" } - { "long" "y" } - { "long" "z" } -; - -FUNCTION: bar ffi_test_16 long x long y long z ; - -[ 11 6 -7 ] [ - 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z -] unit-test - -C-STRUCT: tiny - { "int" "x" } -; - -FUNCTION: tiny ffi_test_17 int x ; - -[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test - -[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with - -: indirect-test-1 - "int" { } "cdecl" alien-indirect ; - -{ 1 1 } [ indirect-test-1 ] must-infer-as - -[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test - -[ -1 indirect-test-1 ] must-fail - -: indirect-test-2 - "int" { "int" "int" } "cdecl" alien-indirect gc ; - -{ 3 1 } [ indirect-test-2 ] must-infer-as - -[ 5 ] -[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] -unit-test - -: indirect-test-3 - "int" { "int" "int" "int" "int" } "stdcall" alien-indirect - gc ; - -<< "f-stdcall" f "stdcall" add-library >> - -[ f ] [ "f-stdcall" load-library ] unit-test -[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test - -: ffi_test_18 ( w x y z -- int ) - "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } - alien-invoke gc ; - -[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test - -: ffi_test_19 ( x y z -- bar ) - "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } - alien-invoke gc ; - -[ 11 6 -7 ] [ - 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z -] unit-test - -FUNCTION: double ffi_test_6 float x float y ; -[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test -[ "a" "b" ffi_test_6 ] must-fail - -FUNCTION: double ffi_test_7 double x double y ; -[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test - -FUNCTION: double ffi_test_8 double x float y double z float t int w ; -[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test - -FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; -[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test - -FUNCTION: void ffi_test_20 double x1, double x2, double x3, - double y1, double y2, double y3, - double z1, double z2, double z3 ; - -[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test - -! Make sure XT doesn't get clobbered in stack frame - -: ffi_test_31 - "void" - f "ffi_test_31" - { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } - alien-invoke gc 3 ; - -[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test - -FUNCTION: longlong ffi_test_21 long x long y ; - -[ 121932631112635269 ] -[ 123456789 987654321 ffi_test_21 ] unit-test - -FUNCTION: long ffi_test_22 long x longlong y longlong z ; - -[ 987655432 ] -[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test - -[ 1111 f 123456789 ffi_test_22 ] must-fail - -C-STRUCT: rect - { "float" "x" } - { "float" "y" } - { "float" "w" } - { "float" "h" } -; - -: - "rect" - [ set-rect-h ] keep - [ set-rect-w ] keep - [ set-rect-y ] keep - [ set-rect-x ] keep ; - -FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; - -[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test - -[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail - -FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; - -[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test - -! Test odd-size structs -C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; - -FUNCTION: test-struct-1 ffi_test_24 ; - -[ B{ 1 } ] [ ffi_test_24 ] unit-test - -C-STRUCT: test-struct-2 { { "char" 2 } "x" } ; - -FUNCTION: test-struct-2 ffi_test_25 ; - -[ B{ 1 2 } ] [ ffi_test_25 ] unit-test - -C-STRUCT: test-struct-3 { { "char" 3 } "x" } ; - -FUNCTION: test-struct-3 ffi_test_26 ; - -[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test - -C-STRUCT: test-struct-4 { { "char" 4 } "x" } ; - -FUNCTION: test-struct-4 ffi_test_27 ; - -[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test - -C-STRUCT: test-struct-5 { { "char" 5 } "x" } ; - -FUNCTION: test-struct-5 ffi_test_28 ; - -[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test - -C-STRUCT: test-struct-6 { { "char" 6 } "x" } ; - -FUNCTION: test-struct-6 ffi_test_29 ; - -[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test - -C-STRUCT: test-struct-7 { { "char" 7 } "x" } ; - -FUNCTION: test-struct-7 ffi_test_30 ; - -[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test - -C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ; - -FUNCTION: double ffi_test_32 test-struct-8 x int y ; - -[ 9.0 ] [ - "test-struct-8" - 1.0 over set-test-struct-8-x - 2.0 over set-test-struct-8-y - 3 ffi_test_32 -] unit-test - -C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ; - -FUNCTION: double ffi_test_33 test-struct-9 x int y ; - -[ 9.0 ] [ - "test-struct-9" - 1.0 over set-test-struct-9-x - 2.0 over set-test-struct-9-y - 3 ffi_test_33 -] unit-test - -C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ; - -FUNCTION: double ffi_test_34 test-struct-10 x int y ; - -[ 9.0 ] [ - "test-struct-10" - 1.0 over set-test-struct-10-x - 2 over set-test-struct-10-y - 3 ffi_test_34 -] unit-test - -C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ; - -FUNCTION: double ffi_test_35 test-struct-11 x int y ; - -[ 9.0 ] [ - "test-struct-11" - 1 over set-test-struct-11-x - 2 over set-test-struct-11-y - 3 ffi_test_35 -] unit-test - -C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; - -: make-struct-12 - "test-struct-12" - [ set-test-struct-12-x ] keep ; - -FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; - -[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test - -FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; - -[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test - -! Test callbacks - -: callback-1 "void" { } "cdecl" [ ] alien-callback ; - -[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test - -[ t ] [ callback-1 alien? ] unit-test - -: callback_test_1 "void" { } "cdecl" alien-indirect ; - -[ ] [ callback-1 callback_test_1 ] unit-test - -: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; - -[ ] [ callback-2 callback_test_1 ] unit-test - -: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; - -[ t ] [ - namestack* - 3 "x" set callback-3 callback_test_1 - namestack* eq? -] unit-test - -[ 5 ] [ - [ - 3 "x" set callback-3 callback_test_1 "x" get - ] with-scope -] unit-test - -: callback-4 - "void" { } "cdecl" [ "Hello world" write ] alien-callback - gc ; - -[ "Hello world" ] [ - [ callback-4 callback_test_1 ] with-string-writer -] unit-test - -: callback-5 - "void" { } "cdecl" [ gc ] alien-callback ; - -[ "testing" ] [ - "testing" callback-5 callback_test_1 -] unit-test - -: callback-5a - "void" { } "cdecl" [ 8000000 f drop ] alien-callback ; - -! Hack; if we're on ARM, we probably don't have much RAM, so -! skip this test. -! cpu "arm" = [ -! [ "testing" ] [ -! "testing" callback-5a callback_test_1 -! ] unit-test -! ] unless - -: callback-6 - "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; - -[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test - -: callback-7 - "void" { } "cdecl" [ 1000 sleep ] alien-callback ; - -[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test - -[ f ] [ namespace global eq? ] unit-test - -: callback-8 - "void" { } "cdecl" [ - [ continue ] callcc0 - ] alien-callback ; - -[ ] [ callback-8 callback_test_1 ] unit-test - -: callback-9 - "int" { "int" "int" "int" } "cdecl" [ - + + 1+ - ] alien-callback ; - -FUNCTION: void ffi_test_36_point_5 ( ) ; - -[ ] [ ffi_test_36_point_5 ] unit-test - -FUNCTION: int ffi_test_37 ( void* func ) ; - -[ 1 ] [ callback-9 ffi_test_37 ] unit-test - -[ 7 ] [ callback-9 ffi_test_37 ] unit-test +IN: alien.compiler.tests +USING: alien alien.c-types alien.syntax compiler kernel +namespaces namespaces tools.test sequences inference words +arrays parser quotations continuations inference.backend effects +namespaces.private io io.streams.string memory system threads +tools.test math ; + +FUNCTION: void ffi_test_0 ; +[ ] [ ffi_test_0 ] unit-test + +FUNCTION: int ffi_test_1 ; +[ 3 ] [ ffi_test_1 ] unit-test + +FUNCTION: int ffi_test_2 int x int y ; +[ 5 ] [ 2 3 ffi_test_2 ] unit-test +[ "hi" 3 ffi_test_2 ] must-fail + +FUNCTION: int ffi_test_3 int x int y int z int t ; +[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test + +FUNCTION: float ffi_test_4 ; +[ 1.5 ] [ ffi_test_4 ] unit-test + +FUNCTION: double ffi_test_5 ; +[ 1.5 ] [ ffi_test_5 ] unit-test + +FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; +[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test +[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail +[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail + +C-STRUCT: foo + { "int" "x" } + { "int" "y" } +; + +: make-foo ( x y -- foo ) + "foo" [ set-foo-y ] keep [ set-foo-x ] keep ; + +FUNCTION: int ffi_test_11 int a foo b int c ; + +[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test + +FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ; + +[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test + +FUNCTION: foo ffi_test_14 int x int y ; + +[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test + +FUNCTION: char* ffi_test_15 char* x char* y ; + +[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test +[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test +[ 1 2 ffi_test_15 ] must-fail + +C-STRUCT: bar + { "long" "x" } + { "long" "y" } + { "long" "z" } +; + +FUNCTION: bar ffi_test_16 long x long y long z ; + +[ 11 6 -7 ] [ + 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z +] unit-test + +C-STRUCT: tiny + { "int" "x" } +; + +FUNCTION: tiny ffi_test_17 int x ; + +[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test + +[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with + +: indirect-test-1 + "int" { } "cdecl" alien-indirect ; + +{ 1 1 } [ indirect-test-1 ] must-infer-as + +[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test + +[ -1 indirect-test-1 ] must-fail + +: indirect-test-2 + "int" { "int" "int" } "cdecl" alien-indirect gc ; + +{ 3 1 } [ indirect-test-2 ] must-infer-as + +[ 5 ] +[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] +unit-test + +: indirect-test-3 + "int" { "int" "int" "int" "int" } "stdcall" alien-indirect + gc ; + +<< "f-stdcall" f "stdcall" add-library >> + +[ f ] [ "f-stdcall" load-library ] unit-test +[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test + +: ffi_test_18 ( w x y z -- int ) + "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } + alien-invoke gc ; + +[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test + +: ffi_test_19 ( x y z -- bar ) + "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } + alien-invoke gc ; + +[ 11 6 -7 ] [ + 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z +] unit-test + +FUNCTION: double ffi_test_6 float x float y ; +[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test +[ "a" "b" ffi_test_6 ] must-fail + +FUNCTION: double ffi_test_7 double x double y ; +[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test + +FUNCTION: double ffi_test_8 double x float y double z float t int w ; +[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test + +FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; +[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test + +FUNCTION: void ffi_test_20 double x1, double x2, double x3, + double y1, double y2, double y3, + double z1, double z2, double z3 ; + +[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test + +! Make sure XT doesn't get clobbered in stack frame + +: ffi_test_31 + "void" + f "ffi_test_31" + { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } + alien-invoke gc 3 ; + +[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test + +FUNCTION: longlong ffi_test_21 long x long y ; + +[ 121932631112635269 ] +[ 123456789 987654321 ffi_test_21 ] unit-test + +FUNCTION: long ffi_test_22 long x longlong y longlong z ; + +[ 987655432 ] +[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test + +[ 1111 f 123456789 ffi_test_22 ] must-fail + +C-STRUCT: rect + { "float" "x" } + { "float" "y" } + { "float" "w" } + { "float" "h" } +; + +: + "rect" + [ set-rect-h ] keep + [ set-rect-w ] keep + [ set-rect-y ] keep + [ set-rect-x ] keep ; + +FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; + +[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test + +[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail + +FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; + +[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test + +! Test odd-size structs +C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; + +FUNCTION: test-struct-1 ffi_test_24 ; + +[ B{ 1 } ] [ ffi_test_24 ] unit-test + +C-STRUCT: test-struct-2 { { "char" 2 } "x" } ; + +FUNCTION: test-struct-2 ffi_test_25 ; + +[ B{ 1 2 } ] [ ffi_test_25 ] unit-test + +C-STRUCT: test-struct-3 { { "char" 3 } "x" } ; + +FUNCTION: test-struct-3 ffi_test_26 ; + +[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test + +C-STRUCT: test-struct-4 { { "char" 4 } "x" } ; + +FUNCTION: test-struct-4 ffi_test_27 ; + +[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test + +C-STRUCT: test-struct-5 { { "char" 5 } "x" } ; + +FUNCTION: test-struct-5 ffi_test_28 ; + +[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test + +C-STRUCT: test-struct-6 { { "char" 6 } "x" } ; + +FUNCTION: test-struct-6 ffi_test_29 ; + +[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test + +C-STRUCT: test-struct-7 { { "char" 7 } "x" } ; + +FUNCTION: test-struct-7 ffi_test_30 ; + +[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test + +C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ; + +FUNCTION: double ffi_test_32 test-struct-8 x int y ; + +[ 9.0 ] [ + "test-struct-8" + 1.0 over set-test-struct-8-x + 2.0 over set-test-struct-8-y + 3 ffi_test_32 +] unit-test + +C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ; + +FUNCTION: double ffi_test_33 test-struct-9 x int y ; + +[ 9.0 ] [ + "test-struct-9" + 1.0 over set-test-struct-9-x + 2.0 over set-test-struct-9-y + 3 ffi_test_33 +] unit-test + +C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ; + +FUNCTION: double ffi_test_34 test-struct-10 x int y ; + +[ 9.0 ] [ + "test-struct-10" + 1.0 over set-test-struct-10-x + 2 over set-test-struct-10-y + 3 ffi_test_34 +] unit-test + +C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ; + +FUNCTION: double ffi_test_35 test-struct-11 x int y ; + +[ 9.0 ] [ + "test-struct-11" + 1 over set-test-struct-11-x + 2 over set-test-struct-11-y + 3 ffi_test_35 +] unit-test + +C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; + +: make-struct-12 + "test-struct-12" + [ set-test-struct-12-x ] keep ; + +FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; + +[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test + +FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; + +[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test + +! Test callbacks + +: callback-1 "void" { } "cdecl" [ ] alien-callback ; + +[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test + +[ t ] [ callback-1 alien? ] unit-test + +: callback_test_1 "void" { } "cdecl" alien-indirect ; + +[ ] [ callback-1 callback_test_1 ] unit-test + +: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; + +[ ] [ callback-2 callback_test_1 ] unit-test + +: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; + +[ t ] [ + namestack* + 3 "x" set callback-3 callback_test_1 + namestack* eq? +] unit-test + +[ 5 ] [ + [ + 3 "x" set callback-3 callback_test_1 "x" get + ] with-scope +] unit-test + +: callback-4 + "void" { } "cdecl" [ "Hello world" write ] alien-callback + gc ; + +[ "Hello world" ] [ + [ callback-4 callback_test_1 ] with-string-writer +] unit-test + +: callback-5 + "void" { } "cdecl" [ gc ] alien-callback ; + +[ "testing" ] [ + "testing" callback-5 callback_test_1 +] unit-test + +: callback-5a + "void" { } "cdecl" [ 8000000 f drop ] alien-callback ; + +! Hack; if we're on ARM, we probably don't have much RAM, so +! skip this test. +! cpu "arm" = [ +! [ "testing" ] [ +! "testing" callback-5a callback_test_1 +! ] unit-test +! ] unless + +: callback-6 + "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; + +[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test + +: callback-7 + "void" { } "cdecl" [ 1000 sleep ] alien-callback ; + +[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test + +[ f ] [ namespace global eq? ] unit-test + +: callback-8 + "void" { } "cdecl" [ + [ continue ] callcc0 + ] alien-callback ; + +[ ] [ callback-8 callback_test_1 ] unit-test + +: callback-9 + "int" { "int" "int" "int" } "cdecl" [ + + + 1+ + ] alien-callback ; + +FUNCTION: void int_ffi_test_36_point_5 ( ) ; + +[ ] [ int_ffi_test_36_point_5 ] unit-test + +FUNCTION: int ffi_test_37 ( void* func ) ; + +[ 1 ] [ callback-9 ffi_test_37 ] unit-test + +[ 7 ] [ callback-9 ffi_test_37 ] unit-test diff --git a/vm/ffi_test.c b/vm/ffi_test.c index b2cbf9b6b5..4293a6bbae 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -253,7 +253,7 @@ double ffi_test_36(struct test_struct_12 x) static int global_var; -void ffi_test_36_point_5(void) +void int_ffi_test_36_point_5(void) { printf("int_ffi_test_36_point_5\n"); global_var = 0; From defc1cfae97329b0aade66049093235a32485601 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 15 Apr 2008 21:55:26 -0500 Subject: [PATCH 009/129] fix sql --- extra/db/sql/sql-tests.factor | 2 +- extra/db/sql/sql.factor | 34 +++++++++++++++++----------------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor index 488026fcc7..db69d71a84 100644 --- a/extra/db/sql/sql-tests.factor +++ b/extra/db/sql/sql-tests.factor @@ -28,7 +28,7 @@ TUPLE: person name age ; { select { columns "salary" } { from "staff" } - { where { "branchno" "b003" } } + { where { "branchno" = "b003" } } } } { "branchno" > 3 } } diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index 26e8429efd..b0ec7aaf34 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -27,23 +27,23 @@ DEFER: sql% : sql-array% ( array -- ) unclip { - { columns [ "," (sql-interleave) ] } - { from [ "from" "," sql-interleave ] } - { where [ "where" "and" sql-interleave ] } - { group-by [ "group by" "," sql-interleave ] } - { having [ "having" "," sql-interleave ] } - { order-by [ "order by" "," sql-interleave ] } - { offset [ "offset" sql% sql% ] } - { limit [ "limit" sql% sql% ] } - { select [ "(select" sql% sql% ")" sql% ] } - { table [ sql% ] } - { set [ "set" "," sql-interleave ] } - { values [ "values(" sql% "," (sql-interleave) ")" sql% ] } - { count [ "count" sql-function, ] } - { sum [ "sum" sql-function, ] } - { avg [ "avg" sql-function, ] } - { min [ "min" sql-function, ] } - { max [ "max" sql-function, ] } + { \ columns [ "," (sql-interleave) ] } + { \ from [ "from" "," sql-interleave ] } + { \ where [ "where" "and" sql-interleave ] } + { \ group-by [ "group by" "," sql-interleave ] } + { \ having [ "having" "," sql-interleave ] } + { \ order-by [ "order by" "," sql-interleave ] } + { \ offset [ "offset" sql% sql% ] } + { \ limit [ "limit" sql% sql% ] } + { \ select [ "(select" sql% sql% ")" sql% ] } + { \ table [ sql% ] } + { \ set [ "set" "," sql-interleave ] } + { \ values [ break "values(" sql% "," (sql-interleave) ")" sql% ] } + { \ count [ "count" sql-function, ] } + { \ sum [ "sum" sql-function, ] } + { \ avg [ "avg" sql-function, ] } + { \ min [ "min" sql-function, ] } + { \ max [ "max" sql-function, ] } [ sql% [ sql% ] each ] } case ; From 336e30b054d6d8d6353c5c2a4431d69c7a659c66 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 17 Apr 2008 19:43:07 -0500 Subject: [PATCH 010/129] add interval queries for sqlite --- extra/db/db.factor | 4 +- extra/db/sql/sql-tests.factor | 2 +- extra/db/sql/sql.factor | 11 +++-- extra/db/sqlite/lib/lib.factor | 5 ++- extra/db/sqlite/sqlite.factor | 68 ++++++++++++++++++++++------- extra/db/tuples/tuples-tests.factor | 41 ++++++++++++++--- extra/db/types/types.factor | 2 + 7 files changed, 103 insertions(+), 30 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index baf4e9db5a..533f238f04 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -11,7 +11,7 @@ TUPLE: db update-statements delete-statements ; -: construct-db ( class -- obj ) +: new-db ( class -- obj ) new H{ } clone >>insert-statements H{ } clone >>update-statements @@ -20,7 +20,7 @@ TUPLE: db GENERIC: make-db* ( seq class -- db ) : make-db ( seq class -- db ) - construct-db make-db* ; + new-db make-db* ; GENERIC: db-open ( db -- db ) HOOK: db-close db ( handle -- ) diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor index db69d71a84..cab7b83ced 100644 --- a/extra/db/sql/sql-tests.factor +++ b/extra/db/sql/sql-tests.factor @@ -1,7 +1,7 @@ USING: kernel namespaces db.sql sequences math ; IN: db.sql.tests -TUPLE: person name age ; +! TUPLE: person name age ; : insert-1 { insert { table "person" } diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index b0ec7aaf34..d7ef986ea6 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -55,15 +55,18 @@ TUPLE: no-sql-match ; { [ dup number? ] [ number>string sql% ] } { [ dup symbol? ] [ unparse sql% ] } { [ dup word? ] [ unparse sql% ] } + { [ dup quotation? ] [ call ] } [ T{ no-sql-match } throw ] } cond ; : parse-sql ( obj -- sql in-spec out-spec in out ) [ unclip { - { insert [ "insert into" sql% ] } - { update [ "update" sql% ] } - { delete [ "delete" sql% ] } - { select [ "select" sql% ] } + { \ create [ "create table" sql% ] } + { \ drop [ "drop table" sql% ] } + { \ insert [ "insert into" sql% ] } + { \ update [ "update" sql% ] } + { \ delete [ "delete" sql% ] } + { \ select [ "select" sql% ] } } case [ sql% ] each ] { "" { } { } { } { } } nmake ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index e66accd7e9..b6221e5a1e 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize io.streams.byte-array byte-arrays io.encodings.binary -tools.walker ; +tools.walker io.backend ; IN: db.sqlite.lib : sqlite-error ( n -- * ) @@ -23,7 +23,8 @@ IN: db.sqlite.lib [ sqlite-error ] } cond ; -: sqlite-open ( filename -- db ) +: sqlite-open ( path -- db ) + normalize-path "void*" [ sqlite3_open sqlite-check-result ] keep *void* ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 11c0150cd2..02bf314a0a 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -4,8 +4,9 @@ USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples -words combinators.lib db.types combinators +words combinators.lib db.types combinators math.intervals io namespaces.lib accessors ; +USE: tools.walker IN: db.sqlite TUPLE: sqlite-db < db path ; @@ -54,16 +55,20 @@ M: sqlite-statement bind-statement* ( statement -- ) [ statement-bind-params ] [ statement-handle ] bi sqlite-bind ; +GENERIC: sqlite-bind-conversion ( tuple obj -- array ) + +M: sql-spec sqlite-bind-conversion ( tuple spec -- array ) + [ column-name>> ":" prepend ] + [ slot-name>> rot get-slot-named ] + [ type>> ] tri 3array ; + +M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) + nip [ key>> ] [ value>> ] [ type>> ] tri 3array ; + M: sqlite-statement bind-tuple ( tuple statement -- ) [ - in-params>> - [ - [ column-name>> ":" prepend ] - [ slot-name>> rot get-slot-named ] - [ type>> ] tri 3array - ] with map - ] keep - bind-statement ; + in-params>> [ sqlite-bind-conversion ] with map + ] keep bind-statement ; : last-insert-id ( -- id ) db get db-handle sqlite3_last_insert_rowid @@ -129,13 +134,46 @@ M: sqlite-db ( tuple -- statement ) M: sqlite-db ( tuple -- statement ) ; +M: sqlite-db bind% ( spec -- ) + dup 1, column-name>> ":" prepend 0% ; + : where-primary-key% ( specs -- ) " where " 0% find-primary-key dup column-name>> 0% " = " 0% bind% ; -: where-clause ( specs -- ) - " where " 0% - [ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ; +! : where-object ( tuple specs -- ) + ! [ dup column-name>> get-slot-named ] keep + ! dup column-name>> 0% " = " 0% bind% ; + +GENERIC: where-object ( specs obj -- ) + +: interval-comparison ( ? str -- str ) + "from" = " >" " <" ? swap [ "= " append ] when ; + +: where-interval ( spec val ? from/to -- ) + roll [ + column-name>> + [ 0% interval-comparison 0% ] + [ ":" spin 3append dup 0% ] 2bi + swap + ] [ + type>> + ] bi literal-bind boa 1, ; + +M: interval where-object ( specs obj -- ) + [ from>> first2 "from" where-interval " and " 0% ] + [ to>> first2 "to" where-interval ] 2bi ; + +M: object where-object ( specs obj -- ) + drop + dup column-name>> 0% " = " 0% bind% ; + +: where-clause ( tuple specs -- ) + " where " 0% [ + " and " 0% + ] [ + 2dup slot-name>> swap get-slot-named where-object + ] interleave drop ; M: sqlite-db ( class -- statement ) [ @@ -158,9 +196,6 @@ M: sqlite-db ( specs table -- sql ) ! : select-interval ( interval name -- ) ; ! : select-sequence ( seq name -- ) ; -M: sqlite-db bind% ( spec -- ) - dup 1, column-name>> ":" prepend 0% ; - M: sqlite-db ( tuple class -- statement ) [ "select " 0% @@ -168,8 +203,9 @@ M: sqlite-db ( tuple class -- statement ) [ dup column-name>> 0% 2, ] interleave " from " 0% 0% + dupd [ slot-name>> swap get-slot-named ] with subset - dup empty? [ drop ] [ where-clause ] if ";" 0% + dup empty? [ 2drop ] [ where-clause ] if ";" 0% ] sqlite-make ; M: sqlite-db modifier-table ( -- hashtable ) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 951ded32ea..36a8d4cd3f 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -233,12 +233,43 @@ TUPLE: exam id name score ; [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test [ - T{ exam f 3 "Kenny" 60 } - T{ exam f 4 "Cartman" 41 } - ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test - ; + { + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + } + ] [ + T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples + ] unit-test -! [ test-ranges ] test-sqlite + [ + { } + ] [ + T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples + ] unit-test + [ + { + T{ exam f 4 "Cartman" 41 } + } + ] [ + T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples + ] unit-test + [ + { + T{ exam f 3 "Kenny" 60 } + } + ] [ + T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples + ] unit-test + [ + { + T{ exam f 3 "Kenny" 60 } + T{ exam f 4 "Cartman" 41 } + } + ] [ + T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples + ] unit-test ; + +[ test-ranges ] test-sqlite TUPLE: secret n message ; C: secret diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 98bc451a6f..bea81f422b 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -15,6 +15,8 @@ HOOK: compound-type db ( str n -- hash ) TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; +TUPLE: literal-bind key value type ; + SINGLETON: +native-id+ SINGLETON: +assigned-id+ SINGLETON: +random-id+ From afaab57f8356b77e7dd9547ecf46bd6e8f8ac638 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 18 Apr 2008 12:43:21 -0500 Subject: [PATCH 011/129] interval, range queries in sqlite --- extra/db/sqlite/sqlite.factor | 62 +++++++++++++++++------------ extra/db/tuples/tuples-tests.factor | 28 +++++++++++-- extra/db/tuples/tuples.factor | 3 ++ extra/db/types/types.factor | 4 +- 4 files changed, 67 insertions(+), 30 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 02bf314a0a..de5c245517 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,7 +5,7 @@ hashtables io.files kernel math math.parser namespaces prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators math.intervals -io namespaces.lib accessors ; +io namespaces.lib accessors vectors math.ranges ; USE: tools.walker IN: db.sqlite @@ -104,7 +104,8 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; : sqlite-make ( class quot -- ) >r sql-props r> - { "" { } { } } nmake ; inline + [ 0 sql-counter rot with-variable ] { "" { } { } } nmake + ; inline M: sqlite-db create-sql-statement ( class -- statement ) [ @@ -134,6 +135,12 @@ M: sqlite-db ( tuple -- statement ) M: sqlite-db ( tuple -- statement ) ; +M: sqlite-db bind# ( spec obj -- ) + >r + [ column-name>> ":" swap next-sql-counter 3append dup 0% ] + [ type>> ] bi + r> 1, ; + M: sqlite-db bind% ( spec -- ) dup 1, column-name>> ":" prepend 0% ; @@ -141,38 +148,44 @@ M: sqlite-db bind% ( spec -- ) " where " 0% find-primary-key dup column-name>> 0% " = " 0% bind% ; -! : where-object ( tuple specs -- ) - ! [ dup column-name>> get-slot-named ] keep - ! dup column-name>> 0% " = " 0% bind% ; - -GENERIC: where-object ( specs obj -- ) +GENERIC: where ( specs obj -- ) : interval-comparison ( ? str -- str ) "from" = " >" " <" ? swap [ "= " append ] when ; -: where-interval ( spec val ? from/to -- ) - roll [ - column-name>> - [ 0% interval-comparison 0% ] - [ ":" spin 3append dup 0% ] 2bi - swap - ] [ - type>> - ] bi literal-bind boa 1, ; +: where-interval ( spec obj from/to -- ) + pick column-name>> 0% + >r first2 r> interval-comparison 0% + bind# ; -M: interval where-object ( specs obj -- ) - [ from>> first2 "from" where-interval " and " 0% ] - [ to>> first2 "to" where-interval ] 2bi ; +: in-parens ( quot -- ) + "(" 0% call ")" 0% ; inline -M: object where-object ( specs obj -- ) - drop - dup column-name>> 0% " = " 0% bind% ; +M: interval where ( spec obj -- ) + [ + [ from>> "from" where-interval " and " 0% ] + [ to>> "to" where-interval ] 2bi + ] in-parens ; + +M: sequence where ( spec obj -- ) + [ + [ " or " 0% ] [ dupd where ] interleave drop + ] in-parens ; + +: object-where ( spec obj -- ) + over column-name>> 0% " = " 0% bind# ; + +M: object where ( spec obj -- ) object-where ; + +M: integer where ( spec obj -- ) object-where ; + +M: string where ( spec obj -- ) object-where ; : where-clause ( tuple specs -- ) " where " 0% [ " and " 0% ] [ - 2dup slot-name>> swap get-slot-named where-object + 2dup slot-name>> swap get-slot-named where ] interleave drop ; M: sqlite-db ( class -- statement ) @@ -193,9 +206,6 @@ M: sqlite-db ( specs table -- sql ) dup column-name>> 0% " = " 0% bind% ] sqlite-make ; -! : select-interval ( interval name -- ) ; -! : select-sequence ( seq name -- ) ; - M: sqlite-db ( tuple class -- statement ) [ "select " 0% diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 36a8d4cd3f..691cc6f687 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.tuples -db.types continuations namespaces math +db.types continuations namespaces math math.ranges prettyprint tools.walker db.sqlite calendar math.intervals db.postgresql ; IN: db.tuples.tests @@ -217,7 +217,7 @@ TUPLE: serialize-me id data ; TUPLE: exam id name score ; -: test-ranges ( -- ) +: test-intervals ( -- ) exam "EXAM" { { "id" "ID" +native-id+ } @@ -267,9 +267,31 @@ TUPLE: exam id name score ; } ] [ T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples + ] unit-test + + [ + { + T{ exam f 1 "Kyle" 100 } + T{ exam f 2 "Stan" 80 } + } + ] [ + T{ exam f f { "Stan" "Kyle" } } select-tuples + ] unit-test + + [ + { + T{ exam f 1 "Kyle" 100 } + T{ exam f 2 "Stan" 80 } + T{ exam f 3 "Kenny" 60 } + } + ] [ + T{ exam f T{ range f 1 3 1 } } select-tuples ] unit-test ; -[ test-ranges ] test-sqlite +[ test-intervals ] test-sqlite + +: test-ranges + ; TUPLE: secret n message ; C: secret diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 311f18daa9..32431b4ddc 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -22,6 +22,9 @@ IN: db.tuples class db-columns find-primary-key sql-spec-slot-name ] keep set-slot-named ; +SYMBOL: sql-counter +: next-sql-counter sql-counter [ inc ] [ get ] bi number>string ; + ! returns a sequence of prepared-statements HOOK: create-sql-statement db ( class -- obj ) HOOK: drop-sql-statement db ( class -- obj ) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index bea81f422b..9959e894a7 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -15,7 +15,8 @@ HOOK: compound-type db ( str n -- hash ) TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; -TUPLE: literal-bind key value type ; +TUPLE: literal-bind key type value ; +C: literal-bind SINGLETON: +native-id+ SINGLETON: +assigned-id+ @@ -132,6 +133,7 @@ TUPLE: no-sql-modifier ; dup empty? [ " " prepend ] unless ; HOOK: bind% db ( spec -- ) +HOOK: bind# db ( spec obj -- ) : offset-of-slot ( str obj -- n ) class "slots" word-prop slot-named slot-spec-offset ; From 6044cc4b3905a7c4b9a30a241f7c31e8032949b8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 18 Apr 2008 16:01:31 -0500 Subject: [PATCH 012/129] make throwable, nonthrowable, retryable a type --- extra/db/db.factor | 60 +++++++++++++++++++-------- extra/db/postgresql/postgresql.factor | 2 +- extra/db/sqlite/sqlite.factor | 8 ++-- extra/db/tuples/tuples-tests.factor | 16 ++++--- 4 files changed, 55 insertions(+), 31 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 533f238f04..7a28dea558 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations kernel math namespaces sequences sequences.lib classes.tuple words strings -tools.walker accessors ; +tools.walker accessors combinators.lib ; IN: db TUPLE: db @@ -36,26 +36,47 @@ HOOK: db-close db ( handle -- ) ] with-variable ; ! TUPLE: sql sql in-params out-params ; -TUPLE: statement handle sql in-params out-params bind-params bound? ; +TUPLE: statement handle sql in-params out-params bind-params bound? type quot ; TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; -TUPLE: nonthrowable-statement < statement ; -TUPLE: throwable-statement < statement ; + +SINGLETON: throwable +SINGLETON: nonthrowable +SINGLETON: retryable + +: make-throwable ( obj -- obj' ) + dup sequence? [ + [ make-throwable ] map + ] [ + throwable >>type + ] if ; : make-nonthrowable ( obj -- obj' ) dup sequence? [ [ make-nonthrowable ] map ] [ - nonthrowable-statement construct-delegate + nonthrowable >>type ] if ; +: make-retryable ( obj quot -- obj' ) + over sequence? [ + [ make-retryable ] curry map + ] [ + >>quot + retryable >>type + ] if ; + +: handle-random-id ( statement -- ) + drop ; + TUPLE: result-set sql in-params out-params handle n max ; : construct-statement ( sql in out class -- statement ) new swap >>out-params swap >>in-params - swap >>sql ; + swap >>sql + throwable >>type ; HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) @@ -70,20 +91,25 @@ GENERIC# row-column-typed 1 ( result-set column -- sql ) GENERIC: advance-row ( result-set -- ) GENERIC: more-rows? ( result-set -- ? ) -GENERIC: execute-statement ( statement -- ) +GENERIC: execute-statement* ( statement type -- ) -M: throwable-statement execute-statement ( statement -- ) - dup sequence? [ - [ execute-statement ] each - ] [ - query-results dispose - ] if ; +M: throwable execute-statement* ( statement type -- ) + drop query-results dispose ; -M: nonthrowable-statement execute-statement ( statement -- ) - dup sequence? [ - [ execute-statement ] each - ] [ +M: nonthrowable execute-statement* ( statement type -- ) + drop [ query-results dispose ] [ 2drop ] recover ; + +M: retryable execute-statement* ( statement type -- ) + [ + dup dup quot>> call [ query-results dispose ] [ 2drop ] recover + ] curry 10 retry ; + +: execute-statement ( statement -- ) + dup sequence? [ + [ execute-statement ] each + ] [ + dup type>> execute-statement* ] if ; : bind-statement ( obj statement -- ) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 322143e7a2..9dfa123952 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -11,7 +11,7 @@ IN: db.postgresql TUPLE: postgresql-db < db host port pgopts pgtty db user pass ; -TUPLE: postgresql-statement < throwable-statement ; +TUPLE: postgresql-statement < statement ; TUPLE: postgresql-result-set < result-set ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index de5c245517..e2ea28fe9a 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -20,7 +20,7 @@ M: sqlite-db db-open ( db -- db ) M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db dispose ( db -- ) dispose-db ; -TUPLE: sqlite-statement < throwable-statement ; +TUPLE: sqlite-statement < statement ; TUPLE: sqlite-result-set < result-set has-more? ; @@ -105,7 +105,8 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; : sqlite-make ( class quot -- ) >r sql-props r> [ 0 sql-counter rot with-variable ] { "" { } { } } nmake - ; inline + + dup handle-random-id ; inline M: sqlite-db create-sql-statement ( class -- statement ) [ @@ -223,7 +224,6 @@ M: sqlite-db modifier-table ( -- hashtable ) { +native-id+ "primary key" } { +assigned-id+ "primary key" } { +random-id+ "primary key" } - ! { +nonnative-id+ "primary key" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } { +default+ "default" } @@ -236,7 +236,7 @@ M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ; M: sqlite-db compound-type ( str seq -- str' ) over { { "default" [ first number>string join-space ] } - [ 2drop ] ! "no sqlite compound data type" 3array throw ] + [ 2drop ] } case ; M: sqlite-db type-table ( -- assoc ) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 691cc6f687..56e401d5ec 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -308,15 +308,13 @@ C: secret [ ] [ 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 +[ 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 From b257640f97885aade8e4364216de9d233d7cddc3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 19:27:46 -0500 Subject: [PATCH 013/129] remove ?head* --- extra/sequences/lib/lib.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 15983329d6..6bc6c706cf 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -197,9 +197,6 @@ USE: continuations >r >r 0 max r> r> [ length tuck min >r min r> ] keep subseq ; -: ?head* ( seq n -- seq/f ) (head) ?subseq ; -: ?tail* ( seq n -- seq/f ) (tail) ?subseq ; - : accumulator ( quot -- quot vec ) V{ } clone [ [ push ] curry compose ] keep ; inline From a81aaa61009f3d84983b1004e94f925f466d4ea7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 19:27:54 -0500 Subject: [PATCH 014/129] add random-id, still needs to retry if insert fails --- extra/db/db.factor | 6 +-- extra/db/sql/sql.factor | 6 +-- extra/db/sqlite/ffi/ffi.factor | 10 ++++- extra/db/sqlite/lib/lib.factor | 17 ++++++-- extra/db/sqlite/sqlite.factor | 34 +++++++++++++-- extra/db/tuples/tuples-tests.factor | 57 +++++++++++++++++++++---- extra/db/tuples/tuples.factor | 23 ++++++----- extra/db/types/types.factor | 64 ++++++++++++++++++----------- 8 files changed, 158 insertions(+), 59 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 7a28dea558..ce6232f414 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -36,7 +36,7 @@ HOOK: db-close db ( handle -- ) ] with-variable ; ! TUPLE: sql sql in-params out-params ; -TUPLE: statement handle sql in-params out-params bind-params bound? type quot ; +TUPLE: statement handle sql in-params out-params bind-params bound? type ; TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; @@ -62,13 +62,9 @@ SINGLETON: retryable over sequence? [ [ make-retryable ] curry map ] [ - >>quot retryable >>type ] if ; -: handle-random-id ( statement -- ) - drop ; - TUPLE: result-set sql in-params out-params handle n max ; : construct-statement ( sql in out class -- statement ) diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index d7ef986ea6..4561424a9d 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -38,7 +38,7 @@ DEFER: sql% { \ select [ "(select" sql% sql% ")" sql% ] } { \ table [ sql% ] } { \ set [ "set" "," sql-interleave ] } - { \ values [ break "values(" sql% "," (sql-interleave) ")" sql% ] } + { \ values [ "values(" sql% "," (sql-interleave) ")" sql% ] } { \ count [ "count" sql-function, ] } { \ sum [ "sum" sql-function, ] } { \ avg [ "avg" sql-function, ] } @@ -47,7 +47,7 @@ DEFER: sql% [ sql% [ sql% ] each ] } case ; -TUPLE: no-sql-match ; +ERROR: no-sql-match ; : sql% ( obj -- ) { { [ dup string? ] [ " " 0% 0% ] } @@ -56,7 +56,7 @@ TUPLE: no-sql-match ; { [ dup symbol? ] [ unparse sql% ] } { [ dup word? ] [ unparse sql% ] } { [ dup quotation? ] [ call ] } - [ T{ no-sql-match } throw ] + [ no-sql-match ] } cond ; : parse-sql ( obj -- sql in-spec out-spec in out ) diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index c724025874..6b94c02c65 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -3,7 +3,7 @@ ! An interface to the sqlite database. Tested against sqlite v3.1.3. ! Not all functions have been wrapped. USING: alien compiler kernel math namespaces sequences strings alien.syntax - system combinators ; + system combinators alien.c-types ; IN: db.sqlite.ffi << "sqlite" { @@ -112,11 +112,14 @@ FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppSt FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; -FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; +FUNCTION: sqlite3_uint64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ; +: sqlite3-bind-uint64 ( pStmt index in64 -- int ) + "int" "sqlite" "sqlite3_bind_int64" + { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ; FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; @@ -126,6 +129,9 @@ FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; 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 ) ; +: sqlite3-column-uint64 ( pStmt col -- uint64 ) + "sqlite3_uint64" "sqlite" "sqlite3_column_int64" + { "sqlite3_stmt*" "int" } alien-invoke ; FUNCTION: double sqlite3_column_double ( 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 ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index b6221e5a1e..61070b078b 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -52,6 +52,9 @@ IN: db.sqlite.lib : sqlite-bind-int64 ( handle i n -- ) sqlite3_bind_int64 sqlite-check-result ; +: sqlite-bind-uint64 ( handle i n -- ) + sqlite3-bind-uint64 sqlite-check-result ; + : sqlite-bind-double ( handle i x -- ) sqlite3_bind_double sqlite-check-result ; @@ -69,7 +72,10 @@ IN: db.sqlite.lib parameter-index sqlite-bind-int ; : sqlite-bind-int64-by-name ( handle name int64 -- ) - parameter-index sqlite-bind-int ; + parameter-index sqlite-bind-int64 ; + +: sqlite-bind-uint64-by-name ( handle name int64 -- ) + parameter-index sqlite-bind-uint64 ; : sqlite-bind-double-by-name ( handle name double -- ) parameter-index sqlite-bind-double ; @@ -86,6 +92,8 @@ IN: db.sqlite.lib { { INTEGER [ sqlite-bind-int-by-name ] } { BIG-INTEGER [ sqlite-bind-int64-by-name ] } + { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] } + { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] } { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } @@ -99,6 +107,7 @@ IN: db.sqlite.lib sqlite-bind-blob-by-name ] } { +native-id+ [ sqlite-bind-int-by-name ] } + { +random-id+ [ sqlite-bind-int64-by-name ] } { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; @@ -121,10 +130,12 @@ IN: db.sqlite.lib : sqlite-column-typed ( handle index type -- obj ) dup array? [ first ] when { - { +native-id+ [ sqlite3_column_int64 ] } - { +random-id+ [ sqlite3_column_int64 ] } + { +native-id+ [ sqlite3_column_int64 ] } + { +random-id+ [ sqlite3-column-uint64 ] } { INTEGER [ sqlite3_column_int ] } { BIG-INTEGER [ sqlite3_column_int64 ] } + { SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] } + { UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] } { DOUBLE [ sqlite3_column_double ] } { TEXT [ sqlite3_column_text ] } { VARCHAR [ sqlite3_column_text ] } diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index e2ea28fe9a..5f8247f67b 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,7 +5,8 @@ hashtables io.files kernel math math.parser namespaces prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators math.intervals -io namespaces.lib accessors vectors math.ranges ; +io namespaces.lib accessors vectors math.ranges random +math.bitfields.lib ; USE: tools.walker IN: db.sqlite @@ -65,6 +66,9 @@ M: sql-spec sqlite-bind-conversion ( tuple spec -- array ) M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) nip [ key>> ] [ value>> ] [ type>> ] tri 3array ; +M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) + nip [ key>> ] [ quot>> call ] [ type>> ] tri 3array ; + M: sqlite-statement bind-tuple ( tuple statement -- ) [ in-params>> [ sqlite-bind-conversion ] with map @@ -105,8 +109,7 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; : sqlite-make ( class quot -- ) >r sql-props r> [ 0 sql-counter rot with-variable ] { "" { } { } } nmake - - dup handle-random-id ; inline + ; M: sqlite-db create-sql-statement ( class -- statement ) [ @@ -129,7 +132,21 @@ M: sqlite-db ( tuple -- statement ) maybe-remove-id dup [ ", " 0% ] [ column-name>> 0% ] interleave ") values(" 0% - [ ", " 0% ] [ bind% ] interleave + [ ", " 0% ] [ + dup type>> +random-id+ = [ +break + dup modifiers>> find-random-generator + [ + [ + column-name>> ":" prepend + dup 0% random-id-quot + ] with-random + ] curry + [ type>> ] bi 10 1, + ] [ + bind% + ] if + ] interleave ");" 0% ] sqlite-make ; @@ -219,6 +236,9 @@ M: sqlite-db ( tuple class -- statement ) dup empty? [ 2drop ] [ where-clause ] if ";" 0% ] sqlite-make ; +M: sqlite-db random-id-quot ( -- quot ) + [ 64 [ 2^ random ] keep 1 - set-bit ] ; + M: sqlite-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } @@ -229,6 +249,9 @@ M: sqlite-db modifier-table ( -- hashtable ) { +default+ "default" } { +null+ "null" } { +not-null+ "not null" } + { system-random-generator "" } + { secure-random-generator "" } + { random-generator "" } } ; M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ; @@ -244,6 +267,9 @@ M: sqlite-db type-table ( -- assoc ) { +native-id+ "integer primary key" } { +random-id+ "integer primary key" } { INTEGER "integer" } + { BIG-INTEGER "bigint" } + { SIGNED-BIG-INTEGER "bigint" } + { UNSIGNED-BIG-INTEGER "bigint" } { TEXT "text" } { VARCHAR "text" } { DATE "date" } diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 56e401d5ec..083cf059c9 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files kernel tools.test db db.tuples +USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges -prettyprint tools.walker db.sqlite calendar -math.intervals db.postgresql ; +prettyprint tools.walker db.sqlite calendar sequences +math.intervals db.postgresql accessors random math.bitfields.lib ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real @@ -290,8 +290,37 @@ TUPLE: exam id name score ; [ test-intervals ] test-sqlite -: test-ranges - ; +TUPLE: bignum-test id m n o ; +: ( m n o -- obj ) + bignum-test new + swap >>o + swap >>n + swap >>m ; + +: test-bignum + bignum-test "BIGNUM_TEST" + { + { "id" "ID" +native-id+ } + { "m" "M" BIG-INTEGER } + { "n" "N" UNSIGNED-BIG-INTEGER } + { "o" "O" SIGNED-BIG-INTEGER } + } define-persistent + [ bignum-test drop-table ] ignore-errors + [ ] [ bignum-test ensure-table ] unit-test + [ ] [ 63 2^ dup dup insert-tuple ] unit-test + + [ T{ bignum-test f 1 + -9223372036854775808 9223372036854775808 -9223372036854775808 } ] + [ T{ bignum-test f 1 } select-tuple ] unit-test ; + +[ test-bignum ] test-sqlite + +TUPLE: does-not-persist ; + +[ + [ does-not-persist create-sql-statement ] + [ class \ not-persistent = ] must-fail-with +] test-sqlite TUPLE: secret n message ; C: secret @@ -299,14 +328,26 @@ C: secret : test-random-id secret "SECRET" { - { "n" "ID" +random-id+ } + { "n" "ID" +random-id+ system-random-generator } { "message" "MESSAGE" TEXT } } define-persistent [ ] [ secret ensure-table ] unit-test + [ ] [ f "kilroy was here" insert-tuple ] unit-test - [ ] [ T{ secret } select-tuples ] unit-test - ; + + [ ] [ f "kilroy was here2" insert-tuple ] unit-test + + [ ] [ f "kilroy was here3" insert-tuple ] unit-test + + [ t ] [ + T{ secret } select-tuples + first message>> "kilroy was here" head? + ] unit-test + + [ t ] [ + T{ secret } select-tuples length 3 = + ] unit-test ; [ test-random-id ] test-sqlite [ native-person-schema test-tuples ] test-sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 32431b4ddc..e0b4fce2f3 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -13,9 +13,16 @@ IN: db.tuples "db-columns" set-word-prop "db-relations" set-word-prop ; -: db-table ( class -- obj ) "db-table" word-prop ; -: db-columns ( class -- obj ) "db-columns" word-prop ; -: db-relations ( class -- obj ) "db-relations" word-prop ; +ERROR: not-persistent ; + +: db-table ( class -- obj ) + "db-table" word-prop [ not-persistent ] unless* ; + +: db-columns ( class -- obj ) + "db-columns" word-prop ; + +: db-relations ( class -- obj ) + "db-relations" word-prop ; : set-primary-key ( key tuple -- ) [ @@ -61,7 +68,7 @@ HOOK: insert-tuple* db ( tuple statement -- ) ] curry 2each ; : sql-props ( class -- columns table ) - dup db-columns swap db-table ; + [ db-columns ] [ db-table ] bi ; : with-disposals ( seq quot -- ) over sequence? [ @@ -88,17 +95,13 @@ HOOK: insert-tuple* db ( tuple statement -- ) [ bind-tuple ] 2keep insert-tuple* ; : insert-nonnative ( tuple -- ) -! TODO logic here for unique ids dup class db get db-insert-statements [ ] cache [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) - dup class db-columns find-primary-key nonnative-id? [ - insert-nonnative - ] [ - insert-native - ] if ; + dup class db-columns find-primary-key nonnative-id? + [ insert-nonnative ] [ insert-native ] if ; : update-tuple ( tuple -- ) dup class diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 9959e894a7..b8855ce296 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -4,7 +4,7 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes mirrors classes.tuple combinators calendar.format symbols -classes.singleton ; +classes.singleton accessors quotations random ; IN: db.types HOOK: modifier-table db ( -- hash ) @@ -12,12 +12,16 @@ HOOK: compound-modifier db ( str seq -- hash ) HOOK: type-table db ( -- hash ) HOOK: create-type-table db ( -- hash ) HOOK: compound-type db ( str n -- hash ) +HOOK: random-id-quot db ( -- quot ) -TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; +TUPLE: sql-spec class slot-name column-name type primary-key modifiers ; TUPLE: literal-bind key type value ; C: literal-bind +TUPLE: generator-bind key quot type retries ; +C: generator-bind + SINGLETON: +native-id+ SINGLETON: +assigned-id+ SINGLETON: +random-id+ @@ -27,6 +31,15 @@ UNION: +nonnative-id+ +random-id+ +assigned-id+ ; SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ +foreign-id+ +has-many+ ; +: find-random-generator ( seq -- obj ) + [ + { + random-generator + system-random-generator + secure-random-generator + } member? + ] find nip [ system-random-generator ] unless* ; + : primary-key? ( spec -- ? ) sql-spec-primary-key +primary-key+? ; @@ -51,26 +64,27 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; -SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR -DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ; +: handle-random-id ( statement -- ) + dup in-params>> [ type>> +random-id+ = ] find drop >boolean [ + retryable >>type + random-id-quot >>quot + ] when drop ; + +SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER +DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB +FACTOR-BLOB NULL ; : spec>tuple ( class spec -- tuple ) - [ ?first3 ] keep 3 ?tail* - { - set-sql-spec-class - set-sql-spec-slot-name - set-sql-spec-column-name - set-sql-spec-type - set-sql-spec-modifiers - } sql-spec construct + 3 f pad-right + [ first3 ] keep 3 tail + sql-spec new + swap >>modifiers + swap >>type + swap >>column-name + swap >>slot-name + swap >>class dup normalize-spec ; -TUPLE: no-sql-type ; -: no-sql-type ( -- * ) T{ no-sql-type } throw ; - -TUPLE: no-sql-modifier ; -: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ; - : number>string* ( n/str -- str ) dup number? [ number>string ] when ; @@ -88,13 +102,15 @@ TUPLE: no-sql-modifier ; ! PostgreSQL Types: ! http://developer.postgresql.org/pgdocs/postgres/datatype.html +ERROR: unknown-modifier ; + : lookup-modifier ( obj -- str ) - dup array? [ - unclip lookup-modifier swap compound-modifier - ] [ - modifier-table at* - [ "unknown modifier" throw ] unless - ] if ; + { + { [ dup array? ] [ unclip lookup-modifier swap compound-modifier ] } + [ modifier-table at* [ unknown-modifier ] unless ] + } cond ; + +ERROR: no-sql-type ; : lookup-type* ( obj -- str ) dup array? [ From 9b5351e81f4b6b4e46da33aedaae748be135b10a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 19:28:25 -0500 Subject: [PATCH 015/129] remove extra using --- extra/db/sqlite/sqlite.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 5f8247f67b..093a705b0d 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -7,7 +7,6 @@ continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators math.intervals io namespaces.lib accessors vectors math.ranges random math.bitfields.lib ; -USE: tools.walker IN: db.sqlite TUPLE: sqlite-db < db path ; @@ -134,7 +133,6 @@ M: sqlite-db ( tuple -- statement ) ") values(" 0% [ ", " 0% ] [ dup type>> +random-id+ = [ -break dup modifiers>> find-random-generator [ [ From 896c920d85008304c9896ca0daf46e91b9faadea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 22:09:36 -0500 Subject: [PATCH 016/129] retryable statements actually retry now --- extra/db/db.factor | 15 +----------- extra/db/sqlite/ffi/ffi.factor | 3 ++- extra/db/sqlite/lib/lib.factor | 4 +++- extra/db/sqlite/sqlite.factor | 24 ++++++++++++------- extra/db/tuples/tuples-tests.factor | 2 +- extra/db/tuples/tuples.factor | 36 ++++++++++++++++++++++++++++- extra/db/types/types.factor | 8 +------ 7 files changed, 59 insertions(+), 33 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index ce6232f414..82193ed467 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -42,7 +42,6 @@ TUPLE: prepared-statement < statement ; SINGLETON: throwable SINGLETON: nonthrowable -SINGLETON: retryable : make-throwable ( obj -- obj' ) dup sequence? [ @@ -58,13 +57,6 @@ SINGLETON: retryable nonthrowable >>type ] if ; -: make-retryable ( obj quot -- obj' ) - over sequence? [ - [ make-retryable ] curry map - ] [ - retryable >>type - ] if ; - TUPLE: result-set sql in-params out-params handle n max ; : construct-statement ( sql in out class -- statement ) @@ -78,6 +70,7 @@ HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) GENERIC: prepare-statement ( statement -- ) GENERIC: bind-statement* ( statement -- ) +GENERIC: low-level-bind ( statement -- ) GENERIC: bind-tuple ( tuple statement -- ) GENERIC: query-results ( query -- result-set ) GENERIC: #rows ( result-set -- n ) @@ -95,12 +88,6 @@ M: throwable execute-statement* ( statement type -- ) M: nonthrowable execute-statement* ( statement type -- ) drop [ query-results dispose ] [ 2drop ] recover ; -M: retryable execute-statement* ( statement type -- ) - [ - dup dup quot>> call - [ query-results dispose ] [ 2drop ] recover - ] curry 10 retry ; - : execute-statement ( statement -- ) dup sequence? [ [ execute-statement ] each diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 6b94c02c65..4b5a019fca 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -108,7 +108,7 @@ LIBRARY: sqlite FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ; FUNCTION: int sqlite3_close ( sqlite3* pDb ) ; FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ; -FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; +FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; @@ -123,6 +123,7 @@ FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; +FUNCTION: int sqlite3_clear_bindings ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ; FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 61070b078b..b6078fc983 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -33,7 +33,7 @@ IN: db.sqlite.lib : sqlite-prepare ( db sql -- handle ) dup length "void*" "void*" - [ sqlite3_prepare sqlite-check-result ] 2keep + [ sqlite3_prepare_v2 sqlite-check-result ] 2keep drop *void* ; : sqlite-bind-parameter-index ( handle name -- index ) @@ -114,6 +114,8 @@ IN: db.sqlite.lib : sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ; : sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ; +: sqlite-clear-bindings ( handle -- ) + sqlite3_clear_bindings 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 ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 093a705b0d..6dc394abd9 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -7,6 +7,7 @@ continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators math.intervals io namespaces.lib accessors vectors math.ranges random math.bitfields.lib ; +USE: tools.walker IN: db.sqlite TUPLE: sqlite-db < db path ; @@ -43,17 +44,21 @@ M: sqlite-statement dispose ( statement -- ) M: sqlite-result-set dispose ( result-set -- ) f >>handle drop ; -: sqlite-bind ( triples handle -- ) - swap [ first3 sqlite-bind-type ] with each ; - : reset-statement ( statement -- ) sqlite-maybe-prepare handle>> sqlite-reset ; +: reset-bindings ( statement -- ) + sqlite-maybe-prepare + handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ; + +M: sqlite-statement low-level-bind ( statement -- ) + [ statement-bind-params ] [ statement-handle ] bi + swap [ first3 sqlite-bind-type ] with each ; + M: sqlite-statement bind-statement* ( statement -- ) sqlite-maybe-prepare - dup statement-bound? [ dup reset-statement ] when - [ statement-bind-params ] [ statement-handle ] bi - sqlite-bind ; + dup statement-bound? [ dup reset-bindings ] when + low-level-bind ; GENERIC: sqlite-bind-conversion ( tuple obj -- array ) @@ -140,13 +145,16 @@ M: sqlite-db ( tuple -- statement ) dup 0% random-id-quot ] with-random ] curry - [ type>> ] bi 10 1, + [ type>> ] bi 1, ] [ bind% ] if ] interleave ");" 0% - ] sqlite-make ; + ] sqlite-make + dup in-params>> [ generator-bind? ] contains? [ + make-retryable + ] when ; M: sqlite-db ( tuple -- statement ) ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 083cf059c9..2eb31ebe18 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -346,7 +346,7 @@ C: secret ] unit-test [ t ] [ - T{ secret } select-tuples length 3 = + T{ secret } select-tuples dup . length 3 = ] unit-test ; [ test-random-id ] test-sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index e0b4fce2f3..1b1e48ddee 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes db kernel namespaces -classes.tuple words sequences slots math +classes.tuple words sequences slots math accessors math.parser io prettyprint db.types continuations mirrors sequences.lib tools.walker combinators.lib ; IN: db.tuples @@ -49,6 +49,40 @@ HOOK: db ( tuple class -- tuple ) HOOK: insert-tuple* db ( tuple statement -- ) +SINGLETON: retryable + +: make-retryable ( obj -- obj' ) + dup sequence? [ + [ make-retryable ] map + ] [ + retryable >>type + ] if ; + +: regenerate-params ( statement -- statement ) + dup + [ bind-params>> ] [ in-params>> ] bi + [ + dup generator-bind? [ + quot>> call over set-second + ] [ + drop + ] if + ] 2map >>bind-params ; + +: handle-random-id ( statement -- ) + dup in-params>> [ type>> +random-id+ = ] find drop >boolean [ + retryable >>type + random-id-quot >>quot + ] when drop ; + +M: retryable execute-statement* ( statement type -- ) + drop + [ + [ query-results dispose t ] + [ ] + [ regenerate-params bind-statement* f ] cleanup + ] curry 10 retry drop ; + : resulting-tuple ( row out-params -- tuple ) dup first sql-spec-class new [ [ diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index b8855ce296..9f111a42e4 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -19,7 +19,7 @@ TUPLE: sql-spec class slot-name column-name type primary-key modifiers ; TUPLE: literal-bind key type value ; C: literal-bind -TUPLE: generator-bind key quot type retries ; +TUPLE: generator-bind key quot type ; C: generator-bind SINGLETON: +native-id+ @@ -64,12 +64,6 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; -: handle-random-id ( statement -- ) - dup in-params>> [ type>> +random-id+ = ] find drop >boolean [ - retryable >>type - random-id-quot >>quot - ] when drop ; - SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ; From 4184a3ce549e1c21a8889d22ae77d4a5deff7edd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 23:18:12 -0500 Subject: [PATCH 017/129] partial conversion of postgres --- extra/db/postgresql/lib/lib.factor | 10 ++++++-- extra/db/postgresql/postgresql.factor | 35 ++++++++++++++++----------- extra/db/sqlite/sqlite.factor | 15 +++++++----- extra/db/tuples/tuples-tests.factor | 4 ++- extra/db/types/types.factor | 3 +-- 5 files changed, 42 insertions(+), 25 deletions(-) diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index bfe7dab3ce..cd3d619326 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -5,7 +5,7 @@ quotations sequences db.postgresql.ffi alien alien.c-types db.types tools.walker ascii splitting math.parser combinators libc shuffle calendar.format byte-arrays destructors prettyprint accessors strings serialize io.encodings.binary -io.streams.byte-array ; +io.streams.byte-array inspector ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) @@ -28,7 +28,13 @@ IN: db.postgresql.lib : postgresql-error ( res -- res ) dup [ postgresql-error-message throw ] unless ; -: postgresql-result-ok? ( n -- ? ) +ERROR: postgresql-result-null ; + +M: postgresql-result-null summary ( obj -- str ) + drop "PQexec returned f." ; + +: postgresql-result-ok? ( res -- ? ) + [ postgresql-result-null ] unless* PQresultStatus PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ; diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 9dfa123952..d0eb390888 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -5,7 +5,7 @@ kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges combinators sequences.lib classes locals words tools.walker -namespaces.lib accessors ; +namespaces.lib accessors random ; IN: db.postgresql TUPLE: postgresql-db < db @@ -43,10 +43,9 @@ M: postgresql-statement bind-statement* ( statement -- ) drop ; M: postgresql-statement bind-tuple ( tuple statement -- ) - [ - statement-in-params - [ sql-spec-slot-name swap get-slot-named ] with map - ] keep set-statement-bind-params ; + tuck in-params>> + [ slot-name>> swap get-slot-named ] with map + >>bind-params drop ; M: postgresql-result-set #rows ( result-set -- n ) handle>> PQntuples ; @@ -55,11 +54,11 @@ M: postgresql-result-set #columns ( result-set -- n ) handle>> PQnfields ; M: postgresql-result-set row-column ( result-set column -- obj ) - >r dup result-set-handle swap result-set-n r> pq-get-string ; + >r [ handle>> ] [ n>> ] bi r> pq-get-string ; M: postgresql-result-set row-column-typed ( result-set column -- obj ) dup pick result-set-out-params nth sql-spec-type - >r >r [ result-set-handle ] [ result-set-n ] bi r> r> postgresql-column-typed ; + >r >r [ handle>> ] [ result-set-n ] bi r> r> postgresql-column-typed ; M: postgresql-statement query-results ( query -- result-set ) dup statement-bind-params [ @@ -82,7 +81,7 @@ M: postgresql-statement dispose ( query -- ) f swap set-statement-handle ; M: postgresql-result-set dispose ( result-set -- ) - dup result-set-handle PQclear + dup handle>> PQclear 0 0 f roll { set-result-set-n set-result-set-max set-result-set-handle } set-slots ; @@ -90,7 +89,7 @@ M: postgresql-result-set dispose ( result-set -- ) M: postgresql-statement prepare-statement ( statement -- ) [ >r db get handle>> "" r> - dup statement-sql swap statement-in-params + [ sql>> ] [ in-params>> ] bi length f PQprepare postgresql-error ] keep set-statement-handle ; @@ -115,7 +114,10 @@ SYMBOL: postgresql-counter postgresql-counter [ inc ] keep get 0# ; M: postgresql-db bind% ( spec -- ) - 1, bind-name% ; + bind-name% 1, ; + +M: postgresql-db bind# ( spec obj -- ) + >r bind-name% f swap type>> r> 1, ; : postgresql-make ( class quot -- ) >r sql-props r> @@ -125,11 +127,10 @@ M: postgresql-db bind% ( spec -- ) : create-table-sql ( class -- statement ) [ "create table " 0% 0% - "(" 0% - [ ", " 0% ] [ - dup sql-spec-column-name 0% + "(" 0% [ ", " 0% ] [ + dup column-name>> 0% " " 0% - dup sql-spec-type t lookup-type 0% + dup type>> t lookup-type 0% modifiers 0% ] interleave ");" 0% ] postgresql-make ; @@ -250,6 +251,7 @@ M: postgresql-db ( tuple class -- statement ) M: postgresql-db type-table ( -- hash ) H{ { +native-id+ "integer" } + { +random-id+ "bigint" } { TEXT "text" } { VARCHAR "varchar" } { INTEGER "integer" } @@ -265,6 +267,7 @@ M: postgresql-db type-table ( -- hash ) M: postgresql-db create-type-table ( -- hash ) H{ { +native-id+ "serial primary key" } + { +random-id+ "bigint primary key" } } ; : postgresql-compound ( str n -- newstr ) @@ -286,12 +289,16 @@ M: postgresql-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } { +assigned-id+ "primary key" } + { +random-id+ "primary key" } { +foreign-id+ "references" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } { +default+ "default" } { +null+ "null" } { +not-null+ "not null" } + { system-random-generator "" } + { secure-random-generator "" } + { random-generator "" } } ; M: postgresql-db compound-type ( str n -- newstr ) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 6dc394abd9..f361e18c48 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -110,10 +110,16 @@ M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ; M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; + +: maybe-make-retryable ( statement -- statement ) + dup in-params>> [ generator-bind? ] contains? [ + make-retryable + ] when ; + : sqlite-make ( class quot -- ) >r sql-props r> [ 0 sql-counter rot with-variable ] { "" { } { } } nmake - ; + maybe-make-retryable ; M: sqlite-db create-sql-statement ( class -- statement ) [ @@ -124,7 +130,7 @@ M: sqlite-db create-sql-statement ( class -- statement ) dup type>> t lookup-type 0% modifiers 0% ] interleave ");" 0% - ] sqlite-make ; + ] sqlite-make dup sql>> . ; M: sqlite-db drop-sql-statement ( class -- statement ) [ "drop table " 0% 0% ";" 0% drop ] sqlite-make ; @@ -151,10 +157,7 @@ M: sqlite-db ( tuple -- statement ) ] if ] interleave ");" 0% - ] sqlite-make - dup in-params>> [ generator-bind? ] contains? [ - make-retryable - ] when ; + ] sqlite-make ; M: sqlite-db ( tuple -- statement ) ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 2eb31ebe18..038197d864 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -346,13 +346,15 @@ C: secret ] unit-test [ t ] [ - T{ secret } select-tuples dup . length 3 = + T{ secret } select-tuples length 3 = ] 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 + +[ test-random-id ] test-postgresql [ native-person-schema test-tuples ] test-postgresql [ assigned-person-schema test-tuples ] test-postgresql [ assigned-person-schema test-repeated-insert ] test-postgresql diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 9f111a42e4..41db970b12 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -110,8 +110,7 @@ ERROR: no-sql-type ; dup array? [ first lookup-type* ] [ - type-table at* - [ no-sql-type ] unless + type-table at* [ no-sql-type ] unless ] if ; : lookup-create-type ( obj -- str ) From 3be408184ce053ff31229cd0b693444ee220d4c1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 23:41:48 -0500 Subject: [PATCH 018/129] remove most of the old setters --- extra/db/postgresql/lib/lib.factor | 36 +++++++--------- extra/db/postgresql/postgresql.factor | 60 ++++++++++++++------------- 2 files changed, 45 insertions(+), 51 deletions(-) diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index cd3d619326..bb4c6872fb 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -23,7 +23,7 @@ IN: db.postgresql.lib "\n" split [ [ blank? ] trim ] map "\n" join ; : postgresql-error-message ( -- str ) - db get db-handle (postgresql-error-message) ; + db get handle>> (postgresql-error-message) ; : postgresql-error ( res -- res ) dup [ postgresql-error-message throw ] unless ; @@ -43,7 +43,7 @@ M: postgresql-result-null summary ( obj -- str ) dup PQstatus zero? [ (postgresql-error-message) throw ] unless ; : do-postgresql-statement ( statement -- res ) - db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [ + db get handle>> swap sql>> PQexec dup postgresql-result-ok? [ dup postgresql-result-error-message swap PQclear throw ] unless ; @@ -64,25 +64,19 @@ M: postgresql-result-null summary ( obj -- str ) } case ; : param-types ( statement -- seq ) - statement-in-params - [ sql-spec-type type>oid ] map - >c-uint-array ; + in-params>> [ type>> type>oid ] map >c-uint-array ; : malloc-byte-array/length [ malloc-byte-array dup free-always ] [ length ] bi ; - : param-values ( statement -- seq seq2 ) - [ statement-bind-params ] - [ statement-in-params ] bi + [ bind-params>> ] [ in-params>> ] bi [ - sql-spec-type { + type>> { { FACTOR-BLOB [ - dup [ - object>bytes - malloc-byte-array/length ] [ 0 ] if ] } - { BLOB [ - dup [ malloc-byte-array/length ] [ 0 ] if ] } + dup [ object>bytes malloc-byte-array/length ] [ 0 ] if + ] } + { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] } [ drop number>string* dup [ malloc-char-string dup free-always @@ -96,22 +90,20 @@ M: postgresql-result-null summary ( obj -- str ) ] if ; : param-formats ( statement -- seq ) - statement-in-params - [ sql-spec-type type>param-format ] map - >c-uint-array ; + in-params>> [ type>> type>param-format ] map >c-uint-array ; : do-postgresql-bound-statement ( statement -- res ) [ - >r db get db-handle r> + >r db get handle>> r> { - [ statement-sql ] - [ statement-bind-params length ] + [ sql>> ] + [ bind-params>> length ] [ param-types ] [ param-values ] [ param-formats ] } cleave 0 PQexecParams dup postgresql-result-ok? [ - dup postgresql-result-error-message swap PQclear throw + [ postgresql-result-error-message ] [ PQclear ] bi throw ] unless ] with-destructors ; @@ -120,7 +112,7 @@ M: postgresql-result-null summary ( obj -- str ) : pq-get-string ( handle row column -- obj ) 3dup PQgetvalue alien>char-string - dup "" = [ >r pq-get-is-null f r> ? ] [ 3nip ] if ; + dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ; : pq-get-number ( handle row column -- obj ) pq-get-string dup [ string>number ] when ; diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index d0eb390888..f13bceddd3 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -57,11 +57,11 @@ M: postgresql-result-set row-column ( result-set column -- obj ) >r [ handle>> ] [ n>> ] bi r> pq-get-string ; M: postgresql-result-set row-column-typed ( result-set column -- obj ) - dup pick result-set-out-params nth sql-spec-type - >r >r [ handle>> ] [ result-set-n ] bi r> r> postgresql-column-typed ; + dup pick out-params>> nth type>> + >r >r [ handle>> ] [ n>> ] bi r> r> postgresql-column-typed ; M: postgresql-statement query-results ( query -- result-set ) - dup statement-bind-params [ + dup bind-params>> [ over [ bind-statement ] keep do-postgresql-bound-statement ] [ @@ -71,27 +71,29 @@ M: postgresql-statement query-results ( query -- result-set ) dup init-result-set ; M: postgresql-result-set advance-row ( result-set -- ) - dup result-set-n 1+ swap set-result-set-n ; + [ 1+ ] change-n drop ; M: postgresql-result-set more-rows? ( result-set -- ? ) - dup result-set-n swap result-set-max < ; + [ n>> ] [ max>> ] bi < ; M: postgresql-statement dispose ( query -- ) - dup statement-handle PQclear - f swap set-statement-handle ; + dup handle>> PQclear + f >>handle drop ; M: postgresql-result-set dispose ( result-set -- ) - dup handle>> PQclear - 0 0 f roll { - set-result-set-n set-result-set-max set-result-set-handle - } set-slots ; + [ handle>> PQclear ] + [ + 0 >>n + 0 >>max + f >>handle drop + ] bi ; M: postgresql-statement prepare-statement ( statement -- ) - [ - >r db get handle>> "" r> - [ sql>> ] [ in-params>> ] bi - length f PQprepare postgresql-error - ] keep set-statement-handle ; + dup + >r db get handle>> "" r> + [ sql>> ] [ in-params>> ] bi + length f PQprepare postgresql-error + >>handle drop ; M: postgresql-db ( sql in out -- statement ) ; @@ -111,7 +113,7 @@ M: postgresql-db rollback-transaction ( -- ) SYMBOL: postgresql-counter : bind-name% ( -- ) CHAR: $ 0, - postgresql-counter [ inc ] keep get 0# ; + postgresql-counter [ inc ] [ get 0# ] bi ; M: postgresql-db bind% ( spec -- ) bind-name% 1, ; @@ -142,7 +144,7 @@ M: postgresql-db bind# ( spec obj -- ) "(" 0% over [ "," 0% ] [ - sql-spec-type f lookup-type 0% + type>> f lookup-type 0% ] interleave ")" 0% " returns bigint as '" 0% @@ -150,7 +152,7 @@ M: postgresql-db bind# ( spec obj -- ) "insert into " 0% dup 0% "(" 0% - over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + over [ ", " 0% ] [ column-name>> 0% ] interleave ") values(" 0% swap [ ", " 0% ] [ drop bind-name% ] interleave "); " 0% @@ -169,7 +171,7 @@ M: postgresql-db create-sql-statement ( class -- seq ) "drop function add_" 0% 0% "(" 0% remove-id - [ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave + [ ", " 0% ] [ type>> f lookup-type 0% ] interleave ");" 0% ] postgresql-make ; @@ -199,7 +201,7 @@ M: postgresql-db ( class -- statement ) [ "insert into " 0% 0% "(" 0% - dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + dup [ ", " 0% ] [ column-name>> 0% ] interleave ")" 0% " values(" 0% @@ -216,10 +218,10 @@ M: postgresql-db ( class -- statement ) " set " 0% dup remove-id [ ", " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + [ dup column-name>> 0% " = " 0% bind% ] interleave " where " 0% find-primary-key - dup sql-spec-column-name 0% " = " 0% bind% + dup column-name>> 0% " = " 0% bind% ] postgresql-make ; M: postgresql-db ( class -- statement ) @@ -227,7 +229,7 @@ M: postgresql-db ( class -- statement ) "delete from " 0% 0% " where " 0% find-primary-key - dup sql-spec-column-name 0% " = " 0% bind% + dup column-name>> 0% " = " 0% bind% ] postgresql-make ; M: postgresql-db ( tuple class -- statement ) @@ -235,16 +237,16 @@ M: postgresql-db ( tuple class -- statement ) ! tuple columns table "select " 0% over [ ", " 0% ] - [ dup sql-spec-column-name 0% 2, ] interleave + [ dup column-name>> 0% 2, ] interleave " from " 0% 0% - [ sql-spec-slot-name swap get-slot-named ] with subset + [ slot-name>> swap get-slot-named ] with subset dup empty? [ drop ] [ " where " 0% [ " and " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + [ dup column-name>> 0% " = " 0% bind% ] interleave ] if ";" 0% ] postgresql-make ; @@ -276,8 +278,8 @@ M: postgresql-db create-type-table ( -- hash ) { "varchar" [ first number>string paren append ] } { "references" [ first2 >r [ unparse join-space ] keep db-columns r> - swap [ sql-spec-slot-name = ] with find nip - sql-spec-column-name paren append + swap [ slot-name>> = ] with find nip + column-name>> paren append ] } [ "no compound found" 3array throw ] } case ; From b0ddc983efc3ad7555fe4b77291a7e7bfcfc384e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 23:48:07 -0500 Subject: [PATCH 019/129] more refactoring --- extra/db/postgresql/lib/lib.factor | 3 +-- extra/db/postgresql/postgresql.factor | 8 +++++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index bb4c6872fb..56bfc29be8 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -44,7 +44,7 @@ M: postgresql-result-null summary ( obj -- str ) : do-postgresql-statement ( statement -- res ) db get handle>> swap sql>> PQexec dup postgresql-result-ok? [ - dup postgresql-result-error-message swap PQclear throw + [ postgresql-result-error-message ] [ PQclear ] bi throw ] unless ; : type>oid ( symbol -- n ) @@ -165,4 +165,3 @@ M: postgresql-malloc-destructor dispose ( obj -- ) 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 f13bceddd3..bcf71ea95f 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -53,12 +53,15 @@ M: postgresql-result-set #rows ( result-set -- n ) M: postgresql-result-set #columns ( result-set -- n ) handle>> PQnfields ; +: result-handle-n ( result-set -- handle n ) + [ handle>> ] [ n>> ] bi ; + M: postgresql-result-set row-column ( result-set column -- obj ) - >r [ handle>> ] [ n>> ] bi r> pq-get-string ; + >r result-handle-n r> pq-get-string ; M: postgresql-result-set row-column-typed ( result-set column -- obj ) dup pick out-params>> nth type>> - >r >r [ handle>> ] [ n>> ] bi r> r> postgresql-column-typed ; + >r >r result-handle-n r> r> postgresql-column-typed ; M: postgresql-statement query-results ( query -- result-set ) dup bind-params>> [ @@ -234,7 +237,6 @@ M: postgresql-db ( class -- statement ) M: postgresql-db ( tuple class -- statement ) [ - ! tuple columns table "select " 0% over [ ", " 0% ] [ dup column-name>> 0% 2, ] interleave From 7293a4f4f8013ce6af452e6921d46f40d91680b3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 20 Apr 2008 00:20:21 -0500 Subject: [PATCH 020/129] clean up the tuples tests --- extra/db/tuples/tuples-tests.factor | 36 ++++++++++++++++------------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 038197d864..0648f9b254 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -212,9 +212,6 @@ TUPLE: serialize-me id data ; { T{ serialize-me f 1 H{ { 1 2 } } } } ] [ T{ serialize-me f 1 } select-tuples ] unit-test ; -[ test-serialize ] test-sqlite -! [ test-serialize ] test-postgresql - TUPLE: exam id name score ; : test-intervals ( -- ) @@ -288,8 +285,6 @@ TUPLE: exam id name score ; T{ exam f T{ range f 1 3 1 } } select-tuples ] unit-test ; -[ test-intervals ] test-sqlite - TUPLE: bignum-test id m n o ; : ( m n o -- obj ) bignum-test new @@ -313,15 +308,6 @@ TUPLE: bignum-test id m n o ; -9223372036854775808 9223372036854775808 -9223372036854775808 } ] [ T{ bignum-test f 1 } select-tuple ] unit-test ; -[ test-bignum ] test-sqlite - -TUPLE: does-not-persist ; - -[ - [ does-not-persist create-sql-statement ] - [ class \ not-persistent = ] must-fail-with -] test-sqlite - TUPLE: secret n message ; C: secret @@ -349,15 +335,33 @@ C: secret T{ secret } select-tuples length 3 = ] 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 +[ test-bignum ] test-sqlite +[ test-serialize ] test-sqlite +[ test-intervals ] test-sqlite +[ test-random-id ] test-sqlite -[ test-random-id ] test-postgresql [ native-person-schema test-tuples ] test-postgresql [ assigned-person-schema test-tuples ] test-postgresql [ assigned-person-schema test-repeated-insert ] test-postgresql +[ test-bignum ] test-sqlite +[ test-serialize ] test-postgresql +! [ test-intervals ] test-postgresql +! [ test-random-id ] test-postgresql + +TUPLE: does-not-persist ; + +[ + [ does-not-persist create-sql-statement ] + [ class \ not-persistent = ] must-fail-with +] test-sqlite + +[ + [ does-not-persist create-sql-statement ] + [ class \ not-persistent = ] must-fail-with +] test-postgresql ! \ insert-tuple must-infer ! \ update-tuple must-infer From 89a728f645cf92f9482716c811ef411edca78f3b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 20 Apr 2008 00:52:05 -0500 Subject: [PATCH 021/129] about to consolidate sql types/create types/modifiers --- extra/db/postgresql/postgresql.factor | 30 +++++++++++---------------- extra/db/sqlite/sqlite.factor | 16 +++++++------- extra/db/types/types.factor | 7 +++---- 3 files changed, 22 insertions(+), 31 deletions(-) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index bcf71ea95f..5f98720de0 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -93,7 +93,7 @@ M: postgresql-result-set dispose ( result-set -- ) M: postgresql-statement prepare-statement ( statement -- ) dup - >r db get handle>> "" r> + >r db get handle>> f r> [ sql>> ] [ in-params>> ] bi length f PQprepare postgresql-error >>handle drop ; @@ -274,21 +274,6 @@ M: postgresql-db create-type-table ( -- hash ) { +random-id+ "bigint primary key" } } ; -: postgresql-compound ( str n -- newstr ) - over { - { "default" [ first number>string join-space ] } - { "varchar" [ first number>string paren append ] } - { "references" [ - first2 >r [ unparse join-space ] keep db-columns r> - swap [ slot-name>> = ] with find nip - column-name>> paren append - ] } - [ "no compound found" 3array throw ] - } case ; - -M: postgresql-db compound-modifier ( str seq -- newstr ) - postgresql-compound ; - M: postgresql-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } @@ -305,5 +290,14 @@ M: postgresql-db modifier-table ( -- hashtable ) { random-generator "" } } ; -M: postgresql-db compound-type ( str n -- newstr ) - postgresql-compound ; +M: postgresql-db compound ( str obj -- str' ) + over { + { "default" [ first number>string join-space ] } + { "varchar" [ first number>string paren append ] } + { "references" [ + first2 >r [ unparse join-space ] keep db-columns r> + swap [ slot-name>> = ] with find nip + column-name>> paren append + ] } + [ "no compound found" 3array throw ] + } case ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index f361e18c48..fb3fbe92be 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -110,7 +110,6 @@ M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ; M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; - : maybe-make-retryable ( statement -- statement ) dup in-params>> [ generator-bind? ] contains? [ make-retryable @@ -263,14 +262,6 @@ M: sqlite-db modifier-table ( -- hashtable ) { random-generator "" } } ; -M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ; - -M: sqlite-db compound-type ( str seq -- str' ) - over { - { "default" [ first number>string join-space ] } - [ 2drop ] - } case ; - M: sqlite-db type-table ( -- assoc ) H{ { +native-id+ "integer primary key" } @@ -291,3 +282,10 @@ M: sqlite-db type-table ( -- assoc ) } ; M: sqlite-db create-type-table ( symbol -- str ) type-table ; + +M: sqlite-db compound ( str seq -- str' ) + over { + { "default" [ first number>string join-space ] } + [ 2drop ] + } case ; + diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 41db970b12..80e11e7afb 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -8,10 +8,9 @@ classes.singleton accessors quotations random ; IN: db.types HOOK: modifier-table db ( -- hash ) -HOOK: compound-modifier db ( str seq -- hash ) +HOOK: compound db ( str obj -- hash ) HOOK: type-table db ( -- hash ) HOOK: create-type-table db ( -- hash ) -HOOK: compound-type db ( str n -- hash ) HOOK: random-id-quot db ( -- quot ) TUPLE: sql-spec class slot-name column-name type primary-key modifiers ; @@ -100,7 +99,7 @@ ERROR: unknown-modifier ; : lookup-modifier ( obj -- str ) { - { [ dup array? ] [ unclip lookup-modifier swap compound-modifier ] } + { [ dup array? ] [ unclip lookup-modifier swap compound ] } [ modifier-table at* [ unknown-modifier ] unless ] } cond ; @@ -115,7 +114,7 @@ ERROR: no-sql-type ; : lookup-create-type ( obj -- str ) dup array? [ - unclip lookup-create-type swap compound-type + unclip lookup-create-type swap compound ] [ dup create-type-table at* [ nip ] [ drop lookup-type* ] if From 6c70907354d122dc48847db3bf6dbec4d69ca8f6 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Sat, 19 Apr 2008 23:41:18 -0700 Subject: [PATCH 022/129] Add sequences.lib.reduce-index --- extra/sequences/lib/lib.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 15983329d6..8e3d394754 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -35,6 +35,10 @@ MACRO: firstn ( n -- ) #! quot: ( elt index -- obj ) prepare-index 2map ; inline +: reduce-index ( seq identity quot -- ) + #! quot: ( prev elt index -- next ) + swapd each-index ; inline + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : each-percent ( seq quot -- ) From fbe7fb58dd0164bf134273c7b6edf739c3a1f788 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Sat, 19 Apr 2008 23:41:26 -0700 Subject: [PATCH 023/129] Add project-euler.148 --- extra/project-euler/148/148.factor | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 extra/project-euler/148/148.factor diff --git a/extra/project-euler/148/148.factor b/extra/project-euler/148/148.factor new file mode 100644 index 0000000000..daad89a40c --- /dev/null +++ b/extra/project-euler/148/148.factor @@ -0,0 +1,24 @@ +! Copyright (c) 2008 Eric Mertens +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions sequences sequences.lib ; + +IN: project-euler.148 + +base7 ( x -- y ) + [ dup 0 > ] [ 7 /mod ] [ ] unfold nip ; + +: (use-digit) ( prev x index -- next ) + [ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ; + +PRIVATE> + +: (euler148) ( x -- y ) + >base7 0 [ (use-digit) ] reduce-index ; + +: euler148 ( -- y ) + 10 9 ^ (euler148) ; From d1f37ab5ecbee1633028ac8118607e0527e5ab47 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 20 Apr 2008 02:30:52 -0500 Subject: [PATCH 024/129] Fix bloopers --- .../io/encodings/utf16/.utf16.factor.swo | Bin {extra => core}/io/encodings/utf16/authors.txt | 0 {extra => core}/io/encodings/utf16/summary.txt | 0 {extra => core}/io/encodings/utf16/tags.txt | 0 .../io/encodings/utf16/utf16-docs.factor | 0 .../io/encodings/utf16/utf16-tests.factor | 0 {extra => core}/io/encodings/utf16/utf16.factor | 8 ++++---- extra/benchmark/spectral-norm/spectral-norm.factor | 4 ++-- extra/bit-vectors/bit-vectors.factor | 4 ++-- extra/float-vectors/float-vectors.factor | 2 +- 10 files changed, 9 insertions(+), 9 deletions(-) rename {extra => core}/io/encodings/utf16/.utf16.factor.swo (100%) rename {extra => core}/io/encodings/utf16/authors.txt (100%) rename {extra => core}/io/encodings/utf16/summary.txt (100%) rename {extra => core}/io/encodings/utf16/tags.txt (100%) rename {extra => core}/io/encodings/utf16/utf16-docs.factor (100%) rename {extra => core}/io/encodings/utf16/utf16-tests.factor (100%) rename {extra => core}/io/encodings/utf16/utf16.factor (95%) diff --git a/extra/io/encodings/utf16/.utf16.factor.swo b/core/io/encodings/utf16/.utf16.factor.swo similarity index 100% rename from extra/io/encodings/utf16/.utf16.factor.swo rename to core/io/encodings/utf16/.utf16.factor.swo diff --git a/extra/io/encodings/utf16/authors.txt b/core/io/encodings/utf16/authors.txt similarity index 100% rename from extra/io/encodings/utf16/authors.txt rename to core/io/encodings/utf16/authors.txt diff --git a/extra/io/encodings/utf16/summary.txt b/core/io/encodings/utf16/summary.txt similarity index 100% rename from extra/io/encodings/utf16/summary.txt rename to core/io/encodings/utf16/summary.txt diff --git a/extra/io/encodings/utf16/tags.txt b/core/io/encodings/utf16/tags.txt similarity index 100% rename from extra/io/encodings/utf16/tags.txt rename to core/io/encodings/utf16/tags.txt diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/core/io/encodings/utf16/utf16-docs.factor similarity index 100% rename from extra/io/encodings/utf16/utf16-docs.factor rename to core/io/encodings/utf16/utf16-docs.factor diff --git a/extra/io/encodings/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor similarity index 100% rename from extra/io/encodings/utf16/utf16-tests.factor rename to core/io/encodings/utf16/utf16-tests.factor diff --git a/extra/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor similarity index 95% rename from extra/io/encodings/utf16/utf16.factor rename to core/io/encodings/utf16/utf16.factor index fbc296e57c..953671d7f4 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -126,11 +126,11 @@ M: utf16 ( stream utf16 -- encoder ) ! Native-order UTF-16 -: native-utf16 ( -- descriptor ) - little-endian? utf16le utf16be ? ; +: utf16n ( -- descriptor ) + little-endian? utf16le utf16be ? ; foldable -M: utf16n drop native-utf16 ; +M: utf16n drop utf16n ; -M: utf16n drop native-utf16 ; +M: utf16n drop utf16n ; PRIVATE> diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 2c7dc1e80d..7eddeefc1b 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -19,7 +19,7 @@ IN: benchmark.spectral-norm pick 0.0 [ swap >r >r 2dup r> (eval-A-times-u) r> + ] reduce nip - ] F{ } map-as { float-array } declare 2nip ; inline + ] F{ } map-as 2nip ; inline : (eval-At-times-u) ( u i j -- x ) tuck swap eval-A >r swap nth-unsafe r> * ; inline @@ -29,7 +29,7 @@ IN: benchmark.spectral-norm pick 0.0 [ swap >r >r 2dup r> (eval-At-times-u) r> + ] reduce nip - ] F{ } map-as { float-array } declare 2nip ; inline + ] F{ } map-as 2nip ; inline : eval-AtA-times-u ( n u -- seq ) dupd eval-A-times-u eval-At-times-u ; inline diff --git a/extra/bit-vectors/bit-vectors.factor b/extra/bit-vectors/bit-vectors.factor index b011f146c5..c14b0a5476 100755 --- a/extra/bit-vectors/bit-vectors.factor +++ b/extra/bit-vectors/bit-vectors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences sequences.private growable bit-arrays prettyprint.backend -parser ; +parser accessors ; IN: bit-vectors TUPLE: bit-vector underlying fill ; @@ -44,7 +44,7 @@ M: bit-array new-resizable drop ; INSTANCE: bit-vector growable -: ?V \ } [ >bit-vector ] parse-literal ; parsing +: ?V{ \ } [ >bit-vector ] parse-literal ; parsing M: bit-vector >pprint-sequence ; diff --git a/extra/float-vectors/float-vectors.factor b/extra/float-vectors/float-vectors.factor index f0db37610a..d51f0d4e44 100755 --- a/extra/float-vectors/float-vectors.factor +++ b/extra/float-vectors/float-vectors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences sequences.private growable float-arrays prettyprint.backend -parser ; +parser accessors ; IN: float-vectors TUPLE: float-vector underlying fill ; From e2a185f1f45696d3c3102196f02f6e7c1e597357 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 20 Apr 2008 04:19:06 -0500 Subject: [PATCH 025/129] Web framework work in progress --- .../server/boilerplate/boilerplate.factor | 23 ++- .../server/components/components-tests.factor | 2 + .../http/server/components/components.factor | 95 +++++++--- .../server/components/farkup/farkup.factor | 6 +- extra/http/server/forms/forms.factor | 5 +- .../http/server/templating/chloe/chloe.factor | 29 ++- .../server/validators/validators-tests.factor | 6 + .../http/server/validators/validators.factor | 7 +- extra/webapps/planet/authors.txt | 1 + extra/webapps/planet/blog-summary.xml | 7 + extra/webapps/planet/edit-blog.xml | 40 ++++ extra/webapps/planet/entry-summary.xml | 10 + extra/webapps/planet/entry.xml | 9 + extra/webapps/planet/mini-planet.xml | 7 + extra/webapps/planet/page.xml | 64 +++++++ extra/webapps/planet/planet.css | 30 +++ extra/webapps/planet/planet.factor | 174 ++++++++++++++++++ extra/webapps/planet/planet.xml | 37 ++++ extra/webapps/planet/view-blog.xml | 41 +++++ 19 files changed, 557 insertions(+), 36 deletions(-) create mode 100755 extra/webapps/planet/authors.txt create mode 100644 extra/webapps/planet/blog-summary.xml create mode 100644 extra/webapps/planet/edit-blog.xml create mode 100644 extra/webapps/planet/entry-summary.xml create mode 100644 extra/webapps/planet/entry.xml create mode 100644 extra/webapps/planet/mini-planet.xml create mode 100644 extra/webapps/planet/page.xml create mode 100644 extra/webapps/planet/planet.css create mode 100755 extra/webapps/planet/planet.factor create mode 100644 extra/webapps/planet/planet.xml create mode 100644 extra/webapps/planet/view-blog.xml diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor index 4e847cff70..6c62452ec2 100644 --- a/extra/http/server/boilerplate/boilerplate.factor +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -1,7 +1,8 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces boxes sequences strings -io io.streams.string +io io.streams.string arrays +html.elements http http.server http.server.templating ; @@ -28,6 +29,18 @@ SYMBOL: style : write-style ( -- ) style get >string write ; +SYMBOL: atom-feed + +: set-atom-feed ( title url -- ) + 2array atom-feed get >box ; + +: write-atom-feed ( -- ) + atom-feed get value>> [ + + ] when* ; + SYMBOL: nested-template? SYMBOL: next-template @@ -40,6 +53,7 @@ M: f call-template drop call-next-template ; : with-boilerplate ( body template -- ) [ title get [ title set ] unless + atom-feed get [ atom-feed set ] unless style get [ SBUF" " clone style set ] unless [ @@ -54,5 +68,8 @@ M: f call-template drop call-next-template ; ] with-scope ; inline M: boilerplate call-responder - [ responder>> call-responder clone ] [ template>> ] bi - [ [ with-boilerplate ] 2curry ] curry change-body ; + tuck responder>> call-responder + dup "content-type" header "text/html" = [ + clone swap template>> + [ [ with-boilerplate ] 2curry ] curry change-body + ] [ nip ] if ; diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index 6d3a048ac4..ff87bb71fb 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -129,3 +129,5 @@ TUPLE: test-tuple text number more-text ; [ t ] [ "wake up sheeple" dup "n" validate = ] unit-test [ ] [ "password" "p" set ] unit-test + +[ ] [ "pub-date" "d" set ] unit-test diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 50353c6b87..bdcdd95c71 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: html.elements http.server.validators accessors namespaces -kernel io math.parser assocs classes words classes.tuple arrays -sequences splitting mirrors hashtables fry combinators -continuations math ; +USING: accessors namespaces kernel io math.parser assocs classes +words classes.tuple arrays sequences splitting mirrors +hashtables fry combinators continuations math +calendar.format html.elements +http.server.validators ; IN: http.server.components ! Renderer protocol @@ -59,9 +60,14 @@ SYMBOL: values : values-tuple values get mirror-object ; +: render-view-or-summary ( component -- value renderer ) + [ id>> value ] [ component-string ] [ renderer>> ] tri ; + : render-view ( component -- ) - [ id>> value ] [ component-string ] [ renderer>> ] tri - render-view* ; + render-view-or-summary render-view* ; + +: render-summary ( component -- ) + render-view-or-summary render-summary* ; ( id -- component ) + url new-string + 5 >>min-length + 60 >>max-length ; + +M: url validate* + call-next-method dup empty? [ v-url ] unless ; + ! Don't send passwords back to the user TUPLE: password-renderer < field ; @@ -206,20 +223,20 @@ M: captcha validate* drop v-captcha ; ! Text areas -TUPLE: textarea-renderer rows cols ; +TUPLE: text-renderer rows cols ; -: new-textarea-renderer ( class -- renderer ) +: new-text-renderer ( class -- renderer ) new 60 >>cols 20 >>rows ; -: ( -- renderer ) - textarea-renderer new-textarea-renderer ; +: ( -- renderer ) + text-renderer new-text-renderer ; -M: textarea-renderer render-view* +M: text-renderer render-view* drop write ; -M: textarea-renderer render-edit* +M: text-renderer render-edit*