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

core/io/files/files-docs.factor

@@ -52,6 +52,21 @@ HELP: <file-appender>
 { $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." }
 { $errors "Throws an error if the file cannot be opened for writing." } ;
 
+HELP: with-file-in
+{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
+{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." }
+{ $errors "Throws an error if the file is unreadable." } ;
+
+HELP: with-file-out
+{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
+{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." }
+{ $errors "Throws an error if the file cannot be opened for writing." } ;
+
+HELP: with-file-appender
+{ $values { "path" "a pathname string" } { "quot" "a quotation" } }
+{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." }
+{ $errors "Throws an error if the file cannot be opened for writing." } ;
+
 HELP: cwd
 { $values { "path" "a pathname string" } }
 { $description "Outputs the current working directory of the Factor process." }

extra/base64/base64-tests.factor

@@ -1,4 +1,4 @@
-USING: tools.test base64 ;
+USING: kernel tools.test base64 strings ;
 
 [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64>
 ] unit-test

extra/base64/base64.factor

@@ -35,13 +35,13 @@ PRIVATE>
     #! pad string with = when not enough bits
     dup length dup 3 mod - cut swap
     [
-        3 group [ encode3 % ] each
+        3 <groups> [ encode3 % ] each
         dup empty? [ drop ] [ >base64-rem % ] if
     ] "" make ;
 
 : base64> ( base64 -- str )
     #! input length must be a multiple of 4
     [
-        [ 4 group [ decode4 % ] each ] keep [ CHAR: = = not ] count-end 
+        [ 4 <groups> [ decode4 % ] each ] keep [ CHAR: = = not ] count-end 
     ] SBUF" " make swap [ dup pop* ] times >string ;
 

extra/crypto/md5/md5.factor

@@ -153,7 +153,7 @@ SYMBOL: old-d
     dup S44 64 9  [ I ] BCDA ;
 
 : (process-md5-block) ( block -- )
-    4 group [ le> ] map
+    4 <groups> [ le> ] map
 
     (process-md5-block-F)
     (process-md5-block-G)

extra/db/db.factor

@@ -4,12 +4,27 @@ USING: arrays assocs classes continuations kernel math
 namespaces sequences sequences.lib tuples words ;
 IN: db
 
-TUPLE: db handle ;
-C: <db> db ( handle -- obj )
+TUPLE: db handle insert-statements update-statements delete-statements select-statements ;
+: <db> ( handle -- obj )
+    H{ } clone
+    H{ } clone
+    H{ } clone
+    H{ } clone
+    db construct-boa ;
 
-! HOOK: db-create db ( str -- )
-! HOOK: db-drop db ( str -- )
 GENERIC: db-open ( db -- )
+HOOK: db-close db ( handle -- )
+
+: dispose-statements [ dispose drop ] assoc-each ;
+
+: 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-select-statements dispose-statements
+        db-handle db-close
+    ] with-variable ;
 
 TUPLE: statement sql params handle bound? ;
 
@@ -43,6 +58,8 @@ GENERIC: #columns ( result-set -- n )
 GENERIC# row-column 1 ( result-set n -- obj )
 GENERIC: advance-row ( result-set -- ? )
 
+HOOK: last-id db ( -- id )
+
 : init-result-set ( result-set -- )
     dup #rows over set-result-set-max
     -1 swap set-result-set-n ;

extra/db/mysql/mysql.factor

@@ -14,7 +14,6 @@ M: mysql-db db-open ( mysql-db -- )
 M: mysql-db dispose ( mysql-db -- )
     mysql-db-handle mysql_close ;
 
-
 M: mysql-db <simple-statement> ( str -- statement )
     ;
 

extra/db/sqlite/ffi/ffi.factor

@@ -106,6 +106,8 @@ IN: db.sqlite.ffi
 
 TYPEDEF: void sqlite3
 TYPEDEF: void sqlite3_stmt
+TYPEDEF: longlong sqlite3_int64
+TYPEDEF: ulonglong sqlite3_uint64
 
 LIBRARY: sqlite
 FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
@@ -116,7 +118,9 @@ FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
 FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
 FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
 FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
+FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
 FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
+FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
 FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
 FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
 FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;

extra/db/sqlite/lib/lib.factor

@@ -21,9 +21,6 @@ TUPLE: sqlite-error n message ;
 : sqlite-close ( db -- )
     sqlite3_close sqlite-check-result ;
 
-: sqlite-last-insert-rowid ( db -- rowid )
-    sqlite3_last_insert_rowid ;
-
 : sqlite-prepare ( db sql -- statement )
     #! TODO: Support multiple statements in the SQL string.
     dup length "void*" <c-object> "void*" <c-object>

extra/db/sqlite/sqlite.factor

@@ -3,7 +3,8 @@
 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 ;
+continuations db.sqlite.lib db.sqlite.ffi db.tuples
+words combinators.lib db.types ;
 IN: db.sqlite
 
 TUPLE: sqlite-db path ;
@@ -13,10 +14,10 @@ M: sqlite-db db-open ( db -- )
     dup sqlite-db-path sqlite-open <db>
     swap set-delegate ;
 
-M: sqlite-db dispose ( obj -- )
-    dup db-handle sqlite-close
-    f over set-db-handle
-    f swap set-delegate ;
+M: sqlite-db db-close ( handle -- )
+    sqlite-close ;
+
+M: sqlite-db dispose ( db -- ) dispose-db ;
 
 : with-sqlite ( path quot -- )
     >r <sqlite-db> r> with-db ; inline
@@ -72,3 +73,105 @@ 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 ;
+
+M: sqlite-db insert-sql* ( columns table -- sql )
+    [
+        "insert into " %
+        %
+        "(" %
+        dup [ ", " % ] [ second % ] interleave
+        ") " %
+        " values (" %
+        [ ", " % ] [ ":" % second % ] interleave
+        ")" %
+    ] "" make ;
+
+M: sqlite-db update-sql* ( columns table -- sql )
+    [
+        "update " %
+        %
+        " set " %
+        dup remove-id
+        [ ", " % ] [ second dup % " = :" % % ] interleave
+        " where " %
+        [ primary-key? ] find nip second dup % " = :" % %
+    ] "" make ;
+
+M: sqlite-db delete-sql* ( columns table -- sql )
+    [
+    break
+        "delete from " %
+        %
+        " where " %
+        first second dup % " = :" % %
+    ] "" make dup . ;
+
+M: sqlite-db select-sql* ( columns table -- sql )
+    [
+        "select ROWID, " %
+        swap [ ", " % ] [ second % ] interleave
+        " from " %
+        %
+        " where ROWID = :ID" %
+    ] "" make ;
+
+M: sqlite-db tuple>params ( columns tuple -- obj )
+    [
+        >r [ second ":" swap append ] keep first r> get-slot-named
+        number>string*
+    ] curry { } map>assoc  ;
+    
+M: sqlite-db last-id ( -- id )
+    db get db-handle sqlite3_last_insert_rowid ;
+
+
+: sqlite-db-modifiers ( -- hashtable )
+    H{
+        { +native-id+ "primary key" }
+        { +assigned-id+ "primary key" }
+        { +autoincrement+ "autoincrement" }
+        { +unique+ "unique" }
+        { +default+ "default" }
+        { +null+ "null" }
+        { +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 ;
+
+: sqlite-type-hash ( -- assoc )
+    H{
+        { INTEGER "integer" }
+        { TEXT "text" }
+        { VARCHAR "text" }
+    } ;
+
+M: sqlite-db >sql-type ( obj -- str )
+    dup pair? [
+        first >sql-type
+    ] [
+        sqlite-type-hash at* [ T{ no-sql-type } throw ] unless
+    ] if ;
+
+! HOOK: get-column-value ( n result-set type -- )
+! M: sqlite get-column-value { { "TEXT" get-text-column } { 
+! "INTEGER" get-integer-column } ... } case ;
+

extra/db/tuples/tuples-tests.factor

@@ -0,0 +1,37 @@
+USING: io.files kernel tools.test db db.sqlite db.tuples ;
+IN: temporary
+
+TUPLE: person the-id the-name the-number ;
+: <person> ( name age -- person )
+    { set-person-the-name set-person-the-number } person construct ;
+
+person "PERSON"
+{
+    { "the-id" "ROWID" INTEGER +native-id+ }
+    { "the-name" "NAME" { VARCHAR 256 } +not-null+ } 
+    { "the-number" "AGE" INTEGER { +default+ 0 } }
+} define-persistent
+
+
+: test-tuples ( -- )
+    f "billy" 100 person construct-boa dup insert-tuple
+
+    [ 1 ] [ dup person-id ] unit-test
+
+    200 over set-person-the-number
+
+    [ ] [ dup update-tuple ] unit-test
+
+    [ ] [ delete-tuple ] unit-test ;
+
+: test-sqlite ( -- )
+    "tuples-test.db" resource-path <sqlite-db> [
+        test-tuples
+    ] with-db ;
+
+test-sqlite
+
+! : test-postgres ( -- )
+    ! resource-path <postgresql-db> [
+        ! test-tuples
+    ! ] with-db ;

extra/db/tuples/tuples.factor

@@ -0,0 +1,116 @@
+USING: arrays assocs classes db kernel namespaces
+tuples words sequences slots slots.private math
+math.parser io prettyprint db.types ;
+USE: continuations
+IN: db.tuples
+
+! only take a tuple if you have to extract things from it
+! otherwise take a class
+! primary-key vs primary-key-spec
+! define-persistent should enforce a primary key
+! in sqlite, defining a new primary key makes it an alias for rowid, _rowid_, and oid
+! -sql outputs sql code
+! table - string
+! columns - seq of column specifiers
+
+: db-columns ( class -- obj )
+    "db-columns" word-prop ;
+
+: db-table ( class -- obj )
+    "db-table" word-prop ;
+
+
+: slot-spec-named ( str class -- slot-spec )
+    "slots" word-prop [ slot-spec-name = ] with find nip ;
+
+: offset-of-slot ( str obj -- n )
+    class slot-spec-named slot-spec-offset ;
+
+: get-slot-named ( str obj -- value )
+    tuck offset-of-slot slot ;
+
+: set-slot-named ( value str obj -- )
+    tuck offset-of-slot set-slot ;
+    
+
+: 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 -- sql )
+HOOK: drop-sql db ( columns table -- sql )
+HOOK: insert-sql* db ( columns table -- sql )
+HOOK: update-sql* db ( columns table -- sql )
+HOOK: delete-sql* db ( columns table -- sql )
+HOOK: select-sql* db ( columns table -- sql )
+
+: insert-sql ( columns class -- statement )
+    db get db-insert-statements [ insert-sql* ] cache-statement ;
+
+: update-sql ( columns class -- statement )
+    db get db-update-statements [ update-sql* ] cache-statement ;
+
+: delete-sql ( columns class -- statement )
+    db get db-delete-statements [ delete-sql* ] cache-statement ;
+
+: select-sql ( columns class -- statement )
+    db get db-select-statements [ select-sql* ] cache-statement ;
+
+HOOK: tuple>params db ( columns tuple -- obj )
+
+: tuple-statement ( columns tuple quot -- statement )
+    >r [ tuple>params ] 2keep class r> call
+    [ bind-statement ] keep ;
+
+: do-tuple-statement ( tuple columns-quot statement-quot -- )
+    >r [ class db-columns ] swap compose keep
+    r> tuple-statement dup . execute-statement ;
+
+: create-table ( class -- )
+    dup db-columns swap db-table create-sql sql-command ;
+    
+: insert-tuple ( tuple -- )
+    [
+        [ maybe-remove-id ] [ insert-sql ] do-tuple-statement
+        last-id
+    ] keep set-primary-key ;
+
+: update-tuple ( tuple -- )
+    [ ] [ update-sql ] do-tuple-statement ;
+
+: delete-tuple ( tuple -- )
+    [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
+
+! : select-tuple ( tuple -- )
+  !  [ select-sql ] bind-tuple do-query ;
+
+: persist ( tuple -- )
+    dup primary-key [ update-tuple ] [ insert-tuple ] if ;
+
+! PERSISTENT:
+
+: define-persistent ( class table columns -- )
+    >r dupd "db-table" set-word-prop r>
+    "db-columns" set-word-prop ;
+
+: define-relation ( spec -- )
+    drop ;
+
+
+
+
+
+
+
+

extra/db/types/types.factor

@@ -0,0 +1,70 @@
+USING: arrays assocs db kernel math math.parser
+sequences continuations ;
+IN: db.types
+
+
+! id   serial not null primary key,
+! ID is the Primary key
+SYMBOL: +native-id+
+SYMBOL: +assigned-id+
+
+: primary-key? ( spec -- ? )
+    [ { +native-id+ +assigned-id+ } member? ] contains? ;
+
+! Same concept, SQLite has autoincrement, PostgreSQL has serial
+SYMBOL: +autoincrement+
+SYMBOL: +serial+
+SYMBOL: +unique+
+
+SYMBOL: +default+
+SYMBOL: +null+
+SYMBOL: +not-null+
+SYMBOL: +has-many+
+
+! SQLite Types
+! http://www.sqlite.org/datatype3.html
+! SYMBOL: NULL
+! SYMBOL: INTEGER
+! SYMBOL: REAL
+! SYMBOL: TEXT
+! SYMBOL: BLOB
+
+SYMBOL: INTEGER
+SYMBOL: DOUBLE
+SYMBOL: BOOLEAN
+
+SYMBOL: TEXT
+SYMBOL: VARCHAR
+
+SYMBOL: TIMESTAMP
+SYMBOL: DATE
+
+SYMBOL: BIG_INTEGER
+
+! SYMBOL: LOCALE
+! SYMBOL: TIMEZONE
+! SYMBOL: CURRENCY
+
+
+! PostgreSQL Types
+! http://developer.postgresql.org/pgdocs/postgres/datatype.html
+
+
+: number>string* ( num/str -- str )
+    dup number? [ number>string ] when ;
+
+TUPLE: no-sql-type ;
+HOOK: sql-modifiers* db ( modifiers -- str )
+HOOK: >sql-type db ( obj -- str )
+
+
+
+
+: maybe-remove-id ( columns -- obj )
+    [ +native-id+ swap member? not ] subset ;
+
+: remove-id ( columns -- obj )
+    [ primary-key? not ] subset ;
+
+: sql-modifiers ( spec -- seq )
+    3 tail sql-modifiers* ;

extra/tar/tar.factor

@@ -236,10 +236,9 @@ TUPLE: unimplemented-typeflag header ;
     ] when* ;
 
 : parse-tar ( path -- obj )
-    <file-reader> [
+    [
         "tar-test" resource-path base-dir set
         global [ nl nl nl "Starting to parse .tar..." print flush ] bind
         global [ "Expanding to: " write base-dir get . flush ] bind
         (parse-tar)
-    ] with-stream ;
-
+    ] with-file-out ;

extra/tools/browser/browser.factor

@@ -10,7 +10,7 @@ IN: tools.browser
 
 MEMO: (vocab-file-contents) ( path -- lines )
     ?resource-path dup exists?
-    [ <file-reader> lines ] [ drop f ] if ;
+    [ file-lines ] [ drop f ] if ;
 
 : vocab-file-contents ( vocab name -- seq )
     vocab-path+ dup [ (vocab-file-contents) ] when ;
@@ -18,7 +18,7 @@ MEMO: (vocab-file-contents) ( path -- lines )
 : set-vocab-file-contents ( seq vocab name -- )
     dupd vocab-path+ [
         ?resource-path
-        <file-writer> [ [ print ] each ] with-stream
+        [ [ print ] each ] with-file-out
     ] [
         "The " swap vocab-name
         " vocabulary was not loaded from the file system"