;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Package   : sqld-oracle.scm
;;; Author    : Hans Oesterholt-Dijkema.
;;; Copyright : HOD 2004/2005.
;;; License   : The Elemental Programming Artistic License.
;;; CVS       : $Id: sqld-oracle-internal.scm,v 1.1 2006/01/01 23:22:36 HansOesterholt Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;#+bigloo
;(module sqld-oracle-internal
;	(extern
;	 (type void* (pointer void) "void *")
;	 (c-oracle-open::void* (::string) "c_oracle_open")
;	 (c-oracle-close::int (::void*) "c_oracle_close")
;	 (c-oracle-query::void* (::void* ::string) "c_oracle_query")
;	 (c-oracle-columns::int (::void*) "c_oracle_columns")
;	 (c-oracle-field::string (::void* ::int) "c_oracle_field")
;	 (c-oracle-lasterr::string (::void*) "c_oracle_lasterr")
;	 (c-oracle-version::int () "c_oracle_version")
;	 (c-oracle-autocommit-on::int (::void*) "c_oracle_autocommit_on")
;	 (c-oracle-autocommit-off::int (::void*) "c_oracle_autocommit_off")
;	 (c-oracle-escape::string (::string) "c_oracle_escape")
;	 (c-oracle-fetch::void* (::void*) "c_oracle_fetch")
;	 (c-oracle-eoq::bool (::void*) "c_oracle_eoq"))
;	(export
;	 (sqld-oracle-new connection-info)))
;#+ mzscheme
(module sqld-oracle-internal mzscheme
	(require (lib "time.ss" "srfi" "19"))
	(require "c-sqld-oracle.scm")

(define-syntax integer->string
  (syntax-rules ()
    ((_ n) (number->string n))))

(define-syntax string->integer
  (syntax-rules ()
    ((_ s) (string->number s))))
;##


(define (ierr . args)
  (define (f args)
    (if (null? args)
	(display "")
	(begin
	  (display (car args))
	  (f (cdr args)))))
  (display "ERROR (sqld-oracle):  ")
  (f args)
  (newline)
  #f)


(define (string2db s) 
  (c-oracle-escape s))

(define (int2db n)
  (integer->string n))

(define (number2db n)
  (number->string n))


(define (date2db dt)

;;#+ bigloo
;  (define (pre-zero2 n)
;    (if (< n 10)
;	(string-append "0" (integer->string n))
;	(integer->string n)))
;##

  (string-append "timestamp'"
;#+ mzscheme
		 (date->string dt "~Y-~m-~d ~H:~M:~S")
;;#+ bigloo
;   (integer->string (date-year dt))      ; 0-3
;   "-"
;   (pre-zero2 (date-month dt))           ; 4-5
;   "-"
;   (pre-zero2 (date-day dt))             ; 6-7
;   " "                                   ; 8
;   (pre-zero2 (date-hour dt))            ; 9-10
;   ":"
;   (pre-zero2 (date-minute dt))          ; 11-12
;   ":"
;   (pre-zero2 (date-second dt))         ; 13-14
;##
		 "'"))

; Oracle doesn't have a boolean type,
; so boolean is converted to a number (0 or 1).
(define (bool2db b)
  (if (eq? b #f)
      "0"
      "1"))

(define (db2bool b)
  (if (= (string->integer b) 0)
      #f
      #t))

(define (db2date dt)
;#+ mzscheme
  (string->date dt "~Y-~m-~d ~H:~M:~S") 
;;#+ bigloo
;  (make-date
;   (string->integer (substring dt 17 19))  ; seconds
;   (string->integer (substring dt 14 16))  ; minutes
;   (string->integer (substring dt  11 13))  ; hours
;   (string->integer (substring dt  8  10))  ; day
;   (string->integer (substring dt  5  7))  ; month
;   (string->integer (substring dt  0  4))  ; year
;   )
;##
)

(define (sqld-oracle-connect connection-string)
  (let* ((dbh (c-oracle-open connection-string))
	 (valid-handle (string=? (c-oracle-lasterr dbh) ""))
	 (commit #t)
	 (sth 'nil))
    
    (define (query q)
      (set! sth (c-oracle-query dbh q)))

    (define (fetch)
      (if (c-oracle-eoq sth)
	  #f
;#+ mzscheme
	  (let ((row (c-oracle-fields sth)))
	    (c-oracle-fetch sth)
	    row)
;;#+ bigloo
;	  (let ((row (list))
;		(N (c-oracle-columns sth)))
;	    (do ((i (- N 1) (- i 1)))
;		((< i 0) #t)
;	      (set! row (cons (c-oracle-field sth i) row)))
;	    (c-oracle-fetch sth)
;	    row)
;##
	  ))

    (define (begin-transaction)
      (c-oracle-autocommit-off dbh))

    (define (commit)
      (c-oracle-query dbh "COMMIT")
      (c-oracle-autocommit-on dbh))

    (define (rollback)
      (c-oracle-query dbh "ROLLBACK")
      (c-oracle-autocommit-on dbh))

    (define (disconnect)
      (c-oracle-close dbh)
      (set! valid-handle #f))

    (begin

      (if (eq? valid-handle #t)
	  (begin
	    (c-oracle-autocommit-on dbh)
	    (query "ALTER SESSION SET NLS_DATE_FORMAT='YYYY-MM-DD HH24:MI:SS'")
	    (query "ALTER SESSION SET NLS_TIMESTAMP_FORMAT='YYYY-MM-DD HH24:MI:SS'")))

      (lambda (cmd . args)
	(if (eq? valid-handle #f)
	    (ierr "ERROR: disconnected handle")
	    (cond

	     ((eq? cmd 'string2db) (string2db (car args)))
	     ((eq? cmd 'int2db) (int2db (car args)))
	     ((eq? cmd 'number2db) (number2db (car args)))
	     ((eq? cmd 'date2db) (date2db (car args)))
	     ((eq? cmd 'bool2db) (bool2db (car args)))

	     ((eq? cmd 'db2bool) (db2bool (car args)))
	     ((eq? cmd 'db2date) (db2date (car args)))

	     ((eq? cmd 'fetchrow) (fetch))

	     ((eq? cmd 'lasterr) (c-oracle-lasterr dbh))

	     ((eq? cmd 'begin) (begin-transaction))
	     ((eq? cmd 'commit) (commit))
	     ((eq? cmd 'rollback) (rollback))
	     ((eq? cmd 'query) (query (car args)))

	     ((eq? cmd 'disconnect) (disconnect))

	     (else (ierr "Unknown command " cmd))))))))


(define (sqld-oracle-new _connection-info)
  (let ((connection-info _connection-info))
    (lambda (cmd . args)
      (cond

       ((eq? cmd 'connect) (sqld-oracle-connect connection-info))
       ((eq? cmd 'clean) #t)

       ((eq? cmd 'name) "oracle")
       ((eq? cmd 'version) (c-oracle-version))

       (else (ierr "ERROR: Connect to the datebase first"))))))

	    
;#+ mzscheme
   (provide sqld-oracle-new)
)
;##