(module sqlid-libpath mzscheme
	(require (lib "getinfo.ss" "setup"))
	(require (lib "config.ss"  "planet"))
	(require (lib "util.ss"    "planet"))
	(provide set-libpath
	         reset-libpath
		 libpath-module)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define COLLECTION         'sqlid)
(define FILE-OF-COLLECTION "sqli.scm")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define FOUT (open-output-string))

(define (get-dynamic-require-module-path module-path)

  (define (ups path)
    (define (ups l)
      (if (null? l)
	  (list)
	  (if (or (char=? (car l) #\/)
		  (char=? (car l) #\\))
	      (cons 'up (ups (cdr l)))
	      (ups (cdr l)))))
    (ups (string->list (path->string path))))

  (define (make-relative path)
    (let ((p (path->string path)))
      (if (string=? (substring p 1 2) ":")
	  (make-relative (build-path (substring p 3 (string-length p))))
	  (apply build-path (append (ups (current-directory)) (list path))))))

  (define (get-relative-name name)
    (define (backslash->slash l)
      (if (null? l)
	  (list)
	  (cons
	   (if (char=? (car l) #\\)
	       #\/
	       (car l))
	   (backslash->slash (cdr l)))))
    (list->string 
     (backslash->slash
      (string->list 
       (path->string (make-relative name))))))

					;(get-relative-name (build-path module-path)))
  (build-path module-path))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define (find-planet-package-with-heighest-version package)

  (define (iterate-searcher s L)
    (if (null? L)
	#f
	(let ((r (s (car L))))
	  (if (eq? r #f)
	      (iterate-searcher s (cdr L))
	      r))))

  (define (search-for-user-and-package l)
    (let ((found #f)
	  (major  0)
	  (minor  0)
	  (user   #f))

    (define (search-package l)

      (define (g p)
	(display (format "cache search: ~a~%" p) FOUT)
	(if (string-ci=? (car p) package)
	    (let* ((version (cadr p))
		   (maj (car version))
		   (min (caadr version)))
	      (if (> maj major)
		  (begin
		    (set! major maj)
		    (set! minor min)
		    (set! found #t))
		  (if (> min minor)
		      (begin
			(set! minor min)
			(set! found #t))))))
	#f)

      (set! user (car l))
      (iterate-searcher g (cdr l))
      (if (eq? found #t)
	  (list user package (number->string major) (number->string minor))
	  #f))

    (iterate-searcher search-package l)))

  (search-for-user-and-package (current-cache-contents)))
			    

(define (determine-collect-path)

  (define (find-dir file dirs)
    (if (null? dirs)
	#f
	(if (file-exists? (build-path (car dirs) file))
	    (begin
	      (display (format "~a FOUND in ~a.~%" file (car dirs)) FOUT)
	      (car dirs))
	    (begin
	      (display (format "~a not found in ~a.~%" file (car dirs)) FOUT)
	      (find-dir file (cdr dirs))))))

  (let* ((collection        (symbol->string COLLECTION))

	 (planet-col        (string-append collection ".plt"))
	 (planet-package    (find-planet-package-with-heighest-version planet-col))
	 (planet-path       (if (eq? planet-package #f)
				(begin
				  (display (format "NO Planet PATH for ~a found.~%" planet-col) FOUT)
				  #f)
				(build-path (CACHE-DIR) (apply build-path planet-package))))
	 (search-path       (append (if (eq? planet-path #f) '() (list planet-path))
				    (map (lambda (p) (build-path p collection)) 
					 (current-library-collection-paths)))))

    (find-dir FILE-OF-COLLECTION search-path)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define internal-reset-libpath (lambda () #t))
(define internal-set-libpath   (lambda () #t))
(define sqlid-libpath          (lambda () ""))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (libpath-module module-name)
  (get-dynamic-require-module-path (sqlid-libpath module-name)))

(define (win32-libpath path)
  (let ((PATH (getenv "PATH")))
    (set! internal-reset-libpath (lambda () (putenv "PATH" PATH)))
    (putenv "PATH" (string-append PATH ";" (path->string path)))))

(define (unix-libpath path)
  (let ((_LIBPATH (getenv "LIBPATH"))
	(_LD_LIBRARY_PATH (getenv "LD_LIBRARY_PATH")))
    (let ((LIBPATH (if (eq? _LIBPATH #f) "" _LIBPATH))
          (LD_LIBRARY_PATH (if (eq? _LD_LIBRARY_PATH #f) "" _LD_LIBRARY_PATH)))
      (set! internal-reset-libpath (lambda () 
				     (putenv "LIBPATH" LIBPATH)
				     (putenv "LD_LIBRARY_PATH" LD_LIBRARY_PATH)))
      (putenv "LIBPATH" (string-append LIBPATH ":" (path->string path)))
      (putenv "LD_LIBRARY_PATH" (string-append LD_LIBRARY_PATH ":" (path->string path))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (reset-libpath)
  (internal-reset-libpath))

(define (set-libpath)
  (internal-set-libpath))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Set the library path for inclusion of dynamic libraries.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(let ((native-path  (system-library-subpath))
      (collect-path (determine-collect-path)))

  (if (eq? collect-path #f)
      (error (format "CANNOT FIND collection for ~a.~%~%~a" COLLECTION (get-output-string FOUT))))
  (close-output-port FOUT)
  

  (let ((libpath (build-path collect-path "lib" native-path)))
    (let ((system  (system-type)))
      (set! sqlid-libpath (lambda (mod) (path->string (build-path collect-path mod))))
      (set! internal-set-libpath (lambda ()
				   (cond
				    ((eq? system 'windows) (win32-libpath libpath))
				    ((or
				      (eq? system 'unix)
				      (eq? system 'macosx)) (unix-libpath libpath))
				    (else
				     (error "Cannot set the LIBPATH for this system ('" 'system "'")))))
      #t)))

)