(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))))))
(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))
(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)))
)