diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 0b9a748eb8..99f2d42542 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -52,6 +52,21 @@ HELP: { $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." } diff --git a/extra/base64/base64-tests.factor b/extra/base64/base64-tests.factor index 23ea6e99ab..d867351f8b 100644 --- a/extra/base64/base64-tests.factor +++ b/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 diff --git a/extra/base64/base64.factor b/extra/base64/base64.factor index 2c393c61e2..074640c536 100644 --- a/extra/base64/base64.factor +++ b/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 [ 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 [ decode4 % ] each ] keep [ CHAR: = = not ] count-end ] SBUF" " make swap [ dup pop* ] times >string ; diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor index c95b3f4477..fe215e32db 100644 --- a/extra/crypto/md5/md5.factor +++ b/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 [ le> ] map (process-md5-block-F) (process-md5-block-G) diff --git a/extra/db/db.factor b/extra/db/db.factor index 1c287cd871..effb971e9f 100644 --- a/extra/db/db.factor +++ b/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 ( handle -- obj ) +TUPLE: db handle insert-statements update-statements delete-statements select-statements ; +: ( 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 ; diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor index 941c25e1fa..040b87c977 100644 --- a/extra/db/mysql/mysql.factor +++ b/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 ( str -- statement ) ; diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 609c597b35..47f42b7e0d 100644 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/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 ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index e5f8425d92..944fc14eef 100644 --- a/extra/db/sqlite/lib/lib.factor +++ b/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*" "void*" diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 73b93d404b..0f4529763a 100644 --- a/extra/db/sqlite/sqlite.factor +++ b/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 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 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 ; + diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor new file mode 100644 index 0000000000..7fc6fd3b97 --- /dev/null +++ b/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 ; +: ( 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 [ + test-tuples + ] with-db ; + +test-sqlite + +! : test-postgres ( -- ) + ! resource-path [ + ! test-tuples + ! ] with-db ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor new file mode 100644 index 0000000000..c08f359d5e --- /dev/null +++ b/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 + [ ] 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 ; + + + + + + + + diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor new file mode 100644 index 0000000000..b4785b7aa1 --- /dev/null +++ b/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* ; diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 20e997185d..e15d9511a3 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -236,10 +236,9 @@ TUPLE: unimplemented-typeflag header ; ] when* ; : parse-tar ( path -- obj ) - [ + [ "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 ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index b91a6177b8..b6c0ef3ecc 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -10,7 +10,7 @@ IN: tools.browser MEMO: (vocab-file-contents) ( path -- lines ) ?resource-path dup exists? - [ 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 - [ [ print ] each ] with-stream + [ [ print ] each ] with-file-out ] [ "The " swap vocab-name " vocabulary was not loaded from the file system"