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

extra/db/db.factor

@@ -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 ;
 

extra/db/postgresql/lib/lib.factor

@@ -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 ] }

extra/db/postgresql/postgresql.factor

@@ -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" } }

extra/db/queries/queries.factor

@@ -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
+    dupd filter-slots [
-    dup empty? [
+        drop
-        2drop
     ] [
         " 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* ]
+        [ group>> [ do-group ] [ drop ] if-seq ]
-        [ order>> [ do-order ] [ drop ] if* ]
+        [ 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 )
+M: db <query> ( tuple class query -- tuple )
-    advanced-statement boa
+    [ <select-by-slots-statement> ] dip make-query ;
-    [ <select-by-slots-statement> ] dip make-advanced-statement ;
+
+! 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 ;

extra/db/sql/sql.factor

@@ -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 )
-    [
+    [ [ sql% ] each ] { { } { } { } } nmake ;
-        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 ;

extra/db/sqlite/lib/lib.factor

@@ -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

extra/db/sqlite/sqlite.factor

@@ -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" } }

extra/db/tuples/tuples-tests.factor

@@ -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 )
+: <person> ( name age real ts date time blob factor-blob url -- person )
-    {
+    person new
-        set-person-the-name
+        swap >>url
-        set-person-the-number
+        swap >>factor-blob
-        set-person-the-real
+        swap >>blob
-        set-person-ts
+        swap >>time
-        set-person-date
+        swap >>date
-        set-person-time
+        swap >>ts
-        set-person-blob
+        swap >>the-real
-        set-person-factor-blob
+        swap >>the-number
-    } person construct ;
+        swap >>the-name ;
 
-: <user-assigned-person> ( id name age real ts date time blob factor-blob -- person )
+: <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
-    <person> [ set-person-the-id ] keep ;
+    <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
+    "billy" 10 3.14 f f f f f f <person> person1 set
-    "johnny" 10 3.14 f f f f f <person> person2 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
+    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 <user-assigned-person> person2 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 )

extra/db/tuples/tuples.factor

@@ -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 ;
+TUPLE: query group order offset limit ;
-HOOK: <advanced-select-statement> db ( tuple class group order offset limit -- tuple )
+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
+    drop [
         [
             [ query-results dispose t ]
             [ ]
             [ regenerate-params bind-statement* f ] cleanup
-    ] curry 10 retry drop ;
+        ] 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>
+    dup dup class \ query new 1 >>limit <query> do-select ?first ;
-    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 ;

extra/db/types/types.factor

@@ -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

extra/html/parser/printer/printer.factor

@@ -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-name write ]
-    tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if
+    [ 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
+! SYMBOL: tablestack
-
+! : with-html-printer ( vector quot -- )
-: with-html-printer
+    ! [ V{ } clone tablestack set ] with-scope ;
-    [
-        V{ } clone tablestack set
-    ] with-scope ;
 
 ! { { 1 2 } { 3 4 } }
 ! H{ { table-gap { 10 10 } } } [

extra/html/parser/utils/utils.factor

@@ -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 ] [ peek ] bi [ = ] keep "'\"" member? and ] [ f ] if-seq ;
-        [ first ] keep peek [ = ] keep "'\"" member? and
-    ] [
-        drop f
-    ] if ;
 
 : ?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? ;
-