scsh-conservatory
/
scsh-0.5
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Summary: 

Three changes
- Updated 0.5.2 to 0.5.3
- Updated for latest cygwin, removing MKS dependency
- Added cleaned up ODBC code

Details:

Updated 0.5.2 to 0.5.3

	M RELEASE
	M scsh.spec
	M bin/scsh-release
	M bin/scsh-test
	M doc/scsh-manual/front.tex
	M doc/scsh-manual/man.tex
	M scsh/minor-version-number
	M scsh/oldtop.scm
	M scsh/scsh-version.scm

Rebuilt to get new version number

	M initial.image

Remove MKS dependency now that Cygwin cat works on binary files
without munging with carriage returns and newlines.

	M cig/image2script

Changed cygwin32 to cygwin.

	M scsh/Makefile.in

Added #ifndef __CYGWIN__ around some pesky extern references.

	M scsh/scsh/network1.c
	M scsh/scsh/time1.c

Updated with optional ODBC bits. This is going to be hard to make nice
and clean. 

	M scsh/Makefile.in

New ODBC code

	A scsh/odbc/odbc.txt
	A scsh/odbc/odbc0.c
	A scsh/odbc/odbc0.scm
	A scsh/odbc/odbc1.c
	A scsh/odbc/odbc1.scm
	A scsh/odbc/odbc2.c
	A scsh/odbc/odbc2.scm
	A scsh/odbc/scsh-odbc.c

New odbc-interface and odbc-package

	M scsh/scsh/scsh-interfaces.scm
	M scsh/scsh/scsh-package.scm
This commit is contained in:
bdc 2001-02-25 19:51:56 +00:00
parent 92e4737c44
commit 89c1f4b11b
24 changed files with 3589 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
Makefile.in
View File

@ -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

8
RELEASE
View File

@ -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

2
bin/scsh-release
View File

@ -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

2
bin/scsh-test
View File

@ -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

6
cig/image2script
View File

@ -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

2
doc/scsh-manual/front.tex
View File

@ -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}

2
doc/scsh-manual/man.tex
View File

@ -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}

BIN
initial.image
View File

Binary file not shown.

2
scsh.spec
View File

@ -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 <pvides@dedalo-ing.com>

2
scsh/minor-version-number
View File

@ -1 +1 @@
5.2
5.3

2
scsh/network1.c
View File

@ -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 */

554
scsh/odbc/odbc.txt Normal file
View File

@ -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].

733
scsh/odbc/odbc0.c Normal file
View File

@ -0,0 +1,733 @@
/* This is an Scheme48/C interface file,
** automatically generated by cig.
*/
#include <stdio.h>
#include <stdlib.h> /* For malloc. */
#include "libcig.h"
#if 0
#include "cli0cli.h"
#include "cli0defs.h"
#include "cli0env.h"
#else
#include <windows.h>
#include <sql.h>
#include <sqlext.h>
#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;
}

570
scsh/odbc/odbc0.scm Normal file
View File

@ -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 <windows.h>"
"#include <sql.h>"
"#include <sqlext.h>"
"#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"))

62
scsh/odbc/odbc1.c Normal file
View File

@ -0,0 +1,62 @@
/* This is an Scheme48/C interface file,
** automatically generated by cig.
*/
#include <stdio.h>
#include <stdlib.h> /* For malloc. */
#include "libcig.h"
#if 0
#include "cli0cli.h"
#include "cli0defs.h"
#include "cli0env.h"
#else
#include <windows.h>
#include <sql.h>
#include <sqlext.h>
#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;
}

414
scsh/odbc/odbc1.scm Normal file
View File

@ -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 <windows.h>"
"#include <sql.h>"
"#include <sqlext.h>"
"#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)
;;; +-------------+ +-------+
;;; | <target>----+---> | 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))

8
scsh/odbc/odbc2.c Normal file
View File

@ -0,0 +1,8 @@
/* This is an Scheme48/C interface file,
** automatically generated by cig.
*/
#include <stdio.h>
#include <stdlib.h> /* For malloc. */
#include "libcig.h"

712
scsh/odbc/odbc2.scm Normal file
View File

@ -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))

416
scsh/odbc/scsh-odbc.c Normal file
View File

@ -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 <stdio.h>
#include <stdlib.h> /* For malloc. */
#include <string.h>
#include <stddef.h>
/*#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 <windows.h>
#include <sql.h>
#include <sqlext.h>
#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;
}
/*---------------------------------------------------------------------*/
/*---------------------------------------------------------------------*/

2
scsh/oldtop.scm
View File

@ -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

22
scsh/scsh-interfaces.scm
View File

@ -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!))

76
scsh/scsh-package.scm
View File

@ -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)

2
scsh/scsh-version.scm
View File

@ -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")

2
scsh/time1.c
View File

@ -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()