;;; Project:           Scheme-PG
;;; Author:            David J. Neu, djneu@acm.org
;;; Maintainer:        David J. Neu, djneu@acm.org
;;; Project Home Page: http://scheme-pg.sourceforge.net
;;; Copyright:         Copyright (c) 2004 Universal Technical Resource Services, Inc.
;;; License:           MIT License, see license.txt
;;; CVS Id:            $Id: cursor.ss,v 1.2 2005/03/21 21:16:24 djneu Exp $

(module cursor
  mzscheme
  
  (require "s-pg.ss")
  
  (define-struct cursor
    (connection name client/server position result select))
  
  (define cursor-open
    (lambda (aconnection aselect aclient/server)
      (when (not (connection? aconnection))
        (error 'cursor-open "expects type <cptr:connection> as 1rst argument, given: ~a" aconnection))
      (when (not (string? aselect))
        (error 'cursor-open "expects type <string> as 2nd argument, given: ~a" aselect))
      (when (and (not (eq? aclient/server 'client)) (not (eq? aclient/server 'server)))
        (error 'cursor-open "expects type <symbol> as 3rd argument with value 'client or 'server, given: ~a" aclient/server))
      (cond ((eq? aclient/server 'client)
             (let ((lresult (result-open aconnection aselect)))
               (make-cursor aconnection (gensym) aclient/server -1 lresult aselect)))
            ((eq? aclient/server 'server)
             (let ((lname (gensym))
                   (lresult #f))
               (execute-sql aconnection "BEGIN")
               (execute-sql aconnection (format "DECLARE ~a SCROLL CURSOR WITHOUT HOLD FOR ~a" lname aselect))
               (make-cursor aconnection lname aclient/server -1 lresult aselect)))
            (else
             (error 'cursor-open "cursor-open given invalid client/server flag: ~a" aclient/server)))))
  
  (define cursor-metadata
    (lambda (acursor)
      (when (not (cursor? acursor))
        (error 'cursor-metadata "expects type <struct:cursor> as 1rst argument, given: ~a" acursor))
      (let ((lconnection (cursor-connection acursor))
            (lname (cursor-name acursor))
            (lclient/server (cursor-client/server acursor))
            (lposition (cursor-position acursor))
            (lresult (cursor-result acursor)))
        (if (eq? lclient/server 'client)
            (result-metadata lresult)
            (let ((ltmp-result (result-open lconnection (format "FETCH FIRST FROM ~a" lname))))
              (let ((lmetadata (result-metadata ltmp-result)))
                (result-close ltmp-result)
                (let ((ltmp-result (result-open lconnection (format "FETCH ABSOLUTE ~a FROM ~a" (add1 lposition) lname))))
                  (result-close ltmp-result))
                lmetadata))))))
  
  (define cursor-ref!
    (lambda (acursor aindex)
      (when (not (cursor? acursor))
        (error 'cursor-ref! "expects type <struct:cursor> as 1rst argument, given: ~a" acursor))
      (when (or (not (integer? aindex)) (< aindex 0))
        (error 'cursor-ref! "expects type <non-negative exact integer> as 2nd argument, given: ~a" aindex))
      (let ((lconnection (cursor-connection acursor))
            (lname (cursor-name acursor))
            (lclient/server (cursor-client/server acursor))
            (lposition (cursor-position acursor))
            (lresult (cursor-result acursor)))
        (if (eq? lclient/server 'client)
            (if (< aindex (result-length lresult))
                (let ((lrow (result-ref lresult aindex)))
                  (set-cursor-position! acursor aindex)
                  lrow)
                (error 'cursor-ref! "index ~a too large for cursor" aindex))
            (let ((ltmp-result (result-open lconnection (format "FETCH ABSOLUTE ~a FROM ~a" (add1 aindex) lname))))
              (if (not (= (result-length ltmp-result) 1))
                  (error 'cursor-ref! "index ~a too large for cursor" aindex)
                  (let ((lrow (result-ref ltmp-result 0)))
                    (result-close ltmp-result)
                    (set-cursor-position! acursor aindex)
                    lrow)))))))

  (define cursor-ref
    (lambda (acursor aindex)
      (when (not (cursor? acursor))
        (error 'cursor-ref "expects type <struct:cursor> as 1rst argument, given: ~a" acursor))
      (when (or (not (integer? aindex)) (< aindex 0))
        (error 'cursor-ref "expects type <non-negative exact integer> as 2nd argument, given: ~a" aindex))
      (let ((lcursor (cursor-open (cursor-connection acursor) (cursor-select acursor) (cursor-client/server acursor))))
        (let ((lconnection (cursor-connection lcursor))
              (lname (cursor-name lcursor))
              (lclient/server (cursor-client/server lcursor))
              (lresult (cursor-result lcursor)))
          (if (eq? lclient/server 'client)
              (if (< aindex (result-length lresult))
                  (result-ref lresult aindex)
                  (error 'cursor-ref "index ~a too large for cursor" aindex))
              (let ((ltmp-result (result-open lconnection (format "FETCH ABSOLUTE ~a FROM ~a" (add1 aindex) lname))))
                (if (not (= (result-length ltmp-result) 1))
                    (error (format "cursor-ref: index ~a too large for cursor" aindex))
                    (let ((lrow (result-ref ltmp-result 0)))
                      (result-close ltmp-result)
                      lrow))))))))
 
  (define cursor-next
    (lambda (acursor)
      (when (not (cursor? acursor))
        (error 'cursor-next "expects type <struct:cursor> as 1rst argument, given: ~a" acursor))
      (let ((lconnection (cursor-connection acursor))
            (lname (cursor-name acursor))
            (lclient/server (cursor-client/server acursor))
            (lposition (cursor-position acursor))
            (lresult (cursor-result acursor)))
        (let ((lnew-position (add1 lposition)))
          (if (eq? lclient/server 'client)
              (if (< lnew-position (result-length lresult))
                  (let ((lrow (result-ref lresult lnew-position)))
                    (set-cursor-position! acursor lnew-position)
                    lrow)
                  'eoc-object)
              (let ((ltmp-result (result-open lconnection (format "FETCH NEXT FROM ~a" lname))))
                (if (not (= (result-length ltmp-result) 1))
                    'eoc-object
                    (let ((lrow (result-ref ltmp-result 0)))
                      (set-cursor-position! acursor lnew-position)
                      (result-close ltmp-result)
                      lrow))))))))

  (define cursor-previous
    (lambda (acursor)
      (when (not (cursor? acursor))
        (error 'cursor-previsou "expects type <struct:cursor> as 1rst argument, given: ~a" acursor))
      (let ((lconnection (cursor-connection acursor))
            (lname (cursor-name acursor))
            (lclient/server (cursor-client/server acursor))
            (lposition (cursor-position acursor))
            (lresult (cursor-result acursor)))
        (let ((lnew-position (sub1 lposition)))
          (if (eq? lclient/server 'client)
              (if (>= lnew-position 0)
                  (let ((lrow (result-ref lresult lnew-position)))
                    (set-cursor-position! acursor lnew-position)
                    lrow)
                  'eoc-object)
              (let ((ltmp-result (result-open lconnection (format "FETCH PRIOR FROM ~a" lname))))
                (if (not (= (result-length ltmp-result) 1))
                    'eoc-object
                    (let ((lrow (result-ref ltmp-result 0)))
                      (set-cursor-position! acursor lnew-position)
                      (result-close ltmp-result)
                      lrow))))))))

  (define cursor-first
    (lambda (acursor)
      (when (not (cursor? acursor))
        (error 'cursor-first "expects type <struct:cursor> as 1rst argument, given: ~a" acursor))
      (let ((lconnection (cursor-connection acursor))
            (lname (cursor-name acursor))
            (lclient/server (cursor-client/server acursor))
            (lposition (cursor-position acursor))
            (lresult (cursor-result acursor)))
        (let ((lnew-position 0))
          (if (eq? lclient/server 'client)
              (if (> (result-length lresult) 0)
                  (let ((lrow (result-ref lresult lnew-position)))
                    (set-cursor-position! acursor lnew-position)
                    lrow)
                  'eoc-object)
              (let ((ltmp-result (result-open lconnection (format "FETCH FIRST FROM ~a" lname))))
                (if (not (= (result-length ltmp-result) 1))
                    'eoc-object
                    (let ((lrow (result-ref ltmp-result 0)))
                      (set-cursor-position! acursor lnew-position)
                      (result-close ltmp-result)
                      lrow))))))))

  (define cursor-last
    (lambda (acursor)
      (when (not (cursor? acursor))
        (error 'cursor-last "expects type <struct:cursor> as 1rst argument, given: ~a" acursor))
      (let ((lconnection (cursor-connection acursor))
            (lname (cursor-name acursor))
            (lclient/server (cursor-client/server acursor))
            (lposition (cursor-position acursor))
            (lresult (cursor-result acursor)))
        (let ((lnew-position (sub1 (cursor-length acursor))))
          (if (eq? lclient/server 'client)
              (if (> (result-length lresult) 0)
                  (let ((lrow (result-ref lresult lnew-position)))
                    (set-cursor-position! acursor lnew-position)
                    lrow)
                  'eoc-object)
              (let ((ltmp-result (result-open lconnection (format "FETCH LAST FROM ~a" lname))))
                (if (not (= (result-length ltmp-result) 1))
                    'eoc-object
                    (let ((lrow (result-ref ltmp-result 0)))
                      (set-cursor-position! acursor lnew-position)
                      (result-close ltmp-result)
                      lrow))))))))
  
  (define cursor-length
    (lambda (acursor)
      (let ((lconnection (cursor-connection acursor))
            (lclient/server (cursor-client/server acursor))
            (lresult (cursor-result acursor))
            (lselect (cursor-select acursor)))
        (if (eq? lclient/server 'client)
            (result-length lresult)
            (let ((lcursor (cursor-open lconnection lselect lclient/server)))
              (let loop ((lrow (cursor-next lcursor))
                         (lcount 0))
                (if (eoc-object? lrow)
                    lcount
                    (loop (cursor-next lcursor)
                          (add1 lcount)))))))))
  
  (define eoc-object?
    (lambda (arow)
      (eq? arow 'eoc-object)))
  
  (define cursor-close
    (lambda (acursor)
      (let ((lconnection (cursor-connection acursor))
            (lname (cursor-name acursor))
            (lclient/server (cursor-client/server acursor))
            (lresult (cursor-result acursor)))
        (if (eq? lclient/server 'client)
            (result-close lresult)
            (begin
              (execute-sql lconnection (format "CLOSE ~a" lname))
              (execute-sql lconnection "END")
              (when lresult (result-close lresult)))))))

  (provide
   cursor
   cursor-open
   cursor-metadata
   cursor-ref!
   cursor-ref
   cursor-next
   cursor-previous
   cursor-first
   cursor-last
   cursor-length
   eoc-object?
   cursor-close))