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

Conflicts:

	extra/db/sql/sql.factor

diff --git a/extra/db/db.factor b/extra/db/db.factor
index 8d1feca6c73c3efd41fa900452f6e9df4c061000..889eff196cc9d19ccd5ffbc15fd9720fb2b56022 100755 (executable)
--- a/extra/db/db.factor
+++ b/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 ;
 
@@ -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 ;
 

diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor
index 59ee60aa1fd68b8dfbde5e2a725b7be51a062a0d..29abe9bddcf80d984aae9c5c5310d51bcf24dce1 100644 (file)
--- a/extra/db/queries/queries.factor
+++ b/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
-    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,7 +146,7 @@ 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* ]
@@ -155,6 +155,43 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
         [ 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 group order limit offset -- tuple )
+    \ query boa
+    [ <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 )
+    f f f \ query boa
+    [ [ "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 ;

diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor
index ae748731b12ae97065b6675ef9f3455d4b88ecb6..7dd4abf4be718641dbd303196b329c3d7fd099be 100755 (executable)
--- a/extra/db/sql/sql.factor
+++ b/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 )
-    [
-        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 ;

diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index f9a597e814a2924344f9ed30d34fbf8bd2f22158..665afa6a5135ac8bf55efbb4c4303be53de889a5 100755 (executable)
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -227,7 +227,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 +340,9 @@ TUPLE: exam id name score ;
         }
     ] [
         T{ exam } select-tuples
-    ] unit-test ;
+    ] unit-test
+
+    [ 4 ] [ T{ exam } count-tuples ] unit-test ;
 
 TUPLE: bignum-test id m n o ;
 : <bignum-test> ( m n o -- obj )

diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 0fe2f3577e592ee7924b44b4c0094a3685ccdc31..b7cc6c81c25db2a909147bb9f588e89f12501873 100755 (executable)
--- a/extra/db/tuples/tuples.factor
+++ b/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 ;
-HOOK: <advanced-select-statement> db ( tuple class group order offset limit -- tuple )
+TUPLE: query group order offset limit ;
+HOOK: <query> db ( tuple class group order offset limit -- tuple )
+HOOK: <count-statement> db ( tuple class -- 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 [
@@ -153,5 +156,20 @@ M: retryable execute-statement* ( statement type -- )
     select-tuples length ;
 
 : select-tuple ( tuple -- tuple/f )
-    dup dup class f f f 1 <advanced-select-statement>
+    dup dup class f f f 1 <query>
     do-select ?first ;
+
+: query ( tuple groups order offset limit -- tuples )
+    >r >r >r >r dup dup class r> r> r> r>
+    <query> do-select ;
+
+: 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 ;

diff --git a/extra/html/parser/printer/printer.factor b/extra/html/parser/printer/printer.factor
index 3078cf23a52fb3134c41b8fb37dbbaf2675ff95f..d352a97688e80d4b1928bda2c4b38786d04ffd25 100644 (file)
--- a/extra/html/parser/printer/printer.factor
+++ b/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-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 } } } [

diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor
index 5083b1cec26581618def86f4bad67224f041d22e..592503e3dd02aca2fcf8ecd9888f3646179aad45 100644 (file)
--- a/extra/html/parser/utils/utils.factor
+++ b/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 ] 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? ;
-