patch-cffi-uffi.lisp 8.42 KB
Newer Older
1 2 3 4 5 6 7
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               patch-cffi-uffi.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
8
;;;;
9
;;;;    Patch to CFFI and  to UFFI to load GNU LD scripts.
10
;;;;
11 12 13 14 15 16 17
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2012-03-03 <PJB> Extracted from terminfo.lisp
;;;;BUGS
;;;;LEGAL
;;;;    GPL2
18
;;;;
19
;;;;    Copyright Pascal J. Bourguignon 2012 - 2014
20
;;;;
21 22 23 24
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU General Public License
;;;;    as published by the Free Software Foundation; either version
;;;;    2 of the License, or (at your option) any later version.
25
;;;;
26 27 28 29
;;;;    This program is distributed in the hope that it will be
;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;;    PURPOSE.  See the GNU General Public License for more details.
30
;;;;
31 32 33 34 35
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************
36 37
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf *readtable* (copy-readtable nil)))
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79

(defpackage "COM.INFORMATIMAGO.CLEXT.GNU-LD-SCRIPT"
  (:use "COMMON-LISP")
  (:export "FOREIGN-LIBRARY-IF-GNU-LD-SCRIPT")
  (:documentation "
This package export a function that returns the first library
specified in a GNU ld script.
"))
(in-package "COM.INFORMATIMAGO.CLEXT.GNU-LD-SCRIPT")


(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))))
80
                          (return
81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195
                            (and right (subseq line ppos right))))))))))))))
    (if newpath
        newpath
        (error error))))


#+cffi
(in-package "CFFI")

#+cffi
(eval-when (:compile-toplevel :load-toplevel :execute)
  (unintern 'foreign-library-if-gnu-ld-script)) ; if the patch is already there.

#+cffi
(eval-when (:compile-toplevel :load-toplevel :execute)
  (import 'com.informatimago.clext.gnu-ld-script:foreign-library-if-gnu-ld-script))

#+cffi
(defun load-foreign-library-path (name path &optional search-path)
  "Tries to load PATH using %LOAD-FOREIGN-LIBRARY which should try and
find it using the OS's usual methods. If that fails we try to find it
ourselves."
  (handler-case
      (values (handler-case (%load-foreign-library name path)
                (error (err)
                  (%load-foreign-library
                   name
                   (foreign-library-if-gnu-ld-script path err))))
              (pathname path))
    (error (error)
      (if-let (file (find-file path (append search-path
                                            *foreign-library-directories*)))
              (handler-case
                  (values (handler-case (%load-foreign-library name (native-namestring file))
                            (error (err)
                              (%load-foreign-library
                               name
                               (foreign-library-if-gnu-ld-script
                                (native-namestring file)
                                err))))
                          file)
                (simple-error (error)
                  (report-simple-error name error)))
              (report-simple-error name error)))))


#+#.(cl:if (cl:find-package "UFFI")  '(:and) '(:or))
(in-package "UFFI")

#+#.(cl:if (cl:find-package "UFFI")  '(:and) '(:or))
(eval-when (:compile-toplevel :load-toplevel :execute)
  (unintern 'foreign-library-if-gnu-ld-script)) ; if the patch is already there.


#+#.(cl:if (cl:find-package "UFFI")  '(:and) '(:or))
(eval-when (:compile-toplevel :load-toplevel :execute)
  (import 'com.informatimago.clext.gnu-ld-script:foreign-library-if-gnu-ld-script))

#+#.(cl:if (cl:find-package "UFFI")  '(:and) '(:or))
(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)))))))))

;;;; THE END ;;;;;