(define-module (gtk dynlink))

;; Alternative implementation of dynamic linking for compiled code
;; modules

;; The idea here is to not use the builtin mechanism for dyn-linking
;; at all, because it sucks.  It can't really deal with a more
;; complicated setup like more than one module in a shared library or
;; one compiled module using another.

;; The problems all stem from the fact that the shared library is
;; required to have a name that matches the module name and that it
;; does not work to load a shared library multiple times via different
;; names.  In addition, dlopen does not deal with version numbers,
;; etc.

;; I hope to use GNU dld in the future, which should provide a sane
;; dlopen abstraction on all supported platforms.

;; All other Guile-gtk related compiled code modules are supposed to
;; use this mechanism as well.  We use the special `gtk
;; %static-initfuncs%' module directory for storing information about
;; statically linked init functions.  You should never explicitely
;; request a module from this directory.

(define (pk . args)
  (write args (current-error-port))
  (newline)
  (car (last-pair args)))

;; We have to use our own dynamic-link function because Guile's
;; doesn't use the RTLD_GLOBAL flag.

(define this-module (current-module))

(define (init-dlopen-funcs)
  (if (not (module-defined? this-module '%sgtk-dlopen))
      (save-module-excursion
       (lambda ()
	 (set-current-module this-module)
	 (dynamic-call 'sgtk_dlopenhelper_init 
		       (dynamic-link "libguiledlopenhelper.so"))))))

;; Split STR at its colons, resulting in a list if strings.

(define (split-colon-path str)
  (if (or (not str) (zero? (string-length str)))
      '()
      (let ((pos (string-index str #\:)))
	(if pos
	    (cons (substring str 0 pos)
		  (split-colon-path (substring str (1+ pos))))
	    (list str)))))

;; Try each element of PATH for NAME.

(define (search-path name path)
  (if (and (> (string-length name) 0) (eqv? (string-ref name 0) #\/))
      name
      (or-map (lambda (p)
		(let ((full-name (string-append p "/" name)))
		  (if (file-exists? full-name)
		      full-name
		      #f)))
	      path)))

(define (default-lib-path)
  (append (split-colon-path (getenv "LD_LIBRARY_PATH"))
	  '("/usr/local/lib" "/usr/lib" "/lib")))

;; Find a libtool information file.  We search PATH for "NAME.la" and
;; return the full path name.  When the file can not be found, return #f.

(define (find-libtool-library name path)
  (search-path (string-append name ".la") path))

;; Return the contents of NAME.la as an alist.  PATH is used to find
;; NAME.la.

(define-public (libtool-library-info name path)
  (define (split line)
    (let ((pos (string-index line #\=)))
      (if pos
	  (let ((key (substring line 0 pos))
		(value (substring line (1+ pos))))
	    (if (eqv? (string-ref value 0) #\')
		(set! value (substring value 1 (1- (string-length value)))))
	    (cons (string->symbol key) value))
	  #f)))
  (let ((full-name (find-libtool-library name path)))
    (if full-name
	(with-input-from-file full-name
	  (lambda ()
	    (let loop ((line (read-line))
		       (info '()))
	      (if (eof-object? line)
		  (reverse info)
		  (let ((i (split line)))
		    (if i
			(loop (read-line) (cons i info))
			(loop (read-line) info)))))))
	'())))

;;(define (find-soname name path)
;;  (define (string-string str1 str2)
;;    (let ((len1 (string-length str1))
;;	  (len2 (string-length str2)))
;;      (let loop ((pos 0))
;;	(cond ((> (+ pos len2) len1)
;;	       #f)
;;	      ((string=? (substring str1 pos (+ pos len2)) str2)
;;	       pos)
;;	      (else
;;	       (loop (1+ pos)))))))
;;  (let ((full-name (pk 'full-name 
;;		       (search-path (string-append name ".so") path))))
;;    (and full-name
;;	 (let ((real-name (pk 'real-name (readlink full-name))))
;;	   (if real-name
;;	       (let ((pos (string-string real-name ".so.")))
;;		 (cond (pos
;;			(set! pos (+ pos 4))
;;			(do ()
;;			    ((or (> pos (string-length real-name))
;;				 (not (char-numeric? (string-ref real-name
;;								 pos)))))
;;			  (set! pos (1+ pos)))
;;			(pk 'soname (substring real-name 0 pos)))
;;		       (else
;;			real-name)))
;;	       full-name)))))

;; Return the soname of a shared object.  Originally I thought that we
;; have to be clever here because of versions and different names for
;; one library.  But I know think that dlopen is clever enough.  I'm
;; confused.

(define (find-soname name path)
  (string-append name ".so"))

;; Find and link a library named NAME, searching PATH.  When PATH is
;; not specified, use a default search path.  NAME should be something
;; like "libfoo", without any extensions.  When NAME.la can not be
;; found, try NAME.so.  When NAME.so can't be found either, return #f.

(define-public (dlopen-libtool-library name . opt-path)
  (let* ((path (if (pair? opt-path) (car opt-path) (default-lib-path)))
	 (info (libtool-library-info name path))
	 (dlname (assq 'dlname info))
	 (deps (assq 'dependency_libs info))
	 (libdir (assq 'libdir info)))
    (init-dlopen-funcs)
    (cond ((and dlname (> (string-length (cdr dlname)) 0))
	   (if deps (do-libtool-link (cdr deps)))
	   (let ((full-name (if libdir
				(string-append (cdr libdir) "/" (cdr dlname))
				(cdr dlname))))
	     (%sgtk-dlopen full-name)))
	  (else
	   (%sgtk-dlopen (find-soname name path))))))

;; Return a procedure that returns the next space-separated word of
;; STR each time it is called.

(define (make-word-scanner str)
  (let ((pos 0)
	(len (string-length str)))
    (lambda ()
      (let loop ((start pos))
	(cond ((>= start len)
	       #f)
	      ((eqv? (string-ref str start) #\space)
	       (loop (1+ start)))
	      (else
	       (let loop ((stop start))
		 (if (or (>= stop len) (eqv? (string-ref str stop) #\space))
		     (begin
		       (set! pos stop)
		       (substring str start stop))
		     (loop (1+ stop))))))))))

;; Perform run-time linking of LIBS.  LIBS should be a string like you
;; would specify it to the system linker, like "-L/usrX11R6/lib -lX11".
;; Returns an unspecified value.

(define-public (do-libtool-link libs)
  (let ((next-word (make-word-scanner libs))
	(path (default-lib-path)))
    (define (option-arg word)
      (if (< (string-length word) 3)
	  (next-word)
	  (substring word 2)))
    (define (doit)
      (let ((word (next-word)))
	(if (and word (eqv? (string-ref word 0) #\-))
	    (let ((arg (option-arg word)))
	      (case (string-ref word 1)
		((#\l)
		 (let ((path path))
		   (doit) ; process rest first
		   (or (dlopen-libtool-library (string-append "lib" arg)
					       path)
		       (display (string-append "Can't link lib" arg
					       ", hope that's ok.\n")
				(current-error-port)))))
		((#\L)
		 (set! path (cons arg path))
		 (doit)))))))
       (doit)))

;; Merge some compiled code into the public interface of the current
;; module.  The compiled code will be initialized by calling a
;; function named INIT-FUNC in the library called LIBNAME.  When
;; INIT-FUNC is among the pre-loaded libraries, we use it.  Else we
;; try to dynamically link LIBNAME, which should be a shared library
;; built and installed with libtool.  LIBNAME should not include any
;; extension, like ".la" or ".so", or version number suffices.

(define-public (merge-compiled-code init-func libname)
  (let* ((module (current-module))
	 (interface (module-public-interface module)))
    ;; make the new primitives visible from within the current module.
    (module-use! module interface) ; XXX - is this safe?
    (save-module-excursion
     (lambda ()
       (set-current-module interface)
       (let* ((modname (list 'gtk '%static-initfuncs%
			     (string->symbol init-func)))
	      (modinfo   (or-map (lambda (modinfo)
				   (if (equal? (car modinfo) modname)
				       modinfo
				       #f))
				 registered-modules))
	      (init-func (if modinfo (cadr modinfo) init-func))
	      (lib       (if modinfo (caddr modinfo)
			     (or (dlopen-libtool-library libname)
				 (error "can't open library" libname)))))
	 (if lib
	     (%sgtk-dlinit init-func lib)
	     (dynamic-call init-func #f)))))))