[UFFI-Devel] Fwd: patch to be able to load libraries thru GNU ld scripts.

[Pascal J. Bourguignon]

Here is a patch to load-foreign-library so that it may find a load
libraries that are loaded indirectly thru GNU ld script, such as on
gentoo.


(defun foreign-library-if-gnu-ld-script (libpath error)
 "
LIBPATH: Pathname to the supposed GNU ld script.
ERROR:   A condition that is signaled with  ERROR if LIBPATH is not a
        GNU ld script.
RETURN:  A pathname to a library.
"
 (let ((newpath
        (with-open-file (stream libpath
                                :direction :input
                                :element-type 'character
                                :external-format :default
                                :if-does-not-exist nil)
          (when stream
            (let ((buffer (make-array 80
                                      :element-type 'character
                                      :fill-pointer 80)))
              (setf (fill-pointer buffer) (read-sequence buffer stream))
              (when (search "GNU ld script" buffer)
                (file-position stream 0)
                (loop
                  (let ((line (read-line stream nil nil)))
                    (cond
                      ((null line) (return nil))
                      ((and (< 5 (length line))
                            (string= "GROUP" (subseq line 0 5)))
                       (let* ((left  (position #\( line))
                              (ppos  (and left (position #\space line
                                                         :start (1+ left)
                                                         :test (function char/=))))
                              (right (and ppos (position #\space line :start ppos))))
                         (return 
                           (and right (subseq line ppos right))))))))))))))
   (if newpath
       newpath
       (error error)))))



(defun load-foreign-library (filename &key module supporting-libraries
                            force-load)
 (declare (ignorable module supporting-libraries))

 (flet ((load-failure ()
          (error "Unable to load foreign library \"~A\"." filename)))
   (declare (ignorable #'load-failure))
   (when (and filename (or (null (pathname-directory filename))
                           (probe-file filename)))
     (if (pathnamep filename)    ;; ensure filename is a string to check if already loaded
         (setq filename (namestring (if (null (pathname-directory filename))
                                        filename
                                        ;; lispworks treats as UNC, so use truename
                                        #+(and lispworks mswindows) (truename filename)
                                        #-(and lispworks mswindows) filename))))

     (if (and (not force-load)
              (find filename *loaded-libraries* :test #'string-equal))
         t ;; return T, but don't reload library
         (flet  ((load-foreign-library (filename)
                   (progn
                     #+cmu
                     (let ((type (pathname-type (parse-namestring filename))))
                       (if (string-equal type "so")
                           (unless
                               (sys::load-object-file filename)
                             (load-failure))
                           (alien:load-foreign filename
                                               :libraries
                                               (convert-supporting-libraries-to-string
                                                supporting-libraries))))
                     #+scl
                     (alien:load-foreign filename
                                         :libraries
                                         (convert-supporting-libraries-to-string
                                          supporting-libraries))
                     #+sbcl
                     (handler-case (sb-alien::load-1-foreign filename)
                       (sb-int:unsupported-operator (c)
                         (if (fboundp (intern "LOAD-SHARED-OBJECT" :sb-alien))
                             (funcall (intern "LOAD-SHARED-OBJECT" :sb-alien) filename)
                             (error c))))

                     #+lispworks (fli:register-module module :real-name filename
                                                      :connection-style :immediate)
                     #+allegro (load filename)
                     #+openmcl (ccl:open-shared-library filename)
                     #+digitool (ccl:add-to-shared-library-search-path filename t)

                     (push filename *loaded-libraries*)
                     t)))
           (handler-case (load-foreign-library filename)
             (error (err)
               (load-foreign-library (foreign-library-if-gnu-ld-script filename err)))))))))


-- 
__Pascal Bourguignon__
http://www.informatimago.com



-------------- next part --------------
An HTML attachment was scrubbed...
URL: http://lists.b9.com/pipermail/uffi-devel/attachments/20120303/f91f89bf/attachment.html