X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fforeign.lisp;h=cac98877fb08550d80f6d91f3e4e8c7d2faeebd5;hb=f9aaac53a4a43ebae198f53079857acb2d628eb0;hp=f854494ef44333c0d97f030ab4a438d1f2ffe6c6;hpb=6139c89c89f45c03509e4f3156293ff656716a8c;p=sbcl.git diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index f854494..cac9887 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -10,20 +10,29 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB-SYS") ; (SB-SYS, not SB!SYS, since we're built in warm load.) +(in-package "SB-ALIEN") ; (SB-ALIEN, not SB!ALIEN, since we're in warm load.) + +;;; SEMI-KLUDGE: Preferable would be to use something like O_NOFOLLOW +;;; which will refuse to open() a file if it is a symlink; but I've +;;; been told that is a FreeBSD/Linux-only thing. Meanwhile, this will +;;; make our filenames a lot less predictable. +;;; (The man file for open() says O_EXCL should treat even a symlink as +;;; an existing file. I wonder if it really does that.) +;;; Also, no more dependence on ASCII character ordering. +;;; -- mrd 20021101 +(defun generate-random-string (&optional (len 6)) + (let* ((characters "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789") + (num (length characters)) + (string (make-string len))) + (dotimes (i len string) + (setf (char string i) + (char characters (random num)))))) (defun pick-temporary-file-name (&optional - ;; KLUDGE: There are various security - ;; nastyisms associated with easily - ;; guessable temporary file names, - ;; and we haven't done anything to - ;; work around them here. -- pointed - ;; out by Dan Barlow on sbcl-devel - ;; 20000702 - (base "/tmp/sbcl-tmp-~D~C")) - (let ((code (char-code #\A))) + (base "/tmp/sbcl-tmp-~D~A")) + (let ((code (generate-random-string))) (loop - (let ((name (format nil base (sb-unix:unix-getpid) (code-char code)))) + (let ((name (format nil base (sb-unix:unix-getpid) code))) (multiple-value-bind (fd errno) (sb-unix:unix-open name (logior sb-unix:o_wronly @@ -37,25 +46,13 @@ (simple-file-perror "couldn't create temporary file ~S" name errno)) - ;; KLUDGE: depends on ASCII character ordering -- WHN 20000128 - ((= code (char-code #\Z)) - (setf code (char-code #\a))) - ((= code (char-code #\z)) - (return nil)) (t - (incf code)))))))) - + (setf code (generate-random-string))))))))) ;;; On any OS where we don't support foreign object file loading, any ;;; query of a foreign symbol value is answered with "no definition ;;; known", i.e. NIL. -;;; -;;; (On any OS which *does* support foreign object file loading, this -;;; placeholder implementation is overwritten by a subsequent real -;;; implementation.) -;;; -;;; You may want to use sb-sys:foreign-symbol-address instead of -;;; calling this directly; see code/target-load.lisp. +#-(or linux sunos FreeBSD OpenBSD darwin) (defun get-dynamic-foreign-symbol-address (symbol) (declare (type simple-string symbol) (ignore symbol)) nil) @@ -63,7 +60,17 @@ ;;; dlsym()-based implementation of GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS ;;; and functions (e.g. LOAD-FOREIGN) which affect it. This should ;;; work on any ELF system with dlopen(3) and dlsym(3) -#+(or linux FreeBSD) +;;; It also works on OpenBSD, which isn't ELF, but is otherwise modern +;;; enough to have a fairly well working dlopen/dlsym implementation. +#-(or linux sunos FreeBSD OpenBSD darwin) +(macrolet ((define-unsupported-fun (fun-name) + `(defun ,fun-name (&rest rest) + "unsupported on this system" + (declare (ignore rest)) + (error 'unsupported-operator :name ',fun-name)))) + (define-unsupported-fun load-1-foreign) + (define-unsupported-fun load-foreign)) +#+(or linux sunos FreeBSD OpenBSD darwin) (progn ;;; flags for dlopen() @@ -105,8 +112,9 @@ *after-save-initializations*) (defvar *dso-linker* "/usr/bin/ld") -(defvar *dso-linker-options* '("-G" "-o")) - +(defvar *dso-linker-options* + #-darwin '("-shared" "-o") + #+darwin '("-bundle" "-o")) (sb-alien:define-alien-routine dlopen system-area-pointer (file sb-alien:c-string) (mode sb-alien:int)) @@ -117,17 +125,16 @@ ;;; Ensure that we've opened our own binary so we can dynamically resolve ;;; symbols in the C runtime. - +;;; ;;; Old comment: This used to happen only in ;;; GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS, and only if no libraries were ;;; dlopen()ed already, but that didn't work if something was ;;; dlopen()ed before any problem global vars were used. So now we do ;;; this in any function that can add to the *HANDLES-FROM-DLOPEN*, as ;;; well as in GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS. - +;;; ;;; FIXME: It would work just as well to do it once at startup, actually. ;;; Then at least we know it's done. -dan 2001.05.10 - (defun ensure-runtime-symbol-table-opened () (unless *handles-from-dlopen* ;; Prevent recursive call if dlopen() isn't defined. @@ -169,7 +176,7 @@ ;; that the list isn't guaranteed to be in reverse order of loading, ;; at least not if a file is loaded more than once. Is this the ;; right thing? (In what cases does it matter?) - (dolist (handle *handles-from-dlopen*) + (dolist (handle (reverse *handles-from-dlopen*)) ;; KLUDGE: We implicitly exclude the possibility that the variable ;; could actually be NULL, but the man page for dlsym(3) ;; recommends doing a more careful test. -- WHN 20000825 @@ -177,6 +184,14 @@ (unless (zerop possible-result) (return possible-result))))) +;;; Dan Barlow's quick summary from IRC 2003-06-21: +;;; fwiw, load-foreign does random stuff with ld so that you can use +;;; it with static libraries +;;; if you have shared objects, load-1-foreign will do fine +;;; and +;;; I think my position on this matter is consistent with Tim Moore's: +;;; use (cmucl equivalent of) load-1-foreign, load-foreign is arse +;;; though he may say ass (defun load-foreign (files &key (libraries '("-lc")) @@ -216,7 +231,7 @@ (when (and env-p environment-p) (error "can't specify :ENV and :ENVIRONMENT simultaneously")) (let ((output-file (pick-temporary-file-name - (concatenate 'string "/tmp/~D~C" (string (gensym))))) + (concatenate 'string "/tmp/~D~A" (string (gensym))))) (error-output (make-string-output-stream))) (/show "running" *dso-linker*)