Merge branch 'master' of git://factorcode.org/git/factor
commit
5cdabb2427
|
@ -2,17 +2,17 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes continuations destructors kernel math
|
||||
namespaces sequences classes.tuple words strings
|
||||
tools.walker accessors combinators fry ;
|
||||
tools.walker accessors combinators fry db.errors ;
|
||||
IN: db
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: db-connection
|
||||
handle
|
||||
insert-statements
|
||||
update-statements
|
||||
delete-statements ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: new-db-connection ( class -- obj )
|
||||
new
|
||||
H{ } clone >>insert-statements
|
||||
|
@ -23,6 +23,7 @@ PRIVATE>
|
|||
|
||||
GENERIC: db-open ( db -- db-connection )
|
||||
HOOK: db-close db-connection ( handle -- )
|
||||
HOOK: parse-db-error db-connection ( error -- error' )
|
||||
|
||||
: dispose-statements ( assoc -- ) values dispose-each ;
|
||||
|
||||
|
@ -77,7 +78,11 @@ GENERIC: bind-tuple ( tuple statement -- )
|
|||
GENERIC: execute-statement* ( statement type -- )
|
||||
|
||||
M: object execute-statement* ( statement type -- )
|
||||
drop query-results dispose ;
|
||||
'[
|
||||
_ _ drop query-results dispose
|
||||
] [
|
||||
parse-db-error rethrow
|
||||
] recover ;
|
||||
|
||||
: execute-one-statement ( statement -- )
|
||||
dup type>> execute-statement* ;
|
||||
|
|
|
@ -8,3 +8,11 @@ ERROR: sql-error ;
|
|||
|
||||
ERROR: table-exists ;
|
||||
ERROR: bad-schema ;
|
||||
|
||||
ERROR: sql-syntax-error error ;
|
||||
|
||||
ERROR: sql-table-exists table ;
|
||||
C: <sql-table-exists> sql-table-exists
|
||||
|
||||
ERROR: sql-table-missing table ;
|
||||
C: <sql-table-missing> sql-table-missing
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test db.errors.postgresql ;
|
||||
IN: db.errors.postgresql.tests
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: ;
|
||||
IN: db.errors.postgresql
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -0,0 +1,26 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit db db.errors
|
||||
db.errors.sqlite db.sqlite io.files.unique kernel namespaces
|
||||
tools.test ;
|
||||
IN: db.errors.sqlite.tests
|
||||
|
||||
: sqlite-error-test-db-path ( -- path )
|
||||
"sqlite" "error-test" make-unique-file ;
|
||||
|
||||
sqlite-error-test-db-path <sqlite-db> [
|
||||
|
||||
[
|
||||
"insert into foo (id) values('1');" sql-command
|
||||
] [
|
||||
{ [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
|
||||
] must-fail-with
|
||||
|
||||
[
|
||||
"create table foo(id);" sql-command
|
||||
"create table foo(id);" sql-command
|
||||
] [
|
||||
{ [ sql-table-exists? ] [ table>> "foo" = ] } 1&&
|
||||
] must-fail-with
|
||||
|
||||
] with-db
|
|
@ -0,0 +1,25 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators db kernel sequences peg.ebnf
|
||||
strings db.errors ;
|
||||
IN: db.errors.sqlite
|
||||
|
||||
ERROR: unparsed-sqlite-error error ;
|
||||
|
||||
SINGLETONS: table-exists table-missing ;
|
||||
|
||||
: sqlite-table-error ( table message -- error )
|
||||
{
|
||||
{ table-exists [ <sql-table-exists> ] }
|
||||
} case ;
|
||||
|
||||
EBNF: parse-sqlite-sql-error
|
||||
|
||||
TableMessage = " already exists" => [[ table-exists ]]
|
||||
|
||||
SqliteError =
|
||||
"table " (!(TableMessage).)+:table TableMessage:message
|
||||
=> [[ table >string message sqlite-table-error ]]
|
||||
| "no such table: " .+:table
|
||||
=> [[ table >string <sql-table-missing> ]]
|
||||
;EBNF
|
|
@ -3,7 +3,7 @@ prettyprint sequences namespaces tools.test db db.private
|
|||
db.tuples db.types unicode.case accessors system ;
|
||||
IN: db.postgresql.tests
|
||||
|
||||
: test-db ( -- postgresql-db )
|
||||
: postgresql-test-db ( -- postgresql-db )
|
||||
<postgresql-db>
|
||||
"localhost" >>host
|
||||
"postgres" >>username
|
||||
|
@ -11,10 +11,10 @@ IN: db.postgresql.tests
|
|||
"factor-test" >>database ;
|
||||
|
||||
os windows? cpu x86.64? and [
|
||||
[ ] [ test-db [ ] with-db ] unit-test
|
||||
[ ] [ postgresql-test-db [ ] with-db ] unit-test
|
||||
|
||||
[ ] [
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
[ "drop table person;" sql-command ] ignore-errors
|
||||
"create table person (name varchar(30), country varchar(30));"
|
||||
sql-command
|
||||
|
@ -30,7 +30,7 @@ os windows? cpu x86.64? and [
|
|||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
"select * from person" sql-query
|
||||
] with-db
|
||||
] unit-test
|
||||
|
@ -40,11 +40,11 @@ os windows? cpu x86.64? and [
|
|||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
] [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
"insert into person(name, country) values('Jimmy', 'Canada')"
|
||||
sql-command
|
||||
] with-db
|
||||
|
@ -56,10 +56,10 @@ os windows? cpu x86.64? and [
|
|||
{ "Jane" "New Zealand" }
|
||||
{ "Jimmy" "Canada" }
|
||||
}
|
||||
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
] [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
|
@ -69,14 +69,14 @@ os windows? cpu x86.64? and [
|
|||
] must-fail
|
||||
|
||||
[ 3 ] [
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
|
@ -87,7 +87,7 @@ os windows? cpu x86.64? and [
|
|||
] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
|
|
@ -5,8 +5,8 @@ kernel math math.parser namespaces make prettyprint quotations
|
|||
sequences debugger db db.postgresql.lib db.postgresql.ffi
|
||||
db.tuples db.types tools.annotations math.ranges
|
||||
combinators classes locals words tools.walker db.private
|
||||
nmake accessors random db.queries destructors db.tuples.private ;
|
||||
USE: tools.walker
|
||||
nmake accessors random db.queries destructors db.tuples.private
|
||||
db.postgresql ;
|
||||
IN: db.postgresql
|
||||
|
||||
TUPLE: postgresql-db host port pgopts pgtty database username password ;
|
||||
|
@ -280,3 +280,6 @@ M: postgresql-db-connection compound ( string object -- string' )
|
|||
{ "references" [ >reference-string ] }
|
||||
[ drop no-compound-found ]
|
||||
} case ;
|
||||
|
||||
M: postgresql-db-connection parse-db-error
|
||||
;
|
||||
|
|
|
@ -6,7 +6,8 @@ sequences strings classes.tuple alien.c-types continuations
|
|||
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
|
||||
math.intervals io nmake accessors vectors math.ranges random
|
||||
math.bitwise db.queries destructors db.tuples.private interpolate
|
||||
io.streams.string multiline make db.private sequences.deep ;
|
||||
io.streams.string multiline make db.private sequences.deep
|
||||
db.errors.sqlite ;
|
||||
IN: db.sqlite
|
||||
|
||||
TUPLE: sqlite-db path ;
|
||||
|
@ -223,13 +224,6 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: drop-insert-trigger ( -- string )
|
||||
[
|
||||
<"
|
||||
DROP TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: update-trigger ( -- string )
|
||||
[
|
||||
<"
|
||||
|
@ -255,13 +249,6 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: drop-update-trigger ( -- string )
|
||||
[
|
||||
<"
|
||||
DROP TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: delete-trigger-restrict ( -- string )
|
||||
[
|
||||
<"
|
||||
|
@ -274,13 +261,6 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: drop-delete-trigger-restrict ( -- string )
|
||||
[
|
||||
<"
|
||||
DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: delete-trigger-cascade ( -- string )
|
||||
[
|
||||
<"
|
||||
|
@ -292,13 +272,6 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: drop-delete-trigger-cascade ( -- string )
|
||||
[
|
||||
<"
|
||||
DROP TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
||||
: can-be-null? ( -- ? )
|
||||
"sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
|
||||
|
||||
|
@ -322,17 +295,7 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
delete-trigger-restrict sqlite-trigger,
|
||||
] if ;
|
||||
|
||||
: drop-sqlite-triggers ( -- )
|
||||
drop-insert-trigger sqlite-trigger,
|
||||
drop-update-trigger sqlite-trigger,
|
||||
delete-cascade? [
|
||||
drop-delete-trigger-cascade sqlite-trigger,
|
||||
] [
|
||||
drop-delete-trigger-restrict sqlite-trigger,
|
||||
] if ;
|
||||
|
||||
: db-triggers ( sql-specs word -- )
|
||||
'[
|
||||
: create-db-triggers ( sql-specs -- )
|
||||
[ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
|
||||
[
|
||||
[ class>> db-table-name "db-table" set ]
|
||||
|
@ -344,11 +307,10 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
[
|
||||
[ second db-table-name "foreign-table-name" set ]
|
||||
[ third "foreign-table-id" set ] bi
|
||||
_ execute
|
||||
create-sqlite-triggers
|
||||
] each
|
||||
] bi
|
||||
] each
|
||||
] call ; inline
|
||||
] each ;
|
||||
|
||||
: sqlite-create-table ( sql-specs class-name -- )
|
||||
[
|
||||
|
@ -373,15 +335,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
|
||||
M: sqlite-db-connection create-sql-statement ( class -- statement )
|
||||
[
|
||||
! specs name
|
||||
[ sqlite-create-table ]
|
||||
[ drop \ create-sqlite-triggers db-triggers ] 2bi
|
||||
[ drop create-db-triggers ] 2bi
|
||||
] query-make ;
|
||||
|
||||
M: sqlite-db-connection drop-sql-statement ( class -- statements )
|
||||
[
|
||||
nip "drop table " 0% 0% ";" 0%
|
||||
] query-make ;
|
||||
[ nip "drop table " 0% 0% ";" 0% ] query-make ;
|
||||
|
||||
M: sqlite-db-connection compound ( string seq -- new-string )
|
||||
over {
|
||||
|
@ -389,3 +348,9 @@ M: sqlite-db-connection compound ( string seq -- new-string )
|
|||
{ "references" [ >reference-string ] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
|
||||
M: sqlite-db-connection parse-db-error
|
||||
dup n>> {
|
||||
{ 1 [ string>> parse-sqlite-sql-error ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Daniel Ehrenberg
|
|
@ -0,0 +1,26 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup math ;
|
||||
IN: math.bits
|
||||
|
||||
ABOUT: "math.bits"
|
||||
|
||||
ARTICLE: "math.bits" "Number bits virtual sequence"
|
||||
{ $subsection bits }
|
||||
{ $subsection <bits> }
|
||||
{ $subsection make-bits } ;
|
||||
|
||||
HELP: bits
|
||||
{ $class-description "Virtual sequence class of bits of a number. The first bit is the least significant bit. This can be constructed with " { $link <bits> } " or " { $link make-bits } "." } ;
|
||||
|
||||
HELP: <bits>
|
||||
{ $values { "number" integer } { "length" integer } { "bits" bits } }
|
||||
{ $description "Creates a virtual sequence of bits of a number in little endian order, with the given length." } ;
|
||||
|
||||
HELP: make-bits
|
||||
{ $values { "number" integer } { "bits" bits } }
|
||||
{ $description "Creates a " { $link bits } " object out of the given number, using its log base 2 as the length. This implies that the last element, corresponding to the most significant bit, will be 1." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bits prettyprint arrays ;" "BIN: 1101 make-bits >array ." "{ t f t t }" }
|
||||
{ $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" }
|
||||
} ;
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test math.bits sequences arrays ;
|
||||
IN: math.bits.tests
|
||||
|
||||
[ t ] [ BIN: 111111 3 <bits> second ] unit-test
|
||||
[ { t t t } ] [ BIN: 111111 3 <bits> >array ] unit-test
|
||||
[ f ] [ BIN: 111101 3 <bits> second ] unit-test
|
||||
[ { f f t } ] [ BIN: 111100 3 <bits> >array ] unit-test
|
||||
[ 3 ] [ BIN: 111111 3 <bits> length ] unit-test
|
||||
[ 6 ] [ BIN: 111111 make-bits length ] unit-test
|
||||
[ 0 ] [ 0 make-bits length ] unit-test
|
||||
[ 2 ] [ 3 make-bits length ] unit-test
|
||||
[ 2 ] [ -3 make-bits length ] unit-test
|
||||
[ 1 ] [ 1 make-bits length ] unit-test
|
||||
[ 1 ] [ -1 make-bits length ] unit-test
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences kernel math accessors sequences.private ;
|
||||
IN: math.bits
|
||||
|
||||
TUPLE: bits { number read-only } { length read-only } ;
|
||||
C: <bits> bits
|
||||
|
||||
: make-bits ( number -- bits )
|
||||
dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ <bits> ] if ; inline
|
||||
|
||||
M: bits length length>> ;
|
||||
|
||||
M: bits nth-unsafe number>> swap bit? ;
|
||||
|
||||
INSTANCE: bits immutable-sequence
|
|
@ -0,0 +1 @@
|
|||
Virtual sequence for bits of an integer
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math math.functions sequences
|
||||
USING: arrays kernel math sequences accessors math.bits
|
||||
sequences.private words namespaces macros hints
|
||||
combinators fry io.binary combinators.smart ;
|
||||
IN: math.bitwise
|
||||
|
@ -65,7 +65,7 @@ DEFER: byte-bit-count
|
|||
|
||||
\ byte-bit-count
|
||||
256 [
|
||||
0 swap [ [ 1+ ] when ] each-bit
|
||||
8 <bits> 0 [ [ 1+ ] when ] reduce
|
||||
] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
|
||||
(( byte -- table )) define-declared
|
||||
|
||||
|
|
|
@ -278,14 +278,6 @@ HELP: mod-inv
|
|||
{ $example "USING: math prettyprint ;" "173 815 * 1119 mod ." "1" }
|
||||
} ;
|
||||
|
||||
HELP: each-bit
|
||||
{ $values { "n" integer } { "quot" { $quotation "( ? -- )" } } }
|
||||
{ $description "Applies the quotation to each bit of the integer, starting from the least significant bit, and stopping at the last bit from which point on all bits are either clear (if the integer is positive) or all bits are set (if the integer is negataive)." }
|
||||
{ $examples
|
||||
{ $example "USING: math.functions make prettyprint ;" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" }
|
||||
{ $example "USING: math.functions make prettyprint ;" "[ -3 [ , ] each-bit ] { } make ." "{ t f }" }
|
||||
} ;
|
||||
|
||||
HELP: ~
|
||||
{ $values { "x" real } { "y" real } { "epsilon" real } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "x" } " and " { $snippet "y" } " are approximately equal to each other. There are three possible comparison tests, chosen based on the sign of " { $snippet "epsilon" } ":"
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel math.constants math.private
|
||||
USING: math kernel math.constants math.private math.bits
|
||||
math.libm combinators math.order sequences ;
|
||||
IN: math.functions
|
||||
|
||||
|
@ -26,16 +26,6 @@ GENERIC: sqrt ( x -- y ) foldable
|
|||
M: real sqrt
|
||||
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
|
||||
|
||||
: each-bit ( n quot: ( ? -- ) -- )
|
||||
over [ 0 = ] [ -1 = ] bi or [
|
||||
2drop
|
||||
] [
|
||||
2dup { [ odd? ] [ call ] [ 2/ ] [ each-bit ] } spread
|
||||
] if ; inline recursive
|
||||
|
||||
: map-bits ( n quot: ( ? -- obj ) -- seq )
|
||||
accumulator [ each-bit ] dip ; inline
|
||||
|
||||
: factor-2s ( n -- r s )
|
||||
#! factor an integer into 2^r * s
|
||||
dup 0 = [ 1 ] [
|
||||
|
@ -47,7 +37,7 @@ M: real sqrt
|
|||
GENERIC# ^n 1 ( z w -- z^w )
|
||||
|
||||
: (^n) ( z w -- z^w )
|
||||
1 swap [ [ dupd * ] when [ sq ] dip ] each-bit nip ; inline
|
||||
make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline
|
||||
|
||||
M: integer ^n
|
||||
[ factor-2s ] dip [ (^n) ] keep rot * shift ;
|
||||
|
@ -94,9 +84,9 @@ PRIVATE>
|
|||
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
|
||||
|
||||
: (^mod) ( n x y -- z )
|
||||
1 swap [
|
||||
make-bits 1 [
|
||||
[ dupd * pick mod ] when [ sq over mod ] dip
|
||||
] each-bit 2nip ; inline
|
||||
] reduce 2nip ; inline
|
||||
|
||||
: (gcd) ( b a x y -- a d )
|
||||
over zero? [
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel base64 checksums.md5 sequences checksums
|
||||
locals prettyprint math math.bitwise grouping io combinators
|
||||
locals prettyprint math math.bits grouping io combinators
|
||||
fry make combinators.short-circuit math.functions splitting ;
|
||||
IN: crypto.passwd-md5
|
||||
|
||||
|
@ -22,8 +22,8 @@ PRIVATE>
|
|||
password length
|
||||
[ 16 / ceiling swap <repetition> concat ] keep
|
||||
head-slice append
|
||||
password [ length ] [ first ] bi
|
||||
'[ [ CHAR: \0 _ ? , ] each-bit ] "" make append
|
||||
password [ length make-bits ] [ first ] bi
|
||||
'[ CHAR: \0 _ ? ] "" map-as append
|
||||
md5 checksum-bytes ] |
|
||||
1000 [
|
||||
"" swap
|
||||
|
|
Loading…
Reference in New Issue