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

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

db4
Slava Pestov 2008-06-12 18:59:25 -05:00
parent 61a9a8c0ec 216bf23e6c
commit 078b2025b9
12 changed files with 169 additions and 88 deletions

4
extra/db/db.factor
View File

@ -35,7 +35,7 @@ HOOK: db-close db ( handle -- )
handle>> db-close
] with-variable ;
TUPLE: statement handle sql in-params out-params bind-params bound? type ;
TUPLE: statement handle sql in-params out-params bind-params bound? type retries ;
TUPLE: simple-statement < statement ;
TUPLE: prepared-statement < statement ;
@ -89,7 +89,7 @@ M: object execute-statement* ( statement type -- )
swap >>out-params
swap >>in-params
swap >>sql ;
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;

4
extra/db/postgresql/lib/lib.factor
View File

@ -5,7 +5,7 @@ quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser combinators
libc shuffle calendar.format byte-arrays destructors prettyprint
accessors strings serialize io.encodings.binary io.encodings.utf8
alien.strings io.streams.byte-array inspector ;
alien.strings io.streams.byte-array inspector present urls ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
@ -84,6 +84,7 @@ M: postgresql-result-null summary ( obj -- str )
{ TIME [ dup [ timestamp>hms ] when default-param-value ] }
{ DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] }
{ TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] }
{ URL [ dup [ present ] when default-param-value ] }
[ drop default-param-value ]
} case 2array
] 2map flip dup empty? [
@ -164,6 +165,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
{ TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] }
{ DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] }
{ BLOB [ pq-get-blob ] }
{ URL [ pq-get-string dup [ >url ] when ] }
{ FACTOR-BLOB [
pq-get-blob
dup [ bytes>object ] when ] }

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

@ -239,6 +239,7 @@ M: postgresql-db persistent-table ( -- hashtable )
{ TIMESTAMP { "timestamp" "timestamp" f } }
{ BLOB { "bytea" "bytea" f } }
{ FACTOR-BLOB { "bytea" "bytea" f } }
{ URL { "varchar" "varchar" f } }
{ +foreign-id+ { f f "references" } }
{ +autoincrement+ { f f "autoincrement" } }
{ +unique+ { f f "unique" } }

59
extra/db/queries/queries.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces sequences random
strings math.parser math.intervals combinators
math.bitfields.lib namespaces.lib db db.tuples db.types ;
math.bitfields.lib namespaces.lib db db.tuples db.types
sequences.lib db.sql classes words shuffle arrays ;
IN: db.queries
GENERIC: where ( specs obj -- )
@ -99,16 +100,15 @@ M: string where ( spec obj -- ) object-where ;
] with filter ;
: where-clause ( tuple specs -- )
dupd filter-slots
dup empty? [
2drop
dupd filter-slots [
drop
] [
" where " 0% [
" and " 0%
] [
2dup slot-name>> swap get-slot-named where
] interleave drop
] if ;
] if-empty ;
M: db <delete-tuples-statement> ( tuple table -- sql )
[
@ -146,15 +146,52 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
number>string " limit " prepend append
] curry change-sql drop ;
: make-advanced-statement ( tuple advanced -- tuple' )
: make-query ( tuple query -- tuple' )
dupd
{
[ group>> [ do-group ] [ drop ] if* ]
[ order>> [ do-order ] [ drop ] if* ]
[ group>> [ do-group ] [ drop ] if-seq ]
[ order>> [ do-order ] [ drop ] if-seq ]
[ limit>> [ do-limit ] [ drop ] if* ]
[ offset>> [ do-offset ] [ drop ] if* ]
} 2cleave ;
M: db <advanced-select-statement> ( tuple class group order limit offset -- tuple )
advanced-statement boa
[ <select-by-slots-statement> ] dip make-advanced-statement ;
M: db <query> ( tuple class query -- tuple )
[ <select-by-slots-statement> ] dip make-query ;
! select ID, NAME, SCORE from EXAM limit 1 offset 3
: select-tuples* ( tuple -- statement )
dup
[
select 0,
dup class db-columns [ ", " 0, ]
[ dup column-name>> 0, 2, ] interleave
from 0,
class word-name 0,
] { { } { } { } } nmake
>r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ;
M: db <count-statement> ( tuple class groups -- statement )
\ query new
swap >>group
[ [ "select count(*) from " 0% 0% where-clause ] query-make ]
dip make-query ;
: where-clause* ( tuple specs -- )
dupd filter-slots [
drop
] [
\ where 0,
[ 2dup slot-name>> swap get-slot-named where ] map 2array 0,
drop
] if-empty ;
: delete-tuple* ( tuple -- sql )
dup
[
delete 0, from 0, dup class db-table 0,
dup class db-columns where-clause*
] { { } { } { } } nmake
>r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ;

30
extra/db/sql/sql.factor
View File

@ -23,12 +23,27 @@ DEFER: sql%
: sql-function, ( seq function -- )
sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ;
: sql-where ( seq -- )
B
[
[ second 0, ]
[ first 0, ]
[ third 1, \ ? 0, ] tri
] each ;
: sql-array% ( array -- )
B
unclip
{
{ \ create [ "create table" sql% ] }
{ \ drop [ "drop table" sql% ] }
{ \ insert [ "insert into" sql% ] }
{ \ update [ "update" sql% ] }
{ \ delete [ "delete" sql% ] }
{ \ select [ B "select" sql% "," (sql-interleave) ] }
{ \ columns [ "," (sql-interleave) ] }
{ \ from [ "from" "," sql-interleave ] }
{ \ where [ "where" "and" sql-interleave ] }
{ \ where [ B "where" 0, sql-where ] }
{ \ group-by [ "group by" "," sql-interleave ] }
{ \ having [ "having" "," sql-interleave ] }
{ \ order-by [ "order by" "," sql-interleave ] }
@ -49,7 +64,7 @@ DEFER: sql%
ERROR: no-sql-match ;
: sql% ( obj -- )
{
{ [ dup string? ] [ " " 0% 0% ] }
{ [ dup string? ] [ 0, ] }
{ [ dup array? ] [ sql-array% ] }
{ [ dup number? ] [ number>string sql% ] }
{ [ dup symbol? ] [ unparse sql% ] }
@ -59,13 +74,4 @@ ERROR: no-sql-match ;
} cond ;
: parse-sql ( obj -- sql in-spec out-spec in out )
[
unclip {
{ \ create [ "create table" sql% ] }
{ \ drop [ "drop table" sql% ] }
{ \ insert [ "insert into" sql% ] }
{ \ update [ "update" sql% ] }
{ \ delete [ "delete" sql% ] }
{ \ select [ "select" sql% ] }
} case [ sql% ] each
] { "" { } { } { } { } } nmake ;
[ [ sql% ] each ] { { } { } { } } nmake ;

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

@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser
namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
io.backend db.errors ;
io.backend db.errors present urls ;
IN: db.sqlite.lib
ERROR: sqlite-error < db-error n string ;
@ -107,6 +107,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
object>bytes
sqlite-bind-blob-by-name
] }
{ URL [ present sqlite-bind-text-by-name ] }
{ +db-assigned-id+ [ sqlite-bind-int-by-name ] }
{ +random-id+ [ sqlite-bind-int64-by-name ] }
{ NULL [ sqlite-bind-null-by-name ] }
@ -147,6 +148,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
{ TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
{ DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
{ BLOB [ sqlite-column-blob ] }
{ URL [ sqlite3_column_text dup [ >url ] when ] }
{ FACTOR-BLOB [
sqlite-column-blob
dup [ bytes>object ] when

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

@ -182,6 +182,7 @@ M: sqlite-db persistent-table ( -- assoc )
{ DOUBLE { "real" "real" } }
{ BLOB { "blob" "blob" } }
{ FACTOR-BLOB { "blob" "blob" } }
{ URL { "text" "text" } }
{ +autoincrement+ { f f "autoincrement" } }
{ +unique+ { f f "unique" } }
{ +default+ { f f "default" } }

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

@ -4,26 +4,27 @@ USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitfields.lib
math.ranges strings sequences.lib ;
math.ranges strings sequences.lib urls ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob ;
ts date time blob factor-blob url ;
: <person> ( name age real ts date time blob factor-blob -- person )
{
set-person-the-name
set-person-the-number
set-person-the-real
set-person-ts
set-person-date
set-person-time
set-person-blob
set-person-factor-blob
} person construct ;
: <person> ( name age real ts date time blob factor-blob url -- person )
person new
swap >>url
swap >>factor-blob
swap >>blob
swap >>time
swap >>date
swap >>ts
swap >>the-real
swap >>the-number
swap >>the-name ;
: <user-assigned-person> ( id name age real ts date time blob factor-blob -- person )
<person> [ set-person-the-id ] keep ;
: <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
<person>
swap >>the-id ;
SYMBOL: person1
SYMBOL: person2
@ -103,6 +104,7 @@ SYMBOL: person4
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f
H{ { 1 2 } { 3 4 } { 5 "lol" } }
URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search"
}
] [ T{ person f 4 } select-tuple ] unit-test
@ -120,19 +122,20 @@ SYMBOL: person4
{ "time" "T" TIME }
{ "blob" "B" BLOB }
{ "factor-blob" "FB" FACTOR-BLOB }
{ "url" "U" URL }
} define-persistent
"billy" 10 3.14 f f f f f <person> person1 set
"johnny" 10 3.14 f f f f f <person> person2 set
"billy" 10 3.14 f f f f f f <person> person1 set
"johnny" 10 3.14 f f f f f f <person> person2 set
"teddy" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <person> person3 set
B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set
"eddie" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ;
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <person> person4 set ;
: user-assigned-person-schema ( -- )
person "PERSON"
@ -146,20 +149,21 @@ SYMBOL: person4
{ "time" "T" TIME }
{ "blob" "B" BLOB }
{ "factor-blob" "FB" FACTOR-BLOB }
{ "url" "U" URL }
} define-persistent
1 "billy" 10 3.14 f f f f f <user-assigned-person> person1 set
2 "johnny" 10 3.14 f f f f f <user-assigned-person> person2 set
1 "billy" 10 3.14 f f f f f f <user-assigned-person> person1 set
2 "johnny" 10 3.14 f f f f f f <user-assigned-person> person2 set
3 "teddy" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
f <user-assigned-person> person3 set
f f <user-assigned-person> person3 set
4 "eddie" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <user-assigned-person> person4 set ;
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;
TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ;
@ -227,7 +231,7 @@ TUPLE: exam id name score ;
: random-exam ( -- exam )
f
6 [ CHAR: a CHAR: b [a,b] random ] replicate >string
6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
100 random
exam boa ;
@ -340,7 +344,9 @@ TUPLE: exam id name score ;
}
] [
T{ exam } select-tuples
] unit-test ;
] unit-test
[ 4 ] [ T{ exam } f count-tuples ] unit-test ;
TUPLE: bignum-test id m n o ;
: <bignum-test> ( m n o -- obj )

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

@ -42,8 +42,9 @@ HOOK: <insert-user-assigned-statement> db ( class -- obj )
HOOK: <update-tuple-statement> db ( class -- obj )
HOOK: <delete-tuples-statement> db ( tuple class -- obj )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
TUPLE: advanced-statement group order offset limit ;
HOOK: <advanced-select-statement> db ( tuple class group order offset limit -- tuple )
TUPLE: query group order offset limit ;
HOOK: <query> db ( tuple class query -- statement' )
HOOK: <count-statement> db ( tuple class groups -- n )
HOOK: insert-tuple* db ( tuple statement -- )
@ -55,6 +56,7 @@ SINGLETON: retryable
[ make-retryable ] map
] [
retryable >>type
10 >>retries
] if ;
: regenerate-params ( statement -- statement )
@ -69,12 +71,13 @@ SINGLETON: retryable
] 2map >>bind-params ;
M: retryable execute-statement* ( statement type -- )
drop
[
[ query-results dispose t ]
[ ]
[ regenerate-params bind-statement* f ] cleanup
] curry 10 retry drop ;
drop [
[
[ query-results dispose t ]
[ ]
[ regenerate-params bind-statement* f ] cleanup
] curry
] [ retries>> ] bi retry drop ;
: resulting-tuple ( class row out-params -- tuple )
rot class new [
@ -146,12 +149,21 @@ M: retryable execute-statement* ( statement type -- )
: do-select ( exemplar-tuple statement -- tuples )
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
: query ( tuple query -- tuples )
>r dup dup class r> <query> do-select ;
: select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> do-select ;
: count-tuples ( tuple -- n )
select-tuples length ;
: select-tuple ( tuple -- tuple/f )
dup dup class f f f 1 <advanced-select-statement>
do-select ?first ;
dup dup class \ query new 1 >>limit <query> do-select ?first ;
: do-count ( exemplar-tuple statement -- tuples )
[
[ bind-tuple ] [ nip default-query ] 2bi
] with-disposal ;
: count-tuples ( tuple groups -- n )
>r dup dup class r> <count-statement> do-count
dup length 1 =
[ first first string>number ] [ [ first string>number ] map ] if ;

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

@ -65,7 +65,7 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
FACTOR-BLOB NULL ;
FACTOR-BLOB NULL URL ;
: spec>tuple ( class spec -- tuple )
3 f pad-right

47
extra/html/parser/printer/printer.factor
View File

@ -2,7 +2,7 @@ USING: assocs html.parser html.parser.utils combinators
continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings ;
strings ;
IN: html.parser.printer
SYMBOL: no-section
@ -16,7 +16,8 @@ TUPLE: state section ;
TUPLE: text-printer ;
TUPLE: ui-printer ;
TUPLE: src-printer ;
UNION: printer text-printer ui-printer src-printer ;
TUPLE: html-prettyprinter ;
UNION: printer text-printer ui-printer src-printer html-prettyprinter ;
HOOK: print-tag printer ( tag -- )
HOOK: print-text-tag printer ( tag -- )
HOOK: print-comment-tag printer ( tag -- )
@ -47,7 +48,7 @@ M: printer print-comment-tag ( tag -- )
tag-text write
"-->" write ;
M: printer print-dtd-tag
M: printer print-dtd-tag ( tag -- )
"<!" write
tag-text write
">" write ;
@ -70,8 +71,8 @@ M: printer print-closing-named-tag ( tag -- )
M: src-printer print-opening-named-tag ( tag -- )
"<" write
dup tag-name write
tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if
[ tag-name write ]
[ tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if ] bi
">" write ;
M: src-printer print-closing-named-tag ( tag -- )
@ -79,9 +80,30 @@ M: src-printer print-closing-named-tag ( tag -- )
tag-name write
">" write ;
TUPLE: unknown-tag-error tag ;
SYMBOL: tab-width
SYMBOL: #indentations
C: <unknown-tag-error> unknown-tag-error
: html-pp ( vector -- )
[
0 #indentations set
2 tab-width set
] with-scope ;
: print-tabs ( -- )
tab-width get #indentations get * CHAR: \s <repetition> write ;
M: html-prettyprinter print-opening-named-tag ( tag -- )
print-tabs "<" write
tag-name write
">\n" write ;
M: html-prettyprinter print-closing-named-tag ( tag -- )
"</" write
tag-name write
">" write ;
ERROR: unknown-tag-error tag ;
M: printer print-tag ( tag -- )
{
@ -92,15 +114,12 @@ M: printer print-tag ( tag -- )
[ print-closing-named-tag ] }
{ [ dup tag-name string? ]
[ print-opening-named-tag ] }
[ <unknown-tag-error> throw ]
[ unknown-tag-error ]
} cond ;
SYMBOL: tablestack
: with-html-printer
[
V{ } clone tablestack set
] with-scope ;
! SYMBOL: tablestack
! : with-html-printer ( vector quot -- )
! [ V{ } clone tablestack set ] with-scope ;
! { { 1 2 } { 3 4 } }
! H{ { table-gap { 10 10 } } } [

11
extra/html/parser/utils/utils.factor
View File

@ -1,7 +1,7 @@
USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings ;
state-parser strings sequences.lib ;
IN: html.parser.utils
: string-parse-end?
@ -13,7 +13,7 @@ IN: html.parser.utils
dup length rot length 1- - head next* ;
: trim1 ( seq ch -- newseq )
[ ?head drop ] keep ?tail drop ;
[ ?head drop ] [ ?tail drop ] bi ;
: single-quote ( str -- newstr )
>r "'" r> "'" 3append ;
@ -26,11 +26,7 @@ IN: html.parser.utils
[ double-quote ] [ single-quote ] if ;
: quoted? ( str -- ? )
dup length 1 > [
[ first ] keep peek [ = ] keep "'\"" member? and
] [
drop f
] if ;
[ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] [ f ] if-seq ;
: ?quote ( str -- newstr )
dup quoted? [ quote ] unless ;
@ -39,4 +35,3 @@ IN: html.parser.utils
dup quoted? [ but-last-slice rest-slice >string ] when ;
: quote? ( ch -- ? ) "'\"" member? ;