258 lines
7.5 KiB
Factor
258 lines
7.5 KiB
Factor
! Copyright (C) 2007 Elie CHAFTARI
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
!
|
|
! Adapted from oci.h and ociap.h
|
|
! Tested with Oracle version - 10.1.0.3 Instant Client
|
|
|
|
USING: alien alien.c-types alien.strings combinators kernel math
|
|
namespaces oracle.liboci prettyprint sequences
|
|
io.encodings.ascii accessors ;
|
|
|
|
IN: oracle
|
|
|
|
SYMBOL: env
|
|
SYMBOL: err
|
|
SYMBOL: srv
|
|
SYMBOL: svc
|
|
SYMBOL: ses
|
|
SYMBOL: stm
|
|
SYMBOL: buf
|
|
SYMBOL: res
|
|
|
|
SYMBOL: con
|
|
|
|
TUPLE: connection username password db ;
|
|
|
|
C: <connection> connection
|
|
|
|
! =========================================================
|
|
! Error-handling routines
|
|
! =========================================================
|
|
|
|
: get-oci-error ( object -- * )
|
|
1 f "uint*" <c-object> dup >r 512 "uchar" <c-array> dup >r
|
|
512 OCI_HTYPE_ERROR OCIErrorGet r> r> *uint drop
|
|
ascii alien>string throw ;
|
|
|
|
: check-result ( result -- )
|
|
{
|
|
{ OCI_SUCCESS [ ] }
|
|
{ OCI_ERROR [ err get get-oci-error ] }
|
|
{ OCI_INVALID_HANDLE [ "invalid handle" throw ] }
|
|
[ "operation failed" throw ]
|
|
} case ;
|
|
|
|
: check-status ( status -- bool )
|
|
{
|
|
{ OCI_SUCCESS [ t ] }
|
|
{ OCI_ERROR [ err get get-oci-error ] }
|
|
{ OCI_INVALID_HANDLE [ "invalid handle" throw ] }
|
|
{ OCI_NO_DATA [ f ] }
|
|
[ "operation failed" throw ]
|
|
} case ;
|
|
|
|
! =========================================================
|
|
! Initialization and handle-allocation routines
|
|
! =========================================================
|
|
|
|
! Legacy initialization routine
|
|
: oci-initialize ( -- )
|
|
OCI_DEFAULT f f f f OCIInitialize check-result ;
|
|
|
|
! Legacy initialization routine
|
|
: oci-env-init ( -- )
|
|
"void*" <c-object> dup OCI_DEFAULT 0 f OCIEnvInit
|
|
check-result *void* env set ;
|
|
|
|
: create-environment ( -- )
|
|
"void*" <c-object> dup OCI_DEFAULT f f f f 0 f OCIEnvCreate
|
|
check-result *void* env set ;
|
|
|
|
: allocate-error-handle ( -- )
|
|
env get
|
|
"void*" <c-object> tuck OCI_HTYPE_ERROR 0 f OCIHandleAlloc
|
|
check-result *void* err set ;
|
|
|
|
: allocate-service-handle ( -- )
|
|
env get
|
|
"void*" <c-object> tuck OCI_HTYPE_SVCCTX 0 f OCIHandleAlloc
|
|
check-result *void* svc set ;
|
|
|
|
: allocate-session-handle ( -- )
|
|
env get
|
|
"void*" <c-object> tuck OCI_HTYPE_SESSION 0 f OCIHandleAlloc
|
|
check-result *void* ses set ;
|
|
|
|
: allocate-server-handle ( -- )
|
|
env get
|
|
"void*" <c-object> tuck OCI_HTYPE_SERVER 0 f OCIHandleAlloc
|
|
check-result *void* srv set ;
|
|
|
|
: init ( -- )
|
|
oci-initialize
|
|
oci-env-init
|
|
allocate-error-handle
|
|
allocate-service-handle
|
|
allocate-session-handle
|
|
allocate-server-handle ;
|
|
|
|
! =========================================================
|
|
! Single user session logon routine
|
|
! =========================================================
|
|
|
|
: oci-log-on ( -- )
|
|
env get err get svc get
|
|
con get username>> dup length swap ascii malloc-string swap
|
|
con get password>> dup length swap ascii malloc-string swap
|
|
con get db>> dup length swap ascii malloc-string swap
|
|
OCILogon check-result ;
|
|
|
|
! =========================================================
|
|
! Attach to server and attribute-setting routines
|
|
! =========================================================
|
|
|
|
: attach-to-server ( -- )
|
|
srv get err get con get db>> dup length OCI_DEFAULT
|
|
OCIServerAttach check-result ;
|
|
|
|
: set-service-attribute ( -- )
|
|
svc get OCI_HTYPE_SVCCTX srv get 0 OCI_ATTR_SERVER err get OCIAttrSet check-result ;
|
|
|
|
: set-username-attribute ( -- )
|
|
ses get OCI_HTYPE_SESSION con get username>> dup length swap ascii malloc-string swap
|
|
OCI_ATTR_USERNAME err get OCIAttrSet check-result ;
|
|
|
|
: set-password-attribute ( -- )
|
|
ses get OCI_HTYPE_SESSION con get password>> dup length swap ascii malloc-string swap
|
|
OCI_ATTR_PASSWORD err get OCIAttrSet check-result ;
|
|
|
|
: set-attributes ( -- )
|
|
set-service-attribute
|
|
set-username-attribute
|
|
set-password-attribute ;
|
|
|
|
! =========================================================
|
|
! Session startup routines
|
|
! =========================================================
|
|
|
|
: begin-session ( -- )
|
|
svc get err get ses get OCI_CRED_RDBMS OCI_DEFAULT OCISessionBegin check-result ;
|
|
|
|
: set-authentication-handle ( -- )
|
|
svc get OCI_HTYPE_SVCCTX ses get 0 OCI_ATTR_SESSION err get OCIAttrSet check-result ;
|
|
|
|
! =========================================================
|
|
! Statement preparation and execution routines
|
|
! =========================================================
|
|
|
|
: allocate-statement-handle ( -- )
|
|
env get
|
|
"void*" <c-object> tuck OCI_HTYPE_STMT 0 f OCIHandleAlloc
|
|
check-result *void* stm set ;
|
|
|
|
: prepare-statement ( statement -- )
|
|
>r stm get err get r> dup length swap ascii malloc-string swap
|
|
OCI_NTV_SYNTAX OCI_DEFAULT OCIStmtPrepare check-result ;
|
|
|
|
: calculate-size ( type -- size )
|
|
{
|
|
{ SQLT_INT [ "int" heap-size ] }
|
|
{ SQLT_FLT [ "float" heap-size ] }
|
|
{ SQLT_CHR [ "char" heap-size ] }
|
|
{ SQLT_NUM [ "int" heap-size 10 * ] }
|
|
{ SQLT_STR [ 64 ] }
|
|
{ SQLT_ODT [ 256 ] }
|
|
} case ;
|
|
|
|
: define-by-position ( position type -- )
|
|
>r >r stm get f <void*> err get
|
|
r> r> dup calculate-size >r [ "char" malloc-array dup buf set ] keep 1+
|
|
r> f f f OCI_DEFAULT OCIDefineByPos check-result ;
|
|
|
|
: execute-statement ( -- bool )
|
|
svc get stm get err get 1 0 f f OCI_DEFAULT OCIStmtExecute check-status ;
|
|
|
|
: fetch-statement ( -- bool )
|
|
stm get err get 1 OCI_FETCH_NEXT OCI_DEFAULT OCIStmtFetch check-status ;
|
|
|
|
: free-statement-handle ( -- )
|
|
stm get OCI_HTYPE_STMT OCIHandleFree check-result ;
|
|
|
|
! =========================================================
|
|
! Log off and detach from server routines
|
|
! =========================================================
|
|
|
|
: end-session ( -- )
|
|
svc get err get ses get OCI_DEFAULT OCISessionEnd check-result ;
|
|
|
|
: detach-from-server ( -- )
|
|
srv get err get OCI_DEFAULT OCIServerDetach check-result ;
|
|
|
|
: log-off ( -- )
|
|
end-session
|
|
detach-from-server ;
|
|
|
|
! =========================================================
|
|
! Clean-up and termination routines
|
|
! =========================================================
|
|
|
|
: free-service-handle ( -- )
|
|
svc get OCI_HTYPE_SVCCTX OCIHandleFree check-result ;
|
|
|
|
: free-server-handle ( -- )
|
|
srv get OCI_HTYPE_SERVER OCIHandleFree check-result ;
|
|
|
|
: free-error-handle ( -- )
|
|
err get OCI_HTYPE_ERROR OCIHandleFree check-result ;
|
|
|
|
: free-environment-handle ( -- )
|
|
env get OCI_HTYPE_ENV OCIHandleFree check-result ;
|
|
|
|
: clean-up ( -- )
|
|
free-service-handle
|
|
free-server-handle
|
|
free-error-handle
|
|
free-environment-handle ;
|
|
|
|
: terminate ( -- )
|
|
OCI_DEFAULT OCITerminate check-result ;
|
|
|
|
! =========================================================
|
|
! Utility routines
|
|
! =========================================================
|
|
|
|
: server-version ( -- )
|
|
srv get err get 512 "uchar" malloc-array dup >r 512 OCI_HTYPE_SERVER
|
|
OCIServerVersion check-result r> ascii alien>string . ;
|
|
|
|
! =========================================================
|
|
! Public routines
|
|
! =========================================================
|
|
|
|
: log-on ( username password db -- )
|
|
<connection> con set
|
|
init attach-to-server set-attributes
|
|
begin-session set-authentication-handle
|
|
V{ } clone res set ;
|
|
|
|
: fetch-each ( object -- object )
|
|
fetch-statement [
|
|
buf get ascii alien>string res get swap suffix res set
|
|
fetch-each
|
|
] [ ] if ;
|
|
|
|
: run-query ( object -- object )
|
|
execute-statement [
|
|
buf get ascii alien>string res get swap suffix res set
|
|
fetch-each
|
|
] [ ] if ;
|
|
|
|
: gather-results ( -- seq )
|
|
res get ;
|
|
|
|
: show-result ( -- )
|
|
res get [ . ] each ;
|
|
|
|
: clear-result ( -- )
|
|
V{ } clone res set ;
|