unmaintained/oracle/oracle.factor

   1 ! Copyright (C) 2007 Elie CHAFTARI
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 !
   4 ! Adapted from oci.h and ociap.h
   5 ! Tested with Oracle version - 10.1.0.3 Instant Client
   6
   7 USING: alien alien.c-types alien.strings combinators kernel math
   8 namespaces oracle.liboci prettyprint sequences
   9 io.encodings.ascii accessors ;
  10
  11 IN: oracle
  12
  13 SYMBOL: env
  14 SYMBOL: err
  15 SYMBOL: srv
  16 SYMBOL: svc
  17 SYMBOL: ses
  18 SYMBOL: stm
  19 SYMBOL: buf
  20 SYMBOL: res
  21
  22 SYMBOL: con
  23
  24 TUPLE: connection username password db ;
  25
  26 C: <connection> connection
  27
  28 ! =========================================================
  29 ! Error-handling routines
  30 ! =========================================================
  31
  32 : get-oci-error ( object -- * )
  33     1 f "uint*" <c-object> dup >r 512 "uchar" <c-array> dup >r
  34     512 OCI_HTYPE_ERROR OCIErrorGet r> r> *uint drop
  35     ascii alien>string throw ;
  36
  37 : check-result ( result -- )
  38     {
  39         { OCI_SUCCESS [ ] }
  40         { OCI_ERROR [ err get get-oci-error ] }
  41         { OCI_INVALID_HANDLE [ "invalid handle" throw ] }
  42         [ "operation failed" throw ]
  43     } case ;
  44
  45 : check-status ( status -- bool )
  46     {
  47         { OCI_SUCCESS [ t ] }
  48         { OCI_ERROR [ err get get-oci-error ] }
  49         { OCI_INVALID_HANDLE [ "invalid handle" throw ] }
  50         { OCI_NO_DATA [ f ] }
  51         [ "operation failed" throw ]
  52     } case ;
  53
  54 ! =========================================================
  55 ! Initialization and handle-allocation routines
  56 ! =========================================================
  57
  58 ! Legacy initialization routine
  59 : oci-initialize ( -- )
  60     OCI_DEFAULT f f f f OCIInitialize check-result ;
  61
  62 ! Legacy initialization routine
  63 : oci-env-init ( -- )
  64     "void*" <c-object> dup OCI_DEFAULT 0 f OCIEnvInit
  65     check-result *void* env set ;
  66
  67 : create-environment ( -- )
  68     "void*" <c-object> dup OCI_DEFAULT f f f f 0 f OCIEnvCreate
  69     check-result *void* env set ;
  70
  71 : allocate-error-handle ( -- )
  72     env get
  73     "void*" <c-object> tuck OCI_HTYPE_ERROR 0 f OCIHandleAlloc
  74     check-result *void* err set ;
  75
  76 : allocate-service-handle ( -- )
  77     env get
  78     "void*" <c-object> tuck OCI_HTYPE_SVCCTX 0 f OCIHandleAlloc
  79     check-result *void* svc set ;
  80
  81 : allocate-session-handle ( -- )
  82     env get
  83     "void*" <c-object> tuck OCI_HTYPE_SESSION 0 f OCIHandleAlloc
  84     check-result *void* ses set ;
  85
  86 : allocate-server-handle ( -- )
  87     env get
  88     "void*" <c-object> tuck OCI_HTYPE_SERVER 0 f OCIHandleAlloc
  89     check-result *void* srv set ;
  90
  91 : init ( -- )
  92     oci-initialize
  93     oci-env-init
  94     allocate-error-handle
  95     allocate-service-handle
  96     allocate-session-handle
  97     allocate-server-handle ;
  98
  99 ! =========================================================
 100 ! Single user session logon routine
 101 ! =========================================================
 102
 103 : oci-log-on ( -- )
 104     env get err get svc get
 105     con get username>> dup length swap ascii malloc-string swap
 106     con get password>> dup length swap ascii malloc-string swap
 107     con get db>> dup length swap ascii malloc-string swap
 108     OCILogon check-result ;
 109
 110 ! =========================================================
 111 ! Attach to server and attribute-setting routines
 112 ! =========================================================
 113
 114 : attach-to-server ( -- )
 115     srv get err get con get db>> dup length OCI_DEFAULT
 116     OCIServerAttach check-result ;
 117
 118 : set-service-attribute ( -- )
 119     svc get OCI_HTYPE_SVCCTX srv get 0 OCI_ATTR_SERVER err get OCIAttrSet check-result ;
 120
 121 : set-username-attribute ( -- )
 122     ses get OCI_HTYPE_SESSION con get username>> dup length swap ascii malloc-string swap
 123     OCI_ATTR_USERNAME err get OCIAttrSet check-result ;
 124
 125 : set-password-attribute ( -- )
 126     ses get OCI_HTYPE_SESSION con get password>> dup length swap ascii malloc-string swap
 127     OCI_ATTR_PASSWORD err get OCIAttrSet check-result ;
 128
 129 : set-attributes ( -- )
 130     set-service-attribute
 131     set-username-attribute
 132     set-password-attribute ;
 133
 134 ! =========================================================
 135 ! Session startup routines
 136 ! =========================================================
 137
 138 : begin-session ( -- )
 139     svc get err get ses get OCI_CRED_RDBMS OCI_DEFAULT OCISessionBegin check-result ;
 140
 141 : set-authentication-handle ( -- )
 142     svc get OCI_HTYPE_SVCCTX ses get 0 OCI_ATTR_SESSION err get OCIAttrSet check-result ;
 143
 144 ! =========================================================
 145 ! Statement preparation and execution routines
 146 ! =========================================================
 147
 148 : allocate-statement-handle ( -- )
 149     env get
 150     "void*" <c-object> tuck OCI_HTYPE_STMT 0 f OCIHandleAlloc
 151     check-result *void* stm set ;
 152
 153 : prepare-statement ( statement -- )
 154     >r stm get err get r> dup length swap ascii malloc-string swap
 155     OCI_NTV_SYNTAX OCI_DEFAULT OCIStmtPrepare check-result ;
 156
 157 : calculate-size ( type -- size )
 158     {
 159         { SQLT_INT [ "int" heap-size ] }
 160         { SQLT_FLT [ "float" heap-size ] }
 161         { SQLT_CHR [ "char" heap-size ] }
 162         { SQLT_NUM [ "int" heap-size 10 * ] }
 163         { SQLT_STR [ 64 ] }
 164         { SQLT_ODT [ 256 ] }
 165     } case ;
 166
 167 : define-by-position ( position type -- )
 168     >r >r stm get f <void*> err get
 169     r> r> dup calculate-size >r [ "char" malloc-array dup buf set ] keep 1+
 170     r> f f f OCI_DEFAULT OCIDefineByPos check-result ;
 171
 172 : execute-statement ( -- bool )
 173     svc get stm get err get 1 0 f f OCI_DEFAULT OCIStmtExecute check-status ;
 174
 175 : fetch-statement ( -- bool )
 176     stm get err get 1 OCI_FETCH_NEXT OCI_DEFAULT OCIStmtFetch check-status ;
 177
 178 : free-statement-handle ( -- )
 179     stm get OCI_HTYPE_STMT OCIHandleFree check-result ;
 180
 181 ! =========================================================
 182 ! Log off and detach from server routines
 183 ! =========================================================
 184
 185 : end-session ( -- )
 186     svc get err get ses get OCI_DEFAULT OCISessionEnd check-result ;
 187
 188 : detach-from-server ( -- )
 189     srv get err get OCI_DEFAULT OCIServerDetach check-result ;
 190
 191 : log-off ( -- )
 192     end-session
 193     detach-from-server ;
 194
 195 ! =========================================================
 196 ! Clean-up and termination routines
 197 ! =========================================================
 198
 199 : free-service-handle ( -- )
 200     svc get OCI_HTYPE_SVCCTX OCIHandleFree check-result ;
 201
 202 : free-server-handle ( -- )
 203     srv get OCI_HTYPE_SERVER OCIHandleFree check-result ;
 204
 205 : free-error-handle ( -- )
 206     err get OCI_HTYPE_ERROR OCIHandleFree check-result ;
 207
 208 : free-environment-handle ( -- )
 209     env get OCI_HTYPE_ENV OCIHandleFree check-result ;
 210
 211 : clean-up ( -- )
 212     free-service-handle
 213     free-server-handle
 214     free-error-handle
 215     free-environment-handle ;
 216
 217 : terminate ( -- )
 218     OCI_DEFAULT OCITerminate check-result ;
 219
 220 ! =========================================================
 221 ! Utility routines
 222 ! =========================================================
 223
 224 : server-version ( -- )
 225     srv get err get 512 "uchar" malloc-array dup >r 512 OCI_HTYPE_SERVER
 226     OCIServerVersion check-result r> ascii alien>string . ;
 227
 228 ! =========================================================
 229 ! Public routines
 230 ! =========================================================
 231
 232 : log-on ( username password db -- )
 233     <connection> con set
 234     init attach-to-server set-attributes
 235     begin-session set-authentication-handle
 236     V{ } clone res set ;
 237
 238 : fetch-each ( object -- object )
 239     fetch-statement [
 240         buf get ascii alien>string res get swap suffix res set
 241         fetch-each
 242     ] [ ] if ;
 243
 244 : run-query ( object -- object )
 245     execute-statement [
 246         buf get ascii alien>string res get swap suffix res set
 247         fetch-each
 248     ] [ ] if ;
 249
 250 : gather-results ( -- seq )
 251     res get ;
 252
 253 : show-result ( -- )
 254     res get [ . ] each ;
 255
 256 : clear-result ( -- )
 257     V{ } clone res set ;