diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor
index 250f98f73e..a6c2975c89 100755
--- a/extra/db/postgresql/postgresql-tests.factor
+++ b/extra/db/postgresql/postgresql-tests.factor
@@ -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
diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor
index 974fdb8782..08139610a0 100755
--- a/extra/db/sqlite/sqlite-tests.factor
+++ b/extra/db/sqlite/sqlite-tests.factor
@@ -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
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
new file mode 100644
index 0000000000..fdd574d00e
--- /dev/null
+++ b/extra/io/windows/files/files.factor
@@ -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 ;
+
diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor
index 59ade44365..85e07fe73f 100755
--- a/extra/math/functions/functions.factor
+++ b/extra/math/functions/functions.factor
@@ -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
diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor
index 3574df36db..37b833cae1 100755
--- a/extra/windows/kernel32/kernel32.factor
+++ b/extra/windows/kernel32/kernel32.factor
@@ -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
diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor
index 62d2805f01..e910ca2888 100755
--- a/extra/windows/time/time.factor
+++ b/extra/windows/time/time.factor
@@ -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 ;