steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Daniel Ehrenberg 2008-03-05 14:55:09 -06:00
parent 93c4ac23a8 4fd4882e02
commit 816a580eb4
6 changed files with 175 additions and 480 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

259
extra/db/postgresql/postgresql-tests.factor
View File

@ -33,24 +33,6 @@ IN: db.postgresql.tests
] with-db
] unit-test
[
{ { "John" "America" } }
] [
test-db [
"select * from person where name = $1 and country = $2"
f f <simple-statement> [
{ { "Jane" TEXT } { "New Zealand" TEXT } }
over do-bound-query
{ { "Jane" "New Zealand" } } =
[ "test fails" throw ] unless
{ { "John" TEXT } { "America" TEXT } }
swap do-bound-query
] with-disposal
] with-db
] unit-test
[
{
{ "John" "America" }
@ -111,244 +93,3 @@ IN: db.postgresql.tests
: with-dummy-db ( quot -- )
>r T{ postgresql-db } db r> with-variable ;
! TEST TUPLE DB
TUPLE: puppy id name age ;
: <puppy> ( name age -- puppy )
{ set-puppy-name set-puppy-age } puppy construct ;
puppy "PUPPY" {
{ "id" "ID" +native-id+ +not-null+ }
{ "name" "NAME" { VARCHAR 256 } }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: kitty id name age ;
: <kitty> ( name age -- kitty )
{ set-kitty-name set-kitty-age } kitty construct ;
kitty "KITTY" {
{ "id" "ID" INTEGER +assigned-id+ }
{ "name" "NAME" TEXT }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: basket id puppies kitties ;
basket "BASKET"
{
{ "id" "ID" +native-id+ +not-null+ }
{ "location" "LOCATION" TEXT }
{ "puppies" { +has-many+ puppy } }
{ "kitties" { +has-many+ kitty } }
} define-persistent
! Create table
[
"create table puppy(id serial primary key not null, name varchar 256, age integer);"
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table create-table-sql >lower
] with-variable
] unit-test
[
"create table kitty(id integer primary key, name text, age integer);"
] [
T{ postgresql-db } db [
kitty dup db-columns swap db-table create-table-sql >lower
] with-variable
] unit-test
[
"create table basket(id serial primary key not null, location text);"
] [
T{ postgresql-db } db [
basket dup db-columns swap db-table create-table-sql >lower
] with-variable
] unit-test
! Create function
[
"create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;"
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table create-function-sql >lower
] with-variable
] unit-test
! Drop table
[
"drop table puppy;"
] [
T{ postgresql-db } db [
puppy db-table drop-table-sql >lower
] with-variable
] unit-test
[
"drop table kitty;"
] [
T{ postgresql-db } db [
kitty db-table drop-table-sql >lower
] with-variable
] unit-test
[
"drop table basket;"
] [
T{ postgresql-db } db [
basket db-table drop-table-sql >lower
] with-variable
] unit-test
! Drop function
[
"drop function add_puppy(varchar, integer);"
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table drop-function-sql >lower
] with-variable
] unit-test
! Insert
[
] [
T{ postgresql-db } db [
puppy <insert-native-statement>
] with-variable
] unit-test
[
"insert into kitty(id, name, age) values($1, $2, $3);"
{
T{
sql-spec
f
"id"
"ID"
INTEGER
{ +assigned-id+ }
+assigned-id+
}
T{ sql-spec f "name" "NAME" TEXT { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
}
{ }
] [
T{ postgresql-db } db [
kitty <insert-assigned-statement>
] with-variable
] unit-test
! Update
[
"update puppy set name = $1, age = $2 where id = $3"
{
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
}
{ }
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table <update-tuple-statement> >r >r >lower r> r>
] with-variable
] unit-test
[
"update kitty set name = $1, age = $2 where id = $3"
{
T{ sql-spec f "name" "NAME" TEXT { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
T{
sql-spec
f
"id"
"ID"
INTEGER
{ +assigned-id+ }
+assigned-id+
}
}
{ }
] [
T{ postgresql-db } db [
kitty dup db-columns swap db-table <update-tuple-statement> >r >r >lower r> r>
] with-variable
] unit-test
! Delete
[
"delete from puppy where id = $1"
{
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
}
{ }
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table <delete-tuple-statement> >r >r >lower r> r>
] with-variable
] unit-test
[
"delete from KITTY where ID = $1"
{
T{
sql-spec
f
"id"
"ID"
INTEGER
{ +assigned-id+ }
+assigned-id+
}
}
{ }
] [
T{ postgresql-db } db [
kitty dup db-columns swap db-table <delete-tuple-statement>
] with-variable
] unit-test
! Select
[
"select from PUPPY ID, NAME, AGE where NAME = $1;"
{ T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } }
{
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
}
] [
T{ postgresql-db } db [
T{ puppy f f "Mr. Clunkers" }
<select-by-slots-statement>
] with-variable
] unit-test

194
extra/db/sqlite/sqlite-tests.factor
View File

@ -3,49 +3,34 @@ prettyprint tools.test db.sqlite db sequences
continuations db.types db.tuples unicode.case ;
IN: db.sqlite.tests
: test.db "extra/db/sqlite/test.db" resource-path ;
: db-path "extra/db/sqlite/test.db" resource-path ;
: test.db db-path sqlite-db ;
[ ] [ [ test.db delete-file ] ignore-errors ] unit-test
[ ] [ [ db-path delete-file ] ignore-errors ] unit-test
[ ] [
test.db [
"create table person (name varchar(30), country varchar(30))" sql-command
"insert into person values('John', 'America')" sql-command
"insert into person values('Jane', 'New Zealand')" sql-command
] with-sqlite
] with-db
] unit-test
[ { { "John" "America" } { "Jane" "New Zealand" } } ] [
test.db [
"select * from person" sql-query
] with-sqlite
] unit-test
[ { { "John" "America" } } ] [
test.db [
"select * from person where name = :name and country = :country"
<simple-statement> [
{ { ":name" "Jane" TEXT } { ":country" "New Zealand" TEXT } }
over do-bound-query
{ { "Jane" "New Zealand" } } =
[ "test fails" throw ] unless
{ { ":name" "John" TEXT } { ":country" "America" TEXT } }
swap do-bound-query
] with-disposal
] with-sqlite
] with-db
] unit-test
[ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ]
[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
[ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test
[ ] [
test.db [
"insert into person(name, country) values('Jimmy', 'Canada')"
sql-command
] with-sqlite
] with-db
] unit-test
[
@ -54,7 +39,7 @@ IN: db.sqlite.tests
{ "2" "Jane" "New Zealand" }
{ "3" "Jimmy" "Canada" }
}
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
] [ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test
[
test.db [
@ -63,13 +48,13 @@ IN: db.sqlite.tests
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"oops" throw
] with-transaction
] with-sqlite
] with-db
] must-fail
[ 3 ] [
test.db [
"select * from person" sql-query length
] with-sqlite
] with-db
] unit-test
[
@ -81,166 +66,11 @@ IN: db.sqlite.tests
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
] with-transaction
] with-sqlite
] with-db
] unit-test
[ 5 ] [
test.db [
"select * from person" sql-query length
] with-sqlite
] unit-test
! TEST TUPLE DB
TUPLE: puppy id name age ;
: <puppy> ( name age -- puppy )
{ set-puppy-name set-puppy-age } puppy construct ;
puppy "PUPPY" {
{ "id" "ID" +native-id+ +not-null+ }
{ "name" "NAME" { VARCHAR 256 } }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: kitty id name age ;
: <kitty> ( name age -- kitty )
{ set-kitty-name set-kitty-age } kitty construct ;
kitty "KITTY" {
{ "id" "ID" INTEGER +assigned-id+ }
{ "name" "NAME" TEXT }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: basket id puppies kitties ;
basket "BASKET"
{
{ "id" "ID" +native-id+ +not-null+ }
{ "location" "LOCATION" TEXT }
{ "puppies" { +has-many+ puppy } }
{ "kitties" { +has-many+ kitty } }
} define-persistent
! Create table
[
"create table puppy(id integer primary key not null, name varchar, age integer);"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
[
"create table kitty(id integer primary key, name text, age integer);"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
[
"create table basket(id integer primary key not null, location text);"
] [
T{ sqlite-db } db [
basket dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
! Drop table
[
"drop table puppy;"
] [
T{ sqlite-db } db [
puppy db-table drop-sql >lower
] with-variable
] unit-test
[
"drop table kitty;"
] [
T{ sqlite-db } db [
kitty db-table drop-sql >lower
] with-variable
] unit-test
[
"drop table basket;"
] [
T{ sqlite-db } db [
basket db-table drop-sql >lower
] with-variable
] unit-test
! Insert
[
"insert into puppy(name, age) values(:name, :age);"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table insert-sql* >lower
] with-variable
] unit-test
[
"insert into kitty(id, name, age) values(:id, :name, :age);"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table insert-sql* >lower
] with-variable
] unit-test
! Update
[
"update puppy set name = :name, age = :age where id = :id"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table update-sql* >lower
] with-variable
] unit-test
[
"update kitty set name = :name, age = :age where id = :id"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table update-sql* >lower
] with-variable
] unit-test
! Delete
[
"delete from puppy where id = :id"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table delete-sql* >lower
] with-variable
] unit-test
[
"delete from kitty where id = :id"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table delete-sql* >lower
] with-variable
] unit-test
! Select
[
"select from puppy id, name, age where name = :name;"
{
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
}
] [
T{ sqlite-db } db [
T{ puppy f f "Mr. Clunkers" }
select-sql >r >lower r>
] with-variable
] with-db
] unit-test

108
extra/io/windows/files/files.factor Normal file
View File

@ -0,0 +1,108 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.files io.windows kernel
math windows windows.kernel32 combinators.cleave
windows.time calendar combinators math.functions
sequences combinators.lib namespaces words ;
IN: io.windows.files
SYMBOL: +read-only+
SYMBOL: +hidden+
SYMBOL: +system+
SYMBOL: +directory+
SYMBOL: +archive+
SYMBOL: +device+
SYMBOL: +normal+
SYMBOL: +temporary+
SYMBOL: +sparse-file+
SYMBOL: +reparse-point+
SYMBOL: +compressed+
SYMBOL: +offline+
SYMBOL: +not-content-indexed+
SYMBOL: +encrypted+
: expand-constants ( word/obj -- obj'/obj )
dup word? [ execute ] when ;
: get-flags ( n seq -- seq' )
[
[
first2 expand-constants
[ swapd mask? [ , ] [ drop ] if ] 2curry
] map call-with
] { } make ;
: win32-file-attributes ( n -- seq )
{
{ +read-only+ FILE_ATTRIBUTE_READONLY }
{ +hidden+ FILE_ATTRIBUTE_HIDDEN }
{ +system+ FILE_ATTRIBUTE_SYSTEM }
{ +directory+ FILE_ATTRIBUTE_DIRECTORY }
{ +archive+ FILE_ATTRIBUTE_ARCHIVE }
{ +device+ FILE_ATTRIBUTE_DEVICE }
{ +normal+ FILE_ATTRIBUTE_NORMAL }
{ +temporary+ FILE_ATTRIBUTE_TEMPORARY }
{ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE }
{ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT }
{ +compressed+ FILE_ATTRIBUTE_COMPRESSED }
{ +offline+ FILE_ATTRIBUTE_OFFLINE }
{ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED }
{ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED }
} get-flags ;
: WIN32_FIND_DATA>file-info
{
[ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
[
[ WIN32_FIND_DATA-nFileSizeLow ]
[ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit
]
[ WIN32_FIND_DATA-dwFileAttributes ]
[
WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp
]
} cleave
\ file-info construct-boa ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
"WIN32_FIND_DATA" <c-object> [
FindFirstFile
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
FindClose win32-error=0/f
] keep ;
: BY_HANDLE_FILE_INFORMATION>file-info
{
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes ]
[
[ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
[ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit
]
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ]
[
BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
FILETIME>timestamp
]
} cleave
\ file-info construct-boa ;
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
[
"BY_HANDLE_FILE_INFORMATION" <c-object>
[ GetFileInformationByHandle win32-error=0/f ] keep
] keep CloseHandle win32-error=0/f ;
: get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION )
dup
GENERIC_READ FILE_SHARE_READ f
OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f
CreateFileW dup INVALID_HANDLE_VALUE = [
drop find-first-file-stat WIN32_FIND_DATA>file-info
] [
nip
get-file-information BY_HANDLE_FILE_INFORMATION>file-info
] if ;
M: windows-nt-io file-info ( path -- info )
get-file-information-stat ;

4
extra/math/functions/functions.factor
View File

@ -34,6 +34,10 @@ M: real sqrt
: set-bit ( x n -- y ) 2^ bitor ; foldable
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
: bit-set? ( x n -- ? ) bit-clear? not ; foldable
: unmask ( x n -- ? ) bitnot bitand ; foldable
: unmask? ( x n -- ? ) unmask 0 > ; foldable
: mask ( x n -- ? ) bitand ; foldable
: mask? ( x n -- ? ) mask 0 > ; foldable
GENERIC: (^) ( x y -- z ) foldable

12
extra/windows/kernel32/kernel32.factor
View File

@ -445,6 +445,18 @@ C-STRUCT: WIN32_FIND_DATA
{ { "TCHAR" 260 } "cFileName" }
{ { "TCHAR" 14 } "cAlternateFileName" } ;
C-STRUCT: BY_HANDLE_FILE_INFORMATION
{ "DWORD" "dwFileAttributes" }
{ "FILETIME" "ftCreationTime" }
{ "FILETIME" "ftLastAccessTime" }
{ "FILETIME" "ftLastWriteTime" }
{ "DWORD" "dwVolumeSerialNumber" }
{ "DWORD" "nFileSizeHigh" }
{ "DWORD" "nFileSizeLow" }
{ "DWORD" "nNumberOfLinks" }
{ "DWORD" "nFileIndexHigh" }
{ "DWORD" "nFileIndexLow" } ;
TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA
TYPEDEF: WIN32_FIND_DATA* LPWIN32_FIND_DATA
TYPEDEF: void* POVERLAPPED

78
extra/windows/time/time.factor
View File

@ -1,39 +1,39 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types kernel math windows windows.kernel32
namespaces calendar.backend ;
IN: windows.time
: >64bit ( lo hi -- n )
32 shift bitor ;
: windows-1601 ( -- timestamp )
1601 1 1 0 0 0 0 <timestamp> ;
: FILETIME>windows-time ( FILETIME -- n )
[ FILETIME-dwLowDateTime ] keep
FILETIME-dwHighDateTime >64bit ;
: windows-time>timestamp ( n -- timestamp )
10000000 /i seconds windows-1601 swap time+ ;
: windows-time ( -- n )
"FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep
FILETIME>windows-time ;
: timestamp>windows-time ( timestamp -- n )
#! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
>gmt windows-1601 (time-) 10000000 * >integer ;
: windows-time>FILETIME ( n -- FILETIME )
"FILETIME" <c-object>
[
[ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep
>r -32 shift r> set-FILETIME-dwHighDateTime
] keep ;
: timestamp>FILETIME ( timestamp -- FILETIME/f )
[ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ;
: FILETIME>timestamp ( FILETIME -- timestamp/f )
FILETIME>windows-time windows-time>timestamp ;
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types kernel math windows windows.kernel32
namespaces calendar calendar.backend ;
IN: windows.time
: >64bit ( lo hi -- n )
32 shift bitor ;
: windows-1601 ( -- timestamp )
1601 1 1 0 0 0 0 <timestamp> ;
: FILETIME>windows-time ( FILETIME -- n )
[ FILETIME-dwLowDateTime ] keep
FILETIME-dwHighDateTime >64bit ;
: windows-time>timestamp ( n -- timestamp )
10000000 /i seconds windows-1601 swap time+ ;
: windows-time ( -- n )
"FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep
FILETIME>windows-time ;
: timestamp>windows-time ( timestamp -- n )
#! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
>gmt windows-1601 (time-) 10000000 * >integer ;
: windows-time>FILETIME ( n -- FILETIME )
"FILETIME" <c-object>
[
[ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep
>r -32 shift r> set-FILETIME-dwHighDateTime
] keep ;
: timestamp>FILETIME ( timestamp -- FILETIME/f )
[ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ;
: FILETIME>timestamp ( FILETIME -- timestamp/f )
FILETIME>windows-time windows-time>timestamp ;