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

Merge git://factorcode.org/git/factor

db4
Eduardo Cavazos 2008-02-25 15:52:41 -06:00
parent 76d70f2621 858d22d3a0
commit f414f304ab
31 changed files with 1184 additions and 510 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/compiler/units/units.factor
View File

@ -42,7 +42,7 @@ definition-observers global [ V{ } like ] change-at
GENERIC: definitions-changed ( assoc obj -- )
: add-definition-observer ( obj -- )
definition-observers get push ;
definition-observers get push-new ;
: remove-definition-observer ( obj -- )
definition-observers get delete ;

18
core/threads/threads-docs.factor
View File

@ -19,8 +19,7 @@ ARTICLE: "threads-yield" "Yielding and suspending threads"
{ $subsection yield }
"Sleeping for a period of time:"
{ $subsection sleep }
"Interruptible sleep:"
{ $subsection nap }
"Interrupting sleep:"
{ $subsection interrupt }
"Threads can be suspended and woken up at some point in the future when a condition is satisfied:"
{ $subsection suspend }
@ -106,14 +105,17 @@ HELP: stop
HELP: yield
{ $description "Adds the current thread to the end of the run queue, and switches to the next runnable thread." } ;
HELP: sleep-until
{ $values { "time/f" "a non-negative integer or " { $link f } } }
{ $description "Suspends the current thread until the given time, or indefinitely if a value of " { $link f } " is passed in."
$nl
"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
HELP: sleep
{ $values { "ms" "a non-negative integer" } }
{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." }
{ $errors "Throws an error if another thread interrupted the sleep with " { $link interrupt } "." } ;
HELP: nap
{ $values { "ms/f" "a non-negative integer or " { $link f } } { "?" "a boolean indicating whether the thread was interrupted" } }
{ $description "Suspends the current thread until another thread interrupts it with " { $link interrupt } ". If the input parameter is not " { $link f } ", then the thread will also wake up if the timeout expires before an interrupt is received." } ;
{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds."
$nl
"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
HELP: interrupt
{ $values { "thread" thread } }

35
core/threads/threads.factor
View File

@ -75,12 +75,15 @@ PRIVATE>
: sleep-queue 43 getenv ;
: resume ( thread -- )
f over set-thread-state
check-registered run-queue push-front ;
: resume-now ( thread -- )
f over set-thread-state
check-registered run-queue push-back ;
: resume-with ( obj thread -- )
f over set-thread-state
check-registered 2array run-queue push-front ;
<PRIVATE
@ -131,34 +134,27 @@ PRIVATE>
self swap call next
] callcc1 2nip ; inline
: yield ( -- ) [ resume ] "yield" suspend drop ;
: yield ( -- ) [ resume ] f suspend drop ;
GENERIC: nap-until ( time -- ? )
GENERIC: sleep-until ( time/f -- )
M: integer nap-until [ schedule-sleep ] curry "sleep" suspend ;
M: integer sleep-until
[ schedule-sleep ] curry "sleep" suspend drop ;
M: f nap-until drop [ drop ] "interrupt" suspend ;
M: f sleep-until
drop [ drop ] "interrupt" suspend drop ;
GENERIC: nap ( time -- ? )
GENERIC: sleep ( ms -- )
M: real nap millis + >integer nap-until ;
M: f nap nap-until ;
: sleep-until ( time -- )
nap-until [ "Sleep interrupted" throw ] when ;
: sleep ( time -- )
nap [ "Sleep interrupted" throw ] when ;
M: real sleep
millis + >integer sleep-until ;
: interrupt ( thread -- )
dup self eq? [
drop
] [
dup thread-state [
dup thread-sleep-entry [ sleep-queue heap-delete ] when*
f over set-thread-sleep-entry
t swap resume-with
] if ;
dup resume
] when drop ;
: (spawn) ( thread -- )
[
@ -204,6 +200,7 @@ M: f nap nap-until ;
initial-thread global
[ drop f "Initial" [ die ] <thread> ] cache
<box> over set-thread-continuation
f over set-thread-state
dup register-thread
set-self ;

2
extra/alarms/alarms.factor
View File

@ -62,7 +62,7 @@ SYMBOL: alarm-thread
: alarm-thread-loop ( -- )
alarms get-global
dup next-alarm nap-until drop
dup next-alarm sleep-until
dup trigger-alarms
alarm-thread-loop ;

4
extra/calendar/calendar.factor
View File

@ -473,9 +473,9 @@ M: timestamp year. ( timestamp -- )
: seconds-since-midnight ( timestamp -- x )
dup beginning-of-day timestamp- ;
M: timestamp nap-until timestamp>millis nap-until ;
M: timestamp sleep-until timestamp>millis sleep-until ;
M: dt nap from-now nap-until ;
M: dt sleep from-now sleep-until ;
{
{ [ unix? ] [ "calendar.unix" ] }

58
extra/db/db.factor
View File

@ -1,14 +1,18 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib tuples words strings ;
namespaces sequences sequences.lib tuples words strings
tools.walker ;
IN: db
TUPLE: db handle insert-statements update-statements delete-statements ;
TUPLE: db handle ;
! TUPLE: db handle insert-statements update-statements delete-statements ;
: <db> ( handle -- obj )
H{ } clone H{ } clone H{ } clone
! H{ } clone H{ } clone H{ } clone
db construct-boa ;
GENERIC: make-db* ( seq class -- db )
: make-db ( seq class -- db ) construct-empty make-db* ;
GENERIC: db-open ( db -- )
HOOK: db-close db ( handle -- )
@ -17,22 +21,29 @@ HOOK: db-close db ( handle -- )
: dispose-db ( db -- )
dup db [
dup db-insert-statements dispose-statements
dup db-update-statements dispose-statements
dup db-delete-statements dispose-statements
! dup db-insert-statements dispose-statements
! dup db-update-statements dispose-statements
! dup db-delete-statements dispose-statements
db-handle db-close
] with-variable ;
TUPLE: statement sql params handle bound? slot-names ;
TUPLE: statement handle sql in-params out-params bind-params bound? ;
: <statement> ( sql in out -- statement )
{
set-statement-sql
set-statement-in-params
set-statement-out-params
} statement construct ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
HOOK: <simple-statement> db ( str -- statement )
HOOK: <prepared-statement> db ( str -- statement )
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( obj statement -- )
GENERIC: reset-statement ( statement -- )
GENERIC: insert-statement ( statement -- id )
GENERIC: bind-tuple ( tuple statement -- )
TUPLE: result-set sql params handle n max ;
GENERIC: query-results ( query -- result-set )
@ -42,12 +53,17 @@ GENERIC# row-column 1 ( result-set n -- obj )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
: execute-statement ( statement -- ) query-results dispose ;
: execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
query-results dispose
] if ;
: bind-statement ( obj statement -- )
dup statement-bound? [ dup reset-statement ] when
[ bind-statement* ] 2keep
[ set-statement-params ] keep
[ set-statement-bind-params ] keep
t swap set-statement-bound? ;
: init-result-set ( result-set -- )
@ -55,7 +71,7 @@ GENERIC: more-rows? ( result-set -- ? )
0 swap set-result-set-n ;
: <result-set> ( query handle tuple -- result-set )
>r >r { statement-sql statement-params } get-slots r>
>r >r { statement-sql statement-in-params } get-slots r>
{
set-result-set-sql
set-result-set-params
@ -75,17 +91,15 @@ GENERIC: more-rows? ( result-set -- ? )
: query-map ( statement quot -- seq )
accumulator >r query-each r> { } like ; inline
: with-db ( db quot -- )
[
over db-open
[ db swap with-variable ] curry with-disposal
] with-scope ;
: with-db ( db seq quot -- )
>r make-db dup db-open db r>
[ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
: do-query ( query -- result-set )
: default-query ( query -- result-set )
query-results [ [ sql-row ] query-map ] with-disposal ;
: do-bound-query ( obj query -- rows )
[ bind-statement ] keep do-query ;
[ bind-statement ] keep default-query ;
: do-bound-command ( obj query -- )
[ bind-statement ] keep execute-statement ;
@ -105,11 +119,11 @@ HOOK: rollback-transaction db ( -- )
] with-variable ;
: sql-query ( sql -- rows )
<simple-statement> [ do-query ] with-disposal ;
f f <simple-statement> [ default-query ] with-disposal ;
: sql-command ( sql -- )
dup string? [
<simple-statement> [ execute-statement ] with-disposal
f f <simple-statement> [ execute-statement ] with-disposal
] [
! [
[ sql-command ] each

18
extra/db/postgresql/lib/lib.factor Normal file → Executable file
View File

@ -2,21 +2,25 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
db.types ;
db.types tools.walker ascii splitting ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
dup zero? [
drop f
] [
PQresultErrorMessage [ CHAR: \n = ] right-trim
PQresultErrorMessage [ blank? ] trim
] if ;
: postgres-result-error ( res -- )
postgresql-result-error-message [ throw ] when* ;
: (postgresql-error-message) ( handle -- str )
PQerrorMessage
"\n" split [ [ blank? ] trim ] map "\n" join ;
: postgresql-error-message ( -- str )
db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ;
db get db-handle (postgresql-error-message) ;
: postgresql-error ( res -- res )
dup [ postgresql-error-message throw ] unless ;
@ -27,7 +31,7 @@ IN: db.postgresql.lib
: connect-postgres ( host port pgopts pgtty db user pass -- conn )
PQsetdbLogin
dup PQstatus zero? [ postgresql-error-message throw ] unless ;
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? [
@ -37,9 +41,9 @@ IN: db.postgresql.lib
: do-postgresql-bound-statement ( statement -- res )
>r db get db-handle r>
[ statement-sql ] keep
[ statement-params length f ] keep
statement-params
[ first number>string* malloc-char-string ] map >c-void*-array
[ statement-bind-params length f ] keep
statement-bind-params
[ number>string* malloc-char-string ] map >c-void*-array
f f 0 PQexecParams
dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw

254
extra/db/postgresql/postgresql-tests.factor Normal file → Executable file
View File

@ -1,13 +1,14 @@
! You will need to run 'createdb factor-test' to create the database.
! Set username and password in the 'connect' word.
USING: kernel db.postgresql alien continuations io prettyprint
sequences namespaces tools.test db db.types ;
USING: kernel db.postgresql alien continuations io classes
prettyprint sequences namespaces tools.test db
db.tuples db.types unicode.case ;
IN: temporary
IN: scratchpad
: test-db ( -- postgresql-db )
"localhost" "postgres" "" "factor-test" <postgresql-db> ;
{ "localhost" "postgres" "" "factor-test" } postgresql-db ;
IN: temporary
[ ] [ test-db [ ] with-db ] unit-test
@ -39,7 +40,7 @@ IN: temporary
] [
test-db [
"select * from person where name = $1 and country = $2"
<simple-statement> [
f f <simple-statement> [
{ { "Jane" TEXT } { "New Zealand" TEXT } }
over do-bound-query
@ -108,3 +109,248 @@ IN: temporary
"select * from person" sql-query length
] with-db
] unit-test
: 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

354
extra/db/postgresql/postgresql.factor
View File

@ -4,25 +4,28 @@ USING: arrays assocs alien alien.syntax continuations io
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 ;
combinators sequences.lib classes locals words tools.walker ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
TUPLE: postgresql-statement ;
TUPLE: postgresql-result-set ;
: <postgresql-statement> ( statement -- postgresql-statement )
: <postgresql-statement> ( statement in out -- postgresql-statement )
<statement>
postgresql-statement construct-delegate ;
: <postgresql-db> ( host user pass db -- obj )
{
set-postgresql-db-host
set-postgresql-db-user
set-postgresql-db-pass
set-postgresql-db-db
} postgresql-db construct ;
M: postgresql-db make-db* ( seq tuple -- db )
>r first4 r> [
{
set-postgresql-db-host
set-postgresql-db-user
set-postgresql-db-pass
set-postgresql-db-db
} set-slots
] keep ;
M: postgresql-db db-open ( db -- )
dup {
dup {
postgresql-db-host
postgresql-db-port
postgresql-db-pgopts
@ -35,15 +38,18 @@ M: postgresql-db db-open ( db -- )
M: postgresql-db dispose ( db -- )
db-handle PQfinish ;
: with-postgresql ( host ust pass db quot -- )
>r <postgresql-db> r> with-disposal ;
M: postgresql-statement bind-statement* ( seq statement -- )
set-statement-params ;
set-statement-bind-params ;
M: postgresql-statement reset-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 ;
M: postgresql-result-set #rows ( result-set -- n )
result-set-handle PQntuples ;
@ -56,19 +62,8 @@ M: postgresql-result-set row-column ( result-set n -- obj )
M: postgresql-result-set row-column-typed ( result-set n type -- obj )
>r row-column r> sql-type>factor-type ;
M: postgresql-result-set sql-type>factor-type ( obj type -- newobj )
{
{ INTEGER [ string>number ] }
{ BIG_INTEGER [ string>number ] }
{ DOUBLE [ string>number ] }
[ drop ]
} case ;
M: postgresql-statement insert-statement ( statement -- id )
query-results [ 0 row-column ] with-disposal string>number ;
M: postgresql-statement query-results ( query -- result-set )
dup statement-params [
dup statement-bind-params [
over [ bind-statement ] keep
do-postgresql-bound-statement
] [
@ -96,17 +91,15 @@ M: postgresql-result-set dispose ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
[
>r db get db-handle "" r>
dup statement-sql swap statement-params
dup statement-sql swap statement-in-params
length f PQprepare postgresql-error
] keep set-statement-handle ;
M: postgresql-db <simple-statement> ( sql -- statement )
{ set-statement-sql } statement construct
M: postgresql-db <simple-statement> ( sql in out -- statement )
<postgresql-statement> ;
M: postgresql-db <prepared-statement> ( sql -- statement )
{ set-statement-sql } statement construct
<postgresql-statement> ;
M: postgresql-db <prepared-statement> ( sql in out -- statement )
<postgresql-statement> dup prepare-statement ;
M: postgresql-db begin-transaction ( -- )
"BEGIN" sql-command ;
@ -117,139 +110,176 @@ M: postgresql-db commit-transaction ( -- )
M: postgresql-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
: postgresql-type-hash* ( -- assoc )
H{
{ SERIAL "serial" }
} ;
SYMBOL: postgresql-counter
: bind-name% ( -- )
CHAR: $ 0,
postgresql-counter [ inc ] keep get 0# ;
: postgresql-type-hash ( -- assoc )
M: postgresql-db bind% ( spec -- )
1, bind-name% ;
: postgresql-make ( class quot -- )
>r sql-props r>
[ postgresql-counter off ] swap compose
{ "" { } { } } nmake <postgresql-statement> ;
: create-table-sql ( class -- statement )
[
"create table " 0% 0%
"(" 0%
[ ", " 0% ] [
dup sql-spec-column-name 0%
" " 0%
dup sql-spec-type t lookup-type 0%
modifiers 0%
] interleave ");" 0%
] postgresql-make ;
: create-function-sql ( class -- statement )
[
>r remove-id r>
"create function add_" 0% dup 0%
"(" 0%
over [ "," 0% ]
[
sql-spec-type f lookup-type 0%
] interleave
")" 0%
" returns bigint as '" 0%
"insert into " 0%
dup 0%
"(" 0%
over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
") values(" 0%
swap [ ", " 0% ] [ drop bind-name% ] interleave
"); " 0%
"select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
] postgresql-make ;
M: postgresql-db create-sql-statement ( class -- seq )
[
[ create-table-sql , ] keep
dup db-columns find-primary-key native-id?
[ create-function-sql , ] [ drop ] if
] { } make ;
: drop-function-sql ( class -- statement )
[
"drop function add_" 0% 0%
"(" 0%
remove-id
[ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave
");" 0%
] postgresql-make ;
: drop-table-sql ( table -- statement )
[
"drop table " 0% 0% ";" 0% drop
] postgresql-make ;
M: postgresql-db drop-sql-statement ( class -- seq )
[
[ drop-table-sql , ] keep
dup db-columns find-primary-key native-id?
[ drop-function-sql , ] [ drop ] if
] { } make ;
M: postgresql-db <insert-native-statement> ( class -- statement )
[
"select add_" 0% 0%
"(" 0%
dup find-primary-key 2,
remove-id
[ ", " 0% ] [ bind% ] interleave
");" 0%
] postgresql-make ;
M: postgresql-db <insert-assigned-statement> ( class -- statement )
[
"insert into " 0% 0%
"(" 0%
dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
")" 0%
" values(" 0%
[ ", " 0% ] [ bind% ] interleave
");" 0%
] postgresql-make ;
M: postgresql-db insert-tuple* ( tuple statement -- )
query-modify-tuple ;
M: postgresql-db <update-tuple-statement> ( class -- statement )
[
"update " 0% 0%
" set " 0%
dup remove-id
[ ", " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
" where " 0%
find-primary-key
dup sql-spec-column-name 0% " = " 0% bind%
] postgresql-make ;
M: postgresql-db <delete-tuple-statement> ( class -- statement )
[
"delete from " 0% 0%
" where " 0%
find-primary-key
dup sql-spec-column-name 0% " = " 0% bind%
] postgresql-make ;
M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
[
! tuple columns table
"select " 0%
over [ ", " 0% ]
[ dup sql-spec-column-name 0% 2, ] interleave
" from " 0% 0%
[ sql-spec-slot-name swap get-slot-named ] with subset
" where " 0%
[ ", " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
";" 0%
] postgresql-make ;
M: postgresql-db type-table ( -- hash )
H{
{ INTEGER "integer" }
{ SERIAL "integer" }
{ +native-id+ "integer" }
{ TEXT "text" }
{ VARCHAR "varchar" }
{ INTEGER "integer" }
{ DOUBLE "real" }
{ TIMESTAMP "timestamp" }
} ;
: enquote ( str -- newstr ) "(" swap ")" 3append ;
: postgresql-type ( str n/str -- newstr )
" " swap number>string* enquote 3append ;
: >sql-type* ( obj -- str )
dup pair? [
first2 >r >sql-type* r> postgresql-type
] [
dup postgresql-type-hash* at* [
nip
] [
drop >sql-type
] if
] if ;
M: postgresql-db >sql-type ( hash obj -- str )
dup pair? [
first2 >r >sql-type r> postgresql-type
] [
postgresql-type-hash at* [
no-sql-type
] unless
] if ;
: insert-function ( columns table -- sql )
[
>r remove-id r>
"create function add_" % dup %
"(" %
over [ "," % ]
[ third dup array? [ first ] when >sql-type % ] interleave
")" %
" returns bigint as '" %
2dup "insert into " %
%
"(" %
dup [ ", " % ] [ second % ] interleave
") " %
" values (" %
length [1,b] [ ", " % ] [ "$" % # ] interleave
"); " %
"select currval(''" % % "_id_seq'');' language sql;" %
drop
] "" make ;
: drop-function ( columns table -- sql )
[
>r remove-id r>
"drop function add_" % %
"(" %
[ "," % ] [ third >sql-type % ] interleave
")" %
] "" make ;
M: postgresql-db create-sql ( columns table -- seq )
[
[
2dup
"create table " % %
" (" % [ ", " % ] [
dup second % " " %
dup third >sql-type* % " " %
sql-modifiers " " join %
] interleave "); " %
] "" make ,
over native-id? [ insert-function , ] [ 2drop ] if
] { } make ;
M: postgresql-db drop-sql ( columns table -- seq )
[
[
dup "drop table " % % ";" %
] "" make ,
over native-id? [ drop-function , ] [ 2drop ] if
] { } make ;
M: postgresql-db insert-sql* ( columns table -- slot-names sql )
[
"select add_" % %
"(" %
length [1,b] [ ", " % ] [ "$" % # ] interleave
")" %
] "" make ;
M: postgresql-db update-sql* ( columns table -- slot-names sql )
[
"update " %
%
" set " %
dup remove-id
dup length [1,b] swap 2array flip
[ ", " % ] [ first2 second % " = $" % # ] interleave
" where " %
[ primary-key? ] find nip second dup % " = $" % length 2 + #
] "" make ;
M: postgresql-db delete-sql* ( columns table -- slot-names sql )
[
"delete from " %
%
" where " %
first second % " = $1" %
] "" make ;
M: postgresql-db select-sql ( columns table -- slot-names sql )
drop ;
M: postgresql-db tuple>params ( columns tuple -- obj )
[ >r dup third swap first r> get-slot-named swap ]
curry { } map>assoc ;
: postgresql-db-modifiers ( -- hashtable )
M: postgresql-db create-type-table ( -- hash )
H{
{ +native-id+ "not null primary key" }
{ +native-id+ "serial 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 [ sql-spec-slot-name = ] with find nip
sql-spec-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" }
{ +assigned-id+ "primary key" }
{ +foreign-id+ "references" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
@ -257,13 +287,5 @@ M: postgresql-db tuple>params ( columns tuple -- obj )
{ +not-null+ "not null" }
} ;
M: postgresql-db sql-modifiers* ( modifiers -- str )
postgresql-db-modifiers swap [
dup array? [
first2
>r swap at r> number>string*
" " swap 3append
] [
swap at
] if
] with map [ ] subset ;
M: postgresql-db compound-type ( str n -- newstr )
postgresql-compound ;

5
extra/db/sqlite/lib/lib.factor
View File

@ -78,7 +78,8 @@ IN: db.sqlite.lib
{ TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
{ SERIAL [ sqlite-bind-int-by-name ] }
{ TIMESTAMP [ sqlite-bind-double-by-name ] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
! { NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ]
} case ;
@ -102,6 +103,8 @@ IN: db.sqlite.lib
{ BIG_INTEGER [ sqlite3_column_int64 ] }
{ TEXT [ sqlite3_column_text ] }
{ DOUBLE [ sqlite3_column_double ] }
{ TIMESTAMP [ sqlite3_column_double ] }
[ no-sql-type ]
} case ;
! TODO

157
extra/db/sqlite/sqlite-tests.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: io io.files io.launcher kernel namespaces
prettyprint tools.test db.sqlite db sequences
continuations db.types ;
continuations db.types db.tuples unicode.case ;
IN: temporary
: test.db "extra/db/sqlite/test.db" resource-path ;
@ -89,3 +89,158 @@ IN: temporary
"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
] unit-test

177
extra/db/sqlite/sqlite.factor
View File

@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings tuples alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types ;
words combinators.lib db.types combinators tools.walker ;
IN: db.sqlite
TUPLE: sqlite-db path ;
@ -23,7 +23,6 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
>r <sqlite-db> r> with-db ; inline
TUPLE: sqlite-statement ;
C: <sqlite-statement> sqlite-statement
TUPLE: sqlite-result-set has-more? ;
@ -31,9 +30,15 @@ M: sqlite-db <simple-statement> ( str -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str -- obj )
db get db-handle over sqlite-prepare
{ set-statement-sql set-statement-handle } statement construct
<sqlite-statement> [ set-delegate ] keep ;
db get db-handle
{
set-statement-sql
set-statement-in-params
set-statement-out-params
set-statement-handle
} statement construct
dup statement-handle over statement-sql sqlite-prepare
sqlite-statement construct-delegate ;
M: sqlite-statement dispose ( statement -- )
statement-handle sqlite-finalize ;
@ -41,10 +46,11 @@ M: sqlite-statement dispose ( statement -- )
M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ;
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
: sqlite-bind ( specs handle -- )
break
swap [ sqlite-bind-type ] with each ;
M: sqlite-statement bind-statement* ( triples statement -- )
M: sqlite-statement bind-statement* ( obj statement -- )
statement-handle sqlite-bind ;
M: sqlite-statement reset-statement ( statement -- )
@ -54,8 +60,8 @@ M: sqlite-statement reset-statement ( statement -- )
db get db-handle sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
M: sqlite-statement insert-statement ( statement -- id )
execute-statement last-insert-id ;
M: sqlite-statement insert-tuple* ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
result-set-handle sqlite-#columns ;
@ -74,6 +80,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ;
M: sqlite-statement query-results ( query -- result-set )
break
dup statement-handle sqlite-result-set <result-set>
dup advance-row ;
@ -86,78 +93,85 @@ M: sqlite-db commit-transaction ( -- )
M: sqlite-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
M: sqlite-db create-sql ( columns table -- sql )
[
"create table " % %
" (" % [ ", " % ] [
dup second % " " %
dup third >sql-type % " " %
sql-modifiers " " join %
] interleave ")" %
] "" make ;
: sqlite-make ( class quot -- )
>r sql-props r>
{ "" { } { } } nmake <simple-statement> ;
M: sqlite-db drop-sql ( columns table -- sql )
M: sqlite-db create-sql-statement ( class -- statement )
[
"drop table " % %
drop
] "" make ;
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
dup sql-spec-column-name 0%
" " 0%
dup sql-spec-type t lookup-type 0%
modifiers 0%
] interleave ");" 0%
] sqlite-make ;
M: sqlite-db insert-sql* ( columns table -- sql )
M: sqlite-db drop-sql-statement ( class -- statement )
[
"insert into " %
%
"(" %
dup [ ", " % ] [ second % ] interleave
") " %
" values (" %
[ ", " % ] [ ":" % second % ] interleave
")" %
] "" make ;
"drop table " 0% 0% ";" 0% drop
] sqlite-make ;
: where-primary-key% ( columns -- )
" where " %
[ primary-key? ] find nip second dup % " = :" % % ;
M: sqlite-db update-sql* ( columns table -- sql )
M: sqlite-db <insert-native-statement> ( tuple -- statement )
[
"update " %
%
" set " %
"insert into " 0% 0%
"(" 0%
maybe-remove-id
dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
") values(" 0%
[ ", " 0% ] [ bind% ] interleave
");" 0%
] sqlite-make ;
M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
<insert-native-statement> ;
: where-primary-key% ( specs -- )
" where " 0%
find-primary-key sql-spec-column-name dup 0% " = " 0% bind% ;
M: sqlite-db <update-tuple-statement> ( class -- statement )
[
"update " 0%
0%
" set " 0%
dup remove-id
[ ", " % ] [ second dup % " = :" % % ] interleave
[ ", " 0% ] [ sql-spec-column-name dup 0% " = " 0% bind% ] interleave
where-primary-key%
] "" make ;
] sqlite-make ;
M: sqlite-db delete-sql* ( columns table -- sql )
M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
[
"delete from " %
%
" where " %
first second dup % " = :" % %
] "" make ;
"delete from " 0% 0%
" where " 0%
find-primary-key
sql-spec-column-name dup 0% " = " 0% bind%
] sqlite-make ;
: select-interval ( interval name -- )
;
! : select-interval ( interval name -- ) ;
! : select-sequence ( seq name -- ) ;
: select-sequence ( seq name -- )
;
M: sqlite-db bind% ( spec -- )
dup 1, sql-spec-column-name ":" swap append 0% ;
! dup 1, sql-spec-column-name
! dup 0% " = " 0% ":" swap append 0% ;
M: sqlite-db select-sql ( columns table -- sql )
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
"select ROWID, " %
over [ ", " % ] [ second % ] interleave
" from " % %
" where " %
] "" make ;
"select " 0%
over [ ", " 0% ]
[ dup sql-spec-column-name 0% 2, ] interleave
M: sqlite-db tuple>params ( columns tuple -- obj )
[
>r [ second ":" swap append ] keep r>
dupd >r first r> get-slot-named swap
third 3array
] curry map ;
" from " 0% 0%
[ sql-spec-slot-name swap get-slot-named ] with subset
" where " 0%
[ ", " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
";" 0%
] sqlite-make ;
: sqlite-db-modifiers ( -- hashtable )
M: sqlite-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
@ -168,32 +182,27 @@ M: sqlite-db tuple>params ( columns tuple -- obj )
{ +not-null+ "not null" }
} ;
M: sqlite-db sql-modifiers* ( modifiers -- str )
sqlite-db-modifiers swap [
dup array? [
first2
>r swap at r> number>string*
" " swap 3append
] [
swap at
] if
] with map [ ] subset ;
M: sqlite-db compound-modifier ( str obj -- newstr )
compound-type ;
: sqlite-type-hash ( -- assoc )
M: sqlite-db compound-type ( str seq -- newstr )
over {
{ "default" [ first number>string join-space ] }
[ 2drop ] ! "no sqlite compound data type" 3array throw ]
} case ;
M: sqlite-db type-table ( -- assoc )
H{
{ +native-id+ "integer primary key" }
{ INTEGER "integer" }
{ SERIAL "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
{ TIMESTAMP "timestamp" }
{ DOUBLE "real" }
} ;
M: sqlite-db >sql-type ( obj -- str )
dup pair? [
first >sql-type
] [
sqlite-type-hash at* [ T{ no-sql-type } throw ] unless
] if ;
M: sqlite-db create-type-table
type-table ;
! HOOK: get-column-value ( n result-set type -- )
! M: sqlite get-column-value { { "TEXT" get-text-column } {

104
extra/db/tuples/tuples-tests.factor
View File

@ -1,70 +1,118 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.sqlite db.tuples
db.types continuations namespaces db.postgresql math ;
! tools.time ;
USING: io.files kernel tools.test db db.tuples
db.types continuations namespaces db.postgresql math
prettyprint tools.walker db.sqlite ;
IN: temporary
TUPLE: person the-id the-name the-number real ;
TUPLE: person the-id the-name the-number the-real ;
: <person> ( name age real -- person )
{
set-person-the-name
set-person-the-number
set-person-real
set-person-the-real
} person construct ;
: <assigned-person> ( id name number real -- obj )
: <assigned-person> ( id name number the-real -- obj )
<person> [ set-person-the-id ] keep ;
SYMBOL: the-person
SYMBOL: the-person1
SYMBOL: the-person2
: test-tuples ( -- )
[ person drop-table ] [ drop ] recover
[ ] [ person create-table ] unit-test
[ ] [ the-person get insert-tuple ] unit-test
[ ] [ the-person1 get insert-tuple ] unit-test
[ 1 ] [ the-person get person-the-id ] unit-test
[ 1 ] [ the-person1 get person-the-id ] unit-test
200 the-person get set-person-the-number
200 the-person1 get set-person-the-number
[ ] [ the-person get update-tuple ] unit-test
[ ] [ the-person1 get update-tuple ] unit-test
[ ] [ the-person get delete-tuple ] unit-test
; ! 1 [ ] [ person drop-table ] unit-test ;
[ T{ person f 1 "billy" 200 3.14 } ]
[ T{ person f 1 } select-tuple ] unit-test
[ ] [ the-person2 get insert-tuple ] unit-test
[
{
T{ person f 1 "billy" 200 3.14 }
T{ person f 2 "johnny" 10 3.14 }
}
] [ T{ person f f f f 3.14 } select-tuples ] unit-test
[ ] [ the-person1 get delete-tuple ] unit-test
[ f ] [ T{ person f 1 } select-tuple ] unit-test
[ ] [ person drop-table ] unit-test ;
: test-sqlite ( -- )
"tuples-test.db" resource-path <sqlite-db> [
"tuples-test.db" resource-path sqlite-db [
test-tuples
] with-db ;
: test-postgresql ( -- )
"localhost" "postgres" "" "factor-test" <postgresql-db> [
{ "localhost" "postgres" "" "factor-test" } postgresql-db [
test-tuples
] with-db ;
person "PERSON"
{
{ "the-id" "ID" SERIAL +native-id+ }
{ "the-id" "ID" +native-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "real" "REAL" DOUBLE { +default+ 0.3 } }
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
} define-persistent
"billy" 10 3.14 <person> the-person set
"billy" 10 3.14 <person> the-person1 set
"johnny" 10 3.14 <person> the-person2 set
! test-sqlite
test-postgresql
test-postgresql
! person "PERSON"
! {
! { "the-id" "ID" INTEGER +assigned-id+ }
! { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
! { "the-number" "AGE" INTEGER { +default+ 0 } }
! { "real" "REAL" DOUBLE { +default+ 0.3 } }
! } define-persistent
person "PERSON"
{
{ "the-id" "ID" INTEGER +assigned-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
} define-persistent
! 1 "billy" 20 6.28 <assigned-person> the-person set
1 "billy" 10 3.14 <assigned-person> the-person1 set
2 "johnny" 10 3.14 <assigned-person> the-person2 set
! test-sqlite
! test-postgresql
test-postgresql
TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ;
paste "PASTE"
{
{ "n" "ID" +native-id+ }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
{ "channel" "CHANNEL" TEXT }
{ "mode" "MODE" TEXT }
{ "contents" "CONTENTS" TEXT }
{ "date" "DATE" TIMESTAMP }
{ "annotations" { +has-many+ annotation } }
} define-persistent
annotation "ANNOTATION"
{
{ "n" "ID" +native-id+ }
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
{ "mode" "MODE" TEXT }
{ "contents" "CONTENTS" TEXT }
} define-persistent
{ "localhost" "postgres" "" "factor-test" } postgresql-db [
[ paste drop-table ] [ drop ] recover
[ annotation drop-table ] [ drop ] recover
[ paste drop-table ] [ drop ] recover
[ annotation drop-table ] [ drop ] recover
[ ] [ paste create-table ] unit-test
[ ] [ annotation create-table ] unit-test
] with-db

159
extra/db/tuples/tuples.factor
View File

@ -1,115 +1,100 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes db kernel namespaces
tuples words sequences slots slots.private math
math.parser io prettyprint db.types continuations ;
tuples words sequences slots math
math.parser io prettyprint db.types continuations
mirrors sequences.lib tools.walker combinators.lib ;
IN: db.tuples
: db-columns ( class -- obj ) "db-columns" word-prop ;
: define-persistent ( class table columns -- )
>r dupd "db-table" set-word-prop dup r>
[ relation? ] partition swapd
dupd [ spec>tuple ] with map
"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 ;
TUPLE: no-slot-named ;
: no-slot-named ( -- * ) T{ no-slot-named } throw ;
: set-primary-key ( key tuple -- )
[
class db-columns find-primary-key sql-spec-slot-name
] keep set-slot-named ;
: slot-spec-named ( str class -- slot-spec )
"slots" word-prop [ slot-spec-name = ] with find nip
[ no-slot-named ] unless* ;
! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj )
: offset-of-slot ( str obj -- n )
class slot-spec-named slot-spec-offset ;
HOOK: <insert-native-statement> db ( tuple -- obj )
HOOK: <insert-assigned-statement> db ( tuple -- obj )
: get-slot-named ( str obj -- value )
tuck offset-of-slot [ no-slot-named ] unless* slot ;
HOOK: <update-tuple-statement> db ( tuple -- obj )
HOOK: <update-tuples-statement> db ( tuple -- obj )
: set-slot-named ( value str obj -- )
tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
HOOK: <delete-tuple-statement> db ( tuple -- obj )
HOOK: <delete-tuples-statement> db ( tuple -- obj )
: primary-key-spec ( class -- spec )
db-columns [ primary-key? ] find nip ;
: primary-key ( tuple -- obj )
dup class primary-key-spec get-slot-named ;
: set-primary-key ( obj tuple -- )
[ class primary-key-spec first ] keep
set-slot-named ;
: cache-statement ( columns class assoc quot -- statement )
[ db-table dupd ] swap
[ <prepared-statement> ] 3compose cache nip ; inline
HOOK: create-sql db ( columns table -- seq )
HOOK: drop-sql db ( columns table -- seq )
HOOK: insert-sql* db ( columns table -- slot-names sql )
HOOK: update-sql* db ( columns table -- slot-names sql )
HOOK: delete-sql* db ( columns table -- slot-names sql )
HOOK: select-sql db ( tuple -- statement )
HOOK: <select-by-slots-statement> db ( tuple -- tuple )
HOOK: row-column-typed db ( result-set n type -- sql )
HOOK: sql-type>factor-type db ( obj type -- obj )
HOOK: tuple>params db ( columns tuple -- obj )
HOOK: insert-tuple* db ( tuple statement -- )
: resulting-tuple ( row out-params -- tuple )
dup first sql-spec-class construct-empty [
[
>r [ sql-spec-type sql-type>factor-type ] keep
sql-spec-slot-name r> set-slot-named
] curry 2each
] keep ;
HOOK: make-slot-names* db ( quot -- seq )
HOOK: column-slot-name% db ( spec -- )
HOOK: column-bind-name% db ( spec -- )
: query-tuples ( statement -- seq )
[ statement-out-params ] keep query-results [
[ sql-row swap resulting-tuple ] with query-map
] with-disposal ;
: query-modify-tuple ( tuple statement -- )
[ query-results [ sql-row ] with-disposal ] keep
statement-out-params rot [
>r [ sql-spec-type sql-type>factor-type ] keep
sql-spec-slot-name r> set-slot-named
] curry 2each ;
: make-slots-names ( quot -- seq str )
[ make-slot-names* ] "" make ; inline
: slot-name% ( seq -- ) first % ;
: column-name% ( seq -- ) second % ;
: column-type% ( seq -- ) third % ;
: sql-props ( class -- columns table )
dup db-columns swap db-table ;
: insert-sql ( columns class -- statement )
db get db-insert-statements [ insert-sql* ] cache-statement ;
: create-table ( class -- ) create-sql-statement execute-statement ;
: drop-table ( class -- ) drop-sql-statement execute-statement ;
: update-sql ( columns class -- statement )
db get db-update-statements [ update-sql* ] cache-statement ;
: insert-native ( tuple -- )
dup class <insert-native-statement>
[ bind-tuple ] 2keep insert-tuple* ;
: delete-sql ( columns class -- statement )
db get db-delete-statements [ delete-sql* ] cache-statement ;
: tuple-statement ( columns tuple quot -- statement )
>r [ tuple>params ] 2keep class r> call
2dup . .
[ bind-statement ] keep ;
: make-tuple-statement ( tuple columns-quot statement-quot -- statement )
>r [ class db-columns ] swap compose keep
r> tuple-statement ;
: do-tuple-statement ( tuple columns-quot statement-quot -- )
make-tuple-statement execute-statement ;
: create-table ( class -- )
dup db-columns swap db-table create-sql sql-command ;
: drop-table ( class -- )
dup db-columns swap db-table drop-sql sql-command ;
: insert-assigned ( tuple -- )
dup class <insert-assigned-statement>
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
[
[ maybe-remove-id ] [ insert-sql ]
make-tuple-statement insert-statement
] keep set-primary-key ;
dup class db-columns find-primary-key assigned-id? [
insert-assigned
] [
insert-native
] if ;
: update-tuple ( tuple -- )
[ ] [ update-sql ] do-tuple-statement ;
dup class <update-tuple-statement>
[ bind-tuple ] keep execute-statement ;
: update-tuples ( seq -- )
<update-tuples-statement> execute-statement ;
: delete-tuple ( tuple -- )
[ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
dup class <delete-tuple-statement>
[ bind-tuple ] keep execute-statement ;
: select-tuple ( tuple -- )
[ select-sql ] keep do-query ;
: setup-select ( tuple -- statement )
dup dup class <select-by-slots-statement>
[ bind-tuple ] keep ;
: persist ( tuple -- )
dup primary-key [ update-tuple ] [ insert-tuple ] if ;
: define-persistent ( class table columns -- )
>r dupd "db-table" set-word-prop r>
"db-columns" set-word-prop ;
: define-relation ( spec -- )
drop ;
: select-tuples ( tuple -- tuple ) setup-select query-tuples ;
: select-tuple ( tuple -- tuple/f ) select-tuples ?first ;

205
extra/db/types/types.factor
View File

@ -1,21 +1,50 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs db kernel math math.parser
sequences continuations ;
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
mirrors tuples combinators ;
IN: db.types
HOOK: modifier-table db ( -- hash )
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 )
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
! ID is the Primary key
! +native-id+ can be a columns type or a modifier
SYMBOL: +native-id+
! +assigned-id+ can only be a modifier
SYMBOL: +assigned-id+
: primary-key? ( spec -- ? )
[ { +native-id+ +assigned-id+ } member? ] contains? ;
: (primary-key?) ( obj -- ? )
{ +native-id+ +assigned-id+ } member? ;
: contains-id? ( columns id -- ? )
swap [ member? ] with contains? ;
: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
: native-id? ( columns -- ? ) +native-id+ contains-id? ;
: primary-key? ( spec -- ? )
sql-spec-primary-key (primary-key?) ;
: normalize-spec ( spec -- )
dup sql-spec-type dup (primary-key?) [
swap set-sql-spec-primary-key
] [
drop dup sql-spec-modifiers [
(primary-key?)
] deep-find
[ swap set-sql-spec-primary-key ] [ drop ] if*
] if ;
: find-primary-key ( specs -- obj )
[ sql-spec-primary-key ] find nip ;
: native-id? ( spec -- ? )
sql-spec-primary-key +native-id+ = ;
: assigned-id? ( spec -- ? )
sql-spec-primary-key +assigned-id+ = ;
SYMBOL: +foreign-id+
! Same concept, SQLite has autoincrement, PostgreSQL has serial
SYMBOL: +autoincrement+
@ -28,40 +57,168 @@ SYMBOL: +not-null+
SYMBOL: +has-many+
SYMBOL: SERIAL
SYMBOL: INTEGER
SYMBOL: DOUBLE
SYMBOL: BOOLEAN
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
SYMBOL: INTEGER
SYMBOL: BIG_INTEGER
SYMBOL: DOUBLE
SYMBOL: REAL
SYMBOL: BOOLEAN
SYMBOL: TEXT
SYMBOL: VARCHAR
SYMBOL: TIMESTAMP
SYMBOL: DATE
SYMBOL: BIG_INTEGER
: 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
dup normalize-spec ;
: sql-type-hash ( -- assoc )
H{
{ INTEGER "integer" }
{ TEXT "text" }
{ VARCHAR "varchar" }
{ DOUBLE "real" }
{ TIMESTAMP "timestamp" }
} ;
TUPLE: no-sql-type ;
: no-sql-type ( -- * ) T{ no-sql-type } throw ;
HOOK: sql-modifiers* db ( modifiers -- str )
HOOK: >sql-type db ( obj -- str )
! HOOK: >factor-type db ( obj -- obj )
TUPLE: no-sql-modifier ;
: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ;
: number>string* ( n/str -- str )
dup number? [ number>string ] when ;
: maybe-remove-id ( columns -- obj )
[ +native-id+ swap member? not ] subset ;
: maybe-remove-id ( specs -- obj )
[ native-id? not ] subset ;
: remove-id ( columns -- obj )
[ primary-key? not ] subset ;
: remove-relations ( specs -- newcolumns )
[ relation? not ] subset ;
: sql-modifiers ( spec -- seq )
3 tail sql-modifiers* ;
: remove-id ( specs -- obj )
[ sql-spec-primary-key not ] subset ;
! SQLite Types: http://www.sqlite.org/datatype3.html
! NULL INTEGER REAL TEXT BLOB
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
: lookup-modifier ( obj -- str )
dup array? [
unclip lookup-modifier swap compound-modifier
] [
modifier-table at*
[ "unknown modifier" throw ] unless
] if ;
: lookup-type* ( obj -- str )
dup array? [
first lookup-type*
] [
type-table at*
[ no-sql-type ] unless
] if ;
: lookup-create-type ( obj -- str )
dup array? [
unclip lookup-create-type swap compound-type
] [
dup create-type-table at*
[ nip ] [ drop lookup-type* ] if
] if ;
: lookup-type ( obj create? -- str )
[ lookup-create-type ] [ lookup-type* ] if ;
: single-quote ( str -- newstr )
"'" swap "'" 3append ;
: double-quote ( str -- newstr )
"\"" swap "\"" 3append ;
: paren ( str -- newstr )
"(" swap ")" 3append ;
: join-space ( str1 str2 -- newstr )
" " swap 3append ;
: modifiers ( spec -- str )
sql-spec-modifiers
[ lookup-modifier ] map " " join
dup empty? [ " " swap append ] unless ;
SYMBOL: building-seq
: get-building-seq ( n -- seq )
building-seq get nth ;
: n, get-building-seq push ;
: n% get-building-seq push-all ;
: n# >r number>string r> n% ;
: 0, 0 n, ;
: 0% 0 n% ;
: 0# 0 n# ;
: 1, 1 n, ;
: 1% 1 n% ;
: 1# 1 n# ;
: 2, 2 n, ;
: 2% 2 n% ;
: 2# 2 n# ;
: nmake ( quot exemplars -- seqs )
dup length dup zero? [ 1+ ] when
[
[
[ drop 1024 swap new-resizable ] 2map
[ building-seq set call ] keep
] 2keep >r [ like ] 2map r> firstn
] with-scope ;
HOOK: bind% db ( spec -- )
TUPLE: no-slot-named ;
: no-slot-named ( -- * ) T{ no-slot-named } throw ;
: slot-spec-named ( str class -- slot-spec )
"slots" word-prop [ slot-spec-name = ] with find nip
[ no-slot-named ] unless* ;
: offset-of-slot ( str obj -- n )
class slot-spec-named slot-spec-offset ;
: get-slot-named ( str obj -- value )
tuck offset-of-slot [ no-slot-named ] unless* slot ;
: set-slot-named ( value str obj -- )
tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
: tuple>filled-slots ( tuple -- alist )
dup <mirror> mirror-slots [ slot-spec-name ] map
swap tuple-slots 2array flip [ nip ] assoc-subset ;
: tuple>params ( specs tuple -- obj )
[
>r dup sql-spec-type swap sql-spec-slot-name r>
get-slot-named swap
] curry { } map>assoc ;
: sql-type>factor-type ( obj type -- obj )
dup array? [ first ] when
{
{ +native-id+ [ string>number ] }
{ INTEGER [ string>number ] }
{ DOUBLE [ string>number ] }
{ REAL [ string>number ] }
{ TEXT [ ] }
{ VARCHAR [ ] }
[ "no conversion from sql type to factor type" throw ]
} case ;

2
extra/http/basic-authentication/basic-authentication.factor
View File

@ -61,5 +61,5 @@ SYMBOL: realms
#! Check if the user is authenticated in the given realm
#! to run the specified quotation. If not, use Basic
#! Authentication to ask for authorization details.
over "Authorization" header-param authorization-ok?
over "authorization" header-param authorization-ok?
[ nip call ] [ drop authentication-error ] if ;

4
extra/http/server/responders/responders.factor
View File

@ -77,7 +77,7 @@ SYMBOL: max-post-request
1024 256 * max-post-request set-global
: content-length ( header -- n )
"Content-Length" swap at string>number dup [
"content-length" peek-at string>number dup [
dup max-post-request get > [
"Content-Length > max-post-request" throw
] when
@ -136,7 +136,7 @@ LOG: log-headers DEBUG
: host ( -- string )
#! The host the current responder was called from.
"Host" header-param ":" split1 drop ;
"host" header-param ":" split1 drop ;
: add-responder ( responder -- )
#! Add a responder object to the list.

4
extra/io/windows/launcher/launcher.factor
View File

@ -146,8 +146,8 @@ M: windows-io kill-process* ( handle -- )
: wait-loop ( -- )
processes get dup assoc-empty?
[ drop f nap drop ]
[ wait-for-processes [ 100 nap drop ] when ] if ;
[ drop f sleep-until ]
[ wait-for-processes [ 100 sleep ] when ] if ;
SYMBOL: wait-thread

9
extra/ogg/player/player.factor
View File

@ -14,7 +14,7 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays
sequences libc shuffle alien.c-types system openal math
namespaces threads shuffle opengl arrays ui.gadgets.worlds
combinators math.parser ui.gadgets ui.render opengl.gl ui
continuations io.files hints combinators.lib sequences.lib ;
continuations io.files hints combinators.lib sequences.lib debugger ;
IN: ogg.player
@ -149,7 +149,7 @@ HINTS: yuv>rgb byte-array byte-array ;
dup player-gadget [
dup { player-td player-yuv } get-slots theora_decode_YUVout drop
dup player-rgb over player-yuv yuv>rgb
dup player-gadget find-world draw-world
dup player-gadget relayout yield
] when ;
: num-audio-buffers-processed ( player -- player n )
@ -177,7 +177,7 @@ HINTS: yuv>rgb byte-array byte-array ;
: append-audio ( player -- player bool )
num-audio-buffers-processed {
{ [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
{ [ over player-buffers length 2 = over zero? and ] [ 0 sleep drop f ] }
{ [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }
{ [ t ] [ fill-processed-audio-buffer t ] }
} cond ;
@ -602,8 +602,7 @@ M: theora-gadget draw-gadget* ( gadget -- )
parse-remaining-headers
initialize-decoder
dup player-gadget [ initialize-gui ] when*
[ decode ] [ drop ] recover
! decode
[ decode ] try
wait-for-sound
cleanup
drop ;

3
extra/random-tester/random-tester.factor
View File

@ -1,5 +1,6 @@
USING: compiler continuations io kernel math namespaces
prettyprint quotations random sequences vectors ;
prettyprint quotations random sequences vectors
compiler.units ;
USING: random-tester.databank random-tester.safe-words ;
IN: random-tester

4
extra/sequences/lib/lib-tests.factor
View File

@ -20,8 +20,6 @@ IN: temporary
[ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test
[ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test
[ -4 ] [ 1 -4 [ abs ] higher ] unit-test
[ 1 ] [ 1 -4 [ abs ] lower ] unit-test
@ -80,4 +78,4 @@ IN: temporary
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test

13
extra/sequences/lib/lib.factor
View File

@ -18,8 +18,9 @@ IN: sequences.lib
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
MACRO: nfirst ( n -- )
[ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
MACRO: firstn ( n -- )
[ [ swap nth ] curry
[ keep ] curry ] map concat [ drop ] compose ;
: prepare-index ( seq quot -- seq n quot )
>r dup length r> ; inline
@ -182,6 +183,14 @@ PRIVATE>
: ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline
: ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline
USE: continuations
: ?subseq ( from to seq -- subseq )
>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 ;

5
extra/tools/threads/threads.factor
View File

@ -8,7 +8,10 @@ heaps.private system math math.parser ;
: thread. ( thread -- )
dup thread-id pprint-cell
dup thread-name over [ write-object ] with-cell
dup thread-state "running" or [ write ] with-cell
dup thread-state [
[ dup self eq? "running" "yield" ? ] unless*
write
] with-cell
[
thread-sleep-entry [
entry-key millis [-] number>string write

2
extra/ui/cocoa/cocoa.factor
View File

@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window?
: event-loop ( -- )
event-loop? [
[
[ NSApp do-events ui-step 10 sleep ] ui-try
[ NSApp do-events ui-step ui-wait ] ui-try
] with-autorelease-pool event-loop
] when ;

12
extra/ui/gadgets/gadgets.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables kernel models math namespaces sequences
quotations math.vectors combinators sorting vectors dlists
models ;
models threads ;
IN: ui.gadgets
TUPLE: rect loc dim ;
@ -178,13 +178,17 @@ M: array gadget-text*
: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
SYMBOL: ui-thread
: notify-ui-thread ( -- ) ui-thread get interrupt ;
: layout-queue ( -- queue ) \ layout-queue get ;
: layout-later ( gadget -- )
#! When unit testing gadgets without the UI running, the
#! invalid queue is not initialized and we simply ignore
#! invalidation requests.
layout-queue [ push-front ] [ drop ] if* ;
layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
DEFER: relayout
@ -256,11 +260,11 @@ M: gadget layout* drop ;
: queue-graft ( gadget -- )
{ f t } over set-gadget-graft-state
graft-queue push-front ;
graft-queue push-front notify-ui-thread ;
: queue-ungraft ( gadget -- )
{ t f } over set-gadget-graft-state
graft-queue push-front ;
graft-queue push-front notify-ui-thread ;
: graft-later ( gadget -- )
dup gadget-graft-state {

4
extra/ui/ui.factor
View File

@ -133,6 +133,9 @@ SYMBOL: ui-hook
: ui-step ( -- )
[ notify-queued layout-queued redraw-worlds ] assert-depth ;
: ui-wait ( -- )
10 sleep ;
: open-world-window ( world -- )
dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
@ -155,6 +158,7 @@ M: object close-window
find-world [ ungraft ] when* ;
: start-ui ( -- )
self ui-thread set-global
restore-windows? [
restore-windows
] [

66
extra/ui/windows/windows.factor
View File

@ -15,8 +15,11 @@ TUPLE: windows-ui-backend ;
: lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
: enum-clipboard ( -- seq )
0 [ EnumClipboardFormats win32-error dup dup 0 > ] [ ]
{ } unfold nip ;
0
[ EnumClipboardFormats win32-error dup dup 0 > ]
[ ]
[ drop ]
unfold nip ;
: with-clipboard ( quot -- )
f OpenClipboard win32-error=0/f
@ -40,13 +43,12 @@ TUPLE: windows-ui-backend ;
: copy ( str -- )
lf>crlf [
string>u16-alien
f OpenClipboard win32-error=0/f
EmptyClipboard win32-error=0/f
GMEM_MOVEABLE over length 1+ GlobalAlloc
dup win32-error=0/f
dup GlobalLock dup win32-error=0/f
rot dup length memcpy
swapd byte-array>memory
dup GlobalUnlock win32-error=0/f
CF_UNICODETEXT swap SetClipboardData win32-error=0/f
] with-clipboard ;
@ -72,31 +74,29 @@ SYMBOL: mouse-captured
: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
: adjust-RECT ( RECT -- )
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( width height -- RECT )
"RECT" <c-object> [ set-RECT-bottom ] keep [ set-RECT-right ] keep ;
: make-adjusted-RECT ( width height -- RECT )
make-RECT dup adjust-RECT ;
: get-RECT-dimensions ( RECT -- width height )
[ RECT-right ] keep [ RECT-left - ] keep
[ RECT-bottom ] keep RECT-top - ;
: get-RECT-top-left ( RECT -- x y )
[ RECT-left ] keep RECT-top ;
: get-RECT-dimensions ( RECT -- x y width height )
[ get-RECT-top-left ] keep
[ RECT-right ] keep [ RECT-left - ] keep
[ RECT-bottom ] keep RECT-top - ;
: handle-wm-paint ( hWnd uMsg wParam lParam -- )
#! wParam and lParam are unused
#! only paint if width/height both > 0
3drop window draw-world ;
: handle-wm-size ( hWnd uMsg wParam lParam -- )
[ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array 2nip
2nip
[ lo-word ] keep hi-word 2array
dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ;
: handle-wm-move ( hWnd uMsg wParam lParam -- )
2nip
[ lo-word ] keep hi-word 2array
swap window set-world-loc ;
: wm-keydown-codes ( -- key )
H{
{ 8 "BACKSPACE" }
@ -240,7 +240,7 @@ M: windows-ui-backend (close-window)
: mouse-absolute>relative ( lparam handle -- array )
>r >lo-hi r>
0 0 make-RECT [ GetWindowRect win32-error=0/f ] keep
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
get-RECT-top-left 2array v- ;
: mouse-event>gesture ( uMsg -- button )
@ -317,6 +317,7 @@ M: windows-ui-backend (close-window)
{ [ dup WM_PAINT = ]
[ drop 4dup handle-wm-paint DefWindowProc ] }
{ [ dup WM_SIZE = ] [ drop handle-wm-size 0 ] }
{ [ dup WM_MOVE = ] [ drop handle-wm-move 0 ] }
! Keyboard events
{ [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ]
@ -353,7 +354,7 @@ M: windows-ui-backend (close-window)
{
{ [ windows get empty? ] [ drop ] }
{ [ dup peek-message? ] [
>r [ ui-step 10 sleep ] ui-try
>r [ ui-step ui-wait ] ui-try
r> event-loop
] }
{ [ dup MSG-message WM_QUIT = ] [ drop ] }
@ -383,13 +384,26 @@ M: windows-ui-backend (close-window)
RegisterClassEx dup win32-error=0/f
] when ;
: create-window ( width height -- hwnd )
: adjust-RECT ( RECT -- )
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( world -- RECT )
dup world-loc { 40 40 } vmax dup rot rect-dim v+
"RECT" <c-object>
over first over set-RECT-right
swap second over set-RECT-bottom
over first over set-RECT-left
swap second over set-RECT-top ;
: make-adjusted-RECT ( rect -- RECT )
make-RECT dup adjust-RECT ;
: create-window ( rect -- hwnd )
make-adjusted-RECT
>r class-name-ptr get-global f r>
>r >r >r ex-style r> r>
{ WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
CW_USEDEFAULT dup r>
get-RECT-dimensions
r> get-RECT-dimensions
f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
: show-window ( hWnd -- )
@ -424,7 +438,7 @@ M: windows-ui-backend (close-window)
get-dc dup setup-pixel-format dup get-rc ;
M: windows-ui-backend (open-window) ( world -- )
[ rect-dim first2 create-window dup setup-gl ] keep
[ create-window dup setup-gl ] keep
[ f <win> ] keep
[ swap win-hWnd register-window ] 2keep
dupd set-world-handle
@ -445,8 +459,8 @@ M: windows-ui-backend raise-window* ( world -- )
M: windows-ui-backend set-title ( string world -- )
world-handle [ nip win-hWnd WM_SETTEXT 0 ] 2keep
dup win-title [ free ] when*
>r malloc-u16-string r>
dupd set-win-title alien-address
>r malloc-u16-string dup r>
set-win-title alien-address
SendMessage drop ;
M: windows-ui-backend ui

2
extra/ui/x11/x11.factor
View File

@ -178,7 +178,7 @@ M: world client-event
next-event dup
None XFilterEvent zero? [ drop wait-event ] unless
] [
ui-step 10 sleep wait-event
ui-step ui-wait wait-event
] if ;
: do-events ( -- )

8
extra/webapps/cgi/cgi.factor
View File

@ -31,13 +31,13 @@ SYMBOL: cgi-root
"method" get >upper "REQUEST_METHOD" set
"raw-query" get "QUERY_STRING" set
"Cookie" header-param "HTTP_COOKIE" set
"cookie" header-param "HTTP_COOKIE" set
"User-Agent" header-param "HTTP_USER_AGENT" set
"Accept" header-param "HTTP_ACCEPT" set
"user-agent" header-param "HTTP_USER_AGENT" set
"accept" header-param "HTTP_ACCEPT" set
post? [
"Content-Type" header-param "CONTENT_TYPE" set
"content-type" header-param "CONTENT_TYPE" set
"raw-response" get length number>string "CONTENT_LENGTH" set
] when
] H{ } make-assoc ;

2
extra/webapps/file/file.factor
View File

@ -25,7 +25,7 @@ SYMBOL: doc-root
: last-modified-matches? ( filename -- bool )
file-http-date dup [
"If-Modified-Since" header-param =
"if-modified-since" header-param =
] when ;
: not-modified-response ( -- )

2
extra/webapps/fjsc/fjsc.factor
View File

@ -25,7 +25,7 @@ IN: webapps.fjsc
: compile-url ( url -- )
#! Compile the factor code at the given url, return the javascript.
dup "http:" head? [ "Unable to access remote sites." throw ] when
"http://" "Host" header-param rot 3append http-get compile "();" write flush ;
"http://" "host" header-param rot 3append http-get compile "();" write flush ;
\ compile-url {
{ "url" v-required }