Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 279 lines (232 sloc) 13.981 kb
edb9af3 @lisp version to accompany de.setf.amqp release
authored
1 ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: de.setf.utility.implementation; -*-
2
3 ;;; This file is part of the 'de.setf.utility' Common Lisp library.
4 ;;; It defines helpful pathname operators and defaults and loads the skeleton package definition.
5 ;;;
6 ;;; (c) 2008, 2009, 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved
7 ;;; 'de.setf.utility' is free software: you can redistribute it and/or modify
8 ;;; it under the terms of version 3 of the GNU Lesser General Public License as published by
9 ;;; the Free Software Foundation.
10 ;;;
11 ;;; 'de.setf.utility' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
12 ;;; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13 ;;; See the GNU Lesser General Public License for more details.
14 ;;;
15 ;;; A copy of the GNU Lesser General Public License should be included with 'de.setf.utility, as `lgpl.txt`.
16 ;;; If not, see the GNU [site](http://www.gnu.org/licenses/).
17
18 ;;; 2008-11-17 [jaa](mailto:james.anderson@setf.de) : factored out of various system definitions
19 ;;; 2010-02-03 jaa : added P-LIBARY host for production v/s dev source
20
21
22 ;;;
23 ;;; content :
24 ;;;
25 ;;; runtime-directory-name ()
26 ;;; return a directory name unique to the lisp implementation runtime and version
27 ;;;
28 ;;; set-relative-logical-pathname-translations (host)
29 ;;; given a logical host name, set its translations relative to a given root.
30 ;;; by default, it uses the currently processed source file.
cf61130 @lisp comment edits
authored
31 ;;; see the use cases at the end of this file.
edb9af3 @lisp version to accompany de.setf.amqp release
authored
32 ;;;
33 ;;; translate-physical-pathname (pathname)
34 ;;; return the most immediate governing logical pathname given a physical pathname
35
36
37 (in-package :common-lisp-user)
38
af39c76 @lisp commentary
authored
39 ;;; ensure an implementation package definition
edb9af3 @lisp version to accompany de.setf.amqp release
authored
40
41 (eval-when (:execute :load-toplevel :compile-toplevel)
42 (unless (find-package :de.setf.utility.implementation)
43 (load (make-pathname :name "package" :defaults *load-pathname*))))
44
45 (in-package :de.setf.utility.implementation)
46
47
48 (defParameter *logical-source-type*
49 #+(or (and allegro unix) sbcl) "lisp"
50 #-(or (and allegro unix) sbcl) "LISP")
51
52
53 (defParameter *logical-binary-type*
54 #+(or (and allegro unix) sbcl) "bin"
55 #-(or (and allegro unix) sbcl) "BIN")
56
57 (defParameter *physical-source-type* "lisp")
58 (defParameter *physical-binary-type*
59 (pathname-type (compile-file-pathname (make-pathname :name "source" :type *physical-source-type*))))
60
61 #+(or )
62 (setq sb-fasl:*fasl-file-type* "sbcfsl")
63
64
65
66 ;;; set up logical pathname translations relative to a given root
67
68 (defun runtime-directory-name ()
69 ;; returns the first one which features satisfy
70 (or
71 #+(and allegro allegro-version>= (version>= 8 0) linux amd64) "acl8linux64"
72 #+(and allegro allegro-version>= (version>= 7 0) linux) "acl7linux"
73 #+(and allegro allegro-version>= (version>= 8 0) osx) "acl8osx"
74 #+(and allegro allegro-version>= (version>= 7 0) osx) "acl7osx"
75 #+(and allegro allegro-version>= (version>= 7 0) mswindows) "acl7win"
76 #+(and allegro allegro-version>= (version>= 6 0) osx) "acl6osx"
77 #+(and allegro allegro-version>= (version>= 6 0) mswindows) "acl6win"
78 #+(and allegro allegro-version>= (version>= 6 0)) "acl6unix"
79 #+(and allegro allegro-version>= ) "acl5"
80
81 #+clisp "clispfasl"
82
83 #+cmu "cmuclfasl"
84
85 #+cormanlisp "corfasl"
86
87 #+(and digitool ccl-5.3) "digi-5-3"
88 #+(and digitool ccl-5.2) "digi-5-2"
89 #+(and digitool ccl-5.1) "digi-5-1"
90 #+(and digitool ccl-5.0) "digi-5-0"
91 #+(and mcl m68k) "digim68k"
92
93 #+(and lispworks lispworks5.1 powerpc) "lw-5-1-ppc"
94 #+(and lispworks powerpc) "lw-ppc"
95 #+(and lispworks) "lw"
96
97 #+(and clozure-common-lisp ccl-1.3 ppc-target) "ccl-1-3-ppc"
98 #+(and clozure-common-lisp ccl-1.2 ppc-target) "ccl-1-2-ppc"
99 #+openmcl "omcl"
100
101 #+(and sbcl linux) "sbcl-linux"
102 #+(and sbcl (or osx darwin)) "sbcl-osx"
103
104 (error "no runtime directory defined for ~s / ~s."
105 (lisp-implementation-type) (lisp-implementation-version))))
106
107
108 (defun make-hosted-pathname (host namestring)
109 (format nil "~a:~a" host namestring))
110
111 (defun make-binary-translation-target (host)
112 (make-pathname :name :wild
113 :type (pathname-type (compile-file-pathname ";NAME.LISP"))
114 :version :newest
115 :defaults
116 (make-hosted-pathname host (format nil "root;bin;~a;**;*.*.*" (runtime-directory-name)))))
117
118 (defun set-relative-logical-pathname-translations
119 (host &key (base (or *compile-file-truename* *load-truename*))
120 ((:relative-pathname location) nil)
121 ((:absolute-pathname root-directory)
122 (if location (merge-pathnames location base) base))
123 (root-target (make-pathname :name :wild :type :wild :version :newest
124 :directory (append (pathname-directory root-directory)
125 '(:wild-inferiors))
126 :defaults root-directory))
127 (translations nil))
128 (let ((bin nil))
129 (setf host (string host))
130 ;; first bootstrap bin, use it to get the actual location
131 ;; then install the extended translation - w/ bin mapped to a physical location
132 (setf (logical-pathname-translations host)
133 `(("root;**;*.*.*" ,root-target)))
134 (setf bin (translate-logical-pathname (make-binary-translation-target host)))
135 (when *load-verbose*
136 (format *trace-output* "~&Host translations: ~a~% base: ~s.~% location: ~s.~% root-target: ~s.~% binary: ~s."
137 host base location root-target bin))
138 (setf (logical-pathname-translations host)
139 ;; some implementation require the distinction in version designator
140 `(("**;*.bin" ,(make-pathname :version nil :defaults bin))
141 ("**;*.BIN" ,(make-pathname :version nil :defaults bin))
142 ("**;*.bin.*" ,bin)
143 ("**;*.BIN.*" ,bin)
144 (,(format nil "**;*.~a" *physical-binary-type*) ,(make-pathname :version nil :defaults bin))
145 (,(format nil "**;*.~a.*" *physical-binary-type*) ,(make-pathname :version :wild :defaults bin))
146 ("code;**;*.*.*" ,(make-hosted-pathname host "root;code;**;*.*.*"))
147 ("code;**;*.*" ,(make-hosted-pathname host "root;code;**;*.*"))
148 ("root;**;*.*" ,(make-pathname :version nil :defaults root-target))
149 ("root;**;*.*.*" ,root-target)
150 ,@translations
151 ("**;*.*" ,(make-hosted-pathname host "root;**;*.*"))
152 ))))
153
154 ;;; both clozure and digitool bind host definitions as an alist
155 #+ccl
156 (defun logical-hosts-translations ()
157 ccl::%logical-host-translations%)
158 #+ccl
159 (defun logical-hosts ()
160 (mapcar #'first (logical-hosts-translations)))
161 #+lispworks
162 (defun logical-hosts ()
163 (loop for host being each hash-key of system::*logical-pathname-translations*
164 collect host))
165 #+sbcl
166 (defun logical-hosts ()
167 (loop for host being each hash-key of SB-IMPL::*LOGICAL-HOSTS*
168 collect host))
cae0cac @lisp define logical-hosts for allegro and add default definition
authored
169 #+allegro
170 (defun logical-hosts ()
171 (loop for host being each hash-key of excl::*logical-pathname-translations*
172 collect host))
173
174 #-(or ccl lispworks sbcl)
175 (defun logical-hosts ()
176 (cerror "Assume no logical hosts." "This runtime has no definition for ~s." 'logical-hosts))
edb9af3 @lisp version to accompany de.setf.amqp release
authored
177
178 (defgeneric translate-physical-pathname (pathname &key &allow-other-keys)
179 (:documentation "translate a given PATHNAME back to the most specific logical pathname.
180 PATHNAME : (designator PATHNAME)
181 VALUE : (or LOGICAL-PATHNAME NULL) : the most specific logical pathname or NIL if
182 no host dominates the given pathname")
183
184 (:method ((designator string) &rest args)
185 (declare (dynamic-extent args))
186 (apply #'translate-physical-pathname (pathname designator) args))
187
188 (:method ((designator stream) &rest args)
189 (declare (dynamic-extent args))
190 (apply #'translate-physical-pathname (pathname designator) args))
191
192 (:method ((pathname logical-pathname) &key &allow-other-keys)
193 pathname)
194
195 (:method ((pathname pathname) &key &allow-other-keys)
196 (let ((specific-host nil)
197 (specific-enough nil)
198 (namestring (namestring pathname)))
199 (flet ((record-candidate (host enough)
200 (setf specific-host host)
201 (setf specific-enough enough)))
202 (dolist (host (logical-hosts))
203 (let ((proto-translation (ignore-errors (translate-logical-pathname (concatenate 'string host ":TEST.LISP")))))
204 (when proto-translation
205 (let* ((host-translation (make-pathname :name nil :type nil :defaults proto-translation))
206 (enough (enough-namestring pathname host-translation)))
207 ;; if the pathname is "hosted", check if it is commensurable with already found
208 ;; if yes, retain the more specific host. if no, signal an error
209 ;; if non yet, cache this one
210 (unless (equal enough namestring)
211 (cond ((null specific-host)
212 ;; save first candidate
213 (record-candidate host enough))
214 ((and (> (length specific-enough) (length enough))
215 (string-equal specific-enough enough :start1 (- (length specific-enough) (length enough))))
216 ;; replace candidate
217 (record-candidate host enough))
218 ((and (> (length enough) (length specific-enough))
219 (string-equal specific-enough enough :start2 (- (length enough) (length specific-enough))))
220 ;; skip additional candidate
221 )
222 (t
223 ;; neither fit in the other
224 (cerror "ignore ambiguity and continue."
225 "translate-physical-pathname: ambiguous host-relative pathname: (~s . ~s) (~s . ~s)"
226 specific-host specific-enough host enough)))))))))
227 (when specific-host
228 (make-pathname :host specific-host
229 :directory (cons :absolute (rest (pathname-directory specific-enough)))
230 :name (pathname-name specific-enough)
231 :type (pathname-type specific-enough)
232 :defaults specific-enough)))))
233
234 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
235 ;;;
236 ;;; set standard host complement
237 ;;; - LIBRARY presumes that this is in in `#p"LIBRARY:de;setf;utility;"`
238 ;;; - P-LIBRARY iff it is found at `#p"LIBRARY:..;..;production;Library;"`
cae0cac @lisp define logical-hosts for allegro and add default definition
authored
239 ;;;
edb9af3 @lisp version to accompany de.setf.amqp release
authored
240
241 ;;; (setf (logical-pathname-translations "LIBRARY") nil)
242 ;;; if there is no LIBRARY host, make one
cae0cac @lisp define logical-hosts for allegro and add default definition
authored
243 ;;; the macrolet captures *compile-file-pathname*, which should work in all runtimes.
244
245 (eval-when (:compile-toplevel :load-toplevel :execute)
246 (defun define-library-host (source-pathname)
247 (set-relative-logical-pathname-translations "LIBRARY"
248 :absolute-pathname
249 (make-pathname :directory (butlast (pathname-directory source-pathname) 3)
250 :name nil :type nil
251 :defaults source-pathname)))
252
253 (or (ignore-errors (logical-pathname-translations "LIBRARY"))
254 (macrolet ((source-pathname () (truename (or *compile-file-pathname* *load-pathname*))))
255 (define-library-host (source-pathname)))))
256
257
edb9af3 @lisp version to accompany de.setf.amqp release
authored
258 (let ((production (merge-pathnames (make-pathname :directory '(:relative :up :up "production" "Library"))
259 (truename #p"LIBRARY:"))))
260 (when (probe-file production)
261 (set-relative-logical-pathname-translations "P-LIBRARY" :absolute-pathname production)))
262
263
264 (unless (let* ((logical #P"LIBRARY:asdf;asdf.lisp")
265 (physical (translate-logical-pathname logical))
266 (back (translate-physical-pathname physical)))
267 ;; test equality for the primary attributes
268 ;; and control for uniqueness
269 (and (equalp (pathname-host back) (pathname-host logical))
270 (equal (pathname-directory back) (pathname-directory logical))
271 (equalp (pathname-name back) (pathname-name logical))
272 (equalp (pathname-type back) (pathname-type logical))
273 (null (translate-physical-pathname
274 (make-pathname :directory (butlast (pathname-directory physical) 2)
275 :defaults physical)))))
276 (warn "translate-physical-pathname ?"))
277 ;(trace translate-physical-pathname)
278 :de.setf.utility
Something went wrong with that request. Please try again.