;------------------------------------------------------------------------
;  The most primitive and thus nearly universal Scheme-Database interface
;	Scripting an SQL front-end in a genuine client-server mode
;
; IMPORT
; My prelude (myenv.scm, myenv-bigloo.scm, etc.)
; catch-error.scm
; db-util1.scm
; db-util.scm
; 
; $Id: vdbaccess.scm,v 3.0 2002/11/21 21:41:39 oleg Exp oleg $


		; Configuration parameters
(define DB:NAME "sysmaster") 	; A sample db to query
				; Incidentally, it's a system catalog of
				; an Informix On-Line RDBMS

;; From db-util.scm

(define DB:PIPE-FROM-SQL #f)
(define DB:output-port   #f)	

(define DB:INIT-STRING   #f)

; The number of second after which a query times out. Should be big
; enough to survive the db checkpoint.

(define DB:TIMEOUT 60)		

(define INFORMIXDIR     (or (OS:getenv "INFORMIXDIR") "/usr/local/informix"))
(define INFORMIXSERVER  (or (OS:getenv "INFORMIXSERVER") "online_coe"))
(define C:NL #\newline)

(load "db-util.scm")

	; A demo procedure that looks up a table based on its name (pattern)
	; and prints the number of its rows
(define (lookup-table-by-patname table-pat-name)
  (cout nl "Information for tables " table-pat-name nl)
  (let ((table-names-rows	; assoc list of table names and rows
        (DB1:fold-left
	 (lambda (seed tab-name nrows)
	   (cout "Table " tab-name " has " nrows " row(s)\n")
	   (assert (string->number nrows))
	   (values #t
		   (cons (cons tab-name (string->number nrows)) seed)))
	 '()   ; initial seed
	 (make-query 
	  '((LITERAL "trim(N.dbsname) || ':' || "
		     "trim(N.owner) || '.' || trim(N.tabname)")
	    I.ti_nrows)
	  from: '((ALIAS sysmaster:informix.systabnames N)
		  (ALIAS sysmaster:informix.systabinfo I))
	  and: '(= N.partnum I.ti_partnum)
	  and: `(like tabname ,(DB:<- table-pat-name))
	  and: '(= (apply trim N.dbsname) "'sysmaster'")
	  query-modifier: "ORDER BY 2"))))
    (cout nl
	  "rechecking the result by selecting count(*) from each table...")
    (cout nl "\tusing DB1:for-singleton" nl)
    (for-each
      (lambda (tabname-nrows)
        (let ((selected-val (DB1:for-singleton
                (lambda (count-str)
                  (inexact->exact (string->number count-str)))
		(make-query '("count(*)")
		  from: (string->symbol (car tabname-nrows))))))
          (cout "table " (car tabname-nrows) " counts " 
            selected-val " row(s)" nl)
          (assert (equal? selected-val (cdr tabname-nrows)))))
      table-names-rows)

    (cout nl
	  "rechecking the result by selecting count(*) from each table...")
    (cout nl "\tusing DB1:assoc-val" nl)
    (for-each
      (lambda (tabname-nrows)
        (let ((selected-val (DB1:assoc-val 
                (make-query '("count(*)")
		  from: (string->symbol (car tabname-nrows))))))
          (cout "table " (car tabname-nrows) " counts " 
            selected-val " row(s)" nl)
          (assert (equal? (inexact->exact (string->number selected-val))
              (cdr tabname-nrows)))))
      table-names-rows)
))

(lookup-table-by-patname "%auth%")
(lookup-table-by-patname "%systa%")

(cout nl nl "Checking empty queries..." nl)
(let ((empty-query-stmt		; a query that for sure returns no rows
       (make-query '* from: 'sysmaster:informix.systabnames
		   and: '(= tabname "'xxx'"))))

  (cout "\tDB1:fold-left...\n")
  (assert (eq? 'init-seed
	       (DB1:fold-left
		(lambda _ (error "called wrongly") #f)
		'init-seed
		empty-query-stmt)))
  (cout "\tDB1:for-singleton...\n")
  (assert (not (DB1:for-singleton (lambda () (error "called wrongly") #f)
        empty-query-stmt)))
  (cout "\tDB1:assoc-val...\n")
  (assert (not (DB1:assoc-val empty-query-stmt)))
)
(cout nl "Done" nl)

(cout nl nl "Checking a premature termination of a long query..." nl)
(let* ((long-query-stmt		; something that returns more than 2 rows
	(make-query '(tabname) from: 'sysmaster:informix.systabnames))
       (query-result
	(DB1:fold-left
	 ; The seed is a pair (count . first-val)
	 (lambda (seed val)
	   (let ((count (car seed))
		 (first-val (cdr seed)))
	     (assert (if (positive? count) first-val
			 (and (zero? count) (not first-val))))
	     (cond
	      ((zero? count)
	       (values #t (cons (++ count) val)))
	      ((= 1 count)
	       (values #f seed))	; that should terminate the query...
	      (else
	       (error "The query wasn't prematurely terminated as expected")))
             ))
	 '(0 . #f)	; initial seed
	 long-query-stmt)))
  (assert (= 1 (car query-result)) (cdr query-result))
  (cout "The first returned row is " (cdr query-result) nl)
)

(cout nl nl "Checking a syntactically wrong query..." nl)
(assert (failed? (DB1:assoc-val (make-query '* from: 'aaa))))
(assert (failed?
	 (DB1:for-singleton (lambda () (error "called wrongly") #f)
	   (make-query '* from: 'sysmaster:informix.systabnames
	     and: `(= xxxname ,(DB1:<- "xxx"))))))


(cout nl "All tests passed" nl)