[Win32forth-cvs] win32forth/src/lib SQLite.F, NONE, 1.1 WinSock.f, NONE, 1.1

[Dirk B. <db...@us...>]

Update of /cvsroot/win32forth/win32forth/src/lib
In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv3872/src/lib

Added Files:
	SQLite.F WinSock.f 
Log Message:
- Tom Dixon's WinSock and SQLite library's added

--- NEW FILE: SQLite.F ---
\ SQLite -- Database Class for SQLite
\ Thomas Dixon

\ *D doc\
\ *! SQLite
\ *T SQLite -- Database Class for SQLite
\ *Q Tom Dixon
\ ** This class provides an interface to SQLite databases.

\ *S SQLite Behavior

\ ** SQLite operates on database files.  Files are opened as read-only, if
\ ** no update occurs, and can be shared through several applications.
\ ** Writes cause a block until the file can be opened as read/write.  This
\ ** makes the locking scheme very efficient and easy to work with.\n\n
\ ** SQLite is very fast, flexible, and simple.  One very nice feature is
\ ** that SQLite will convert types as best as it can for you if you want
\ ** a type different from the native database type.\n\n
\ ** For more information about SQLite, please see
\ *W <A href="http://www.sqlite.org/">www.sqlite.org</A>

anew -SQLite.f

INTERNAL
EXTERNAL

winlibrary sqlite3.dll

\ Code to handle returned floats

CODE retF
        FPU>
float;

CFA-CODE DOCALL64 ( [ n ] -- r ) \ like DOCALL, but with a double returned
        push    ebx
        mov     ebx, edx                \ save UP
        call    4 [eax]                 \ call address is absolute!!!
        push    edx
        mov     edx, ebx                \ restore UP
        mov     ebx, eax
        next    c;

: make-proc64 ' docall64 swap ! ;


\ convert standard calls to 64-bit return calls
0 proc sqlite3_column_int64

make-proc64 sqlite3_column_int64


\ DataTypes
1 constant SQLITE_INTEGER
2 constant SQLITE_FLOAT
3 constant SQLITE_TEXT
4 constant SQLITE_BLOB
5 constant SQLITE_NULL


variable SQLITE_STATIC          0 SQLITE_STATIC !
variable SQLITE_TRANSIENT      -1 SQLITE_TRANSIENT !


:class SQLiteDB               <SUPER Object
\ *G SQLiteDB is an interface to SQLite.

        CELL bytes dbhndl
        CELL bytes stmt
        CELL bytes tail
             int   lasterr
             int   sstate
             int   #args
        256  bytes tstr

:M SQLOK: ( n -- ) \ checks return argument for errors
        dup 1 99 within if
          to lasterr
        else drop then ;M

:M ERR: ( -- ) \ thows an error on any problem
\ *G Displays any error that might have occured.
        lasterr if
          dbhndl @ call sqlite3_errmsg nip
          zcount tstr place  0 to lasterr
          tstr $DB nabort!
        then ;M

:M Open: ( str len -- )
\ *G Opens a database file so we can execute operations on it.\n
\ ** If the string is ":memory:" the database is actually created
\ ** in memory instead of on disk, and should be faster.
        dup 1+ tstr + 0 swap c! tstr swap cmove
        dbhndl tstr call sqlite3_open
        SQLOK: self drop drop ERR: self ;M

:M Close: ( -- flag )
\ *G Closes the database.  You can still open another database with
\ ** the same object after closing, if desired.
        stmt @ if
          stmt call sqlite3_finalize drop
          SQLOK: self ERR: self
          0 stmt ! 0 to sstate
        then
        dbhndl @ if
          dbhndl @ call sqlite3_close SQLOK: self drop
          0 dbhndl ! ERR: self
        then ;M

:M ~: (  --  ) Close: self ;M


:M Version: ( -- str len )
\ *G Returns the version of SQLite being used
        call sqlite3_libversion zcount ;M

:M (Step): ( -- n )
        stmt @ call sqlite3_step nip ;M

:M (Execute): ( str len -- )
        stmt @ if
          stmt call sqlite3_finalize drop
          SQLOK: self ERR: self
          0 stmt ! 0 to sstate
        then
        tail stmt 2swap swap dbhndl @
        call sqlite3_prepare_v2
        SQLOK: self ERR: self
        2drop 2drop drop ;M


:M Execute: ( str len -- )
\ *G Execute a SQL query on the cursor.  Any returned data will be in the cursor.
        (Execute): self
        stmt @ call sqlite3_bind_parameter_count nip
        dup to #args if exitm then
        begin (Step): self 5 = while
        drop 1 ms repeat ;M

:M Requery: ( -- )
\ *G Rerun the last query.
        stmt @ call sqlite3_reset 2drop ;M

:M FieldCnt: ( -- n )
\ *G Returns the number of columns in the current record.
        stmt @ call sqlite3_column_count nip ;M

:M FieldType: ( field -- DataTypeEnum )
\ *G Returns the data type constant of the given column. Possible data types are:
\ *L
\ *| SQLITE_INTEGER |
\ *| SQLITE_FLOAT |
\ *| SQLITE_TEXT |
\ *| SQLITE_BLOB |
\ *| SQLITE_NULL |
        stmt @ call sqlite3_column_type nip nip ;M

:M FieldName: ( field -- str len )
\ *G Returns the column name of the given column number.
        stmt @ call sqlite3_column_name nip nip
        dup if zcount else drop s" " then ;M

:M GetInt: ( field -- int )
\ *G Returns an integer value of the given column on the current row.
        stmt @ call sqlite3_column_int nip nip ;M

:M GetDouble: ( field -- d )
\ *G Returns the double of the given column on the current row.
        stmt @ sqlite3_column_int64 2swap 2drop swap ;M

:M GetFloat: ( field -- float )
\ *G Returns the floating point value of the given column on the current row.
        stmt @ call sqlite3_column_double retF 2drop drop ;M

:M GetStr: ( field -- str len )
\ *G Returns the string of the given column on the current row.  May be much longer than 255
        stmt @ call sqlite3_column_text nip nip
        dup if zcount else drop s" " then ;M

:M GetBLOB: ( field -- addr len )
\ *G Returns the Binary Buffer of the given column on the current row.
\ ** This binary data may be anything.
        stmt @ call sqlite3_column_bytes >r
        call sqlite3_column_blob nip nip r> ;M

:M isNull?: ( field -- flag )
\ *G Returns true if the given field for the given flag is null
        FieldType: self SQLITE_NULL = ;M

:M NextRow: ( -- flag )
\ *G Goes to the next row of the query result.  If there are no more rows,
\ ** it will return true
        (Step): self 100 <> ;M

:M (Bind): ( -- )
        #args 0= if
          begin (Step): self 5 = while
          drop 1 ms repeat
        then ;M

:M BindInt: ( n i -- )
\ *G Binds a '?' in the query string to a integer.  If there are no more question
\ ** marks in the query string, the query will execute.
        1+ stmt @ call sqlite3_bind_int
        SQLOK: self ERR: self
        2drop drop -1 +to #args
        (bind): self ;M

:M BindDouble: ( d i -- )
\ *G Binds a '?' in the query string to a double int.  If there are no more question
\ ** marks in the query string, the query will execute.
        1+ stmt @ call sqlite3_bind_int64
        SQLOK: self ERR: self
        2drop 2drop -1 +to #args
        (bind): self ;M

:M BindFloat: ( f i -- )
\ *G Binds a '?' in the query string to a floating point number.
\ ** If there are no more question
\ ** marks in the query string, the query will execute.
        1+ >r FS>DS r> stmt @ call sqlite3_bind_double
        SQLOK: self ERR: self
        2drop 2drop -1 +to #args
        (bind): self ;M

:M BindStr: ( str len i -- )
\ *G Binds a '?' in the query string to a string.  If there are no more question
\ ** marks in the query string, the query will execute.
        1+ >r swap SQLITE_TRANSIENT -rot r>
        stmt @ call sqlite3_bind_text
        SQLOK: self ERR: self
        2drop 2drop drop -1 +to #args
        (bind): self ;M

:M BindBlob: ( str len i -- )
\ *G Binds a '?' in the query string to a blob (binary buffer object, or in simpler
\ ** terms, a bunch of bytes).  If there are no more question
\ ** marks in the query string, the query will execute.
        1+ >r swap SQLITE_TRANSIENT -rot r>
        stmt @ call sqlite3_bind_text
        SQLOK: self ERR: self
        2drop 2drop drop -1 +to #args
        (bind): self ;M

;class

MODULE

\ *S Examples of Usage:

\ *W <br><U>Creating/Opening a Database:</U><br><br>

\ *E SQLiteDB sqlite
\ ** s" c:\\test.db" open: sqlite

\ *W <br><U>Creating a Database in RAM:</U><br><br>

\ *E SQLiteDB sqlite
\ ** s" :memory:" open: sqlite


\ *W <br><U>Closing a Database:</U><br><br>

\ *E close: sqlite


\ *W <br><U>Creating a table:</U><br><br>

\ *E s" CREATE TABLE idtoname (id int, name varchar)"
\ ** execute: sqlite



\ *W <br><U>Inserting into a table:</U><br><br>

\ *E s" INSERT INTO idtoname(id, name) VALUES(?,?)"
\ ** execute: sqlite
\ ** 1                  0 bindint: sqlite
\ ** s" Jim Hawkins"    1 bindstr: sqlite
\ **
\ ** s" INSERT INTO idtoname(id, name) VALUES(?,?)"
\ ** execute: sqlite
\ ** 2                  0 bindint: sqlite
\ ** s" Billy Bones"    1 bindstr: sqlite
\ **
\ ** s" INSERT INTO idtoname(id, name) VALUES(?,?)"
\ ** execute: sqlite
\ ** 3                  0 bindint: sqlite
\ ** s" Long John Silver" 1 bindstr: sqlite


\ *W <br><U>Executing SQL:</U><br><br>

\ *E : qdump ( -- )
\ **  fieldcnt: sqlite
\ **  0 ?do
\ **    i fieldname: sqlite type tab
\ **  loop cr cr
\ **  begin
\ **    fieldcnt: sqlite
\ **    0 ?do
\ **        i getstr: sqlite type tab
\ **    loop cr
\ **    nextrow: sqlite
\ **  until ;
\ **
\ ** s" SELECT * FROM idtoname WHERE id < 1000 ORDER BY name DESC"
\ ** execute: sqlite
\ ** cr qdump
\ **


\ *W <br><U>Deleting a table:</U><br><br>

\ *E s" DROP TABLE idtoname"
\ ** execute: sqlite



--- NEW FILE: WinSock.f ---
\ Socket Library
\ Thomas Dixon
\ 7/7/2006

\ *D doc\
\ *! WinSock
\ *T Simple Socket Library
\ *Q Tom Dixon - July 2006

\ *P This is intended to be a simple wordset for sockets in forth.
\ ** The words do not match the standard socket api.  It has been adapted to
\ ** be easier to use in Forth.
\ ** It's simplicity should make it easy to port network apps to other
\ ** forth systems.

anew -WinSock.f

INTERNAL
EXTERNAL

\ these constants come from a complicated formula in winsock2.h
$4004667f constant FIONREAD
$8004667e constant FIONIO
$8004667d constant FIONASYNC

\ Import WinSock2 Dll

winlibrary ws2_32.dll


\ Import functions from the dll

\ *S Network Formatting Words
\ ** These words are for converting 16-bit and 32-bit values to the right
\ ** format so any machine should be able to convert them back into their
\ ** values.

1 PROC htonl ( hostlong -- u_long )
\ *G Convert a 32-bit number on the stack to a network acceptable
\ ** byte-ordered value.

1 PROC htons ( hostshort -- u_short )
\ *G Convert a 16-bit number on the stack to a network acceptable
\ ** byte-ordered value.

1 PROC ntohl ( netlong -- u_long )
\ *G Convert a network compatible 32-bit number on the stack to the
\ ** correct 32-bit integer

1 PROC ntohs ( netshort -- u_short )
\ *G Convert a network compatible 16-bit number on the stack to the
\ ** correct 16-bit integer


1 PROC inet_addr ( *cp -- in_addr )
1 PROC inet_ntoa ( in_addr -- *char )

2 PROC listen ( backlog sock -- int )
4 PROC recv   ( flags len *buf sock -- int )
5 PROC select ( *timeout *exceptfds *writefds *readfds nfds -- int )
4 PROC send   ( flags len *buf sock -- int )
2 PROC shutdown ( how sock -- int )
3 PROC socket ( protocol type af-- sock )
3 PROC bind ( namelen 'sock sock -- int )
1 PROC closesocket ( sock -- int )
3 PROC connect ( len 'sock sock -- int )
3 PROC ioctlsocket ( *argp cmd sock -- int )
1 PROC gethostbyname ( *name -- hostent )

2 PROC WSAStartup ( lpWSAData wVersionRequired -- int )
0 PROC WSACleanup ( -- int )


\ *S Socket Library and Initialization Words
\ ** These words are for initializing and unloading the windows socket
\ ** dll.  They are automatically called when the console is initialized
\ ** and right before it closes, so normally a developer would never need
\ ** to use these.

\ API Setup and Closure (linked to initialization and closure chains)

: wsocket2-init ( -- )
\ *G Initializes the windows socket dll \n
\ ** called in initialization-chain
  pad $202 WSAStartup drop ;

: wsocket2-cleanup ( -- )
\ *G Initializes the windows socket dll \n
\ ** called in initialization-chain
  WSACleanup drop ;

initialization-chain	chain-add wsocket2-init
unload-chain		chain-add wsocket2-cleanup

wsocket2-init	\ initialize sockets


\ User Area Definition
\ This is to make all socket functions thread-safe

16 newuser saddr \ socket address structure

\ *S Main Socket Words
\ ** These words represent the core of the socket library.
\ ** They have been written to be thread-safe.

: host>iaddr ( str len -- iaddr )
\ *G This function converts a host string to an ip address \n
\ ** The host string could be anything from a domain name to ip address. \n
\ ** Returns 0 if the host is unable to be looked up.
  pad place 0 pad c+place pad 1+ gethostbyname
  dup if 12 + @ @ @ then ;

: iaddr>str ( iaddr -- str len )
\ *G This converts an ip address to a readable string.
\ ** It does not look up the host name, the string is in the "255.255.255.255" format
  inet_ntoa zcount ;


\ *W <br><br><U>Example:</U> simple host lookup.<br>
\ *E s" www.win32forth.org" host>iaddr
\ ** dup . \ should be anything other than 0
\ ** iaddr>str type \ should return ip address of win32forth.org



: sock-open ( addr len port -- sock )
\ *G This opens up a new socket to a host name on a given port number \n
\ ** the host name will be looked up and the port number is converted implicitly \n
\ ** If the socket cannot be opened, a exception will be thrown.
  htons saddr 2 + w!
  AF_INET saddr w!
  host>iaddr saddr 4 + !
  0 SOCK_STREAM AF_INET socket dup
  16 saddr rot connect abort" Unable to connect!" ;


: sock-read ( addr len sock -- len )
\ *G Reads data from the socket to a buffer. \n
\ ** It works very similarly to 'read-file', but has different return parameters \n
\ ** a returned 'len' of -1 means there was a socket error (SOCKET_ERROR) \n
\ ** If the provided 'len' is larger than the amount of data ready to be read from the socket,
\ ** the socket will block until it has revceived the full amount of data.\n
\ ** If the socket is a non-blocking socket, it will read what it can and return
\ ** right away.
  >r swap 0 -rot r> recv ;

: sock-write ( addr len sock -- len )
\ *G Write data from a buffer to the socket. \n
\ ** It works very similarly to 'write-file' \n
\ ** a returned 'len' of -1 means there was a socket error (SOCKET_ERROR) \n
\ ** If the socket is currently unable to take any data,
\ ** the socket will block until it has room in it's internal buffer to send the data.\n
\ ** If the socket is a non-blocking socket, it will write what it can and return
\ ** right away. (amount actually written is returned as 'len')
  >r swap 0 -rot r> send ;

: sock-close ( sock -- ior )
\ *G Closes socket - very similar to close-file\n
\ ** ior is 0 if the close was successful
  closesocket ;


\ *W <br><br><U>Example:</U> Get data from a socket.<br>
\ *W This will dump the html data from google's homepage through the use of sockets.<br>
\ *E create tbuf 256 allot
\ ** 0 value sock
\ ** : sdump ( sock -- )
\ **   begin
\ **     dup sock-read? if dup tbuf 256 rot sock-read tbuf swap type then
\ **     dup sock-closed? key? or until
\ **   sock-close drop ;
\ **
\ ** s" www.google.com" 80 sock-open value sock
\ ** s" GET / HTTP/1.0" sock sock-write .
\ ** crlf$ count sock sock-write .
\ ** crlf$ count sock sock-write .
\ ** sock sdump



\ *S Socket Listening Words
\ ** These words are for writting the serving-end of network applications.\n
\ ** They have also been written to be thread-safe.

: sock-create ( p -- sock )
\ *G Make a new socket for listening on port 'p'
\ ** Used only for server-side sockets
  htons saddr 2 + w!
  AF_INET saddr w!
  INADDR_ANY saddr 4 + !
  0 SOCK_STREAM AF_INET socket dup
  16 saddr rot bind abort" Unable to bind socket!" ;

: sock-listen ( n sock -- )
\ *G This tells a socket to start queuing sockets that want to connect.\n
\ ** 'n' is the size of the queue that should be created to listen.
\ ** after 'n' sockets have tried to connect and have yet to be accepted,
\ ** further sockets will be refused until waiting sockets are accepted.
\ ** (standard queue size is 5)
  listen drop ;

: sock-accept ( sock -- sock iaddr )
\ *G This will accept a socket that is in the listening queue. \n
\ ** 'iaddr' is the ip address of the connecting socket and can be converted
\ ** into an easy-to-read number through the 'iaddr>str' word. \n
\ ** If no sockets are in queue to be accepted, this function will block
\ ** until one tries to connect. \n
\ ** If the socket is a non-blocking socket, then the function will fail
\ ** and return immediately if the queue has no sockets to accept. \n
\ ** If the function fails, it will return '0' as the iaddr and '-1'
\ ** (or INVALID_SOCKET) as the socket.
  16 >r rp@ saddr rot call accept r> drop
  dup INVALID_SOCKET = if 0
  else saddr 4 + @ then ;



\ *S Asyncronous Socket Words
\ ** These words are for the ability to use the sockets without having them block.\n
\ ** Very useful for apps that need to do many things at once.


: sock-read? ( sock -- n )
\ *G This function returns the amount of data that the socket can read
\ ** without blocking.  It is useful for working with socket asyncronously.\n
\ ** It will return -1 if the socket has no data to read (will block, or socket closed).
  0 >r rp@ FIONREAD rot ioctlsocket if r> drop -1 exit then r> ;

: sock-write? ( sock -- flag )
\ *G This function returns true if the socket can write data without blocking.\n
\ ** You can send 0-1024 bytes to the socket asyncronously without blocking if
\ ** the flag is true.
  1 saddr !
    saddr 4 + !
  0 saddr 8 + !
  0 saddr 12 + !
  saddr 8 + 0 saddr 0 0 select ;

: sock-accept? ( sock -- flag )
\ *G This function returns true if the socket has other sockets in queue that
\ ** want to be connected.  It is to be used in conjunction with 'sock-accept'
\ ** so you can call sock-accept without blocking.
  1 saddr !
    saddr 4 + !
  0 saddr 8 + !
  0 saddr 12 + !
  saddr 8 + 0 0 saddr 0 select ;

: sock-closed? ( sock -- flag )
\ *G This function tests to see if the socket has been closed at the other end
\ ** or broken at any point.
  dup sock-accept? 1 = swap sock-read? 0 = and ;

: sock-err? ( sock -- n )
\ *G This function tests to see if there are any errors on the socket.
  1 saddr !
    saddr 4 + !
  0 saddr 8 + !
  0 saddr 12 + !
  saddr 8 + saddr 0 0 0 select ;

: sock-blocked ( flag sock -- )
\ *G This function sets a socket to blocked or unblocked mode.\n
\ ** If the flag is false, the socket will be set to 'unblocked'.\n
\ ** If the flag is true, the socket will be set to 'blocked'.\n
  swap not >r rp@ FIONIO rot ioctlsocket r> 2drop ;

MODULE

\ *Z