--- /dev/null
+USING: kernel namespaces ;\r
+IN: sql\r
+\r
+GENERIC: execute-sql* ( string db -- )\r
+GENERIC: query-sql* ( string db -- seq )\r
+\r
+: execute-sql ( string -- ) db get execute-sql* ;\r
+: query-sql ( string -- ) db get query-sql* ;\r
+\r
+\r
--- /dev/null
+PROVIDE: libs/sql\r
+{ +files+ {\r
+ "sql.factor"\r
+ "utils.factor"\r
+ "simple.factor"\r
+ "mappings.factor"\r
+ "execute.factor"\r
+\r
+ "sqlite/libsqlite.factor"\r
+ "sqlite/sqlite.factor"\r
+ "sqlite/simple.factor"\r
+ "sqlite/execute.factor"\r
+ "postgresql/libpq.factor"\r
+ "postgresql/postgresql.factor"\r
+ "postgresql/simple.factor"\r
+ "postgresql/execute.factor"\r
+\r
+ "tupledb.factor"\r
+\r
+ "thewebsite.factor"\r
+} }\r
+{ +tests+ {\r
+ "test/data.factor"\r
+ "test/insert.factor"\r
+ "test/util.factor"\r
+} } ;\r
+\r
--- /dev/null
+IN: postgresql\r
--- /dev/null
+! See http://factor.sf.net/license.txt for BSD license.
+
+! adapted from libpq-fe.h version 7.4.7
+! tested on debian linux with postgresql 7.4.7
+! Updated to 8.1
+
+IN: postgresql
+USING: alien ;
+
+
+! ConnSatusType
+: CONNECTION_OK HEX: 0 ; inline
+: CONNECTION_BAD HEX: 1 ; inline
+: CONNECTION_STARTED HEX: 2 ; inline
+: CONNECTION_MADE HEX: 3 ; inline
+: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
+: CONNECTION_AUTH_OK HEX: 5 ; inline
+: CONNECTION_SETENV HEX: 6 ; inline
+: CONNECTION_SSL_STARTUP HEX: 7 ; inline
+: CONNECTION_NEEDED HEX: 8 ; inline
+
+! PostgresPollingStatusType
+: PGRES_POLLING_FAILED HEX: 0 ; inline
+: PGRES_POLLING_READING HEX: 1 ; inline
+: PGRES_POLLING_WRITING HEX: 2 ; inline
+: PGRES_POLLING_OK HEX: 3 ; inline
+: PGRES_POLLING_ACTIVE HEX: 4 ; inline
+
+! ExecStatusType;
+: PGRES_EMPTY_QUERY HEX: 0 ; inline
+: PGRES_COMMAND_OK HEX: 1 ; inline
+: PGRES_TUPLES_OK HEX: 2 ; inline
+: PGRES_COPY_OUT HEX: 3 ; inline
+: PGRES_COPY_IN HEX: 4 ; inline
+: PGRES_BAD_RESPONSE HEX: 5 ; inline
+: PGRES_NONFATAL_ERROR HEX: 6 ; inline
+: PGRES_FATAL_ERROR HEX: 7 ; inline
+
+! PGTransactionStatusType;
+: PQTRANS_IDLE HEX: 0 ; inline
+: PQTRANS_ACTIVE HEX: 1 ; inline
+: PQTRANS_INTRANS HEX: 2 ; inline
+: PQTRANS_INERROR HEX: 3 ; inline
+: PQTRANS_UNKNOWN HEX: 4 ; inline
+
+! PGVerbosity;
+: PQERRORS_TERSE HEX: 0 ; inline
+: PQERRORS_DEFAULT HEX: 1 ; inline
+: PQERRORS_VERBOSE HEX: 2 ; inline
+
+
+TYPEDEF: int size_t
+TYPEDEF: int ConnStatusType
+TYPEDEF: int ExecStatusType
+TYPEDEF: int PostgresPollingStatusType
+TYPEDEF: int PGTransactionStatusType
+TYPEDEF: int PGVerbosity
+
+TYPEDEF: void* PGconn*
+TYPEDEF: void* PGresult*
+TYPEDEF: void* PGcancel*
+TYPEDEF: uint Oid
+TYPEDEF: uint* Oid*
+TYPEDEF: char pqbool
+TYPEDEF: void* PQconninfoOption*
+TYPEDEF: void* PGnotify*
+TYPEDEF: void* PQArgBlock*
+TYPEDEF: void* PQprintOpt*
+TYPEDEF: void* FILE*
+TYPEDEF: void* SSL*
+
+LIBRARY: postgresql
+
+
+! Exported functions of libpq
+! === in fe-connect.c ===
+
+! make a new client connection to the backend
+! Asynchronous (non-blocking)
+FUNCTION: PGconn* PQconnectStart ( char* conninfo ) ;
+FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn ) ;
+
+! Synchronous (blocking)
+FUNCTION: PGconn* PQconnectdb ( char* conninfo ) ;
+FUNCTION: PGconn* PQsetdbLogin ( char* pghost, char* pgport,
+ char* pgoptions, char* pgtty,
+ char* dbName,
+ char* login, char* pwd ) ;
+
+: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* )
+ f f PQsetdbLogin ;
+
+! close the current connection and free the PGconn data structure
+FUNCTION: void PQfinish ( PGconn* conn ) ;
+
+! get info about connection options known to PQconnectdb
+FUNCTION: PQconninfoOption* PQconndefaults ( ) ;
+
+! free the data structure returned by PQconndefaults()
+FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
+
+!
+! close the current connection and restablish a new one with the same
+! parameters
+!
+! Asynchronous (non-blocking)
+FUNCTION: int PQresetStart ( PGconn* conn ) ;
+FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;
+
+! Synchronous (blocking)
+FUNCTION: void PQreset ( PGconn* conn ) ;
+
+! request a cancel structure
+FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ;
+
+! free a cancel structure
+FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ;
+
+! issue a cancel request
+FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
+
+! Accessor functions for PGconn objects
+FUNCTION: char* PQdb ( PGconn* conn ) ;
+FUNCTION: char* PQuser ( PGconn* conn ) ;
+FUNCTION: char* PQpass ( PGconn* conn ) ;
+FUNCTION: char* PQhost ( PGconn* conn ) ;
+FUNCTION: char* PQport ( PGconn* conn ) ;
+FUNCTION: char* PQtty ( PGconn* conn ) ;
+FUNCTION: char* PQoptions ( PGconn* conn ) ;
+FUNCTION: ConnStatusType PQstatus ( PGconn* conn ) ;
+FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn ) ;
+FUNCTION: char* PQparameterStatus ( PGconn* conn,
+ char* paramName ) ;
+FUNCTION: int PQprotocolVersion ( PGconn* conn ) ;
+FUNCTION: int PQServerVersion ( PGconn* conn ) ;
+FUNCTION: char* PQerrorMessage ( PGconn* conn ) ;
+FUNCTION: int PQsocket ( PGconn* conn ) ;
+FUNCTION: int PQbackendPID ( PGconn* conn ) ;
+FUNCTION: int PQclientEncoding ( PGconn* conn ) ;
+FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
+
+! May not be compiled into libpq
+! Get the SSL structure associated with a connection
+FUNCTION: SSL* PQgetssl ( PGconn* conn ) ;
+
+! Tell libpq whether it needs to initialize OpenSSL
+FUNCTION: void PQinitSSL ( int do_init ) ;
+
+! Set verbosity for PQerrorMessage and PQresultErrorMessage
+FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
+ PGVerbosity verbosity ) ;
+
+! Enable/disable tracing
+FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ;
+FUNCTION: void PQuntrace ( PGconn* conn ) ;
+
+! BROKEN
+! Function types for notice-handling callbacks
+! typedef void (*PQnoticeReceiver) (void *arg, PGresult *res);
+! typedef void (*PQnoticeProcessor) (void *arg, char* message);
+! ALIAS: void* PQnoticeReceiver
+! ALIAS: void* PQnoticeProcessor
+
+! Override default notice handling routines
+! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
+ ! PQnoticeReceiver proc,
+ ! void* arg ) ;
+! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
+ ! PQnoticeProcessor proc,
+ ! void* arg ) ;
+! END BROKEN
+
+! === in fe-exec.c ===
+
+! Simple synchronous query
+FUNCTION: PGresult* PQexec ( PGconn* conn, char* query ) ;
+FUNCTION: PGresult* PQexecParams ( PGconn* conn,
+ char* command,
+ int nParams,
+ Oid* paramTypes,
+ char** paramValues,
+ int* paramLengths,
+ int* paramFormats,
+ int resultFormat ) ;
+FUNCTION: PGresult* PQprepare ( PGconn* conn, char* stmtName,
+ char* query, int nParams,
+ Oid* paramTypes ) ;
+FUNCTION: PGresult* PQexecPrepared ( PGconn* conn,
+ char* stmtName,
+ int nParams,
+ char** paramValues,
+ int* paramLengths,
+ int* paramFormats,
+ int resultFormat ) ;
+
+! Interface for multiple-result or asynchronous queries
+FUNCTION: int PQsendQuery ( PGconn* conn, char* query ) ;
+FUNCTION: int PQsendQueryParams ( PGconn* conn,
+ char* command,
+ int nParams,
+ Oid* paramTypes,
+ char** paramValues,
+ int* paramLengths,
+ int* paramFormats,
+ int resultFormat ) ;
+FUNCTION: PGresult* PQsendPrepare ( PGconn* conn, char* stmtName,
+ char* query, int nParams,
+ Oid* paramTypes ) ;
+FUNCTION: int PQsendQueryPrepared ( PGconn* conn,
+ char* stmtName,
+ int nParams,
+ char** paramValues,
+ int *paramLengths,
+ int *paramFormats,
+ int resultFormat ) ;
+FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ;
+
+! Routines for managing an asynchronous query
+FUNCTION: int PQisBusy ( PGconn* conn ) ;
+FUNCTION: int PQconsumeInput ( PGconn* conn ) ;
+
+! LISTEN/NOTIFY support
+FUNCTION: PGnotify* PQnotifies ( PGconn* conn ) ;
+
+! Routines for copy in/out
+FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
+FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
+FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
+
+! Deprecated routines for copy in/out
+FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ;
+FUNCTION: int PQputline ( PGconn* conn, char* string ) ;
+FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
+FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
+FUNCTION: int PQendcopy ( PGconn* conn ) ;
+
+! Set blocking/nonblocking connection to the backend
+FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ;
+FUNCTION: int PQisnonblocking ( PGconn* conn ) ;
+
+! Force the write buffer to be written (or at least try)
+FUNCTION: int PQflush ( PGconn* conn ) ;
+
+!
+! * "Fast path" interface --- not really recommended for application
+! * use
+!
+FUNCTION: PGresult* PQfn ( PGconn* conn,
+ int fnid,
+ int* result_buf,
+ int* result_len,
+ int result_is_int,
+ PQArgBlock* args,
+ int nargs ) ;
+
+! Accessor functions for PGresult objects
+FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ;
+FUNCTION: char* PQresStatus ( ExecStatusType status ) ;
+FUNCTION: char* PQresultErrorMessage ( PGresult* res ) ;
+FUNCTION: char* PQresultErrorField ( PGresult* res, int fieldcode ) ;
+FUNCTION: int PQntuples ( PGresult* res ) ;
+FUNCTION: int PQnfields ( PGresult* res ) ;
+FUNCTION: int PQbinaryTuples ( PGresult* res ) ;
+FUNCTION: char* PQfname ( PGresult* res, int field_num ) ;
+FUNCTION: int PQfnumber ( PGresult* res, char* field_name ) ;
+FUNCTION: Oid PQftable ( PGresult* res, int field_num ) ;
+FUNCTION: int PQftablecol ( PGresult* res, int field_num ) ;
+FUNCTION: int PQfformat ( PGresult* res, int field_num ) ;
+FUNCTION: Oid PQftype ( PGresult* res, int field_num ) ;
+FUNCTION: int PQfsize ( PGresult* res, int field_num ) ;
+FUNCTION: int PQfmod ( PGresult* res, int field_num ) ;
+FUNCTION: char* PQcmdStatus ( PGresult* res ) ;
+FUNCTION: char* PQoidStatus ( PGresult* res ) ;
+FUNCTION: Oid PQoidValue ( PGresult* res ) ;
+FUNCTION: char* PQcmdTuples ( PGresult* res ) ;
+FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
+FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ;
+FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ;
+
+! Delete a PGresult
+FUNCTION: void PQclear ( PGresult* res ) ;
+
+! For freeing other alloc'd results, such as PGnotify structs
+FUNCTION: void PQfreemem ( void* ptr ) ;
+
+! Exists for backward compatibility.
+: PQfreeNotify PQfreemem ;
+
+!
+! Make an empty PGresult with given status (some apps find this
+! useful). If conn is not NULL and status indicates an error, the
+! conn's errorMessage is copied.
+!
+FUNCTION: PGresult* PQmakeEmptyPGresult ( PGconn* conn, ExecStatusType status ) ;
+
+! Quoting strings before inclusion in queries.
+FUNCTION: size_t PQescapeStringConn ( PGconn* conn,
+ char* to, char* from, size_t length,
+ int* error ) ;
+FUNCTION: uchar* PQescapeByteaConn ( PGconn* conn,
+ char* from, size_t length,
+ size_t* to_length ) ;
+FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
+ size_t* retbuflen ) ;
+! These forms are deprecated!
+FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ;
+FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen,
+ size_t* bytealen ) ;
+
+! === in fe-print.c ===
+
+FUNCTION: void PQprint ( FILE* fout, PGresult* res, PQprintOpt* ps ) ;
+
+! really old printing routines
+FUNCTION: void PQdisplayTuples ( PGresult* res,
+ FILE* fp,
+ int fillAlign,
+ char* fieldSep,
+ int printHeader,
+ int quiet ) ;
+
+FUNCTION: void PQprintTuples ( PGresult* res,
+ FILE* fout,
+ int printAttName,
+ int terseOutput,
+ int width ) ;
+
+! === in fe-lobj.c ===
+
+! Large-object access routines
+FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
+FUNCTION: int lo_close ( PGconn* conn, int fd ) ;
+FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
+FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
+FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
+FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ;
+FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ;
+FUNCTION: int lo_tell ( PGconn* conn, int fd ) ;
+FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ;
+FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ;
+FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
+
+! === in fe-misc.c ===
+
+! Determine length of multibyte encoded char at *s
+FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
+
+! Determine display length of multibyte encoded char at *s
+FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
+
+! Get encoding id from environment variable PGCLIENTENCODING
+FUNCTION: int PQenv2encoding ( ) ;
+
--- /dev/null
+! See http://factor.sf.net/license.txt for BSD license.
+
+! adapted from libpq-fe.h version 7.4.7
+! tested on debian linux with postgresql 7.4.7
+
+IN: postgresql
+USING: kernel alien errors io prettyprint sequences namespaces arrays math sql ;
+
+SYMBOL: query-res
+
+: connect-postgres ( host port pgopts pgtty db user pass -- conn )
+ PQsetdbLogin
+ dup PQstatus zero? [ "couldn't connect to database" throw ] unless ;
+
+: with-postgres ( host port pgopts pgtty db user pass quot -- )
+ [ >r connect-postgres db set r>
+ [ db get PQfinish ] cleanup ] with-scope ; inline
+
+: with-postgres-catch ( host port pgopts pgtty db user pass quot -- )
+ [ with-postgres ] catch [ "caught: " write print ] when* ;
+
+: postgres-error ( ret -- ret )
+ dup zero? [ PQresultErrorMessage throw ] when ;
+
+: (do-query) ( PGconn query -- PGresult* )
+ ! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK
+ ! For queries that return rows, PQexec() returns PGRES_TUPLES_OK
+ PQexec
+ dup PQresultStatus PGRES_COMMAND_OK =
+ over PQresultStatus PGRES_TUPLES_OK =
+ or [
+ [ PQresultErrorMessage CHAR: \n swap remove ] keep PQclear throw
+ ] unless ;
+
+: (do-command) ( PGconn query -- PGresult* )
+ [ (do-query) ] catch
+ [
+ swap
+ "non-fatal error: " print
+ "\tQuery: " write "'" write write "'" print
+ "\t" write print
+ ] when* drop ;
+
+: do-command ( str -- )
+ unit \ (do-command) add db get swap call ;
+
+: prepare ( str quot word -- conn quot )
+ rot unit swap append swap append db get swap ;
+
+: do-query ( str quot -- )
+ [ (do-query) query-res set ] prepare catch
+ [ rethrow ] [ query-res get PQclear ] if* ;
+
+: result>seq ( -- seq )
+ query-res get [ PQnfields ] keep PQntuples
+ [ swap [ query-res get -rot PQgetvalue ] map-with ] map-with ;
+
+: print-table ( seq -- )
+ [ [ write bl ] each "\n" write ] each ;
+
--- /dev/null
+IN: postgresql\r
--- /dev/null
+USING: kernel ;\r
+IN: sql\r
+\r
+\r
--- /dev/null
+USING: generic kernel namespaces prettyprint sequences sql:utils ;\r
+IN: sql\r
+\r
+GENERIC: create-sql* ( tuple db -- string )\r
+GENERIC: drop-sql* ( tuple db -- string )\r
+GENERIC: insert-sql* ( tuple db -- string )\r
+GENERIC: delete-sql* ( tuple db -- string )\r
+GENERIC: update-sql* ( tuple db -- string )\r
+GENERIC: select-sql* ( tuple db -- string )\r
+\r
+: create-sql ( tuple -- string ) db get create-sql* ;\r
+: drop-sql ( tuple -- string ) db get drop-sql* ;\r
+: insert-sql ( tuple -- string ) db get insert-sql* ;\r
+: delete-sql ( tuple -- string ) db get delete-sql* ;\r
+: update-sql ( tuple -- string ) db get update-sql* ;\r
+: select-sql ( tuple -- string ) db get select-sql* ;\r
+\r
+M: connection create-sql* ( tuple db -- string )\r
+ drop [\r
+ "create table " %\r
+ dup class unparse % "(" %\r
+ tuple>mapping%\r
+ ");" %\r
+ ] "" make ;\r
+\r
+M: connection drop-sql* ( tuple db -- string )\r
+ drop [ "drop table " % tuple>sql-name % ";" % ] "" make ;\r
+\r
+M: connection insert-sql* ( tuple db -- string )\r
+ drop [\r
+ "insert into " %\r
+ dup tuple>sql-name %\r
+ " (" % tuple>insert-parts dup first ", " join %\r
+ ") values(" %\r
+ second [ escape-sql enquote ] map ", " join %\r
+ ");" %\r
+ ] "" make ;\r
+\r
+M: connection delete-sql* ( tuple db -- string )\r
+ drop [\r
+ ! "delete from table " % unparse % ";" %\r
+ ] "" make ;\r
+\r
+M: connection update-sql* ( tuples db -- string )\r
+ drop [\r
+ ] "" make ;\r
+\r
+M: connection select-sql* ( tuples db -- string )\r
+ drop [\r
+ ] "" make ;\r
+\r
+\r
--- /dev/null
+USING: kernel namespaces ;\r
+IN: sql\r
+\r
+SYMBOL: db\r
+TUPLE: connection handle ;\r
+\r
+! TESTING\r
+"handle" <connection> db set-global\r
+\r
+\r
--- /dev/null
+USING: kernel namespaces sql ;\r
+IN: sqlite\r
+\r
+M: sqlite execute-sql* ( string db -- )\r
+ connection-handle swap\r
+ sqlite-prepare dup [ drop ] sqlite-each sqlite-finalize ;\r
+\r
--- /dev/null
+! Copyright (C) 2005 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! An interface to the sqlite database. Tested against sqlite v3.1.3.
+! Remeber to pass the following to factor:
+! -libraries:sqlite=libsqlite3.so
+!
+! Not all functions have been wrapped yet. Only those directly involving
+! executing SQL calls and obtaining results.
+!
+IN: libsqlite
+USING: alien compiler errors kernel math namespaces sequences strings ;
+
+! Return values from sqlite functions
+: SQLITE_OK 0 ; inline ! Successful result
+: SQLITE_ERROR 1 ; inline ! SQL error or missing database
+: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite
+: SQLITE_PERM 3 ; inline ! Access permission denied
+: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort
+: SQLITE_BUSY 5 ; inline ! The database file is locked
+: SQLITE_LOCKED 6 ; inline ! A table in the database is locked
+: SQLITE_NOMEM 7 ; inline ! A malloc() failed
+: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database
+: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt()
+: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred
+: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed
+: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found
+: SQLITE_FULL 13 ; inline ! Insertion failed because database is full
+: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file
+: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error
+: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty
+: SQLITE_SCHEMA 17 ; inline ! The database schema changed
+: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table
+: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation
+: SQLITE_MISMATCH 20 ; inline ! Data type mismatch
+: SQLITE_MISUSE 21 ; inline ! Library used incorrectly
+: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host
+: SQLITE_AUTH 23 ; inline ! Authorization denied
+: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error
+: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range
+: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file
+
+: sqlite-error-messages ( -- seq ) {
+ "Successful result"
+ "SQL error or missing database"
+ "An internal logic error in SQLite"
+ "Access permission denied"
+ "Callback routine requested an abort"
+ "The database file is locked"
+ "A table in the database is locked"
+ "A malloc() failed"
+ "Attempt to write a readonly database"
+ "Operation terminated by sqlite_interrupt()"
+ "Some kind of disk I/O error occurred"
+ "The database disk image is malformed"
+ "(Internal Only) Table or record not found"
+ "Insertion failed because database is full"
+ "Unable to open the database file"
+ "Database lock protocol error"
+ "(Internal Only) Database table is empty"
+ "The database schema changed"
+ "Too much data for one row of a table"
+ "Abort due to contraint violation"
+ "Data type mismatch"
+ "Library used incorrectly"
+ "Uses OS features not supported on host"
+ "Authorization denied"
+ "Auxiliary database format error"
+ "2nd parameter to sqlite3_bind out of range"
+ "File opened that is not a database file"
+} ;
+
+: SQLITE_ROW 100 ; inline ! sqlite_step() has another row ready
+: SQLITE_DONE 101 ; inline ! sqlite_step() has finished executing
+
+! Return values from the sqlite3_column_type function
+: SQLITE_INTEGER 1 ; inline
+: SQLITE_FLOAT 2 ; inline
+: SQLITE_TEXT 3 ; inline
+: SQLITE_BLOB 4 ; inline
+: SQLITE_NULL 5 ; inline
+
+! Values for the 'destructor' parameter of the 'bind' routines.
+: SQLITE_STATIC 0 ; inline
+: SQLITE_TRANSIENT -1 ; inline
+
+TYPEDEF: void sqlite3
+TYPEDEF: void sqlite3_stmt
+
+LIBRARY: sqlite
+FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
+FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
+FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
+FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
+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_int ( sqlite3_stmt* pStmt, int index, int 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 ) ;
+FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ;
+FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;
+
--- /dev/null
+PROVIDE: libs/sqlite
+{ +files+ {
+ "libsqlite.factor"
+ "sqlite.factor"
+ "sqlite.facts"
+ "tuple-db.factor"
+ "tuple-db.facts"
+} }
+{ +tests+ {
+ "tuple-db-tests.factor"
+} } ;
--- /dev/null
+USING: generic kernel namespaces prettyprint sql sql:utils ;\r
+IN: sqlite\r
+\r
+TUPLE: sqlite ;\r
+C: sqlite ( path -- db )\r
+ >r sqlite-open <connection> r>\r
+ [ set-delegate ] keep ;\r
+\r
+! M: sqlite insert-sql* ( tuple db -- string )\r
+ #! Insert and fill in the ID column\r
+ ! ;\r
+\r
+M: sqlite delete-sql* ( tuple db -- string )\r
+ #! Delete based on the ID column\r
+ ;\r
+\r
+M: sqlite update-sql* ( tuple db -- string )\r
+ #! Update based on the ID column\r
+ ;\r
+\r
+M: sqlite select-sql* ( tuple db -- string )\r
+ ;\r
+\r
+\r
--- /dev/null
+! Copyright (C) 2005 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! An interface to the sqlite database. Tested against sqlite v3.0.8.
+! Remeber to pass the following to factor:
+! -libraries:sqlite=libsqlite3.so
+!
+! Not all functions have been wrapped yet. Only those directly involving
+! executing SQL calls and obtaining results.
+!
+IN: sqlite
+USING: alien compiler errors libsqlite kernel namespaces sequences sql strings ;
+
+TUPLE: sqlite-error n message ;
+
+! High level sqlite routines
+: sqlite-check-result ( result -- )
+ #! Check the result from a sqlite call is ok. If it is
+ #! return, otherwise throw an error.
+ dup SQLITE_OK = [
+ drop
+ ] [
+ dup sqlite-error-messages nth <sqlite-error> throw
+ ] if ;
+
+: sqlite-open ( filename -- db )
+ #! Open the database referenced by the filename and return
+ #! a handle to that database. An error is thrown if the database
+ #! failed to open.
+ "void*" <c-object> [ sqlite3_open sqlite-check-result ] keep *void* ;
+
+: sqlite-close ( db -- )
+ #! Close the given database
+ sqlite3_close sqlite-check-result ;
+
+: sqlite-last-insert-rowid ( db -- rowid )
+ #! Return the rowid of the last insert
+ sqlite3_last_insert_rowid ;
+
+: sqlite-prepare ( db sql -- statement )
+ #! Prepare a SQL statement. Returns the statement which
+ #! can have values bound to parameters or simply executed.
+ #! TODO: Support multiple statements in the SQL string.
+ dup length "void*" <c-object> "void*" <c-object>
+ [ sqlite3_prepare sqlite-check-result ] 2keep
+ drop *void* ;
+
+: sqlite-bind-text ( statement index text -- )
+ #! Bind the text to the parameterized value in the statement.
+ dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ;
+
+: sqlite-bind-parameter-index ( statement name -- index )
+ sqlite3_bind_parameter_index ;
+
+: sqlite-bind-text-by-name ( statement name text -- )
+ >r dupd sqlite-bind-parameter-index r> sqlite-bind-text ;
+
+: sqlite-finalize ( statement -- )
+ #! Clean up all resources related to a statement. Once called
+ #! the statement cannot be used. All statements must be finalized
+ #! before closing the database.
+ sqlite3_finalize sqlite-check-result ;
+
+: sqlite-reset ( statement -- )
+ #! Reset a statement so it can be called again, possibly with
+ #! different parameters.
+ sqlite3_reset sqlite-check-result ;
+
+: column-count ( statement -- int )
+ #! Given a prepared statement, return the number of
+ #! columns in each row of the result set of that statement.
+ sqlite3_column_count ;
+
+: column-text ( statement index -- string )
+ #! Return the value of the given column, indexed
+ #! from zero, as a string.
+ sqlite3_column_text ;
+
+: step-complete? ( step-result -- bool )
+ #! Return true if the result of a sqlite3_step is
+ #! such that the iteration has completed (ie. it is
+ #! SQLITE_DONE). Throw an error if an error occurs.
+ dup SQLITE_ROW = [
+ drop f
+ ] [
+ dup SQLITE_DONE = [
+ drop t
+ ] [
+ sqlite-check-result t
+ ] if
+ ] if ;
+
+: sqlite-each ( statement quot -- )
+ #! Execute the SQL statement, and call the quotation for
+ #! each row returned from executing the statement with the
+ #! statement on the top of the stack.
+ over sqlite3_step step-complete? [
+ 2drop
+ ] [
+ [ call ] 2keep sqlite-each
+ ] if ; inline
+
+! For comparison, here is the linrec implementation of sqlite-each
+! [ drop sqlite3_step step-complete? ]
+! [ 2drop ]
+! [ 2dup 2slip ]
+! [ ] linrec ;
+
+DEFER: (sqlite-map)
+
+: (sqlite-map) ( statement quot seq -- )
+ pick sqlite3_step step-complete? [
+ 2nip
+ ] [
+ >r 2dup call r> curry (sqlite-map)
+ ] if ;
+
+: sqlite-map ( statement quot -- seq )
+ [ ] (sqlite-map) ;
+
+: with-sqlite ( path quot -- )
+ [
+ >r sqlite-open db set r>
+ [ db get sqlite-close ] cleanup
+ ] with-scope ;
+
--- /dev/null
+USING: kernel math sql:utils ;
+IN: sql
+
+: save ( tuple -- )
+ dup "id" tuple-slot [
+ ! update
+ ] [
+ ! insert
+ ] if ;
+
+: restore ( tuple -- )
+ ;
+
+
--- /dev/null
+USING: arrays errors generic hashtables kernel math namespaces\r
+prettyprint sequences sql strings tools words ;\r
+IN: sql:utils\r
+\r
+! : 2seq>hash 2array flip alist>hash ;\r
+\r
+: 2seq>hash ( seq seq -- hash )\r
+ H{ } clone -rot [ pick set-hash ] 2each ;\r
+\r
+: tuple-fields ( tuple -- seq )\r
+ class "slot-names" word-prop ;\r
+\r
+: tuple>parts ( tuple -- values names )\r
+ [ tuple-slots ] keep tuple-fields ;\r
+\r
+: tuple>hash ( tuple -- hash )\r
+ tuple>parts 2seq>hash ;\r
+\r
+: tuple>all-slots\r
+ delegates <reversed> V{ } clone\r
+ [ tuple-slots dupd nappend ] reduce\r
+ <reversed> prune <reversed> >array ;\r
+\r
+: tuple>all-fields\r
+ delegates <reversed> V{ } clone\r
+ [ tuple-fields dupd nappend ] reduce\r
+ <reversed> prune <reversed> >array ;\r
+ \r
+: full-tuple>hash ( tuple -- hash )\r
+ delegates <reversed>\r
+ H{ } clone [ tuple>hash hash-union ] reduce ;\r
+\r
+: tuple>all-parts ( tuple -- values names )\r
+ [\r
+ [ full-tuple>hash ] keep tuple>all-fields\r
+ [ swap hash ] map-with\r
+ ] keep tuple>all-fields ;\r
+\r
+: maybe-unparse ( obj -- )\r
+ dup string? [ unparse ] unless ;\r
+\r
+: replace ( new old seq -- seq )\r
+ >r 2seq>hash r> [\r
+ [\r
+ [\r
+ tuck swap hash* [ nip ] [ drop ] if\r
+ dup sequence? [ % ] [ , ] if \r
+ ] each-with\r
+ ] { } make\r
+ ] keep like ;\r
+\r
+GENERIC: escape-sql* ( string type db -- string )\r
+\r
+M: connection escape-sql* ( string type db -- string )\r
+ drop { "''" } "'" rot replace ;\r
+\r
+: escape-sql ( string type -- string ) db get escape-sql* ;\r
+\r
+: sanitize-name ( string -- string )\r
+ "_p" "-?" pick subst ;\r
+\r
+: tuple>sql-name ( tuple -- string )\r
+ class unparse sanitize-name ;\r
+\r
+: enquote% "'" % % "'" % ;\r
+\r
+: enquote ( string -- 'string' )\r
+ [ enquote% ] "" make ;\r
+\r
+: split-last ( seq -- last most )\r
+ dup length {\r
+ { [ dup zero? ] [ 2drop f f ] }\r
+ { [ dup 1 = ] [ drop f ] }\r
+ { [ t ] [ >r [ peek 1array ] keep r> 1- head ] }\r
+ } cond ;\r
+\r
+: (each-last) ( seq quot quot -- )\r
+ >r >r split-last r> each r> each ; inline\r
+\r
+: each-last ( seq quot quot -- )\r
+ >r dup clone r> append swap (each-last) ;\r
+\r
+: (2each-last) ( seq seq quot quot -- )\r
+ >r >r [ split-last ] 2apply swapd r> 2each r> 2each ; inline\r
+\r
+: 2each-last ( seq seq quot quot -- )\r
+ #! apply first quotation on all but last elt of seq\r
+ #! apply second quotation on last element\r
+ >r dup clone r> append swap (2each-last) ;\r
+\r
+! <foo1> { integer string }\r
+! mapping: { integer { varchar(256) "not null" } }\r
+! { "a integer" "b string" }\r
+\r
+SYMBOL: mappings\r
+H{ } clone mappings set-global\r
+\r
+: get-mapping ( tuple -- seq )\r
+ dup class mappings get hash* [\r
+ nip\r
+ ] [\r
+ drop tuple-slots [ drop "varchar" ] map\r
+ ] if ;\r
+\r
+: tuple>mapping% ( obj -- seq )\r
+ [ get-mapping ] keep tuple-fields\r
+ [ sanitize-name % " " % % ] [ ", " % ] 2each-last ;\r
+\r
+: tuple>mapping ( tuple -- string )\r
+ [ tuple>mapping% ] "" make ;\r
+\r
+: tuple>insert-parts ( tuple -- string )\r
+ [\r
+ tuple>parts\r
+ [\r
+ dup "id" = [\r
+ 2drop\r
+ ] [\r
+ over [ swap 2array , ] [ 2drop ] if\r
+ ] if\r
+ ] 2each\r
+ ] { } make flip ;\r
+\r
+: tuple>assignments% ( tuple -- string )\r
+ [ tuple-slots [ maybe-unparse escape-sql ] map ] keep\r
+ tuple-fields\r
+ [ sanitize-name % " = " % enquote% ] [ ", " % ] 2each-last ;\r
+\r
+: tuple>assignments% ( tuple -- string )\r
+ tuple>parts dup [ "id" = ] find drop\r
+ dup -1 = [ "tuple must have an id slot" throw ] when\r
+ swap >r tuck >r remove-nth r> r> remove-nth\r
+ >r [ maybe-unparse escape-sql ] map r>\r
+ [ % " = " % enquote% ] [ ", " % ] 2each-last ;\r
+\r
+: tuple>assignments ( tuple -- string )\r
+ [ tuple>assignments% ] "" make ;\r
+\r
+: tuple-slot ( string slot -- ? obj )\r
+ "slot-names" over class word-props hash\r
+ rot [ = ] curry find over -1 = [\r
+ swap\r
+ ] [\r
+ drop 2 + swap tuple>array nth >r t r>\r
+ ] if ;\r
+\r
+: explode-tuple ( tuple -- )\r
+ dup tuple-slots swap class "slot-names" word-prop\r
+ [ set ] 2each ;\r
+\r
+\r
projects / factor.git / commitdiff