diff --git a/Makefile.in b/Makefile.in index ddd7e05..37a3708 100644 --- a/Makefile.in +++ b/Makefile.in @@ -3,20 +3,25 @@ # Documentation in files INSTALL and doc/install.txt +ODBC=/cygdrive/d/Program Files/Microsoft Platform SDK +#ODBCCPPFLAGS="-I$(ODBC)/Include/" +ODBCLDFLAGS="-L$(ODBC)/Lib/" +ODBCLIBS=-lodbc32 + srcdir = @srcdir@ VPATH = @srcdir@ CC = @CC@ DEFS = @DEFS@ EXEEXT = @EXEEXT@ -LIBS = @LIBS@ +LIBS = @LIBS@ $(ODBCLIBS) #DBOPEN = @DBOPEN@ CFLAGS = @CFLAGS@ -CPPFLAGS= @CPPFLAGS@ -I$(srcdir)/cig -I$(srcdir)/scsh/regexp +CPPFLAGS= @CPPFLAGS@ -I$(srcdir)/cig -I$(srcdir)/scsh/regexp $(ODBCCPPFLAGS) INSTALL = @INSTALL@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ -c INSTALL_DATA = @INSTALL_DATA@ -c -LDFLAGS = -g @LDFLAGS@ +LDFLAGS = -g @LDFLAGS@ $(ODBCLDFLAGS) LDFLAGS_AIX= @LDFLAGS_AIX@ RM = rm -f @@ -127,8 +132,15 @@ SCSHOBJS = \ # scsh/$(DBOPEN) \ # scsh/dbm.o scsh/dbm1.o +SCSHODBCOBJS = \ + scsh/odbc/scsh-odbc.o \ + scsh/odbc/odbc0.o \ + scsh/odbc/odbc1.o \ + scsh/odbc/odbc2.o \ +# + OBJS = unix.o dynload.o prescheme.o extension.o scheme48vm.o \ - process_args.o $(CIGOBJS) $(SCSHVMHACKS) $(SCSHOBJS) + process_args.o $(CIGOBJS) $(SCSHVMHACKS) $(SCSHOBJS) $(SCSHODBCOBJS) # Sources: @@ -187,26 +199,26 @@ include $(srcdir)/scsh/machine/Makefile.inc #.include "$(srcdir)/scsh/machine/Makefile.inc" $(VM): main.o $(OBJS) $(AIX_P) - if [ ! "$${OSTYPE}" = "cygwin32" ] ; then \ + if [ ! "$${OSTYPE}" = "cygwin" ] ; then \ $(CC) $(LDFLAGS) $(LDFLAGS_AIX) -o $@ main.o $(OBJS) $(LIBS); \ else \ dlltool \ --export-all-symbols \ --output-def $@.def \ main.o $(OBJS); \ - $(CC) -s -Wl,--base-file,$@.base -o $@ main.o $(OBJS); \ + $(CC) -s -Wl,--base-file,$@.base -o $@ main.o $(OBJS) $(LIBS); \ dlltool \ --dllname $@ \ --input-def $@.def \ --base-file $@.base \ --output-exp $@.exp; \ - $(CC) -s -Wl,--base-file,$@.base,$@.exp -o $@ main.o $(OBJS); \ + $(CC) -s -Wl,--base-file,$@.base,$@.exp -o $@ main.o $(OBJS) $(LIBS); \ dlltool \ --dllname $@ \ --input-def $@.def \ --base-file $@.base \ --output-exp $@.exp; \ - $(CC) -Wl,$@.exp -o $@ main.o $(OBJS); \ + $(CC) -Wl,$@.exp -o $@ main.o $(OBJS) $(LIBS); \ fi $(LIBCIG): main.o $(OBJS) @@ -358,8 +370,8 @@ distclean: clean scsh/machine scsh/regexp/Makefile \ scsh/endian.scm scsh/static.scm \ exportlist.aix - $(RM) a.exe $(VM).base $(VM).def $(VM).exp - -find . -name '*~' -o -name '#*' -o -name core -exec rm {} \; + $(RM) a.exe $(VM).base $(VM).def $(VM).exp $(VM)$(EXEEXT).stackdump + -find . -name '*~' -o -name '#*' -o -name core -exec rm {} \; man: $(MANPAGE) @@ -608,6 +620,9 @@ SCHEME =scsh/awk.scm \ scsh/meta-arg.scm \ scsh/network.scm \ scsh/newports.scm \ + scsh/odbc/odbc0.scm \ + scsh/odbc/odbc1.scm \ + scsh/odbc/odbc2.scm \ scsh/procobj.scm \ scsh/pty.scm \ scsh/rdelim.scm \ @@ -645,6 +660,9 @@ scsh/select.c: scsh/select.scm scsh/syscalls.c: scsh/syscalls.scm scsh/tty.c: scsh/tty.scm scsh/time.c: scsh/time.scm +scsh/odbc/odbc0.c: scsh/odbc/odbc0.scm +scsh/odbc/odbc1.c: scsh/odbc/odbc1.scm +scsh/odbc/odbc2.c: scsh/odbc/odbc2.scm scsh/scsh: scsh/scsh-tramp.c $(CC) -o $@ $(CPPFLAGS) $(CFLAGS) \ @@ -720,7 +738,11 @@ install-scsh: scsh do $(INSTALL_DATA) $$f $(LIB)/scsh/; done clean-scsh: - $(RM) scsh/*.o scsh/regexp/*.o scsh/rx/*.o scsh/machine/*.o + $(RM) scsh/*.o + $(RM) scsh/machine/*.o + $(RM) scsh/odbc/*.o + $(RM) scsh/regexp/*.o + $(RM) scsh/rx/*.o $(RM) scsh/*.image $(RM) $(LIBSCSH) scsh/scsh$(EXEEXT) scsh/scsh.vm -cd scsh/regexp; $(MAKE) clean diff --git a/RELEASE b/RELEASE index ca37d53..37903ac 100644 --- a/RELEASE +++ b/RELEASE @@ -1,11 +1,11 @@ -Scsh 0.5.2 Release notes -*- outline -*- +Scsh 0.5.3 Release notes -*- outline -*- -We are pleased to release scsh version 0.5.2. The new release has many bug +We are pleased to release scsh version 0.5.3. The new release has many bug fixes, improvements and new features. The text below gives a general description of scsh, instructions for obtaining it, pointers to discussion forums, and a description of the new features in -release 0.5.2. (Emacs should display this document is in outline mode. Say +release 0.5.3. (Emacs should display this document is in outline mode. Say c-h m for instructions on how to move through it by sections (e.g., c-c c-n, c-c c-p).) @@ -271,7 +271,7 @@ particularly in the task of porting scsh to new platforms. Michael Schinz Manuel Serrano Mark Shirle - Bill Sommerfeld + Bill Somerfeld Mike Sperber Harvey J. Stein Pawel Turnau diff --git a/bin/scsh-release b/bin/scsh-release index 9e37925..42e8569 100755 --- a/bin/scsh-release +++ b/bin/scsh-release @@ -15,7 +15,7 @@ # # rm /zu/bdc/ftp/scsh/README~ # -VERSION=-0.5.2 +VERSION=-0.5.3 FTPDIR=${HOME}/ftp/users/bdc CVSROOT=/projects/express/scsh-cvs diff --git a/bin/scsh-test b/bin/scsh-test index c4327cd..b0c1eb1 100755 --- a/bin/scsh-test +++ b/bin/scsh-test @@ -1,6 +1,6 @@ #!/bin/sh cd /dl/bdc tar xzvf /zu/bdc/ftp/users/bdc/scsh.tar.gz -cd scsh-0.5.2 +cd scsh-0.5.3 ./configure make diff --git a/cig/image2script b/cig/image2script index 96735f2..e39e30c 100755 --- a/cig/image2script +++ b/cig/image2script @@ -14,11 +14,7 @@ elif [ $# -gt 0 ] ; then else echo '#!'$binary -i fi -if [ ! "${OSTYPE}" = "cygwin32" ] ; then - exec cat -else - exec /mksnt/cat -fi +exec cat # This program reads an S48 image from stdin and turns it into # an executable by prepending a #! prefix. The vm and its diff --git a/doc/scsh-manual/front.tex b/doc/scsh-manual/front.tex index 94beeea..4d1b484 100644 --- a/doc/scsh-manual/front.tex +++ b/doc/scsh-manual/front.tex @@ -1,7 +1,7 @@ %&latex -*- latex -*- \title{Scsh Reference Manual} -\subtitle{For scsh release 0.5.2} +\subtitle{For scsh release 0.5.3} \author{Olin Shivers and Brian D.~Carlstrom} \date{September 1999} diff --git a/doc/scsh-manual/man.tex b/doc/scsh-manual/man.tex index 07e4f73..4e358f4 100644 --- a/doc/scsh-manual/man.tex +++ b/doc/scsh-manual/man.tex @@ -7,7 +7,7 @@ headings,mantitle,array,matter,mysize10} \usepackage[dvipdfm,hyperindex,hypertex, - pdftitle={scsh manual, release 0.5.2}, + pdftitle={scsh manual, release 0.5.3}, pdfauthor={Olin Shivers and Brian D.~Carlstrom} colorlinks=true,linkcolor=blue,pagecolor=blue,urlcolor=blue, pdfstartview=FitH,pdfview=FitH]{hyperref} diff --git a/initial.image b/initial.image index a935d2d..08734a0 100644 Binary files a/initial.image and b/initial.image differ diff --git a/scsh.spec b/scsh.spec index d5a1fd4..49325d9 100644 --- a/scsh.spec +++ b/scsh.spec @@ -1,6 +1,6 @@ Summary: Scheme shell Name: scsh -Version: 0.5.2 +Version: 0.5.3 Release: 1 Copyright: Massachusetts Institute of Technology Packager: Francisco Vides Fernandez diff --git a/scsh/minor-version-number b/scsh/minor-version-number index ef425ca..d346e2a 100644 --- a/scsh/minor-version-number +++ b/scsh/minor-version-number @@ -1 +1 @@ -5.2 +5.3 diff --git a/scsh/network1.c b/scsh/network1.c index 52fc070..5eed933 100644 --- a/scsh/network1.c +++ b/scsh/network1.c @@ -22,7 +22,9 @@ /* Make sure our exports match up w/the implementation: */ #include "network1.h" +#ifndef __CYGWIN__ extern int h_errno; +#endif /* to extract a 4 byte long value from a scheme string */ diff --git a/scsh/odbc/odbc.txt b/scsh/odbc/odbc.txt new file mode 100644 index 0000000..8fd5d42 --- /dev/null +++ b/scsh/odbc/odbc.txt @@ -0,0 +1,554 @@ +Sam Thibault +ODBC interface for scsh +Spring 1999 + +1 Scsh ODBC + +Scsh ODBC is an ODBC interface for scsh providing the complete +functionality for all ODBC Core 1.0 functions. The procedures that +Scsh ODBC exports allow a clean, scheme-style interface for executing +SQL statements with a RDBMS. The tools include simple management of +open connections, SQL statement execution with or without parameters, +and multiple fetch operations. Scsh ODBC also possesses a small error +system that raises conditions specific to ODBC errors and errors +returned from the RDBMS. + +2 Exported Interface + +The procedures and syntaxes exported by Scsh ODBC provide all the functionality +neccesary to conduct SQL interaction with a RDBMS. + +2.1 A Note on Data Types + +Scsh ODBC makes use of three abstract data types to keep the interface clean and +straight-forward. These three data types are explained here: + + db: + A DB is an opened connection to a RDBMS. In addition, Scsh ODBC also + allows a program to keep track of a "current db". The current db + will be used as the default connection in some procedure calls where + the db argument is optional. + + command: + The COMMAND data type keeps track of an SQL statement (e.g. "select * + from foo"), its associated statement handle, the preparation state + of the command, and allows statement handle re-use (see CURSORS + below). In Scsh ODBC a command can be passed to procedures executing + SQL statements rather than just a string. This helps performance for + SQL statements that are repeatedly executed. + + cursor: + After executing a select statement, Scsh ODBC will return a CURSOR. + The cursor may then be passed to a fetching procedure to get values + from a result table. Once all the resulting rows have been fetched + or the cursor has bee closed (by calling close-cursor), the cursor's + associated statement handle will be freed and cycled into the + originating command for re-use. + +2.2 Managing Connections + +(open-db host user password) => db procedure + + This procedure opens a connection to a RDBMS. The arguments passed are + all strings. HOST will probably contain port information, such as: + + "my-rdbms.foo.bar tcpip 1313" + + USER is the username you would like to use for this connection; + PASSWORD is the password for the username given. + + The return value DB is an abstract data type that will be passed to the + other procedures at this level. + +(set-current-db! db) => undefined procedure + + Once a connection has been opened, it can be set as the "current-db". + Any procedure with an optional db argument will use this current-db if + the db argument is not supplied. (see close-db below) + +(current-db) => db | #f procedure + + Calling this procedure will return the current-db if one has been set. If + a current-db has not been set, this procedure returns #f. + +(close-db [db]) => #t procedure + + This procedure is used to close an opened connection DB. If a db is + supplied in DB, that connection will be closed. Otherwise, close-db + will close the db assigned to be the current db. + +(call/db host user password proc) => value(s) of proc procedure + + This procedure opens a connection with the HOST USER and PASSWORD + provided (see open-db). PROC is then called with one argument, the newly + opened connection. The connections is closed when the value(s) of proc + are returned. + +(with-current-db* db thunk) => value(s) of thunk procedure + + This procedure evaluates THUNK within a dynamic scope that binds the + connection DB to be the current db. The value of (CURRENT-DB) returns to + its previous value when this procedure returns. In the event of a + non-local exit (throwing to an outer continuation, or raising an + exception), the current db is also reset. + +(with-open-db* host user password thunk) => value(s) of thunk procedure + + This procedure opens a connection with the HOST USER and PASSWORD + provided (see open-db). THUNK is then evaluated within a scope that + binds the newly opened connection to be the current-db. The connection + is closed when the value(s) are returned. Like with-current-db*, the + current-db resumes its prior value. + +(with-current-db db body1 body2 ...) => value(s) of body syntax +(with-open-db host user password body1 body2 ...) => value(s) of body syntax + + These two syntaxes are macro versions of with-current-db* and + with-open-db*. + +2.3 Executing SQL Statements + +(string->sql-command sql-string) => command procedure + + This procedure will create an abstract "command" datatype from the given + string. A command record is useful because the SQL string passed + will only be prepared once. If the SQL statement contains parameters, + the new parameter arguments can be supplied again without re-preparing + the SQL string. + +(execute-sql command [db params]) => #t | integer | cursor procedure + + This procedure will execute any SQL command. The COMMAND argument can + be either a command record (made with sql->command) or a string + containing a properly formed SQL statement. A connection may be supplied + in DB. If no connection is given, the current-db will be used. + Any number of parameters for the SQL statement may then be given. + + The value returned by execute-sql depends on the type of SQL statement. + Commands such as "create" or "drop" will return #t. Commands modifying + rows, like "insert" "update" or "delete", will return an integer - the + number of rows modified. A select statement will cause execute-sql + to return a cursor record. This cursor record may be passed to any of + the fetch procedures (fetch-row, fetch-rows, fetch-all) to retrieve + data from the selected table. + + Recycling of statements... + +2.4 Fetching Results + +(fetch-row cursor) => vector | #f procedure +(fetch-rows cursor nrows) => list of vectors | #f procedure +(fetch-all cursor) => list of vectors | #f procedure + + These fetch operations will retrieve data from a table using a cursor + record returned from execute-sql. If there are no more rows in the table + these procedures will return #f. Otherwise, fetch-row will return the + first row of data in the result set. Fetch-rows will return NROWS rows + from the table (NROWS is an integer) or all remaining rows if less than + NROWS rows remain in the result set. Fetch-all will return all the + remaining rows in the result set. If all rows in a cursor have been + fetched, close-cursor will be called on CURSOR. + + Each row is returned as a vector; each element of the vector corresponds + to a column of the table. The element's order matches the order of the + the columns in the result set. Vectors in a list (of multiple fetched + rows) are in fetched order, with the first row fetched begin the first row + in the list. + +2.5 Cursors + +(close-cursor cursor) => #t procedure + + This procedure calls free-stmt/close on the cursor's associated statement + handle. Next, it will recycle the statement back into the originating + command for reuse. If the command already has a statament handle for use, + the freed statement handle will be discarded. + +(cursor-name? cursor) => string procedure + + This procedure returns the cursor name associated with CURSOR. + +(set-cursor-name cursor name-string) => undefined procedure + + Set-cursor-name associates the cursor name [name-string] with the active + statement handle [odbc-hstmt]. If an application does not call + set-cursor-name, the driver generates cursor names as needed for SQL + statement processing. + +2.6 Transaction Control + +(cancel command) => #t procedure + + This procedure cancels all processing on the statement handle associated + with COMMAND. + +(commit db) => #t procedure + + This procedure performs a commit operation for all active operations on + all statement handles associated with the connection DB. + +(rollback db) => #t procedure + + This procedure performs a rollback operation for all active operations on + all statement handles associated with the connection DB. + +2.7 Column Information and Binding + +(bind-col command icol type precision) => c-storage procedure + + Bind-col allocates a storage buffer to receieve data returned in fetches + from a result set. The buffer will correspond to the select performed + using the statement handle COMMAND, and a particular column of that + select as specified by ICOL, an integer value. The size of the buffer + will depend on the final two arguments. TYPE is one of the data type + symbols such as 'sql/integer' (not a string), and PRECISION is an + integer that the table should have defined for that column. The ODBC + documentation specifies how the precision value relates to each ODBC + data type. + +(bind-parameter command icol data-type + precision scale param) => #t procedure + + Bind-parameter creates a storage buffer containing the value of a + parameter for an SQL statement associated with the statement handle + COMMAND. The ICOL argument names the parameter corresponding to + this buffer. So if ICOL is the value '2', this buffer will hold the + value for the second parameter argument ('?') in the SQL statement. + DATA_TYPE is one of the defined data-type symbols like 'SQL/Integer'. + PRECISION and SCALE are integer arguments that affect different + data types in the manner specified by the ODBC documentation. PARAM + is the actual string, integer, etc. that will be bound and used in the + execution of the SQL statement. + +(describe-col command icol) + => values: name name-size data-type precision scale nullable procedure + + Describe-col returns information about one column (specified by ICOL) + in the result set associated with the statement handle of COMMAND. + + All the return values are integers, except for the column name which is a + string. The interpretation of the integer arguments is specified in the + ODBC documentation concerning data types. + +(describe-param command icol) + => values: data-type precision scale nullable procedure + + Describe-param returns the description of a parameter marker (specified by + the integer ICOL) associated with the SQL statement prepared using the + statement handle command. The return values are all integers. + +(num-result-cols command) => integer procedure + + This procedure returns the number of columns in the result set associated + with the statement handle [odbc-hstmt]. + +(row-count command) => integer procedure + + Row-count returns the number of rows affected by the UPDATE, INSERT, or + DELETE statement associated with the statement handle of COMMAND. + +2.8 Freeing Resources + +(free-env) => #t procedure + + Free-env frees the environment handle and frees all memory associated + with the environment handle. This procedure should only be called + after the application is completely finished and *all* connections have + been closed. + +3 Error System + +3.1 Calling ODBC Functions + + When a call to an ODBC function occurs - whether initiated from a +top-level or mid-level procedure - the ODBC function has the possibility of +raising several different error conditions. The Scsh ODBC interface provides +procedures to handle the possible conditions that may arise. Below are the +error conditions associated with each ODBC return value: + + odbc return type = scheme condition + ----------------------=-------------------- + SQL_INVALID_HANDLE = sql-invalid-error + SQL_ERROR = sql-error + SQL_SUCCESS = #t + SQL_SUCCESS_WITH_INFO = sql-info-warning + SQL_STILL_EXECUTING = sql-busy-exception + SQL_NEED_DATA = sql-param-exception + SQL_NO_DATA_FOUND = #f + ----------------------=-------------------- + + SQL_INVALID_HANDLE: + Function failed due to invalid environment, connection, or statement + handles. This indicates a programming error. + + SQL_ERROR: + Function failed. The error message and error code will be returned in + the condition raised. + + SQL_SUCCESS: + Function completed successfully; no additional information is + available. + + SQL_SUCCESS_WITH_INFO: + Function completed successfully; possibly with a nonfatal error. The + warning message and error code can be caught using + with-sql-info-handler* described below. + + SQL_STILL_EXECUTING: + A function that was started asynchronously is still executing. + + SQL_NEED_DATA: + The application failed to send parameter data values for the statement + being processed. + + SQL_NO_DATA_FOUND: + All rows from the result set have been fetched. + +3.2 Scheme Error Procedures + +(sql-invalid-error? condition) => boolean procedure +(sql-error? condition) => boolean procedure +(sql-info-warning? condition) => boolean procedure +(sql-busy-exception? condition) => boolean procedure +(sql-param-exception? condition) => boolean procedure + + These five procedures check a condition to see if it corresponds to the + particular condition contained in the procedure name. (sql-invalid-error + for example) + +(with-sql-invalid-handler* handler thunk) => value(s) of thunk procedure +(with-sql-error-handler* handler thunk) => value(s) of thunk procedure +(with-sql-info-handler* handler thunk) => value(s) of thunk procedure +(with-sql-busy-handler* handler thunk) => value(s) of thunk procedure +(with-sql-param-handler* handler thunk) => value(s) of thunk procedure + + Programs can use the five procedures above to handle the specific + condition specified in the name of the handler. (sql-invalid-error for + example) If the specific condition is signalled while the thunk is + executing, handler will be called with six arguments: + + (handler function error-code error-message henv hdbc hstmt) + + The ERROR-CODE and ERROR-MESSAGE are strings automatically retrieved by + Scsh ODBC. The [function] is a symbol name of the ODBC function in which + the error occured, such as 'Execute. + +(with-sql-handler* handler thunk) => value(s) of thunk procedure + + With-sql-handler* will call the handler for all of the five conditions + above. + +------------------------------------------------------------------------------- + +4 Other Stuff + +4.1 Notes About this Level + + This level of the interface contains all of the ODBC Core 1.0 functions. +Each ODBC function has been wrapped up inside a Scheme procedure which +manages all the neccesary resources for the ODBC function (by allocating +memory and converting datatypes using procedure in the Low Level Scsh ODBC +Interface) and then calls the ODBC function (these procedures actually call +procedures in the Low Level Interface that link to C stubs that call to the +ODBC library). These Scheme "wrappers" will raise any conditions resulting +from the ODBC call (see Error System below). Finally these procedures will +return a useful Scheme value approproate to the ODBC function called. + +4.2 ODBC Core 1.0 + + + sql/char + sql/numeric + sql/decimal + sql/integer + sql/smallint + sql/float + sql/real + sql/double + sql/varchar + sql/date + sql/time + sql/timestamp + sql/longvarchar + sql/binary + sql/varbinary + sql/longvarbinary + sql/bigint + sql/tinyint + sql/bit + +(type-val->string type) procedure + + This procedure merely returns a string representation of the given data + type such as "sql/integer" useful for error messages. + +(col-attributes odbc-hstmt icol descriptor-type) => integer | string procedure + + Col-attributes returns information about one attribute associated with + a column (selected by the integer ICOL) in a result set. (specified + by the statement handle ODBC-HSTMT). The desired attribute is + specified in DESCRIPTOR-TYPE using one of the following defined symbols: + + column-auto-increment + column-case-sensitive + column-count + column-display-size + column-length + column-money + column-name + column-nullable + column-precision + column-scale + column-searchable + column-type + column-type-name + column-unsigned + column-updatable + +(describe-col odbc-hstmt icol) + => values: name name-size data-type precision scale nullable procedure + + Describe-col returns information about one column (specified by ICOL) + in the result set associated with the statement handle ODBC-HSTMT. + + All the return values are integers, except for the column name which is a + string. The interpretation of the integer arguments is specified in the + ODBC documentation concerning data types. + +(describe-param odbc-hstmt icol) + => values: data-type precision scale nullable procedure + + Describe-param returns the description of a parameter marker (specified by + the integer ICOL) associated with the SQL statement prepared using the + statement handle odbc-hstmt. The return values are all integers. + +(num-result-cols odbc-hstmt) => integer procedure + + This procedure returns the number of columns in the result set associated + with the statement handle [odbc-hstmt]. + +(row-count odbc-hstmt) => integer procedure + + Row-count returns the number of rows affected by the UPDATE, INSERT, or + DELETE statement associated with the statement handle [odbc-hstmt]. + +(alloc-connect) => odbc-hdbc procedure + + This procedure allocates space for a new database connection without + performing the actual connection. The new connection handle, the + ODBC-HDBC that is returned, is allocated within the allocated + environment. If the environment handle has not yet been created, + alloc-connect will create the environment handle by calling server-env. + +(alloc-stmt odbc-hdbc) => odbc-hstmt procedure + + This procedure allocates a new statement handle using the supplied + connection handle. The newly allocated statement handle is then returned. + +(bind-col odbc-hstmt icol type precision) => c-storage procedure + + Bind-col allocates a storage buffer to receieve data returned in fetches + from a result set. The buffer will correspond to the select performed + using the statement handle ODBC-HSTMT, and a particular column of that + select as specified by ICOL, an integer value. The size of the buffer + will depend on the final two arguments. TYPE is one of the data type + symbols such as 'sql/integer' (not a string), and PRECISION is an + integer that the table should have defined for that column. The ODBC + documentation specifies how the precision value relates to each ODBC + data type. + +(bind-parameter odbc-hstmt icol data-type + precision scale param) => #t procedure + + Bind-parameter creates a storage buffer containing the value of a + parameter for an SQL statement associated with the statement handle + ODBC-HSTMT. The ICOL argument names the parameter corresponding to + this buffer. So if ICOL is the value '2', this buffer will hold the + value for the second parameter argument ('?') in the SQL statement. + DATA_TYPE is one of the defined data-type symbols like 'SQL/Integer'. + PRECISION and SCALE are integer arguments that affect different + data types in the manner specified by the ODBC documentation. PARAM + is the actual string, integer, etc. that will be bound and used in the + execution of the SQL statement. + +(connect host user password) => odbc-hdbc procedure + + Connect allocates a new connection handle (using alloc-connect) and opens + a connection to the data source specified by the three string arguments + HOST, USER, and PASSWORD. The connection handle associated with + the newly opened connection is returned. + +(connect! odbc-hdbc host user password) => undefined procedure + + Connect! uses the already allocated connection handle given in ODBC-HDBC + and connects to the data source specified by the three string arguments + HOST, USER, and PASSWORD. + +(disconnect odbc-hdbc) => #t procedure + + Disconnect closes the connection associated with the connection handle + ODBC-HDBC. + +(exec-direct odbc-hstmt sql-string) => #t procedure + + Given an allocated statement handle ODBC-HSTMT, exec-direct executes + the preparable SQL statement given as a string in SQL-STRING. + +(execute odbc-hstmt) => #t procedure + + This procedure executes the prepared SQL statment associated with the + statement handle ODBC-HSTMT. + +(fetch cursor-record) => vector | #f procedure + + Fetch retrieves a row of data from a result set using the information in + the given CURSOR-RECORD. The driver returns data for all columns that + were bound to storage locations with bind-col and combines the returned + values in a vector. If there were no more rows to be fetched, #f is + returned. + + Note: Fetch needs to be changed so it acts like the other mid-level + functions. Right now it is exactly fetch-row. + +(free-connection odbc-hdbc) => #t procedure + + Free-connection releases the connection handle [odbc-hdbc] and frees all + the memory associated with that connection handle. + +(free-stmt/close cursor) => #t procedure +(free-stmt/drop (command | cursor)) => #t procedure +(free-stmt/unbind command) => #t procedure +(free-stmt/reset command) => #t procedure + + These procedures stop processing associated with a specific statement + handle, close any open cursors, discards pending results, and, optionally, + frees all resources associated with the statement handle. The four + options for this ODBC function have been separated into four different + procedures as described below: + + free-stmt/close: Closes the cursor associated with the given CURSOR, + discarding pending results. The cursor may be reopened + by executing a "select" statement. + + free-stmt/drop: Frees all resorces associated with the COMMAND or + CURSOR's statement handle. The statement handle will + no longer be accesible. + + free-stmt/unbind: Any buffers bound to ODBC-HSTMT using bind-col are + released. + + free-stmt/reset: Any buffers bound to ODBC-HSTMT using bind-param are + released. + +(prepare sql-string [db]) => odbc-hstmt procedure + + Prepare uses the given DB, and opens a connction to the + data source specified by [host], [user], and [password]. Then prepare + allocates a statement handle and prepares the statement given as + [sql-string] for execution. The new statement handle is returned. + +(prepare! odbc-hstmt sql-string) => undefined procedure + + Using the connection handle given as [odbc-hstmt], this procedure prepares + the sql-string given as [sql-string]. + diff --git a/scsh/odbc/odbc0.c b/scsh/odbc/odbc0.c new file mode 100644 index 0000000..5e4fddb --- /dev/null +++ b/scsh/odbc/odbc0.c @@ -0,0 +1,733 @@ +/* This is an Scheme48/C interface file, +** automatically generated by cig. +*/ + +#include +#include /* For malloc. */ +#include "libcig.h" + +#if 0 +#include "cli0cli.h" +#include "cli0defs.h" +#include "cli0env.h" +#else +#include +#include +#include +#endif +scheme_value df_SQLAllocConnect(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLAllocConnect(SQLHENV, SQLHDBC*); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(2, nargs, "SQLAllocConnect"); + r1 = SQLAllocConnect((SQLHENV)AlienVal(args[1]), (SQLHDBC*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLAllocEnv(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLAllocEnv(SQLHENV*); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(1, nargs, "SQLAllocEnv"); + r1 = SQLAllocEnv((SQLHENV*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLAllocStmt(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLAllocStmt(SQLHDBC , SQLHSTMT*); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(2, nargs, "SQLAllocStmt"); + r1 = SQLAllocStmt((SQLHDBC )AlienVal(args[1]), (SQLHSTMT*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLBindCol(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLBindCol(SQLHSTMT , UWORD , SWORD , PTR , SDWORD , SDWORD*); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(6, nargs, "SQLBindCol"); + r1 = SQLBindCol((SQLHSTMT )AlienVal(args[5]), EXTRACT_FIXNUM(args[4]), EXTRACT_FIXNUM(args[3]), (PTR )AlienVal(args[2]), EXTRACT_FIXNUM(args[1]), (SDWORD*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLBindParameter(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLBindParameter(SQLHSTMT , UWORD , SWORD , SWORD , SWORD , UDWORD , SWORD , PTR , SDWORD , SDWORD*); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(10, nargs, "SQLBindParameter"); + r1 = SQLBindParameter((SQLHSTMT )AlienVal(args[9]), EXTRACT_FIXNUM(args[8]), EXTRACT_FIXNUM(args[7]), EXTRACT_FIXNUM(args[6]), EXTRACT_FIXNUM(args[5]), EXTRACT_FIXNUM(args[4]), EXTRACT_FIXNUM(args[3]), (PTR )AlienVal(args[2]), EXTRACT_FIXNUM(args[1]), (SDWORD*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLCancel(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLCancel(SQLHSTMT ); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(1, nargs, "SQLCancel"); + r1 = SQLCancel((SQLHSTMT )AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLColAttributes(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLColAttributes(SQLHSTMT , UWORD , UWORD , PTR , SWORD , SWORD*, SDWORD*); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(7, nargs, "SQLColAttributes"); + r1 = SQLColAttributes((SQLHSTMT )AlienVal(args[6]), EXTRACT_FIXNUM(args[5]), EXTRACT_FIXNUM(args[4]), (PTR )AlienVal(args[3]), EXTRACT_FIXNUM(args[2]), (SWORD*)AlienVal(args[1]), (SDWORD*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLConnect(long nargs, scheme_value *args) +{ + + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(7, nargs, "SQLConnect"); + r1 = SQLConnect((SQLHDBC )AlienVal(args[6]), cig_string_body(args[5]), EXTRACT_FIXNUM(args[4]), cig_string_body(args[3]), EXTRACT_FIXNUM(args[2]), cig_string_body(args[1]), EXTRACT_FIXNUM(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLDescribeCol(long nargs, scheme_value *args) +{ + + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(9, nargs, "SQLDescribeCol"); + r1 = SQLDescribeCol((SQLHSTMT )AlienVal(args[8]), EXTRACT_FIXNUM(args[7]), cig_string_body(args[6]), EXTRACT_FIXNUM(args[5]), (SWORD*)AlienVal(args[4]), (SWORD*)AlienVal(args[3]), (UDWORD*)AlienVal(args[2]), (SWORD*)AlienVal(args[1]), (SWORD*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLDescribeParam(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLDescribeParam(SQLHSTMT , UWORD , SWORD*, UDWORD*, SWORD*, SWORD*); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(6, nargs, "SQLDescribeParam"); + r1 = SQLDescribeParam((SQLHSTMT )AlienVal(args[5]), EXTRACT_FIXNUM(args[4]), (SWORD*)AlienVal(args[3]), (UDWORD*)AlienVal(args[2]), (SWORD*)AlienVal(args[1]), (SWORD*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLDisconnect(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLDisconnect(SQLHDBC ); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(1, nargs, "SQLDisconnect"); + r1 = SQLDisconnect((SQLHDBC )AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLError(long nargs, scheme_value *args) +{ + + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(8, nargs, "SQLError"); + r1 = SQLError((SQLHENV )AlienVal(args[7]), (SQLHDBC )AlienVal(args[6]), (SQLHSTMT )AlienVal(args[5]), cig_string_body(args[4]), (SDWORD*)AlienVal(args[3]), cig_string_body(args[2]), EXTRACT_FIXNUM(args[1]), (SWORD*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLExecDirect(long nargs, scheme_value *args) +{ + + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(3, nargs, "SQLExecDirect"); + r1 = SQLExecDirect((SQLHSTMT )AlienVal(args[2]), cig_string_body(args[1]), EXTRACT_FIXNUM(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLExecute(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLExecute(SQLHSTMT ); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(1, nargs, "SQLExecute"); + r1 = SQLExecute((SQLHSTMT )AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLFetch(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLFetch(SQLHSTMT ); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(1, nargs, "SQLFetch"); + r1 = SQLFetch((SQLHSTMT )AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLFreeConnect(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLFreeConnect(SQLHDBC ); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(1, nargs, "SQLFreeConnect"); + r1 = SQLFreeConnect((SQLHDBC )AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLFreeEnv(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLFreeEnv(SQLHENV ); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(1, nargs, "SQLFreeEnv"); + r1 = SQLFreeEnv((SQLHENV )AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLFreeStmt(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLFreeStmt(SQLHSTMT , UWORD ); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(2, nargs, "SQLFreeStmt"); + r1 = SQLFreeStmt((SQLHSTMT )AlienVal(args[1]), EXTRACT_FIXNUM(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLGetCursorName(long nargs, scheme_value *args) +{ + + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(4, nargs, "SQLGetCursorName"); + r1 = SQLGetCursorName((SQLHSTMT )AlienVal(args[3]), cig_string_body(args[2]), EXTRACT_FIXNUM(args[1]), (SWORD*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLNumResultCols(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLNumResultCols(SQLHSTMT , SWORD*); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(2, nargs, "SQLNumResultCols"); + r1 = SQLNumResultCols((SQLHSTMT )AlienVal(args[1]), (SWORD*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLPrepare(long nargs, scheme_value *args) +{ + + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(3, nargs, "SQLPrepare"); + r1 = SQLPrepare((SQLHSTMT )AlienVal(args[2]), cig_string_body(args[1]), EXTRACT_FIXNUM(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLRowCount(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLRowCount(SQLHSTMT , SDWORD*); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(2, nargs, "SQLRowCount"); + r1 = SQLRowCount((SQLHSTMT )AlienVal(args[1]), (SDWORD*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLSetCursorName(long nargs, scheme_value *args) +{ + + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(3, nargs, "SQLSetCursorName"); + r1 = SQLSetCursorName((SQLHSTMT )AlienVal(args[2]), cig_string_body(args[1]), EXTRACT_FIXNUM(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_SQLTransact(long nargs, scheme_value *args) +{ + extern SQLRETURN SQL_API SQLTransact(SQLHENV , SQLHDBC , UWORD ); + scheme_value ret1; + SQLRETURN SQL_API r1; + + cig_check_nargs(3, nargs, "SQLTransact"); + r1 = SQLTransact((SQLHENV )AlienVal(args[2]), (SQLHDBC )AlienVal(args[1]), EXTRACT_FIXNUM(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_makesqlhenv(long nargs, scheme_value *args) +{ + extern SQLHENV*makesqlhenv(void); + scheme_value ret1; + SQLHENV*r1; + + cig_check_nargs(1, nargs, "makesqlhenv"); + r1 = makesqlhenv(); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_derefsqlhenv(long nargs, scheme_value *args) +{ + extern SQLHENV derefsqlhenv(SQLHENV*); + scheme_value ret1; + SQLHENV r1; + + cig_check_nargs(2, nargs, "derefsqlhenv"); + r1 = derefsqlhenv((SQLHENV*)AlienVal(args[1])); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_freesqlhenv(long nargs, scheme_value *args) +{ + extern int freesqlhenv(SQLHENV*); + scheme_value ret1; + int r1; + + cig_check_nargs(1, nargs, "freesqlhenv"); + r1 = freesqlhenv((SQLHENV*)AlienVal(args[0])); + ret1 = ENTER_BOOLEAN(r1); + return ret1; + } + +scheme_value df_makesqlhdbc(long nargs, scheme_value *args) +{ + extern SQLHDBC*makesqlhdbc(void); + scheme_value ret1; + SQLHDBC*r1; + + cig_check_nargs(1, nargs, "makesqlhdbc"); + r1 = makesqlhdbc(); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_derefsqlhdbc(long nargs, scheme_value *args) +{ + extern SQLHDBC derefsqlhdbc(SQLHDBC*); + scheme_value ret1; + SQLHDBC r1; + + cig_check_nargs(2, nargs, "derefsqlhdbc"); + r1 = derefsqlhdbc((SQLHDBC*)AlienVal(args[1])); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_freesqlhdbc(long nargs, scheme_value *args) +{ + extern int freesqlhdbc(SQLHDBC*); + scheme_value ret1; + int r1; + + cig_check_nargs(1, nargs, "freesqlhdbc"); + r1 = freesqlhdbc((SQLHDBC*)AlienVal(args[0])); + ret1 = ENTER_BOOLEAN(r1); + return ret1; + } + +scheme_value df_makesqlhstmt(long nargs, scheme_value *args) +{ + extern SQLHSTMT*makesqlhstmt(void); + scheme_value ret1; + SQLHSTMT*r1; + + cig_check_nargs(1, nargs, "makesqlhstmt"); + r1 = makesqlhstmt(); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_derefsqlhstmt(long nargs, scheme_value *args) +{ + extern SQLHSTMT derefsqlhstmt(SQLHSTMT*); + scheme_value ret1; + SQLHSTMT r1; + + cig_check_nargs(2, nargs, "derefsqlhstmt"); + r1 = derefsqlhstmt((SQLHSTMT*)AlienVal(args[1])); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_freesqlhstmt(long nargs, scheme_value *args) +{ + extern int freesqlhstmt(SQLHSTMT*); + scheme_value ret1; + int r1; + + cig_check_nargs(1, nargs, "freesqlhstmt"); + r1 = freesqlhstmt((SQLHSTMT*)AlienVal(args[0])); + ret1 = ENTER_BOOLEAN(r1); + return ret1; + } + +scheme_value df_makeStorage(long nargs, scheme_value *args) +{ + extern void*makeStorage(SDWORD*); + scheme_value ret1; + void*r1; + + cig_check_nargs(2, nargs, "makeStorage"); + r1 = makeStorage((SDWORD*)AlienVal(args[1])); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_freeStorage(long nargs, scheme_value *args) +{ + extern int freeStorage(void*); + scheme_value ret1; + int r1; + + cig_check_nargs(1, nargs, "freeStorage"); + r1 = freeStorage((void*)AlienVal(args[0])); + ret1 = ENTER_BOOLEAN(r1); + return ret1; + } + +scheme_value df_makeSDWORD(long nargs, scheme_value *args) +{ + extern SDWORD*makeSDWORD(void); + scheme_value ret1; + SDWORD*r1; + + cig_check_nargs(1, nargs, "makeSDWORD"); + r1 = makeSDWORD(); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_derefSDWORD(long nargs, scheme_value *args) +{ + extern SDWORD derefSDWORD(SDWORD*); + scheme_value ret1; + SDWORD r1; + + cig_check_nargs(2, nargs, "derefSDWORD"); + r1 = derefSDWORD((SDWORD*)AlienVal(args[1])); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_extractSDWORD(long nargs, scheme_value *args) +{ + extern SDWORD extractSDWORD(SDWORD*); + scheme_value ret1; + SDWORD r1; + + cig_check_nargs(1, nargs, "extractSDWORD"); + r1 = extractSDWORD((SDWORD*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_assignSDWORD(long nargs, scheme_value *args) +{ + extern int assignSDWORD(SDWORD*, long ); + scheme_value ret1; + int r1; + + cig_check_nargs(2, nargs, "assignSDWORD"); + r1 = assignSDWORD((SDWORD*)AlienVal(args[1]), EXTRACT_FIXNUM(args[0])); + ret1 = ENTER_BOOLEAN(r1); + return ret1; + } + +scheme_value df_freeSDWORD(long nargs, scheme_value *args) +{ + extern int freeSDWORD(SDWORD*); + scheme_value ret1; + int r1; + + cig_check_nargs(1, nargs, "freeSDWORD"); + r1 = freeSDWORD((SDWORD*)AlienVal(args[0])); + ret1 = ENTER_BOOLEAN(r1); + return ret1; + } + +scheme_value df_makeUDWORD(long nargs, scheme_value *args) +{ + extern UDWORD*makeUDWORD(void); + scheme_value ret1; + UDWORD*r1; + + cig_check_nargs(1, nargs, "makeUDWORD"); + r1 = makeUDWORD(); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_derefUDWORD(long nargs, scheme_value *args) +{ + extern UDWORD derefUDWORD(UDWORD*); + scheme_value ret1; + UDWORD r1; + + cig_check_nargs(2, nargs, "derefUDWORD"); + r1 = derefUDWORD((UDWORD*)AlienVal(args[1])); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_extractUDWORD(long nargs, scheme_value *args) +{ + extern UDWORD extractUDWORD(UDWORD*); + scheme_value ret1; + UDWORD r1; + + cig_check_nargs(1, nargs, "extractUDWORD"); + r1 = extractUDWORD((UDWORD*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_freeUDWORD(long nargs, scheme_value *args) +{ + extern int freeUDWORD(UDWORD*); + scheme_value ret1; + int r1; + + cig_check_nargs(1, nargs, "freeUDWORD"); + r1 = freeUDWORD((UDWORD*)AlienVal(args[0])); + ret1 = ENTER_BOOLEAN(r1); + return ret1; + } + +scheme_value df_makeSWORD(long nargs, scheme_value *args) +{ + extern SWORD*makeSWORD(void); + scheme_value ret1; + SWORD*r1; + + cig_check_nargs(1, nargs, "makeSWORD"); + r1 = makeSWORD(); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_derefSWORD(long nargs, scheme_value *args) +{ + extern SWORD derefSWORD(SWORD*); + scheme_value ret1; + SWORD r1; + + cig_check_nargs(2, nargs, "derefSWORD"); + r1 = derefSWORD((SWORD*)AlienVal(args[1])); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_extractSWORD(long nargs, scheme_value *args) +{ + extern SWORD extractSWORD(SWORD*); + scheme_value ret1; + SWORD r1; + + cig_check_nargs(1, nargs, "extractSWORD"); + r1 = extractSWORD((SWORD*)AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_assignSWORD(long nargs, scheme_value *args) +{ + extern int assignSWORD(SWORD*, long ); + scheme_value ret1; + int r1; + + cig_check_nargs(2, nargs, "assignSWORD"); + r1 = assignSWORD((SWORD*)AlienVal(args[1]), EXTRACT_FIXNUM(args[0])); + ret1 = ENTER_BOOLEAN(r1); + return ret1; + } + +scheme_value df_freeSWORD(long nargs, scheme_value *args) +{ + extern int freeSWORD(SWORD*); + scheme_value ret1; + int r1; + + cig_check_nargs(1, nargs, "freeSWORD"); + r1 = freeSWORD((SWORD*)AlienVal(args[0])); + ret1 = ENTER_BOOLEAN(r1); + return ret1; + } + +scheme_value df_makeUCHAR(long nargs, scheme_value *args) +{ + extern char *makeUCHAR(void); + scheme_value ret1; + char *r1; + + cig_check_nargs(1, nargs, "makeUCHAR"); + r1 = makeUCHAR(); + ret1 = VECTOR_REF(*args,0); + {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} + return ret1; + } + +scheme_value df_derefUCHAR(long nargs, scheme_value *args) +{ + extern UCHAR derefUCHAR(const char *); + scheme_value ret1; + UCHAR r1; + + cig_check_nargs(2, nargs, "derefUCHAR"); + r1 = derefUCHAR(cig_string_body(args[1])); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_extractUCHAR(long nargs, scheme_value *args) +{ + extern char *extractUCHAR(const char *); + scheme_value ret1; + char *r1; + + cig_check_nargs(2, nargs, "extractUCHAR"); + r1 = extractUCHAR(cig_string_body(args[1])); + ret1 = VECTOR_REF(*args,0); + {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} + return ret1; + } + +scheme_value df_freeUCHAR(long nargs, scheme_value *args) +{ + extern int freeUCHAR(const char *); + scheme_value ret1; + int r1; + + cig_check_nargs(1, nargs, "freeUCHAR"); + r1 = freeUCHAR(cig_string_body(args[0])); + ret1 = ENTER_BOOLEAN(r1); + return ret1; + } + +scheme_value df_VoidToString(long nargs, scheme_value *args) +{ + extern char *VoidToString(PTR ); + scheme_value ret1; + char *r1; + + cig_check_nargs(2, nargs, "VoidToString"); + r1 = VoidToString((PTR )AlienVal(args[1])); + ret1 = VECTOR_REF(*args,0); + {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} + return ret1; + } + +scheme_value df_VoidToInteger(long nargs, scheme_value *args) +{ + extern int VoidToInteger(PTR ); + scheme_value ret1; + int r1; + + cig_check_nargs(1, nargs, "VoidToInteger"); + r1 = VoidToInteger((PTR )AlienVal(args[0])); + ret1 = ENTER_FIXNUM(r1); + return ret1; + } + +scheme_value df_StringToVoid(long nargs, scheme_value *args) +{ + extern void*StringToVoid(scheme_value , PTR ); + scheme_value ret1; + void*r1; + + cig_check_nargs(3, nargs, "StringToVoid"); + r1 = StringToVoid(args[2], (PTR )AlienVal(args[1])); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_FixedStringToVoid(long nargs, scheme_value *args) +{ + extern void*FixedStringToVoid(scheme_value , UDWORD , PTR ); + scheme_value ret1; + void*r1; + + cig_check_nargs(4, nargs, "FixedStringToVoid"); + r1 = FixedStringToVoid(args[3], EXTRACT_FIXNUM(args[2]), (PTR )AlienVal(args[1])); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + +scheme_value df_IntegerToVoid(long nargs, scheme_value *args) +{ + extern void*IntegerToVoid(int , PTR ); + scheme_value ret1; + void*r1; + + cig_check_nargs(3, nargs, "IntegerToVoid"); + r1 = IntegerToVoid(EXTRACT_FIXNUM(args[2]), (PTR )AlienVal(args[1])); + ret1 = VECTOR_REF(*args,0); + AlienVal(ret1) = (long) r1; + return ret1; + } + diff --git a/scsh/odbc/odbc0.scm b/scsh/odbc/odbc0.scm new file mode 100644 index 0000000..3c91715 --- /dev/null +++ b/scsh/odbc/odbc0.scm @@ -0,0 +1,570 @@ +;;; Sam Thibault +;;; ODBC/SQL interface for scsh +;;; Spring 1999 + +;;; This is file: odbc0.scm + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; General Comments +;;; ---------------- +;;; This file contains define-foreigns that link to stubs in odbc0.c, a file +;;; automatically generated with cig. The C definitiions are located in two +;;; separate files: +;;; +;;; /solidSDK30/Solaris_SPARC/lib/sclssx30.so contains definitions of the +;;; ODBC functions in the first half of this file. +;;; +;;; scch-sql.o (compiled from scsh-sql.c) contains the definitions of the +;;; functions in the second half of this file (used for allocating and +;;; freeing memory, and converting some data types. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; The headers below will be included in C file the generated by cig + +(foreign-source + "#if 0" + "#include \"cli0cli.h\"" + "#include \"cli0defs.h\"" + "#include \"cli0env.h\"" + "#else" + "#include " + "#include " + "#include " + "#endif" + "") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ODBC Functions +;;; --------------- +;;; These define-foreigns link to ODBC functions defined in sclssx30.so +;;; This set contains all ODBC core functions. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; SQLAllocConnect allocates memory for a connection handle within the +;;; identified environment. + +(define-foreign %alloc-connect + ("SQLAllocConnect" ((C "SQLHENV~a") environment) + ((C "SQLHDBC*~a") connection)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLAllocEnv allocates memory for an environment handle and initializes the +;;; ODBC call level interface for use by an application. AllocEnv must be +;;; called before any other ODBC function can be called. + +(define-foreign %alloc-env + ("SQLAllocEnv" ((C "SQLHENV*~a") pSQLHENV)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLAllocStmt allocates memory for a statement handle and associates the +;;; statement handle with the specified connection. AllocStmt must be called +;;; before executing any SQL statements. + +(define-foreign %alloc-stmt + ("SQLAllocStmt" ((C "SQLHDBC ~a") connection) + ((C "SQLHSTMT*~a") statement)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLBindCol assigns storage and data type for a column in a result set. + +(define-foreign %bind-col + ("SQLBindCol" ((C "SQLHSTMT ~a") statement) + ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") column-number) + ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") data-type) + ((C "PTR ~a") storage-pointer) + ((rep integer? "SDWORD ~a" "EXTRACT_FIXNUM") buffer-length) + ((C "SDWORD*~a") available-bytes)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLBindParameter binds a buffer to a parameter marker in an SQL statement. + +(define-foreign %bind-parameter + ("SQLBindParameter" ((C "SQLHSTMT ~a") statement) + ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") param-number) + ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") param-type) + ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") c-datatype) + ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") sql-datatype) + ((rep integer? "UDWORD ~a" "EXTRACT_FIXNUM") precision) + ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") scale) + ((C "PTR ~a") storage-pointer) + ((rep integer? "SDWORD ~a" "EXTRACT_FIXNUM") buf-length) + ((C "SDWORD*~a") available-bytes)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLCancel cancels the processing on a statement. + +(define-foreign %cancel + ("SQLCancel" ((C "SQLHSTMT ~a") statement)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLColAttributes returns descriptor information for a cloumn in a result +;;; set. + +(define-foreign %col-attributes + ("SQLColAttributes" ((C "SQLHSTMT ~a") statement) + ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") column-num) + ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") desc-type) + ((C "PTR ~a") storage-pointer) + ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") buf-length) + ((C "SWORD*~a") available-bytes) + ((C "SDWORD*~a") descriptor-pointer)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLConnect loads a driver and establishes a connection to the data source. + +(define-foreign %connect + ("SQLConnect" ((C "SQLHDBC ~a") connection) + (string source-name) + ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") source-name-length) + (string user-name) + ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") user-name-length) + (string password) + ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") password-length)) + no-declare + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLDescribeCol returns the result descriptor for one column in a result +;;; set. + +(define-foreign %describe-col + ("SQLDescribeCol" ((C "SQLHSTMT ~a") statment) + ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") column-number) + (string column-name) + ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") name-buffer-length) + ((C "SWORD*~a") bytes-available) + ((C "SWORD*~a") data-type) + ((C "UDWORD*~a") precision) + ((C "SWORD*~a") scale) + ((C "SWORD*~a") nullable)) + no-declare + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLDescribeParam returns the description of a parameter marker associated +;;; with a prepared SQL statement. + +(define-foreign %describe-param + ("SQLDescribeParam" ((C "SQLHSTMT ~a") statement) + ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") param-number) + ((C "SWORD*~a") sql-type) + ((C "UDWORD*~a") precision) + ((C "SWORD*~a") scale) + ((C "SWORD*~a") nullable)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLDisconnect closes the connection associated with a specific connection +;;; handle. + +(define-foreign %disconnect + ("SQLDisconnect" ((C "SQLHDBC ~a") connection)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLError returns error or status information. + +(define-foreign %sql-error + ("SQLError" ((C "SQLHENV ~a") environment) + ((C "SQLHDBC ~a") connection) + ((C "SQLHSTMT ~a") statement) + (string state) + ((C "SDWORD*~a") error-code) + (string error-message) + ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") buffer-length) + ((C "SWORD*~a") bytes-available)) + no-declare + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLExecDirect executes a preparable statement. + +(define-foreign %exec-direct + ("SQLExecDirect" ((C "SQLHSTMT ~a") statement) + (string sql-string) + ((rep integer? "SDWORD ~a" "EXTRACT_FIXNUM") string-length)) + no-declare + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLExecute executes a prepared statement. + +(define-foreign %execute + ("SQLExecute" ((C "SQLHSTMT ~a") statement)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLFetch fetches a row of data from a result set. The driver returns data +;;; for all columns that were bound to storage locations with BindCol. + +(define-foreign %fetch + ("SQLFetch" ((C "SQLHSTMT ~a") statement)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLFreeConnect releases a connection handle and frees all memory associated +;;; with the handle. + +(define-foreign %free-connect + ("SQLFreeConnect" ((C "SQLHDBC ~a") connection)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLFreeEnv frees the environment handle and frees all memory associated +;;; with the environment handle. + +(define-foreign %free-env + ("SQLFreeEnv" ((C "SQLHENV ~a") environment)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLFreeStmt stops processing associated with a specific statement handle, +;;; closes any open cursors, discards pending results, and, optionally, frees +;;; all resources associated with the statement handle. + +(define-foreign %free-stmt + ("SQLFreeStmt" ((C "SQLHSTMT ~a") statement) + ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") option)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLGetCursorName returns the cursor name associated with a specified +;;; statement handle. + +(define-foreign %get-cursor-name + ("SQLGetCursorName" ((C "SQLHSTMT ~a") statement) + (string cursor-name) + ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") name-length) + ((C "SWORD*~a") bytes-available)) + no-declare + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLNumResultCols returns the number of columns in a result set. + +(define-foreign %num-result-cols + ("SQLNumResultCols" ((C "SQLHSTMT ~a") statement) + ((C "SWORD*~a") columns)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLPrepare prepares an SQL string for execution. + +(define-foreign %prepare + ("SQLPrepare" ((C "SQLHSTMT ~a") statement) + (string sql-string) + ((rep integer? "SDWORD ~a" "EXTRACT_FIXNUM") string-length)) + no-declare + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLRowCount returns the number of rows affected by an UPDATE, INSERT, or +;;; DELETE statement. + +(define-foreign %row-count + ("SQLRowCount" ((C "SQLHSTMT ~a") statement) + ((C "SDWORD*~a") rows)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLSetCursorName associates a cursor name with an active statement handle. +;;; If an application does not call SetCursorName, the driver generates cursor +;;; names as needed for SQL statement processing. + +(define-foreign %set-cursor-name + ("SQLSetCursorName" ((C "SQLHSTMT ~a") statement) + (string cursor-name) + ((rep integer? "SWORD ~a" "EXTRACT_FIXNUM") name-length)) + no-declare + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;; SQLTransact requests a commit or rollback operation for all active +;;; operations on all statement handles associated with a connection. + +(define-foreign %transact + ("SQLTransact" ((C "SQLHENV ~a") environment) + ((C "SQLHDBC ~a") connection) + ((rep integer? "UWORD ~a" "EXTRACT_FIXNUM") option)) + (to-scheme (C "SQLRETURN SQL_API ~a") "ENTER_FIXNUM")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Other Functions +;;; --------------- +;;; These define-foregins link to functions defined in scsh-sql.c. These +;;; functions are used for allocating and freeing memory in C that the ODBC +;;; functions utilize. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Environment handles + +(define *environment* #f) + +(define-foreign make-environment + (makesqlhenv) + (C "SQLHENV*~a")) + +(define-foreign de-ref-env + (derefsqlhenv ((C "SQLHENV*~a") EnvPointer)) + (C "SQLHENV ~a")) + +(define-foreign free-environment + (freesqlhenv ((C "SQLHENV*~a") EnvPointer)) + bool) + +;;; Connection handles + +(define-foreign make-connection + (makesqlhdbc) + (C "SQLHDBC*~a")) + +(define-foreign de-ref-con + (derefsqlhdbc ((C "SQLHDBC*~a") DBCPointer)) + (C "SQLHDBC ~a")) + +(define-foreign free-connection + (freesqlhdbc ((C "SQLHDBC*~a") DBCPointer)) + bool) + +;;; Statement handles + +(define-foreign make-statement + (makesqlhstmt) + (C "SQLHSTMT*~a")) + +(define-foreign de-ref-stmt + (derefsqlhstmt ((C "SQLHSTMT*~a") StmtPointer)) + (C "SQLHSTMT ~a")) + +(define-foreign free-statement + (freesqlhstmt ((C "SQLHSTMT*~a") StmtPointer)) + bool) + +;;; void* (unknown type) + +(define-foreign make-storage + ("makeStorage" ((C "SDWORD*~a") pcbValue)) + (C "void*~a")) + +(define-foreign free-storage + ("freeStorage" ((C "void*~a") rgbValue)) + bool) + +;;; SDWORDs (long ints) + +(define-foreign make-SDWORD + ("makeSDWORD") + (C "SDWORD*~a")) + +(define-foreign de-ref-SDWORD + ("derefSDWORD" ((C "SDWORD*~a") SDWORDpointer)) + (C "SDWORD ~a")) + +(define-foreign extract-SDWORD + ("extractSDWORD" ((C "SDWORD*~a") SDWORDpointer)) + (to-scheme (C "SDWORD ~a") "ENTER_FIXNUM")) + +(define-foreign assign-SDWORD + ("assignSDWORD" ((C "SDWORD*~a") SDWORDpointer) + (long value)) + bool) + +(define-foreign free-SDWORD + ("freeSDWORD" ((C "SDWORD*~a") SDWORDpointer)) + bool) + +;;; UDWORDs (unsigned long ints) + +(define-foreign make-UDWORD + ("makeUDWORD") + (C "UDWORD*~a")) + +(define-foreign de-ref-UDWORD + ("derefUDWORD" ((C "UDWORD*~a") UDWORDpointer)) + (C "UDWORD ~a")) + +(define-foreign extract-UDWORD + ("extractUDWORD" ((C "UDWORD*~a") UDWORDpointer)) + (to-scheme (C "UDWORD ~a") "ENTER_FIXNUM")) + +(define-foreign free-UDWORD + ("freeUDWORD" ((C "UDWORD*~a") UDWORDpointer)) + bool) + +;;; SWORDs (short ints) + +(define-foreign make-SWORD + ("makeSWORD") + (C "SWORD*~a")) + +(define-foreign de-ref-SWORD + ("derefSWORD" ((C "SWORD*~a") SWORDpointer)) + (C "SWORD ~a")) + +(define-foreign extract-SWORD + ("extractSWORD" ((C "SWORD*~a") SWORDpointer)) + (to-scheme (C "SWORD ~a") "ENTER_FIXNUM")) + +(define-foreign assign-SWORD + ("assignSWORD" ((C "SWORD*~a") SWORDpointer) + (long value)) + bool) + +(define-foreign free-SWORD + ("freeSWORD" ((C "SWORD*~a") SWORDpointer)) + bool) + +;;; UCHARs (unsigned chars) + +(define-foreign make-UCHAR + ("makeUCHAR") + static-string) + +(define-foreign de-ref-UCHAR + ("derefUCHAR" (string UCHARpointer)) + (C "UCHAR ~a")) + +(define-foreign extract-UCHAR + ("extractUCHAR" (string UCHARpointer)) + static-string) + +(define-foreign free-UCHAR + ("freeUCHAR" (string UCHARpointer)) + bool) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Getting values to Scheme +;;; ------------------------ +;;; The following define foreigns enable ways to yank values +;;; in a C void* into Scheme. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-foreign void*->string + ("VoidToString" ((C "PTR ~a") pointer)) + static-string) + +(define-foreign void*->integer + ("VoidToInteger" ((C "PTR ~a") pointer)) + integer) + +(define (void*->number val) + (string->number (void*->string val))) + +;;; Date manipulations using sql-date records + +(define-record sql-date + seconds ; Seconds after the minute [0-59] or #f + minute ; Minutes after the hour [0-59] or #f + hour ; Hours since midnight [0-23] or #f + month-day ; Day of the month [1-31] or #f + month ; Months since January [1-12] or #f + year) ; Years since 1900 or #f + +;;; Conversion from string into sql-date records + +(define (void*->date val) + (let ((date-string (void*->string val))) + (make-sql-date #f #f #f + (string->number (substring date-string 8 10)) + (string->number (substring date-string 5 7)) + (string->number (substring date-string 0 4))))) + +(define (void*->time val) + (let ((time-string (void*->string val))) + (make-sql-date (substring time-string 6 8) + (substring time-string 3 5) + (substring time-string 0 2) + #f #f #f))) + +(define (void*->timestamp val) + (let ((timestamp-string (void*->string val))) + (make-sql-date (string->number (substring timestamp-string 17 19)) + (string->number (substring timestamp-string 14 16)) + (string->number (substring timestamp-string 11 13)) + (string->number (substring timestamp-string 8 10)) + (string->number (substring timestamp-string 5 7)) + (string->number (substring timestamp-string 0 4))))) + +;;; Conversion from sql-date records into strings + +(define (number->string/len n l) + (let* ((s (number->string n)) + (dif (- l (string-length n)))) + (case dif + ((0) s) + ((1) (string-append "0" s)) + ((2) (string-append "00" s)) + ((3) (string-append "000" s))))) + +(define (sql-date->string d) + (let ((sd (sql-date:seconds d)) + (mn (sql-date:minute d)) + (hr (sql-date:hour d)) + (md (sql-date:month-day d)) + (mo (sql-date:month d)) + (yr (sql-date:year d))) + (cond ((and sd mn hr md mo yr) ;make timestamp + (string-append + (number->string/len yr 4) "-" + (number->string/len mo 2) "-" + (number->string/len md 2) " " + (number->string/len md 2) ":" + (number->string/len md 2) ":" + (number->string/len sd 2))) + ((and sd mn hr) ;make time + (string-append + (number->string/len md 2) ":" + (number->string/len md 2) ":" + (number->string/len sd 2))) + ((and md mo yr) ;make date + (string-append + (number->string/len yr 4) "-" + (number->string/len mo 2) "-" + (number->string/len md 2))) + (else (error "sql-date record contains incomplete fields" d))))) + +;;; Conversion from scsh date record to sql-date record + +(define (date->sql-date d) + (make-sql-date (date:seconds d) + (date:minute d) + (date:hour d) + (date:month-day d) + (+ 1 (date:month d)) + (date:year d))) + +;;; Conversion from sql-date record to scsh date record +;;; This function may return an error if fields in sql-date record are #f. +;;; Raising an error here will prevent later scsh date manipulations from +;;; blowing up. + +(define (sql-date->date d) + (let ((sd (sql-date:seconds d)) + (mn (sql-date:minute d)) + (hr (sql-date:hour d)) + (md (sql-date:month-day d)) + (mo (sql-date:month d)) + (yr (sql-date:year d))) + (if (and sd mn hr md mo yr) + (make-date sd mn hr md (- mo 1) yr) + (error "sql-date record contains incomplete fields" d)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Getting values to C +;;; ------------------- +;;; The following define foreigns enable was to stuff values +;;; from Scheme into a C void* +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-foreign string->void* + ("StringToVoid" (string-desc value) + ((C "PTR ~a") pointer)) + (C "void*~a")) + +(define-foreign fixed-string->void* + ("FixedStringToVoid" (string-desc value) + ((rep integer? "UDWORD ~a" "EXTRACT_FIXNUM") precision) + ((C "PTR ~a") pointer)) + (C "void*~a")) + +(define (number->void* num ptr) + (string->void* (number->string num) ptr)) + +(define-foreign integer->void* + ("IntegerToVoid" (integer value) + ((C "PTR ~a") pointer)) + (C "void*~a")) diff --git a/scsh/odbc/odbc1.c b/scsh/odbc/odbc1.c new file mode 100644 index 0000000..10c63dc --- /dev/null +++ b/scsh/odbc/odbc1.c @@ -0,0 +1,62 @@ +/* This is an Scheme48/C interface file, +** automatically generated by cig. +*/ + +#include +#include /* For malloc. */ +#include "libcig.h" + +#if 0 +#include "cli0cli.h" +#include "cli0defs.h" +#include "cli0env.h" +#else +#include +#include +#include +#endif +scheme_value df_GetHenvErrorState(long nargs, scheme_value *args) +{ + extern char *GetHenvErrorState(SQLHENV , char **); + scheme_value ret1; + char *r1; + char *r2; + + cig_check_nargs(2, nargs, "GetHenvErrorState"); + r1 = GetHenvErrorState((SQLHENV )AlienVal(args[1]), &r2); + ret1 = VECTOR_REF(*args,0); + {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} + {AlienVal(CAR(VECTOR_REF(*args,1))) = (long) r2; CDR(VECTOR_REF(*args,1)) = strlen_or_false(r2);} + return ret1; + } + +scheme_value df_GetHdbcErrorState(long nargs, scheme_value *args) +{ + extern char *GetHdbcErrorState(SQLHENV , SQLHDBC , char **); + scheme_value ret1; + char *r1; + char *r2; + + cig_check_nargs(3, nargs, "GetHdbcErrorState"); + r1 = GetHdbcErrorState((SQLHENV )AlienVal(args[2]), (SQLHDBC )AlienVal(args[1]), &r2); + ret1 = VECTOR_REF(*args,0); + {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} + {AlienVal(CAR(VECTOR_REF(*args,1))) = (long) r2; CDR(VECTOR_REF(*args,1)) = strlen_or_false(r2);} + return ret1; + } + +scheme_value df_GetHstmtErrorState(long nargs, scheme_value *args) +{ + extern char *GetHstmtErrorState(SQLHENV , SQLHSTMT , char **); + scheme_value ret1; + char *r1; + char *r2; + + cig_check_nargs(3, nargs, "GetHstmtErrorState"); + r1 = GetHstmtErrorState((SQLHENV )AlienVal(args[2]), (SQLHSTMT )AlienVal(args[1]), &r2); + ret1 = VECTOR_REF(*args,0); + {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} + {AlienVal(CAR(VECTOR_REF(*args,1))) = (long) r2; CDR(VECTOR_REF(*args,1)) = strlen_or_false(r2);} + return ret1; + } + diff --git a/scsh/odbc/odbc1.scm b/scsh/odbc/odbc1.scm new file mode 100644 index 0000000..577d5c8 --- /dev/null +++ b/scsh/odbc/odbc1.scm @@ -0,0 +1,414 @@ +;;; Sam Thibault +;;; ODBC/SQL interface for scsh +;;; Spring 1999 + +;;; This is file: odbc1.scm + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; General Comments +;;; ---------------- +;;; This file contains several items: +;;; +;;; 1. Mappings of sql/odbc/c datatypes to integer values used by ODBC. +;;; +;;; 2. Definitions of records used by the scsh-sql interface and some +;;; additional tools for accessing the records/vector structures. +;;; +;;; 3. Error handling tools for scsh-sql. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; The headers below will be included in C file the generated by cig + +(foreign-source + "#if 0" + "#include \"cli0cli.h\"" + "#include \"cli0defs.h\"" + "#include \"cli0env.h\"" + "#else" + "#include " + "#include " + "#include " + "#endif" + "") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Datatypes +;;; --------- +;;; These value assign sql/odbc/c datatypes to the values used by odbc. There +;;; is also a function to decode the integer values so error messages can b +;;; more useful. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define sql/char 1) +(define sql/numeric 2) +(define sql/decimal 3) +(define sql/integer 4) +(define sql/smallint 5) +(define sql/float 6) +(define sql/real 7) +(define sql/double 8) +(define sql/varchar 12) +(define sql/date 9) +(define sql/time 10) +(define sql/timestamp 11) +(define sql/longvarchar -1) +(define sql/binary -2) +(define sql/varbinary -3) +(define sql/longvarbinary -4) +(define sql/bigint -5) +(define sql/tinyint -6) +(define sql/bit -7) + +(define (type-val->string type) + (cond + ((= type sql/char) "sql/char") + ((= type sql/numeric) "sql/numeric") + ((= type sql/decimal) "sql/decimal") + ((= type sql/integer) "sql/integer") + ((= type sql/smallint) "sql/smallint") + ((= type sql/float) "sql/float") + ((= type sql/real) "sql/real") + ((= type sql/double) "sql/double") + ((= type sql/varchar) "sql/varchar") + ((= type sql/date) "sql/date") + ((= type sql/time) "sql/time") + ((= type sql/timestamp) "sql/timestamp") + ((= type sql/longvarchar) "sql/longvarchar") + ((= type sql/binary) "sql/binary") + ((= type sql/varbinary) "sql/varbinary") + ((= type sql/longvarbinary) "sql/longvarbinary") + ((= type sql/bigint) "sql/bigint") + ((= type sql/tinyint) "sql/tinyint") + ((= type sql/bit) "sql/bit") + (else "unknown data type"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Records +;;; ------- +;;; Here are definitions of records/vectors for storing table-descriptions and +;;; cursor information. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; +;;; making a reference chart +;;; +;;; +-------+ +;;; cursor -> | hstmt | +;;; +-------+ +---+---+---+---+---+---+ - - - - - - +---+ +;;; | cols -+-----> | 0 | 1 | 2 | 3 | 4 | 5 | | N | +;;; +-------+ +---+---+-+-+---+---+---+ - - - - - - +---+ +;;; | +;;; | +-------------+ +;;; +--> | column name | +;;; +-------------+ +;;; | name size | +;;; +-------------+ +;;; | data type | +;;; +-------------+ +;;; | precision | +;;; +-------------+ +;;; | scale | +;;; +-------------+ +;;; | nullable | (alien) +;;; +-------------+ +-------+ +;;; | ----+---> | data | +;;; +-------------+ +-------+ +;;; + +(define-record column-desc + name + size + type + precision + scale + nullable + target) + +(define-record table-desc + hstmt ; ODBC statment handle + cols) ; vector of column-desc records (see above) + +;;; These functions reference items in the cursor. + +(define (column-name table-desc column-number) + (column-desc:name (vector-ref (table-desc:cols table-desc) + column-number))) + +(define (column-size table-desc column-number) + (column-desc:size (vector-ref (table-desc:cols table-desc) + column-number))) + +(define (column-type table-desc column-number) + (column-desc:type (vector-ref (table-desc:cols table-desc) + column-number))) + +(define (column-precision table-desc column-number) + (column-desc:precision (vector-ref (table-desc:cols table-desc) + column-number))) + +(define (column-scale table-desc column-number) + (column-desc:scale (vector-ref (table-desc:cols table-desc) + column-number))) + +(define (column-nullable table-desc column-number) + (column-desc:nullable (vector-ref (table-desc:cols table-desc) + column-number))) + +(define (column-target table-desc column-number) + (column-desc:target (vector-ref (table-desc:cols table-desc) + column-number))) + +;;; These functions are for changing items in a cursor. + +(define (set-column-name! table-desc column-number val) + (set-column-desc:name (vector-ref (table-desc:cols table-desc) + column-number) + val)) + +(define (set-column-size! table-desc column-number val) + (set-column-desc:size (vector-ref (table-desc:cols table-desc) + column-number) + val)) + +(define (set-column-type! table-desc column-number val) + (set-column-desc:type (vector-ref (table-desc:cols table-desc) + column-number) + val)) + +(define (set-column-precision! table-desc column-number val) + (set-column-desc:precision (vector-ref (table-desc:cols table-desc) + column-number) + val)) + +(define (set-column-scale! table-desc column-number val) + (set-column-desc:scale (vector-ref (table-desc:cols table-desc) + column-number) + val)) + +(define (set-column-nullable! table-desc column-number val) + (set-column-desc:nullable (vector-ref (table-desc:cols table-desc) + column-number) + val)) + +(define (set-column-target! table-desc column-number val) + (set-column-desc:target (vector-ref (table-desc:cols table-desc) + column-number) + val)) + +(define-record cursor + col-data ; a table-desc + ncols ; number of cols in desc + stmt ; statement handle + cmd) ; command that created this cursor (to recycle stmt handle) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Error system +;;; ------------ +;;; The functions defined here signal and handle errors in the scsh-sql +;;; interface. The define-foreigns link to C functions defined in scsh-sql.c. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; These functions get the error message from ODBC + +(define-foreign get-henv-error-state + ("GetHenvErrorState" ((C "SQLHENV ~a") environment)) + static-string + static-string) + +(define-foreign get-hdbc-error-state + ("GetHdbcErrorState" ((C "SQLHENV ~a") environment) + ((C "SQLHDBC ~a") connection)) + static-string + static-string) + +(define-foreign get-hstmt-error-state + ("GetHstmtErrorState" ((C "SQLHENV ~a") environment) + ((C "SQLHSTMT ~a") statement)) + static-string + static-string) + +(define (sql-error environment connection statement) + (cond (statement (get-hstmt-error-state (de-ref-env (server-env)) + (de-ref-stmt statement))) + (connection (get-hdbc-error-state (de-ref-env (server-env)) + (de-ref-con connection))) + (else (get-henv-error-state (de-ref-env environment))))) + +;;; In order to deal with odbc errors, we will wrap the define-foreigns for +;;; the ODBC functions in Scheme functions that can raise an appropriate error. +;;; First, we define conditions for 5 of the 7 possible odbc error types. For +;;; two of the ODBC functions we will return a boolean value. +;;; +;;; code = odbc return type = scheme condition +;;;------=-----------------------=----------------- +;;; (-2) = SQL_INVALID_HANDLE = sql-invalid-error +;;; (-1) = SQL_ERROR = sql-error +;;; 0 = SQL_SUCCESS = #t +;;; 1 = SQL_SUCCESS_WITH_INFO = sql-info-warning +;;; 2 = SQL_STILL_EXECUTING = sql-busy-exception +;;; 99 = SQL_NEED_DATA = sql-param-exception +;;; 100 = SQL_NO_DATA_FOUND = #f + +;;; SQL_INVALID_HANDLE +(define-condition-type 'sql-invalid-error '(error)) +(define sql-invalid-error? (condition-predicate 'sql-invalid-error)) + +(define (raise-sql-invalid-error function code message henv hdbc hstmt) + (signal 'sql-invalid-error function code message henv hdbc hstmt)) + +;;; SQL_ERROR +(define-condition-type 'sql-error '(error)) +(define sql-error? (condition-predicate 'sql-error)) + +(define (raise-sql-error function code message henv hdbc hstmt) + (signal 'sql-error function code message henv hdbc hstmt)) + +;;; SQL_SUCCESS +;;; #t + +;;; SQL_SUCCESS_WITH_INFO +(define-condition-type 'sql-info-warning '()) +(define sql-info-warning? (condition-predicate 'sql-info-warning)) + +(define (raise-sql-info-warning function code message henv hdbc hstmt) + (signal 'sql-info-warning function code message henv hdbc hstmt)) + +;;; SQL_STILL_EXECUTING +(define-condition-type 'sql-busy-exception '(error)) +(define sql-busy-exception? (condition-predicate 'sql-busy-exception)) + +(define (raise-sql-busy-exception function code message henv hdbc hstmt) + (signal 'sql-busy-exception function code message henv hdbc hstmt)) + +;;; SQL_NEED_DATA +(define-condition-type 'sql-param-exception '(error)) +(define sql-param-exception? (condition-predicate 'sql-param-exception)) + +(define (raise-sql-param-exception function code message henv hdbc hstmt) + (signal 'sql-param-exception function code message henv hdbc hstmt)) + +;;; SQL_NO_DATA_FOUND +;;; #f + +;;; translate-return is the function which will enclose the define-foreigns of +;;; the ODBC functions. For the errors/exceptions/warnings which can be +;;; raised there is a handler defined below. + +(define (translate-return return-code function henv hdbc hstmt) + (receive (code message) (sql-error henv hdbc hstmt) + (case return-code + ((-2) (raise-sql-invalid-error function code message + henv hdbc hstmt)) ;; INVALID_HANDLE + ((-1) (raise-sql-error function code message + henv hdbc hstmt)) ;; SQL_ERROR + ((0) #t) ;; SQL_SUCCESS + ((1) (raise-sql-info-warning function code message + henv hdbc hstmt) + #t) ;; SQL_SUCCESS_WITH_INFO + ((2) (raise-sql-busy-exception function code message + henv hdbc hstmt)) ;; STILL_EXECUTING + ((99) (raise-sql-param-exception function code message + henv hdbc hstmt)) ;;SQL_NEED_DATA + ((100) #f) ;; SQL_NO_DATA_FOUND + (else (error function + "impossible return code: contact samt@ai.mit.edu"))))) + +;;; Tools for handlers. + +(define (with-sql-invalid-handler* handler thunk) + (with-handler + (lambda (condition more) + (if (sql-invalid-error? condition) + (let ((stuff (cdr condition))) ; (function code message) + (handler (car stuff) ; function + (cadr stuff) ; error code + (caddr stuff) ; error message + (list-ref stuff 3) ; henv + (list-ref stuff 4) ; hdbc + (list-ref stuff 5)))) ; hstmt + (more)) + thunk)) + +(define (with-sql-error-handler* handler thunk) + (with-handler + (lambda (condition more) + (if (sql-error? condition) + (let ((stuff (cdr condition))) ; (function code message) + (handler (car stuff) ; function + (cadr stuff) ; error code + (caddr stuff) ; error message + (list-ref stuff 3) ; henv + (list-ref stuff 4) ; hdbc + (list-ref stuff 5)))) ; hstmt + (more)) + thunk)) + +(define (with-sql-info-handler* handler thunk) + (with-handler + (lambda (condition more) + (if (sql-info-warning? condition) + (let ((stuff (cdr condition))) ; (function code message) + (handler (car stuff) ; function + (cadr stuff) ; error code + (caddr stuff) ; error message + (list-ref stuff 3) ; henv + (list-ref stuff 4) ; hdbc + (list-ref stuff 5)))) ; hstmt + (more)) + thunk)) + +(define (with-sql-busy-handler* handler thunk) + (with-handler + (lambda (condition more) + (if (sql-busy-exception? condition) + (let ((stuff (cdr condition))) ; (function code message) + (handler (car stuff) ; function + (cadr stuff) ; error code + (caddr stuff) ; error message + (list-ref stuff 3) ; henv + (list-ref stuff 4) ; hdbc + (list-ref stuff 5)))) ; hstmt + (more)) + thunk)) + +(define (with-sql-param-handler* handler thunk) + (with-handler + (lambda (condition more) + (if (sql-param-exception? condition) + (let ((stuff (cdr condition))) ; (function code message) + (handler (car stuff) ; function + (cadr stuff) ; error code + (caddr stuff) ; error message + (list-ref stuff 3) ; henv + (list-ref stuff 4) ; hdbc + (list-ref stuff 5)))) ; hstmt + (more)) + thunk)) + +;;; Catch all sql errors/exceptions/warnings. + +(define (with-sql-handler* handler thunk) + (with-handler + (lambda (condition more) + (if (or (sql-invalid-error? condition) + (sql-error? condition) + (sql-info-warning? condition) + (sql-busy-exception? condition) + (sql-param-exception? condition)) + (let ((stuff (cdr condition))) ; (function code message) + (handler (car stuff) ; function + (cadr stuff) ; error code + (caddr stuff) ; error message + (list-ref stuff 3) ; henv + (list-ref stuff 4) ; hdbc + (list-ref stuff 5)))) ; hstmt + (more)) + thunk)) + diff --git a/scsh/odbc/odbc2.c b/scsh/odbc/odbc2.c new file mode 100644 index 0000000..66acd4e --- /dev/null +++ b/scsh/odbc/odbc2.c @@ -0,0 +1,8 @@ +/* This is an Scheme48/C interface file, +** automatically generated by cig. +*/ + +#include +#include /* For malloc. */ +#include "libcig.h" + diff --git a/scsh/odbc/odbc2.scm b/scsh/odbc/odbc2.scm new file mode 100644 index 0000000..fd3ae63 --- /dev/null +++ b/scsh/odbc/odbc2.scm @@ -0,0 +1,712 @@ +;;; Sam Thibault +;;; ODBC/SQL interface for scsh +;;; Spring 1999 + +;;; This is file: odbc2.scm + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; General Comments +;;; ---------------- +;;; This file contains the functions used by scsh-sql.scm. These functions +;;; are the original define-foreigns for the ODBC functions (from odbc0.scm) +;;; enclosed in the scsh-sql error system (in odbc1.scm). These functions also +;;; handling all the neccesary memory allocation the ODBC functions require. +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Values defined by ODBC + +(define sql-param-input 1) +(define sql-c-default 99) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Scheme Names +;;; ------------ +;;; The define-foreigns for ODBC library functions (in odbc0.scm) rename the +;;; functions by replacing the beginning "SQL" with "%" and hyphenating the +;;; function name. For example "SQLAllocConnect" becomes "%alloc-connect". +;;; The function used by scsh-sql.scm is the name without the "%". These +;;; functions are created below by encapsulating the %-name within a translate- +;;; return and doing neccesary memory allocation within the function. This +;;; provides a clean Scheme-like interface for scsh-sql.scm +;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; alloc-connect allocates memory for a connection handle within the +;;; environment returned from server-env. + +(define (alloc-connect) + (let ((con (make-connection)) + (env (de-ref-env (server-env)))) + (translate-return (%alloc-connect env con) + 'alloc-connect + *environment* + con + #f) + con)) + +;;; server-env checks if an environment handle has been created. If there is +;;; a current henv it returns it; otherwise, server-env allocates a new henv +;;; sets it as the current henv, and returns the henv. +;;; +;;; server-env was renamed from alloc-env because this function only allocates +;;; a new environment handle if none exists. + +(define (server-env) + (if (not *environment*) + (let ((env (make-environment))) + (translate-return (%alloc-env env) + 'server-env + env + #f + #f) + (set! *environment* env))) + *environment*) + +;;; alloc-stmt allocates memory for a statement handle and associates the +;;; statement handle with the specified connection. alloc-stmt must be called +;;; before executing any SQL statements. + +(define (alloc-stmt con) + (let ((stmt (make-statement))) + (translate-return (%alloc-stmt (de-ref-con con) + stmt) + 'alloc-stmt + #f ; env handle ignored by sql-error + con + stmt) + stmt)) + +;;; bind-col assigns storage and data type for a column in a result set. The +;;; newly created storage, "target" is returned. + +(define (bind-col cmd icol type precision) + (let ((p (make-SDWORD)) + (stmt (sql-command:statement cmd))) + (assign-SDWORD p precision) + (let* ((target-size p) + (target (make-storage target-size))) + (translate-return (%bind-col (de-ref-stmt stmt) + icol + (if (or (= type sql/integer) + (= type sql/smallint)) + type + sql/char) + target + (if (or (= type sql/integer) + (= type sql/smallint)) + (extract-SDWORD target-size) + (+ 1 (extract-SDWORD target-size))) + target-size) + 'bind-col + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + stmt) + target))) + +;;; bind-parameter binds a buffer to a parameter marker in an SQL statement. + +(define (bind-parameter cmd coln data-type precision scale param) + ;; create buffers + (receive (target-size) + (cond ((= data-type sql/char) + (assign-SDWORD (make-SDWORD) (+ 1 precision))) + ((or (= data-type sql/numeric) + (= data-type sql/decimal) + (= data-type sql/float) + (= data-type sql/real) + (= data-type sql/double)) + (assign-SDWORD (make-SDWORD) + (+ 1 (string-length (number->string param))))) + ((or (= data-type sql/integer) + (= data-type sql/smallint)) + (assign-SDWORD (make-SDWORD) precision)) + ((= data-type sql/varchar) + (assign-SDWORD (make-SDWORD) (string-length param))) + (else (error "unsupported parameter type: " + (type-val->string data-type)))) + (receive (target) + (cond ((= data-type sql/char) + (fixed-string->void* param precision + (make-storage target-size))) + ((or (= data-type sql/numeric) + (= data-type sql/decimal) + (= data-type sql/float) + (= data-type sql/real) + (= data-type sql/double)) + (number->void* param (make-storage target-size))) + ((or (= data-type sql/integer) + (= data-type sql/smallint)) + (integer->void* param (make-storage target-size))) + ((= data-type sql/varchar) + (string->void* param (make-storage target-size))) + (else (error "unsupported parameter type: " + (type-val->string data-type)))) + ;; do it + (let ((stmt (sql-command:statement cmd))) + (translate-return (%bind-parameter (de-ref-stmt stmt) + coln + sql-param-input + sql-c-default + data-type + precision + scale + target ;storage-pointer + (extract-SDWORD target-size) ;buf-lng + target-size ;available-bytes + 'bind-parameter + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + stmt)))))) + +;;; cancel cancels the processing on a statement. + +(define (cancel cmd) + (let ((stmt (sql-command:statement cmd))) + (translate-return (%cancel (de-ref-stmt stmt)) + 'cancel + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + stmt))) + +;;; col-attributes returns descriptor information for a cloumn in a result set. + +;;; col-attributes descriptor types: +(define column-auto-increment 11) ; pfDesc (int return in desriptor-pointer) +(define column-case-sensitive 12) ; pfDesc +(define column-count 0) ; pfDesc +(define column-display-size 6) ; pfDesc +(define column-length 3) ; pfDesc +(define column-money 9) ; pfDesc +(define column-name 1) ; rgbDesc (string return in storage-pointer) +(define column-nullable 7) ; pfDesc +(define column-precision 4) ; pfDesc +(define column-scale 5) ; pfDesc +(define column-searchable 13) ; pfDesc +(define column-data-type 2) ; pfDesc +(define column-type-name 14) ; pfDesc +(define column-unsigned 8) ; pfDesc +(define column-updatable 10) ; pfDesc + +(define (col-attributes stmt column-number descriptor-type storage-pointer + buffer-length available-bytes descriptor-pointer) + (translate-return (%col-attributes stmt column-number descriptor-type + storage-pointer buffer-length + available-bytes descriptor-pointer) + 'col-attributes + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + stmt)) + +;;; connect creates a new connection, loads a driver, and establishes a +;;; connection to the data source using the new connection. + +(define (connect source-name user-name password) + (let ((con (alloc-connect))) + (translate-return (%connect con + source-name (string-length source-name) + user-name (string-length user-name) + password (string-length password)) + 'connect + #f + con + #f) + con)) + +;;; connect! loads a driver, and establishes a connection to the data source +;;; using the supplied connection. + +(define (connect! con source-name user-name password) + (translate-return (%connect (de-ref-con con) + source-name (string-length source-name) + user-name (string-length user-name) + password (string-length password)) + 'connect + *environment* + con + #f)) + +;;; describe-col returns the result descriptor for one column in a result set. + +(define (describe-col cmd icol) + (let ((stmt (sql-command:statement cmd)) + (name (make-string 1)) + (name-byte-size (make-SWORD)) + (data-type (make-SWORD)) + (precision (make-UDWORD)) + (scale (make-SWORD)) + (nullable (make-SWORD))) + (with-sql-info-handler* + (lambda (func code mess henv hdbc hstmt) #t) + (lambda () + (translate-return (%describe-col (de-ref-stmt stmt) icol name + (+ 1 (string-length name)) + name-byte-size data-type precision + scale nullable) + 'describe-col + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + stmt))) + (set! name (make-string (extract-SWORD name-byte-size))) + (translate-return (%describe-col (de-ref-stmt stmt) icol name + (+ 1 (string-length name)) + name-byte-size data-type precision + scale nullable) + 'describe-col + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + stmt) + (values name (extract-SWORD name-byte-size) (extract-SWORD data-type) + (extract-UDWORD precision) (extract-SWORD scale) + (extract-SWORD nullable)))) + +;;; describe-param returns the description of a parameter marker associated +;;; with a prepared SQL statement. + +(define (describe-param cmd coln) + (let ((stmt (sql-command:statement cmd)) + (data-type (make-SWORD)) + (precision (make-UDWORD)) + (scale (make-SWORD)) + (nullable (make-SWORD))) + (translate-return (%describe-param (de-ref-stmt stmt) coln data-type + precision scale nullable) + 'describe-param + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + stmt) + (values (extract-SWORD data-type) + (extract-UDWORD precision) + (extract-SWORD scale) + (extract-SWORD nullable)))) + +;;; disconnect closes the connection associated with a specific connection +;;; handle. + +(define (disconnect con) + (translate-return (%disconnect (de-ref-con con)) + 'disconnect + #f + con + #f)) + +;;; sql-error: see error-system in file odbc1.scm + +;;; execdirect executes a preparable statement. + +(define (exec-direct stmt sql-string) + (translate-return (%exec-direct stmt sql-string (string-length sql-string)) + 'exec-direct + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + stmt)) + +;;; execute executes a prepared statement. + +(define (execute stmt) + (translate-return (%execute (de-ref-stmt stmt)) + 'execute + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + stmt)) + +;;; fetch fetches a row of data from a result set. The driver returns data +;;; for all columns that were bound to storage locations with bind-col. + +(define (fetch cursor) + (if (not (translate-return (%fetch (de-ref-stmt (cursor:stmt cursor))) + 'fetch + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + (cursor:stmt cursor))) + ;; close the cursor if no more rows + (begin (close-cursor cursor) + #f) ; #f for multi-fetch operations + + ;; otherwise build the row + (let* ((ncols (cursor:ncols cursor)) + (row (make-vector ncols)) + (cd (cursor:col-data cursor))) + (let get-cols ((i 0)) + (cond ((< i ncols) + (vector-set! + row i ((cond + ((or (= (column-type cd i) sql/char) + (= (column-type cd i) sql/varchar)) + void*->string) + + ((or (= (column-type cd i) sql/numeric) + (= (column-type cd i) sql/decimal) + (= (column-type cd i) sql/float) + (= (column-type cd i) sql/real) + (= (column-type cd i) sql/double)) + void*->number) + + ((or (= (column-type cd i) sql/integer) + (= (column-type cd i) sql/smallint)) + void*->integer) + + ((= (column-type cd i) sql/date) + void*->date) + + ((= (column-type cd i) sql/time) + void*->time) + + ((= (column-type cd i) sql/timestamp) + void*->timestamp) + + (else (error "can't convert type: fetch-rows"))) + (column-target cd i))) + (get-cols (+ i 1))))) + row))) + +;;; free-connect releases a connection handle and frees all memory associated +;;; with the handle. + +(define (free-connect con) + (translate-return (%free-connect (de-ref-con con)) + 'free-connect + #f + con + #f) + (free-connection con)) + +;;; free-env frees the environment handle and frees all memory associated +;;; with the environment handle and sets the *environment* variable to #f. + +(define (free-env) + (let ((env (if *environment* + *environment* + (error "no current environment")))) + (translate-return (%free-env (de-ref-env env)) + 'free-env + env + #f + #f) + (free-environment env) + (set! *environment* #f) + #t)) + +;;; free-stmt stops processing associated with a specific statement handle, +;;; closes any open cursors, discards pending results, and, optionally, frees +;;; all resources associated with the statement handle. +;;; +;;; SQLFreeStmt Flags: +;;; +;;; flag = means this +;;; -----=----------------- +;;; 0 = SQL_CLOSE +;;; 1 = SQL_DROP +;;; 2 = SQL_UNBIND +;;; 3 = SQL_RESET_PARAMS + +(define (free-stmt/close stmt) + (translate-return (%free-stmt (de-ref-stmt stmt) 0) + 'free-stmt + #f + #f + stmt) + (free-statement stmt) + #t) + +(define free-stmt free-stmt/close) + +(define (free-stmt/drop stmt) + (translate-return (%free-stmt (de-ref-stmt stmt) 1) + 'free-stmt + #f + #f + stmt) + (free-statement stmt) + #t) + +(define (free-stmt/unbind stmt) + (translate-return (%free-stmt (de-ref-stmt stmt) 2) + 'free-stmt + #f + #f + stmt)) + +(define (free-stmt/reset stmt) + (translate-return (%free-stmt (de-ref-stmt stmt) 3) + 'free-stmt + #f + #f + stmt)) + +;;; get-cursor-name returns the cursor name associated with a specified +;;; statement handle. + +(define (get-cursor-name statement cursor-name name-length bytes-available) + (translate-return (%get-cursor-name statement cursor-name name-length + bytes-available) + 'get-cursor-name + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + statement)) + +(define (cursor-name? cursor) + (let ((c-name (make-string 65)) + (c-avail (make-SWORD))) + (assign-SWORD c-avail 64) + (get-cursor-name (de-ref-stmt (cursor:stmt cursor)) c-name 64 c-avail) + c-name)) + +;;; num-result-cols returns the number of columns in a result set. + +(define (num-result-cols cmd) + (let ((stmt (sql-command:statement cmd)) + (ncols (make-SWORD))) + (translate-return (%num-result-cols (de-ref-stmt stmt) ncols) + 'num-result-cols + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + stmt) + (extract-SWORD ncols))) + +;;; prepare allocates a new connection and statement handle and prepares an +;;; SQL string for execution with that hstmt. The new hstmt is returned. + +(define (prepare sql-str db) + (let* ((con (db:con db)) + (stmt (alloc-stmt con))) + (translate-return (%prepare (de-ref-stmt stmt) sql-str + (string-length sql-str)) + 'prepare + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + stmt) + stmt)) + + +;;; prepare! prepares an SQL string for execution with the provided hstmt. + +(define (prepare! stmt sql-str) + (translate-return (%prepare (de-ref-stmt stmt) sql-str + (string-length sql-str)) + 'prepare + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + stmt)) + +;;; row-count returns the number of rows affected by an UPDATE, INSERT, or +;;; DELETE statement. + +(define (row-count cmd) + (let ((stmt (sql-command:statement cmd)) + (rows (make-SDWORD))) + (translate-return (%row-count (de-ref-stmt stmt) rows) + 'row-count + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + stmt) + (extract-SDWORD rows))) + +;;; set-cursor-name associates a cursor name with an active statement handle. +;;; If an application does not call set-cursor-name, the driver generates +;;; cursor names as needed for SQL statement processing. + +(define (set-cursor-name! cursor cursor-name) + (translate-return (%set-cursor-name (de-ref-stmt (cursor:stmt cursor)) + cursor-name + (string-length cursor-name)) + 'set-cursor-name! + #f ; env handle ignored by sql-error + #f ; con handle ignored by sql-error + (cursor:stmt cursor))) + +;;; transact requests a commit or rollback operation for all active operations +;;; on all statement handles associated with a connection. + +(define (transact con option) + (let ((env (de-ref-env (server-env)))) + (translate-return (%transact env (de-ref-con con) option) + 'transact + *environment* + con + #f))) +;;; transact OPTION must be one of these: +(define sql-commit 0) +(define sql-rollback 1) + +(define *current-db* (make-fluid #f)) +(define (current-db) (fluid *current-db*)) + +(define (with-current-db* db thunk) + (let-fluid *current-db* db + thunk)) + +(define-syntax with-current-db + (syntax-rules () + ((with-current-db db body1 body2 ...) + (with-current-db* db (lambda () body1 body2 ...))))) + +(define (call/db host user password proc) + (let ((db (open-db host user password))) + (dynamic-wind (lambda () #t) + (lambda () (proc db)) + (lambda () (close-db db))))) + +(define (with-open-db* host user password thunk) + (call/db host user password (lambda (db) (let-fluid *current-db* db thunk)))) + +(define-syntax with-open-db + (syntax-rules () + ((with-open-db dbname user pwd body1 body2 ...) + (with-open-db* dbname user pwd (lambda () body1 body2 ...))))) + +(define-record sql-command + sql-string ;actual string of sql query, e.g. "select * from ..." + statement ;ODBC statement handle + prep) ;#t if statement has been prepared by odbc command PREPARE + +(define (string->sql-command sql-string) + (make-sql-command sql-string + #f + #f)) + +(define-record db + con) ; ODBC connection handle + +(define (open-db host user password) + (let ((con (alloc-connect))) + (connect! con host user password) + (make-db con))) + +(define (set-current-db! d) + (if (not (db? d)) + (error "Error: set-current-db! must be called with a db as argument.") + (set-fluid! *current-db* d)) + d) + +(define (close-db . maybe-d) + (let* ((db (:optional maybe-d (current-db))) + (con (db:con db))) + (disconnect con) + (free-connect con) + #t)) + +(define (execute-sql command . args) + (receive (db params) (if (null? args) + (values (current-db) '()) + (values (car args) (cdr args))) + (let* ((con (db:con db)) + (cmd (if (sql-command? command) + (begin (if (not (sql-command:statement command)) + (set-sql-command:statement + command (alloc-stmt con))) + command) + (make-sql-command command (alloc-stmt con) #f))) + (stmt (sql-command:statement cmd))) + + ;; Prepare the statement if it's not already prepared. + (if (not (sql-command:prep cmd)) + (begin (prepare! stmt (sql-command:sql-string cmd)) + (set-sql-command:prep cmd #t))) + + ;; Do it. + (let ((ncols (num-result-cols cmd))) + (if (not (null? params)) + (bind-params cmd params)) + (execute stmt) + (let* ((nrows (row-count cmd)) + (answer (cond ((> nrows 0) nrows) ;delete,insert,update + ((= ncols 0) #t) ;make table + (else ;select + (let ((cursor (prepare-cursor cmd ncols))) + (set-sql-command:prep cmd #f) + (set-sql-command:statement cmd #f) + cursor))))) + ;;(if (not (cursor? answer)) ;different free-stmts + ;; (free-stmt stmt)) + answer))))) + +(define (bind-params cmd params) + (let iter ((coln 1) (prms params)) + (if (null? prms) + cmd + ;; get info for each column + (let ((val (car prms))) + (receive (data-type precision scale nullable) + (describe-param cmd coln) + ;; bind it + (bind-parameter cmd + coln + data-type + precision + scale + (cond ((date? val) + (sql-date->string (date->sql-date val))) + ((and (= data-type + (or sql/date + sql/time + sql/timestamp)) + (integer? val)) + (sql-date->string + (date->sql-date (date val)))) + (else val))) + ;; bind next parameter + (iter (+ 1 coln) (cdr prms))))))) + +;; prepare to fetch rows of data + +(define (prepare-cursor cmd ncols) + (let ((col-data (make-table-desc (sql-command:statement cmd) + (make-vector ncols)))) + (let iter ((icol 1)) + (if (<= icol ncols) + ;; get info for column + (receive (name name-size data-type precision scale nullable) + (describe-col cmd icol) + ;; bind it + (vector-set! (table-desc:cols col-data) + (- icol 1) + (make-column-desc + name name-size data-type precision scale nullable + (bind-col cmd icol data-type precision))) + ;; bind the next column + (iter (+ icol 1))))) + (make-cursor col-data ncols (sql-command:statement cmd) cmd))) + +;; fetching rows of data + +(define fetch-row fetch) + +(define (fetch-rows cursor nrows) + (let recur ((nrows nrows)) + (if (zero? nrows) '() + (let ((row (fetch-row cursor))) + (if row + (cons row (recur (- nrows 1))) + '()))))) + +(define (fetch-all cursor) + (let ((row (fetch-row cursor))) + (if row + (cons row (fetch-all cursor)) + '()))) + +;; closing a cursor to recycle statement handle + +(define (cursor-closed? cursor) + (not (cursor:cmd cursor))) + +(define (close-cursor cursor) + (or (cursor-closed? cursor) ;check if already closed + (let ((stmt (cursor:stmt cursor)) + (cmd (cursor:cmd cursor))) + (set-cursor:cmd cursor #f) + (if (sql-command:statement cmd) + (free-stmt/drop stmt) + (set-sql-command:statement cmd (free-stmt/close stmt))))) + #t) + +;; commit or rollback + +(define (commit db) + (transact (db:con db) sql-commit)) + +(define (rollback db) + (transact (db:con db) sql-rollback)) diff --git a/scsh/odbc/scsh-odbc.c b/scsh/odbc/scsh-odbc.c new file mode 100644 index 0000000..f63a1be --- /dev/null +++ b/scsh/odbc/scsh-odbc.c @@ -0,0 +1,416 @@ +/* Sam Thibault +** ODBC/SQL interface for scsh +** Spring 1999 +*/ + +/*---------------------------------------------------------------------*/ +/*---------------------------------------------------------------------*/ + +/* All the functions contained in this file are linked to +** define-foreign functions in the file "interface.scm". The C stubs +** for those define-foreign functions are located in "interface.c". +*/ + +/* double dividers are used to separate functions with very different +** uses, variables, and include file. single dividers separate functions +** with the same general use but for a slightly different purpose (like +** a different variable type). +** +** dividers: +** +** single: /*-----*/ +/* +** double: /*-----*/ +/* /*-----*/ +/* +*/ + +/*---------------------------------------------------------------------*/ +/*---------------------------------------------------------------------*/ + +#include +#include /* For malloc. */ +#include +#include +/*#include "./../cig/scheme48.h" + */ +#include "libcig.h" + + +/* the solid header files include odbc function definitions +** and definitions for variables and constants +*/ +#if 0 +#include "cli0cli.h" +#include "cli0defs.h" +#include "cli0env.h" +#else +#include +#include +#include +#endif + +/*---------------------------------------------------------------------*/ +/*---------------------------------------------------------------------*/ + +/* the following variables are used when calling SQLError +** to get error messages from the server. they are used in the +** following functions: GetHenvError, GetHdbcError, GetHstmtError, +** GetHenvState, GetHdbcState, GetHstmtState, GetHenvErrorState, +** GetHdbcErrorState, GetHstmtErrorState +*/ + +RETCODE retcode; +UCHAR SqlState[200], ErrorMsg[200]; +SDWORD NativeError; +SWORD MsgMax=200; +SWORD pcbError; + +/*---------------------------------------------------------------------*/ +/*---------------------------------------------------------------------*/ + +/* the henv functions below are used to make, reference, and +** free environment handles (variables of the type SQLHENV) +*/ + +SQLHENV* makesqlhenv(void) +{ + SQLHENV* EnvPointer = (SQLHENV*)malloc(sizeof(SQLHENV)); + return EnvPointer; +} + +SQLHENV derefsqlhenv(SQLHENV* EnvPointer) +{ + return *EnvPointer; +} + +scheme_value freesqlhenv(SQLHENV* EnvPointer) +{ + free(*EnvPointer); + return SCHTRUE; +} + +/*---------------------------------------------------------------------*/ + +/* the SQLHDBC functions below are used to make, reference, and +** free environment handles (variables of the type SQLHDBC) +*/ + +SQLHDBC* makesqlhdbc(void) +{ + SQLHDBC* DBCPointer = (SQLHDBC*)malloc(sizeof(SQLHDBC)); + return DBCPointer; +} + +SQLHDBC derefsqlhdbc(SQLHDBC* DBCPointer) +{ + return *DBCPointer; +} + +scheme_value freesqlhdbc(SQLHDBC* DBCPointer) +{ + free(DBCPointer); + return SCHTRUE; +} + +/*---------------------------------------------------------------------*/ + +/* the SQLHSTMT functions below are used to make, reference, and +** free environment handles (variables of the type SQLHSTMT) +*/ + +SQLHSTMT* makesqlhstmt(void) +{ + SQLHSTMT* StmtPointer = (SQLHSTMT*)malloc(sizeof(SQLHSTMT)); + return StmtPointer; +} + +SQLHSTMT derefsqlhstmt(SQLHSTMT* StmtPointer) +{ + return *StmtPointer; +} + +scheme_value freesqlhstmt(SQLHSTMT* StmtPointer) +{ + free(StmtPointer); + return SCHTRUE; +} + +/*---------------------------------------------------------------------*/ +/*---------------------------------------------------------------------*/ + +/* the "Storage" functions are used to make and free space in the C +** heap for void* variables. these are needed to hold information until +** the date can be cast to a specific type +*/ + +void* makeStorage(SDWORD* pcbValue) +{ + void* rgbValue = malloc(*pcbValue); + return rgbValue; +} + +scheme_value freeStorage(void* rgbValue) +{ + free(rgbValue); + return SCHTRUE; +} + +/*---------------------------------------------------------------------*/ + +/* the SDWORD functions below are used to make, reference, get +** values from, assign new values to, and free variables of the +** type SDWORD (signed long ints) +*/ + +SDWORD* makeSDWORD(void) +{ + SDWORD* SDWORDpointer = (SDWORD*)malloc(sizeof(SDWORD)); + return SDWORDpointer; +} + +SDWORD derefSDWORD(SDWORD* SDWORDpointer) +{ + return *SDWORDpointer; +} + +SDWORD extractSDWORD(SDWORD* SDWORDpointer) +{ + return *SDWORDpointer; +} + +scheme_value assignSDWORD(SDWORD* SDWORDpointer, long value) +{ + *SDWORDpointer = value; + return SCHTRUE; +} + +scheme_value freeSDWORD(SDWORD* SDWORDpointer) +{ + free(SDWORDpointer); + return SCHTRUE; +} + +/*---------------------------------------------------------------------*/ + +/* the UDWORD functions below are used to make, reference, get +** values from, assign new values to, and free variables of the +** type UDWORD (unsigned long ints) +*/ + +UDWORD* makeUDWORD(void) +{ + UDWORD* UDWORDpointer = (UDWORD*)malloc(sizeof(UDWORD)); + return UDWORDpointer; +} + +UDWORD derefUDWORD(UDWORD* UDWORDpointer) +{ + return *UDWORDpointer; +} + +UDWORD extractUDWORD(UDWORD* UDWORDpointer) +{ + return *UDWORDpointer; +} + +scheme_value freeUDWORD(UDWORD* UDWORDpointer) +{ + free(UDWORDpointer); + return SCHTRUE; +} + +/*---------------------------------------------------------------------*/ + +/* the SWORD functions below are used to make, reference, get +** values from, assign new values to, and free variables of the +** type SWORD (signed short ints) +*/ + +SWORD* makeSWORD(void) +{ + SWORD* SWORDpointer = (SWORD*)malloc(sizeof(SWORD)); + return SWORDpointer; +} + +SWORD derefSWORD(SWORD* SWORDpointer) +{ + return *SWORDpointer; +} + +SWORD extractSWORD(SWORD* SWORDpointer) +{ + return *SWORDpointer; +} + +scheme_value assignSWORD(SWORD* SWORDpointer, long value) +{ + *SWORDpointer = (short)value; + return SCHTRUE; +} + +scheme_value freeSWORD(SWORD* SWORDpointer) +{ + free(SWORDpointer); + return SCHTRUE; +} + +/*---------------------------------------------------------------------*/ + +/* the UCHAR functions below are used to make, reference, and +** free variables of the type UCHAR (strings) +*/ + +unsigned char * makeUCHAR(void) +{ + unsigned char * UCHARpointer = (unsigned char *)malloc(sizeof(UCHAR)); + return UCHARpointer; +} + +UCHAR derefUCHAR(unsigned char * UCHARpointer) +{ + return *UCHARpointer; +} + +UCHAR extractUCHAR(unsigned char * UCHARpointer) +{ + return *UCHARpointer; +} + +scheme_value freeUCHAR(unsigned char * UCHARpointer) +{ + free(UCHARpointer); + return SCHTRUE; +} + +/*---------------------------------------------------------------------*/ +/*---------------------------------------------------------------------*/ + +/* the VoidTo functions below are used cast void* variables into +** either strings or integers +*/ + +const char * VoidToString(PTR pointer) +{ + return (const char *)pointer; +} + +int VoidToInteger(PTR pointer) +{ + return *(int*)pointer; +} + +/*---------------------------------------------------------------------*/ +/*---------------------------------------------------------------------*/ + +/* the ToVoid functions below are used insert either string or integer +** values into void* variables. +*/ + +void* StringToVoid(scheme_value sstr, PTR pointer) +{ + int slen; + slen = STRING_LENGTH(sstr); + strncpy(pointer, (char*)StobData(sstr), slen); + ((char*)pointer)[slen] = '\000'; + return pointer; +} + +void* FixedStringToVoid(scheme_value sstr, UDWORD clen, PTR pointer) +{ + int slen, i; + slen = STRING_LENGTH(sstr); + strncpy(pointer, (char*)StobData(sstr), slen); + for (i = slen ; i <= clen ; i ++) + ((char*)pointer)[i] = ' '; + ((char*)pointer)[clen] = '\000'; + return pointer; +} + +void* IntegerToVoid(int value, PTR pointer) +{ + *((int*)pointer) = value; + return pointer; +} + + +/*---------------------------------------------------------------------*/ +/*---------------------------------------------------------------------*/ + +/* the Error(State) functions below make calls to the ODBC function +** SQLError. the values returned to scheme are strings which contain +** the error message (Error), the error state (State), or the two +** concatenated together (ErrorState). +*/ + +/*---------------------------------------------------------------------*/ + +/* Error */ + +UCHAR* GetHenvError(SQLHENV sqlhenv) +{ + SQLError(sqlhenv, 0, 0, SqlState, &NativeError, ErrorMsg, MsgMax, &pcbError); + return ErrorMsg; +} + +UCHAR* GetHdbcError(SQLHENV sqlhenv, SQLHDBC sqlhdbc) +{ + SQLError(sqlhenv, sqlhdbc, 0, SqlState, &NativeError, ErrorMsg, MsgMax, &pcbError); + return ErrorMsg; +} + +UCHAR* GetHstmtError(SQLHENV sqlhenv, SQLHSTMT sqlhstmt) +{ + SQLError(sqlhenv, 0, sqlhstmt, SqlState, &NativeError, ErrorMsg, MsgMax, &pcbError); + return ErrorMsg; +} + +/*---------------------------------------------------------------------*/ + +/* State */ + +UCHAR* GetHenvtate(SQLHENV sqlhenv) +{ + SQLError(sqlhenv, 0, 0, SqlState, &NativeError, ErrorMsg, MsgMax, &pcbError); + return SqlState; +} + +UCHAR* GetHdbcState(SQLHENV sqlhenv, SQLHDBC sqlhdbc) +{ + SQLError(sqlhenv, sqlhdbc, 0, SqlState, &NativeError, ErrorMsg, MsgMax, &pcbError); + return SqlState; +} + +UCHAR* GetHstmtState(SQLHENV sqlhenv, SQLHSTMT sqlhstmt) +{ + SQLError(sqlhenv, 0, sqlhstmt, SqlState, &NativeError, ErrorMsg, MsgMax, &pcbError); + return SqlState; +} + +/*---------------------------------------------------------------------*/ + +/* Error and State for multiple value return*/ + +UCHAR* GetHenvErrorState(SQLHENV sqlhenv, UCHAR** msgval) +{ + SQLError(sqlhenv, 0, 0, SqlState, &NativeError, ErrorMsg, MsgMax, &pcbError); + *msgval = ErrorMsg; + return SqlState; +} + +UCHAR* GetHdbcErrorState(SQLHENV sqlhenv, SQLHDBC sqlhdbc, UCHAR** msgval) +{ + SQLError(sqlhenv, sqlhdbc, 0, SqlState, &NativeError, ErrorMsg, MsgMax, &pcbError); + *msgval = ErrorMsg; + return SqlState; +} + +UCHAR* GetHstmtErrorState(SQLHENV sqlhenv, SQLHSTMT sqlhstmt, UCHAR** msgval) +{ + SQLError(sqlhenv, 0, sqlhstmt, SqlState, &NativeError, ErrorMsg, MsgMax, &pcbError); + *msgval = ErrorMsg; + return SqlState; +} + +/*---------------------------------------------------------------------*/ +/*---------------------------------------------------------------------*/ diff --git a/scsh/oldtop.scm b/scsh/oldtop.scm index a0689fa..e337e41 100644 --- a/scsh/oldtop.scm +++ b/scsh/oldtop.scm @@ -12,7 +12,7 @@ (define scsh-major-version 0) (define scsh-minor-version 5) -(define scsh-version-string "0.5.2") +(define scsh-version-string "0.5.3") ;;; A scsh starter takes the command line args, parses them, ;;; initialises the scsh system, and either starts up a repl loop diff --git a/scsh/scsh-interfaces.scm b/scsh/scsh-interfaces.scm index f12d3e8..5342108 100644 --- a/scsh/scsh-interfaces.scm +++ b/scsh/scsh-interfaces.scm @@ -1089,3 +1089,25 @@ interrupt/winch interrupt/xcpu interrupt/xfsz)) + +(define-interface odbc-interface + (export current-db + call/db + with-current-db* + with-current-db + with-open-db* + with-open-db + string->sql-command + open-db + set-current-db! + close-db + execute-sql + fetch-row + fetch-rows + fetch-all + close-cursor + commit + rollback + cancel + cursor-name? + set-cursor-name!)) diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index bd6121e..ca74362 100644 --- a/scsh/scsh-package.scm +++ b/scsh/scsh-package.scm @@ -108,8 +108,8 @@ (compound-interface posix-fdflags-interface posix-errno-interface posix-signals-interface - sockets-network-interface ; Standard Network Interface - os-extras-interface ; Extra stuff from OS. + sockets-network-interface ; Standard Network Interface + os-extras-interface ; Extra stuff from OS. scsh-delimited-readers-interface scsh-errors-interface scsh-io-interface @@ -125,15 +125,15 @@ scsh-file-names-interface scsh-misc-interface scsh-high-level-process-interface - scsh-time-interface ; new in 0.2 - scsh-sockets-interface ; new in 0.3 - tty-interface ; new in 0.4 + scsh-time-interface ; New in release 0.2 + scsh-sockets-interface ; New in release 0.3 + tty-interface ; New in release 0.4 scsh-version-interface char-set-interface signal-handler-interface ;; This stuff would probably be better off kept ;; in separate modules, but we'll toss it in for now. - (interface-of ascii) ; char<->ascii + (interface-of ascii) ; char<->ascii string-ports-interface )) (scsh-level-0-internals (export set-command-line-args! @@ -149,8 +149,8 @@ defrec-package define-foreign-syntax formats - os-dependent ; OS dependent stuff - buffered-io-flags ; stdio dependent + os-dependent ; OS dependent cpde + buffered-io-flags ; stdio dependent ascii records extended-ports @@ -171,27 +171,27 @@ char-set-package scsh-version tty-flags - scsh-internal-tty-flags ; Not exported - let-opt ; optional-arg parsing & defaulting + scsh-internal-tty-flags ; Not exported + let-opt ; optional-arg parsing & defaulting - interrupts ; signal handler code + interrupts ; signal handler code re-level-0 rx-syntax string-lib - loopholes ; For my bogus CALL-TERMINALLY implementation. + loopholes ; For my bogus CALL-TERMINALLY implementation. scheme ) (access command-processor escapes - ports ; S48's force-output + ports ; S48's force-output formats - records ; I don't think this is necessary. !!! - scheme) ; For accessing the normal I/O operators. + records ; I don't think this is necessary. !!! + scheme) ; For accessing the normal I/O operators. (begin (define set-batch-mode?! (structure-ref command-processor set-batch-mode?!)) @@ -206,20 +206,20 @@ rw newports fdports - procobj ; New in release 0.4. - (machine waitcodes) ; OS dependent code. + procobj ; New in release 0.4 + (machine waitcodes) ; OS dependent code filesys fileinfo glob ; filemtch - time ; New in release 0.2. + time ; New in release 0.2 (machine time_dep) - network ; New in release 0.3. - endian ; New in release 0.4. - flock ; New in release 0.4. - tty ; New in release 0.4. - pty ; New in release 0.4. - sighandlers ; New in release 0.5. + network ; New in release 0.3 + endian ; New in release 0.4 + flock ; New in release 0.4 + tty ; New in release 0.4 + pty ; New in release 0.4 + sighandlers ; New in release 0.5 scsh ; re rdelim @@ -276,10 +276,10 @@ packages receiving scsh-version - scsh-level-0 ; with-current-input-port error-output-port - ; with-current-output-port exit - scsh-level-0-internals ; set-command-line-args! init-scsh-vars - handle list-lib ; For lib-search facility + scsh-level-0 ; with-current-input-port error-output-port + ; with-current-output-port exit + scsh-level-0-internals ; set-command-line-args! init-scsh-vars + handle list-lib ; For lib-search facility scheme) (files top meta-arg) (optimize auto-integrate) @@ -335,6 +335,24 @@ (begin (define-syntax awk (syntax-rules () ((awk body ...) (awk/posix-string body ....)))))) +(define-structure odbc-package odbc-interface + (open scsh-level-0 + defrec-package + define-foreign-syntax + let-opt + conditions + fluids + handle + signals + scheme) + (files + (odbc odbc0) ; New in release 0.5.3 + (odbc odbc1) ; New in release 0.5.3 + (odbc odbc2) ; New in release 0.5.3 + ) +; (optimize auto-integrate) +) + (define-structure scsh (compound-interface (interface-of scsh-level-0) (interface-of scsh-startup-package) @@ -345,6 +363,7 @@ ; scsh-dbm-interface (export repl) awk-interface + odbc-interface ) (open structure-refs @@ -356,6 +375,7 @@ scsh-startup-package ; dbm awk-package + odbc-package field-reader-package scheme) diff --git a/scsh/scsh-version.scm b/scsh/scsh-version.scm index 749e0dd..482b773 100644 --- a/scsh/scsh-version.scm +++ b/scsh/scsh-version.scm @@ -1,3 +1,3 @@ (define scsh-major-version 0) (define scsh-minor-version 5) -(define scsh-version-string "0.5.2") +(define scsh-version-string "0.5.3") diff --git a/scsh/time1.c b/scsh/time1.c index 228f2b3..772e945 100644 --- a/scsh/time1.c +++ b/scsh/time1.c @@ -55,8 +55,10 @@ extern char **environ; static char *utc_env[] = {"TZ=UCT0", 0}; #ifdef HAVE_TZNAME +#ifndef __CYGWIN__ extern char *tzname[]; /* Why isn't this defined in time.h? */ #endif +#endif /* These two functions allow you to temporarily override ** the current time zone with one of your choice. make_newenv()