#!/usr/local/bin/siod -v0,-m3 -*-mode:lisp-*-

;; name:    sp_help.html
;; purpose: example use of Chunks of HTML, nested repeating objects.
;; author:  george j. carrette
;; $Id: sp_help.scm,v 1.2 1996/12/09 23:09:36 gjc Exp $

(define (main)
  (let ((before-realtime (realtime))
	(before-runtime (runtime)))
    (require'cgi.scm)
    (let ((form (car (load "sp_help.html-bin" t)))
	  (table (cons-array 10)))
      (hset table 'SCRIPT_NAME (getenv "SCRIPT_NAME"))
      (hset table 'errflag 0)
      (hset table 'msgsflag 0)
      (hset table 'statusflag 0)
      (hset table 'rowflag 0)
      (cond ((equal? "GET" (getenv "REQUEST_METHOD"))
	     (main-get table))
	    ((equal? "POST" (getenv "REQUEST_METHOD"))
	     (main-post table
			(read-content-alist)))
	    ('else
	     (error "REQUEST_METHOD not handled"
		    (getenv "REQUEST_METHOD"))))
      (hset table 'realtime (- (realtime) before-realtime))
      (hset table 'runtime (- (car (runtime)) (car before-runtime)))
      (writes nil
	      "Content-type: text/html\n\n")
      (swrite nil table form))))

(define (locate-sybase-stuff)
  (let ((fdir (car (subset (lambda (x)
			     (not (access-problem?
				   (string-append x "/interfaces")
				   "r")))
			   (list (or (and (getenv "SYBASE")
					  (> (length (getenv "SYBASE"))
					     0)
					  (getenv "SYBASE"))
				     "/sybase")
				 "/sybase"
				 "/home/sybase"
				 "/export/home/sybase"))))

	(i nil))
    (cond ((not fdir)
	   '("" ""))
	  ('else
	   (let ((f (fopen (string-append fdir "/interfaces") "r"))
		 (line nil))
	     (while (and (not i) (set! line (gets f)))
	       (set! line (string-trim line))
	       (cond ((substring-equal? "#" line 0 1))
		     ((= (length line) 0))
		     ('else
		      (set! i (substring line 0
					 (or
					  (string-search " " line)
					  (string-search "\t" line))))
		      (set! i (string-trim i)))))
	     (fclose f)
	     (list fdir (or i "")))))))

(define (main-get env)
  (let ((s (locate-sybase-stuff)))
    (hset env 'SYBASE (car s))
    (hset env 'DSQUERY (cadr s))
    (hset env 'username "")
    (hset env 'password "")
    (hset env 'database "")
    (hset env 'appname "sp_help.cgi")
    (hset env 'obj "")))

(define (main-post env alist)
  (putenv (string-append "SYBASE="
			 (cadr (assq 'SYBASE alist))))
  (putenv (string-append "DSQUERY="
			 (cadr (assq 'DSQUERY alist))))
  (require'sql_sybase.scm)
  (mapcar (lambda (x)
	    (hset env
		  x
		  (html-encode (or (cadr (assq x alist)) ""))))
	  '(SYBASE DSQUERY username password
		   appname database obj))
  (cond ((sybase-fcn env
		     sybase-open
		     'username (or (cadr (assq 'username alist)) "")
		     'password (or (cadr (assq 'password alist)) "")
		     'appname (or (cadr (assq 'appname alist)) ""))
	 (if (and (cadr (assq 'database alist))
		  (> (length (cadr (assq 'database alist))) 0))
	     (sybase-fcn env
			 sybase-execute
			 (string-append
			  "use " 
			  (cadr (assq 'database alist)))
			 CS_LANG_CMD))
	 (let ((obj (if (and (assq 'SP_HELP_OBJ alist)
			     (cadr (assq 'obj alist))
			     (> (length (cadr (assq 'obj alist)))
				0))
			(cadr (assq 'obj alist))
		      (or (cadr (assq 'SP_HELP alist))
			  (cadr (assq 'obj alist))
			  "")))
	       (result nil))
	   (hset env 'obj (html-encode obj))
	   (set! result (sybase-fcn env
				    sybase-execute
				    "sp_help"
				    CS_RPC_CMD
				    "" obj))
	   (mapcar (lambda (x)
		     (setup-result env x))
		   result)
	   (sybase-close)))))

(define (sybase-fcn env f . args)
  (set! *sybase-messages* nil)
  (let ((result (*catch 'errobj (list 'ok (apply f args)))))
    (cond (*sybase-messages*
	   (hset env 'msgsflag 1)
	   (hset env 'nmsgs (+ (or (href env 'nmsgs) 0)
			       (length *sybase-messages*)))
	   (hset env 'msgtype
		 (append (href env 'msgtype)
			 (mapcar car
				 *sybase-messages*)))
	   (hset env 'msgcode
		 (append (href env 'msgcode)
			 (mapcar (lambda (x)
				   (cdr (assq 'msgnumber x)))
				 *sybase-messages*)))
	   (hset env 'msgtext
		 (append (href env 'msgtext)
			 (mapcar (lambda (x)
				   (html-encode
				    (or (cdr (assq 
					      (if (eq? (car x) 'client)
						  'msgstring
						'text)
					      x))
					"")))
				 *sybase-messages*)))))
    (cond ((and (pair? result) (eq? (car result) 'ok))
	   (cadr result))
	  ('else
	   (hset env 'errflag 1)
	   (hset env 'errmsg (car result))
	   nil))))

(define *tflag-prototypes*
  '(((Name Owner Type) (1 0 0))
    ((Column_name Type Length Prec Scale Nulls
		  Default_name Rule_name Identity)
     (0 1 0 0 0 0 0 0 0))
    ((Type_name Storage_type Length Prec Scale Nulls
		Default_name Rule_name Identity)
     (1 1 0 0 0 0 0 0 0))
    ((Name Owner Object_type)
     (1 0 0))
    ((User_type Storage_type Length Nulls Default_name Rule_name)
     (1 1 0 0 0 0))
    ((Parameter_name Type Length Prec Scale Param_order)
     (0 1 0 0 0 0))))

(define (tflag-prototype cols)
  (or (cadr (assoc cols *tflag-prototypes*))
      (make-list (length cols) 0)))

(define (setup-result env x)
  (cond ((not (pair? x)))
	((eq? (car x) 'CS_STATUS_RESULT)
	 (hset env 'statusflag 1)
	 (hset env 'nstatus (+ 1 (or (href env 'nstatus) 0)))
	 (hset env 'status (append (href env 'status)
				   (list (aref (nth 2 x) 0)))))
	((eq? (car x) 'CS_ROW_RESULT)
	 (hset env 'rowflag (+ 1 (or (href env 'rowflag) 0)))
	 (hset env 'ncols
	       (nconc (href env 'ncols)
		      (list (length (nth 1 x)))))
	 (let ((cols (array->list (nth 1 x)))
	       (tflags nil)
	       (ntflags nil))
	   (hset env 'cols
		 (nconc (href env 'cols)
			(mapcar
			 (lambda (x)
			   (unbreakupstr
			    (strbreakup
			     (html-encode x)
			     "_")
			    " "))
			 cols)))
	   (hset env 'nrows
		 (nconc (href env 'nrows)
			(list (length (cddr x)))))
	   (set! tflags (tflag-prototype cols))
	   (set! ntflags (mapcar (lambda (x) (if (= 0 x) 1 0))
				 tflags))
	   (hset env 'tflag
		 (nconc (href env 'tflag)
			(apply append (make-list
				       (length (cddr x))
				       tflags))))
	   (hset env 'ntflag
		 (nconc (href env 'ntflag)
			(apply append (make-list
				       (length (cddr x))
				       ntflags))))
	   (hset env 'element
		 (nconc (href env 'element)
			(list-array->html-list (cddr x)))))
	 nil)))



(define (array->list x)
  (let ((j 0)
	(result nil))
    (while (< j (length x))
      (set! result (cons (aref x j) result))
      (set! j (+ 1 j)))
    (nreverse result)))

(define (list-array->html-list x)
  (let ((l x)
	(j 0)
	(result nil))
    (while l
      (set! j 0)
      (while (< j (length (car l)))
	(set! result (cons (html-encode (aref (car l) j)) result))
	(set! j (+ 1 j)))
      (set! l (cdr l)))
    (nreverse result)))