diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -17,7 +17,7 @@ hooks: - id: codespell name: Check source code spelling - exclude: ^(swh/loader/package/.*[/]+tests/data/.*)$ + exclude: ^(swh/loader/(package/.*[/]+|core)/tests/data/.*)$ args: [-L crate] entry: codespell --ignore-words-list=iff stages: [commit] diff --git a/swh/loader/core/loader.py b/swh/loader/core/loader.py --- a/swh/loader/core/loader.py +++ b/swh/loader/core/loader.py @@ -3,12 +3,14 @@ # License: GNU General Public License version 3, or any later version # See top-level LICENSE file for more information +import base64 import datetime import hashlib import logging import os import time from typing import Any, ContextManager, Dict, Iterable, List, Optional, Union +from urllib.parse import urlparse import sentry_sdk @@ -16,6 +18,7 @@ from swh.core.statsd import Statsd from swh.loader.core.metadata_fetchers import CredentialsType, get_fetchers_for_lister from swh.loader.exception import NotFound +from swh.loader.package.utils import get_url_body from swh.model.model import ( BaseContent, Content, @@ -29,8 +32,11 @@ Sha1Git, SkippedContent, Snapshot, + SnapshotBranch, + TargetType, ) from swh.storage import get_storage +from swh.storage.algos.snapshot import snapshot_get_latest from swh.storage.interface import StorageInterface from swh.storage.utils import now @@ -273,7 +279,7 @@ """ return True - def store_data(self): + def store_data(self) -> None: """Store fetched data in the database. Should call the :func:`maybe_load_xyz` methods, which handle the @@ -640,3 +646,107 @@ self.storage.snapshot_add([snapshot]) self.flush() self.loaded_snapshot_id = snapshot.id + + +class ContentLoader(BaseLoader): + """Basic loader for edge case content ingestion.""" + + visit_type = "content" + + def __init__(self, *args, **kwargs): + self.fallback_urls: List[str] = kwargs.pop("fallback_urls", []) + integrity: Optional[str] = kwargs.pop("integrity", None) + if not integrity: + raise ValueError("Mandatory field 'integrity' missing.") + self.integrity: str = integrity + super().__init__(*args, **kwargs) + self.content: Optional[Content] = None + self.snapshot: Optional[Snapshot] = None + self.last_snapshot: Optional[Snapshot] = None + + def prepare(self) -> None: + self.last_snapshot = snapshot_get_latest(self.storage, self.origin.url) + + def fetch_data(self) -> bool: + """Retrieve the content file as a Content Object""" + urls = set([self.origin.url]) | set(self.fallback_urls) + data: Optional[bytes] = None + for url in urls: + url_ = urlparse(url) + self.log.debug( + "prepare; origin_url=%s fallback=%s scheme=%s path=%s", + self.origin.url, + url, + url_.scheme, + url_.path, + ) + try: + data = get_url_body(url) + self.content = Content.from_data(data) + + # Ensure content received matched the integrity field received + hash_algo, hash_value_b64 = self.integrity.split("-") + actual_hash = getattr(self.content, hash_algo.lower()) + expected_hash_value = base64.decodebytes(hash_value_b64.encode()) + + # If that matches, we have found our content to ingest + if actual_hash == expected_hash_value: + break + # otherwise continue + except NotFound: + continue + + if not self.content: + raise NotFound( + f"Unknown origin {self.origin.url} and no fallback urls gave result." + ) + + return False + + def process_data(self) -> bool: + """Build the snapshot out of the Content retrieved.""" + + filename = os.path.basename(self.origin.url) + assert self.content is not None + self.snapshot = Snapshot( + branches={ + b"alias": SnapshotBranch( + target=b"HEAD", + target_type=TargetType.ALIAS, + ), + filename.encode("utf-8"): SnapshotBranch( + target=self.content.sha1_git, # FIXME: which hash? + target_type=TargetType.CONTENT, + ), + } + ) + + return False + + def store_data(self) -> None: + """Store newly retrieved Content and Snapshot.""" + assert self.content is not None + self.storage.content_add([self.content]) + assert self.snapshot is not None + self.storage.snapshot_add([self.snapshot]) + self.loaded_snapshot_id = self.snapshot.id + + def visit_status(self): + return "full" if self.content and self.snapshot is not None else "partial" + + def load_status(self) -> Dict[str, Any]: + if self.snapshot is None: + load_status = "failed" + elif self.last_snapshot == self.snapshot: + load_status = "uneventful" + else: + load_status = "eventful" + return { + "status": load_status, + } + + def cleanup(self) -> None: + self.log.debug("cleanup") + + def save_data(self) -> None: + pass diff --git a/swh/loader/core/tests/data/https_common-lisp.net/project_asdf_archives_asdf-3.3.5.lisp b/swh/loader/core/tests/data/https_common-lisp.net/project_asdf_archives_asdf-3.3.5.lisp new file mode 100644 --- /dev/null +++ b/swh/loader/core/tests/data/https_common-lisp.net/project_asdf_archives_asdf-3.3.5.lisp @@ -0,0 +1,13873 @@ +;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; Package: CL-USER ; buffer-read-only: t; -*- +;;; This is ASDF 3.3.5: Another System Definition Facility. +;;; +;;; Feedback, bug reports, and patches are all welcome: +;;; please mail to . +;;; Note first that the canonical source for ASDF is presently +;;; . +;;; +;;; If you obtained this copy from anywhere else, and you experience +;;; trouble using it, or find bugs, you may want to check at the +;;; location above for a more recent version (and for documentation +;;; and test files, if your copy came without them) before reporting +;;; bugs. There are usually two "supported" revisions - the git master +;;; branch is the latest development version, whereas the git release +;;; branch may be slightly older but is considered `stable' + +;;; -- LICENSE START +;;; (This is the MIT / X Consortium license as taken from +;;; http://www.opensource.org/licenses/mit-license.html on or about +;;; Monday; July 13, 2009) +;;; +;;; Copyright (c) 2001-2019 Daniel Barlow and contributors +;;; +;;; Permission is hereby granted, free of charge, to any person obtaining +;;; a copy of this software and associated documentation files (the +;;; "Software"), to deal in the Software without restriction, including +;;; without limitation the rights to use, copy, modify, merge, publish, +;;; distribute, sublicense, and/or sell copies of the Software, and to +;;; permit persons to whom the Software is furnished to do so, subject to +;;; the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;;; +;;; -- LICENSE END + +;;; The problem with writing a defsystem replacement is bootstrapping: +;;; we can't use defsystem to compile it. Hence, all in one file. + +#+genera +(eval-when (:compile-toplevel :load-toplevel :execute) + (multiple-value-bind (system-major system-minor) + (sct:get-system-version) + (multiple-value-bind (is-major is-minor) + (sct:get-system-version "Intel-Support") + (unless (or (> system-major 452) + (and is-major + (or (> is-major 3) + (and (= is-major 3) (> is-minor 86))))) + (error "ASDF requires either System 453 or later or Intel Support 3.87 or later"))))) +;;;; --------------------------------------------------------------------------- +;;;; Handle ASDF package upgrade, including implementation-dependent magic. +;; +;; See https://bugs.launchpad.net/asdf/+bug/485687 +;; + +;; CAUTION: The definition of the UIOP/PACKAGE package MUST NOT CHANGE, +;; NOT NOW, NOT EVER, NOT UNDER ANY CIRCUMSTANCE. NEVER. +;; ... and the same goes for UIOP/PACKAGE-LOCAL-NICKNAMES. +;; +;; The entire point of UIOP/PACKAGE is to address the fact that the CL standard +;; *leaves it unspecified what happens when a package is redefined incompatibly*. +;; For instance, SBCL 1.4.2 will signal a full WARNING when this happens, +;; throwing a wrench in upgrading code with ASDF itself, while continuing to +;; export old symbols it now shouldn't as it also exports new ones, +;; causing problems with code that relies on the new/current exports. +;; CLISP and CCL also exports both sets of symbols, though without any WARNING. +;; ABCL 1.6.1 will plainly ignore the new definition. +;; Other implementations may do whatever they want and change their behavior at any time. +;; ***Using DEFPACKAGE twice with different definitions is nasal-demon territory.*** +;; +;; Thus we define UIOP/PACKAGE:DEFINE-PACKAGE with which packages can be defined +;; in an upgrade-friendly way: the new definition is authoritative, and +;; the package will define and export exactly those symbols in the new definition, +;; no more and no fewer, whereas it is well-defined what happens to previous symbols. +;; However, for obvious bootstrap reasons, we cannot use DEFINE-PACKAGE +;; to define UIOP/PACKAGE itself, only DEFPACKAGE. +;; Therefore, unlike the other packages in ASDF, UIOP/PACKAGE is immutable, +;; now and forever. It is frozen for the aeons to come, like the CL package itself, +;; to the same exact state it was defined at its inception, in ASDF 2.27 in 2013. +;; The same goes for UIOP/PACKAGE-LOCAL-NICKNAMES, that we use internally. +;; +;; If you ever must define new symbols in this file, you can and must +;; export them from a different package, possibly defined in the same file, +;; say a package UIOP/PACKAGE* defined at the end of this file with DEFINE-PACKAGE, +;; that might use :import-from to import the symbols from UIOP/PACKAGE, +;; if you must somehow define them in UIOP/PACKAGE. + +(defpackage :uiop/package ;;; THOU SHALT NOT modify this definition, EVER. See explanations above. + (:use :common-lisp) + (:export + #:find-package* #:find-symbol* #:symbol-call + #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern* + #:symbol-shadowing-p #:home-package-p + #:symbol-package-name #:standard-common-lisp-symbol-p + #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol + #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol + #:ensure-package-unused #:delete-package* + #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away + #:package-definition-form #:parse-define-package-form + #:ensure-package #:define-package + )) + +(in-package :uiop/package) + +;;; package local nicknames feature. +;;; This can't be deferred until common-lisp.lisp, where most such features are set. +;;; ABCL and CCL already define this feature appropriately. +;;; Seems to be unconditionally present for SBCL, ACL, and CLASP +;;; Don't know about ECL, or others +(eval-when (:load-toplevel :compile-toplevel :execute) + ;; ABCL pushes :package-local-nicknames without UIOP interfering, + ;; and Lispworks will do so + #+(or sbcl clasp) + (pushnew :package-local-nicknames *features*) + #+allegro + (let ((fname (find-symbol (symbol-name '#:add-package-local-nickname) '#:excl))) + (when (and fname (fboundp fname)) + (pushnew :package-local-nicknames *features*)))) + +;;; THOU SHALT NOT modify this definition, EVER, *EXCEPT* to add a new implementation. +;; If you somehow need to modify the API in any way, +;; you will need to create another, differently named, and just as immutable package. +#+package-local-nicknames +(defpackage :uiop/package-local-nicknames + (:use :cl) + (:import-from + #+allegro #:excl + #+sbcl #:sb-ext + #+(or clasp abcl ecl) #:ext + #+ccl #:ccl + #+lispworks #:hcl + #-(or allegro sbcl clasp abcl ccl lispworks ecl) + (error "Don't know from which package this lisp supplies the local-package-nicknames API.") + #:remove-package-local-nickname #:package-local-nicknames #:add-package-local-nickname) + (:export + #:add-package-local-nickname #:remove-package-local-nickname #:package-local-nicknames)) + +;;;; General purpose package utilities + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun find-package* (package-designator &optional (error t)) + (let ((package (find-package package-designator))) + (cond + (package package) + (error (error "No package named ~S" (string package-designator))) + (t nil)))) + (defun find-symbol* (name package-designator &optional (error t)) + "Find a symbol in a package of given string'ified NAME; +unlike CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax +by letting you supply a symbol or keyword for the name; +also works well when the package is not present. +If optional ERROR argument is NIL, return NIL instead of an error +when the symbol is not found." + (block nil + (let ((package (find-package* package-designator error))) + (when package ;; package error handled by find-package* already + (multiple-value-bind (symbol status) (find-symbol (string name) package) + (cond + (status (return (values symbol status))) + (error (error "There is no symbol ~S in package ~S" name (package-name package)))))) + (values nil nil)))) + (defun symbol-call (package name &rest args) + "Call a function associated with symbol of given name in given package, +with given ARGS. Useful when the call is read before the package is loaded, +or when loading the package is optional." + (apply (find-symbol* name package) args)) + (defun intern* (name package-designator &optional (error t)) + (intern (string name) (find-package* package-designator error))) + (defun export* (name package-designator) + (let* ((package (find-package* package-designator)) + (symbol (intern* name package))) + (export (or symbol (list symbol)) package))) + (defun import* (symbol package-designator) + (import (or symbol (list symbol)) (find-package* package-designator))) + (defun shadowing-import* (symbol package-designator) + (shadowing-import (or symbol (list symbol)) (find-package* package-designator))) + (defun shadow* (name package-designator) + (shadow (list (string name)) (find-package* package-designator))) + (defun make-symbol* (name) + (etypecase name + (string (make-symbol name)) + (symbol (copy-symbol name)))) + (defun unintern* (name package-designator &optional (error t)) + (block nil + (let ((package (find-package* package-designator error))) + (when package + (multiple-value-bind (symbol status) (find-symbol* name package error) + (cond + (status (unintern symbol package) + (return (values symbol status))) + (error (error "symbol ~A not present in package ~A" + (string symbol) (package-name package)))))) + (values nil nil)))) + (defun symbol-shadowing-p (symbol package) + (and (member symbol (package-shadowing-symbols package)) t)) + (defun home-package-p (symbol package) + (and package (let ((sp (symbol-package symbol))) + (and sp (let ((pp (find-package* package))) + (and pp (eq sp pp)))))))) + + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun symbol-package-name (symbol) + (let ((package (symbol-package symbol))) + (and package (package-name package)))) + (defun standard-common-lisp-symbol-p (symbol) + (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil) + (and (eq sym symbol) (eq status :external)))) + (defun reify-package (package &optional package-context) + (if (eq package package-context) t + (etypecase package + (null nil) + ((eql (find-package :cl)) :cl) + (package (package-name package))))) + (defun unreify-package (package &optional package-context) + (etypecase package + (null nil) + ((eql t) package-context) + ((or symbol string) (find-package package)))) + (defun reify-symbol (symbol &optional package-context) + (etypecase symbol + ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol) + (symbol (vector (symbol-name symbol) + (reify-package (symbol-package symbol) package-context))))) + (defun unreify-symbol (symbol &optional package-context) + (etypecase symbol + (symbol symbol) + ((simple-vector 2) + (let* ((symbol-name (svref symbol 0)) + (package-foo (svref symbol 1)) + (package (unreify-package package-foo package-context))) + (if package (intern* symbol-name package) + (make-symbol* symbol-name))))))) + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defvar *all-package-happiness* '()) + (defvar *all-package-fishiness* (list t)) + (defun record-fishy (info) + ;;(format t "~&FISHY: ~S~%" info) + (push info *all-package-fishiness*)) + (defmacro when-package-fishiness (&body body) + `(when *all-package-fishiness* ,@body)) + (defmacro note-package-fishiness (&rest info) + `(when-package-fishiness (record-fishy (list ,@info))))) + +(eval-when (:load-toplevel :compile-toplevel :execute) + #+(or clisp clozure) + (defun get-setf-function-symbol (symbol) + #+clisp (let ((sym (get symbol 'system::setf-function))) + (if sym (values sym :setf-function) + (let ((sym (get symbol 'system::setf-expander))) + (if sym (values sym :setf-expander) + (values nil nil))))) + #+clozure (gethash symbol ccl::%setf-function-names%)) + #+(or clisp clozure) + (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind) + #+clisp (assert (member kind '(:setf-function :setf-expander))) + #+clozure (assert (eq kind t)) + #+clisp + (cond + ((null new-setf-symbol) + (remprop symbol 'system::setf-function) + (remprop symbol 'system::setf-expander)) + ((eq kind :setf-function) + (setf (get symbol 'system::setf-function) new-setf-symbol)) + ((eq kind :setf-expander) + (setf (get symbol 'system::setf-expander) new-setf-symbol)) + (t (error "invalid kind of setf-function ~S for ~S to be set to ~S" + kind symbol new-setf-symbol))) + #+clozure + (progn + (gethash symbol ccl::%setf-function-names%) new-setf-symbol + (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol)) + #+(or clisp clozure) + (defun create-setf-function-symbol (symbol) + #+clisp (system::setf-symbol symbol) + #+clozure (ccl::construct-setf-function-name symbol)) + (defun set-dummy-symbol (symbol reason other-symbol) + (setf (get symbol 'dummy-symbol) (cons reason other-symbol))) + (defun make-dummy-symbol (symbol) + (let ((dummy (copy-symbol symbol))) + (set-dummy-symbol dummy 'replacing symbol) + (set-dummy-symbol symbol 'replaced-by dummy) + dummy)) + (defun dummy-symbol (symbol) + (get symbol 'dummy-symbol)) + (defun get-dummy-symbol (symbol) + (let ((existing (dummy-symbol symbol))) + (if existing (values (cdr existing) (car existing)) + (make-dummy-symbol symbol)))) + (defun nuke-symbol-in-package (symbol package-designator) + (let ((package (find-package* package-designator)) + (name (symbol-name symbol))) + (multiple-value-bind (sym stat) (find-symbol name package) + (when (and (member stat '(:internal :external)) (eq symbol sym)) + (if (symbol-shadowing-p symbol package) + (shadowing-import* (get-dummy-symbol symbol) package) + (unintern* symbol package)))))) + (defun nuke-symbol (symbol &optional (packages (list-all-packages))) + #+(or clisp clozure) + (multiple-value-bind (setf-symbol kind) + (get-setf-function-symbol symbol) + (when kind (nuke-symbol setf-symbol))) + (loop :for p :in packages :do (nuke-symbol-in-package symbol p))) + (defun rehome-symbol (symbol package-designator) + "Changes the home package of a symbol, also leaving it present in its old home if any" + (let* ((name (symbol-name symbol)) + (package (find-package* package-designator)) + (old-package (symbol-package symbol)) + (old-status (and old-package (nth-value 1 (find-symbol name old-package)))) + (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name)))) + (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package) + (unless (eq package old-package) + (let ((overwritten-symbol-shadowing-p + (and overwritten-symbol-status + (symbol-shadowing-p overwritten-symbol package)))) + (note-package-fishiness + :rehome-symbol name + (when old-package (package-name old-package)) old-status (and shadowing t) + (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p) + (when old-package + (if shadowing + (shadowing-import* shadowing old-package)) + (unintern* symbol old-package)) + (cond + (overwritten-symbol-shadowing-p + (shadowing-import* symbol package)) + (t + (when overwritten-symbol-status + (unintern* overwritten-symbol package)) + (import* symbol package))) + (if shadowing + (shadowing-import* symbol old-package) + (import* symbol old-package)) + #+(or clisp clozure) + (multiple-value-bind (setf-symbol kind) + (get-setf-function-symbol symbol) + (when kind + (let* ((setf-function (fdefinition setf-symbol)) + (new-setf-symbol (create-setf-function-symbol symbol))) + (note-package-fishiness + :setf-function + name (package-name package) + (symbol-name setf-symbol) (symbol-package-name setf-symbol) + (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol)) + (when (symbol-package setf-symbol) + (unintern* setf-symbol (symbol-package setf-symbol))) + (setf (fdefinition new-setf-symbol) setf-function) + (set-setf-function-symbol new-setf-symbol symbol kind)))) + #+(or clisp clozure) + (multiple-value-bind (overwritten-setf foundp) + (get-setf-function-symbol overwritten-symbol) + (when foundp + (unintern overwritten-setf))) + (when (eq old-status :external) + (export* symbol old-package)) + (when (eq overwritten-symbol-status :external) + (export* symbol package)))) + (values overwritten-symbol overwritten-symbol-status)))) + (defun ensure-package-unused (package) + (loop :for p :in (package-used-by-list package) :do + (unuse-package package p))) + (defun delete-package* (package &key nuke) + (let ((p (find-package package))) + (when p + (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s)))) + (ensure-package-unused p) + (delete-package package)))) + (defun package-names (package) + (cons (package-name package) (package-nicknames package))) + (defun packages-from-names (names) + (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t)) + (defun fresh-package-name (&key (prefix :%TO-BE-DELETED) + separator + (index (random most-positive-fixnum))) + (loop :for i :from index + :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i) + :thereis (and (not (find-package n)) n))) + (defun rename-package-away (p &rest keys &key prefix &allow-other-keys) + (let ((new-name + (apply 'fresh-package-name + :prefix (or prefix (format nil "__~A__" (package-name p))) keys))) + (record-fishy (list :rename-away (package-names p) new-name)) + (rename-package p new-name)))) + + +;;; Communicable representation of symbol and package information + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun package-definition-form (package-designator + &key (nicknamesp t) (usep t) + (shadowp t) (shadowing-import-p t) + (exportp t) (importp t) internp (error t)) + (let* ((package (or (find-package* package-designator error) + (return-from package-definition-form nil))) + (name (package-name package)) + (nicknames (package-nicknames package)) + (use (mapcar #'package-name (package-use-list package))) + (shadow ()) + (shadowing-import (make-hash-table :test 'equal)) + (import (make-hash-table :test 'equal)) + (export ()) + (intern ())) + (when package + (loop :for sym :being :the :symbols :in package + :for status = (nth-value 1 (find-symbol* sym package)) :do + (ecase status + ((nil :inherited)) + ((:internal :external) + (let* ((name (symbol-name sym)) + (external (eq status :external)) + (home (symbol-package sym)) + (home-name (package-name home)) + (imported (not (eq home package))) + (shadowing (symbol-shadowing-p sym package))) + (cond + ((and shadowing imported) + (push name (gethash home-name shadowing-import))) + (shadowing + (push name shadow)) + (imported + (push name (gethash home-name import)))) + (cond + (external + (push name export)) + (imported) + (t (push name intern))))))) + (labels ((sort-names (names) + (sort (copy-list names) #'string<)) + (table-keys (table) + (loop :for k :being :the :hash-keys :of table :collect k)) + (when-relevant (key value) + (when value (list (cons key value)))) + (import-options (key table) + (loop :for i :in (sort-names (table-keys table)) + :collect `(,key ,i ,@(sort-names (gethash i table)))))) + `(defpackage ,name + ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames))) + (:use ,@(and usep (sort-names use))) + ,@(when-relevant :shadow (and shadowp (sort-names shadow))) + ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import)) + ,@(import-options :import-from (and importp import)) + ,@(when-relevant :export (and exportp (sort-names export))) + ,@(when-relevant :intern (and internp (sort-names intern))))))))) + + +;;; ensure-package, define-package +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun ensure-shadowing-import (name to-package from-package shadowed imported) + (check-type name string) + (check-type to-package package) + (check-type from-package package) + (check-type shadowed hash-table) + (check-type imported hash-table) + (let ((import-me (find-symbol* name from-package))) + (multiple-value-bind (existing status) (find-symbol name to-package) + (cond + ((gethash name shadowed) + (unless (eq import-me existing) + (error "Conflicting shadowings for ~A" name))) + (t + (setf (gethash name shadowed) t) + (setf (gethash name imported) t) + (unless (or (null status) + (and (member status '(:internal :external)) + (eq existing import-me) + (symbol-shadowing-p existing to-package))) + (note-package-fishiness + :shadowing-import name + (package-name from-package) + (or (home-package-p import-me from-package) (symbol-package-name import-me)) + (package-name to-package) status + (and status (or (home-package-p existing to-package) (symbol-package-name existing))))) + (shadowing-import* import-me to-package)))))) + (defun ensure-imported (import-me into-package &optional from-package) + (check-type import-me symbol) + (check-type into-package package) + (check-type from-package (or null package)) + (let ((name (symbol-name import-me))) + (multiple-value-bind (existing status) (find-symbol name into-package) + (cond + ((not status) + (import* import-me into-package)) + ((eq import-me existing)) + (t + (let ((shadowing-p (symbol-shadowing-p existing into-package))) + (note-package-fishiness + :ensure-imported name + (and from-package (package-name from-package)) + (or (home-package-p import-me from-package) (symbol-package-name import-me)) + (package-name into-package) + status + (and status (or (home-package-p existing into-package) (symbol-package-name existing))) + shadowing-p) + (cond + ((or shadowing-p (eq status :inherited)) + (shadowing-import* import-me into-package)) + (t + (unintern* existing into-package) + (import* import-me into-package)))))))) + (values)) + (defun ensure-import (name to-package from-package shadowed imported) + (check-type name string) + (check-type to-package package) + (check-type from-package package) + (check-type shadowed hash-table) + (check-type imported hash-table) + (multiple-value-bind (import-me import-status) (find-symbol name from-package) + (when (null import-status) + (note-package-fishiness + :import-uninterned name (package-name from-package) (package-name to-package)) + (setf import-me (intern* name from-package))) + (multiple-value-bind (existing status) (find-symbol name to-package) + (cond + ((and imported (gethash name imported)) + (unless (and status (eq import-me existing)) + (error "Can't import ~S from both ~S and ~S" + name (package-name (symbol-package existing)) (package-name from-package)))) + ((gethash name shadowed) + (error "Can't both shadow ~S and import it from ~S" name (package-name from-package))) + (t + (setf (gethash name imported) t)))) + (ensure-imported import-me to-package from-package))) + (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited) + (check-type name string) + (check-type symbol symbol) + (check-type to-package package) + (check-type from-package package) + (check-type mixp (member nil t)) ; no cl:boolean on Genera + (check-type shadowed hash-table) + (check-type imported hash-table) + (check-type inherited hash-table) + (multiple-value-bind (existing status) (find-symbol name to-package) + (let* ((sp (symbol-package symbol)) + (in (gethash name inherited)) + (xp (and status (symbol-package existing)))) + (when (null sp) + (note-package-fishiness + :import-uninterned name + (package-name from-package) (package-name to-package) mixp) + (import* symbol from-package) + (setf sp (package-name from-package))) + (cond + ((gethash name shadowed)) + (in + (unless (equal sp (first in)) + (if mixp + (ensure-shadowing-import name to-package (second in) shadowed imported) + (error "Can't inherit ~S from ~S, it is inherited from ~S" + name (package-name sp) (package-name (first in)))))) + ((gethash name imported) + (unless (eq symbol existing) + (error "Can't inherit ~S from ~S, it is imported from ~S" + name (package-name sp) (package-name xp)))) + (t + (setf (gethash name inherited) (list sp from-package)) + (when (and status (not (eq sp xp))) + (let ((shadowing (symbol-shadowing-p existing to-package))) + (note-package-fishiness + :inherited name + (package-name from-package) + (or (home-package-p symbol from-package) (symbol-package-name symbol)) + (package-name to-package) + (or (home-package-p existing to-package) (symbol-package-name existing))) + (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported) + (unintern* existing to-package))))))))) + (defun ensure-mix (name symbol to-package from-package shadowed imported inherited) + (check-type name string) + (check-type symbol symbol) + (check-type to-package package) + (check-type from-package package) + (check-type shadowed hash-table) + (check-type imported hash-table) + (check-type inherited hash-table) + (unless (gethash name shadowed) + (multiple-value-bind (existing status) (find-symbol name to-package) + (let* ((sp (symbol-package symbol)) + (im (gethash name imported)) + (in (gethash name inherited))) + (cond + ((or (null status) + (and status (eq symbol existing)) + (and in (eq sp (first in)))) + (ensure-inherited name symbol to-package from-package t shadowed imported inherited)) + (in + (remhash name inherited) + (ensure-shadowing-import name to-package (second in) shadowed imported)) + (im + (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]" + name (package-name from-package) + (home-package-p symbol from-package) (symbol-package-name symbol) + (package-name to-package) + (home-package-p existing to-package) (symbol-package-name existing))) + (t + (ensure-inherited name symbol to-package from-package t shadowed imported inherited))))))) + + (defun recycle-symbol (name recycle exported) + ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE + ;; packages, and a hash-table of names (strings) of symbols scheduled to be + ;; EXPORTED from the package being defined. It returns two values, the + ;; symbol found (if any, or else NIL), and a boolean flag indicating whether + ;; a symbol was found. The caller (DEFINE-PACKAGE) will then do the + ;; re-homing of the symbol, etc. + (check-type name string) + (check-type recycle list) + (check-type exported hash-table) + (when (gethash name exported) ;; don't bother recycling private symbols + (let (recycled foundp) + (dolist (r recycle (values recycled foundp)) + (multiple-value-bind (symbol status) (find-symbol name r) + (when (and status (home-package-p symbol r)) + (cond + (foundp + ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that. + (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r))) + (t + (setf recycled symbol foundp r))))))))) + (defun symbol-recycled-p (sym recycle) + (check-type sym symbol) + (check-type recycle list) + (and (member (symbol-package sym) recycle) t)) + (defun ensure-symbol (name package intern recycle shadowed imported inherited exported) + (check-type name string) + (check-type package package) + (check-type intern (member nil t)) ; no cl:boolean on Genera + (check-type shadowed hash-table) + (check-type imported hash-table) + (check-type inherited hash-table) + (unless (or (gethash name shadowed) + (gethash name imported) + (gethash name inherited)) + (multiple-value-bind (existing status) + (find-symbol name package) + (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported) + (cond + ((and status (eq existing recycled) (eq previous package))) + (previous + (rehome-symbol recycled package)) + ((and status (eq package (symbol-package existing)))) + (t + (when status + (note-package-fishiness + :ensure-symbol name + (reify-package (symbol-package existing) package) + status intern) + (unintern existing)) + (when intern + (intern* name package)))))))) + (declaim (ftype (function (t t t &optional t) t) ensure-exported)) + (defun ensure-exported-to-user (name symbol to-package &optional recycle) + (check-type name string) + (check-type symbol symbol) + (check-type to-package package) + (check-type recycle list) + (assert (equal name (symbol-name symbol))) + (multiple-value-bind (existing status) (find-symbol name to-package) + (unless (and status (eq symbol existing)) + (let ((accessible + (or (null status) + (let ((shadowing (symbol-shadowing-p existing to-package)) + (recycled (symbol-recycled-p existing recycle))) + (unless (and shadowing (not recycled)) + (note-package-fishiness + :ensure-export name (symbol-package-name symbol) + (package-name to-package) + (or (home-package-p existing to-package) (symbol-package-name existing)) + status shadowing) + (if (or (eq status :inherited) shadowing) + (shadowing-import* symbol to-package) + (unintern existing to-package)) + t))))) + (when (and accessible (eq status :external)) + (ensure-exported name symbol to-package recycle)))))) + (defun ensure-exported (name symbol from-package &optional recycle) + (dolist (to-package (package-used-by-list from-package)) + (ensure-exported-to-user name symbol to-package recycle)) + (unless (eq from-package (symbol-package symbol)) + (ensure-imported symbol from-package)) + (export* name from-package)) + (defun ensure-export (name from-package &optional recycle) + (multiple-value-bind (symbol status) (find-symbol* name from-package) + (unless (eq status :external) + (ensure-exported name symbol from-package recycle)))) + + #+package-local-nicknames + (defun install-package-local-nicknames (destination-package new-nicknames) + ;; First, remove all package-local nicknames. (We'll reinstall any desired ones later.) + (dolist (pair-to-remove (uiop/package-local-nicknames:package-local-nicknames destination-package)) + (uiop/package-local-nicknames:remove-package-local-nickname + (string (car pair-to-remove)) destination-package)) + ;; Then, install all desired nicknames. + (loop :for (nickname package) :in new-nicknames + :do (uiop/package-local-nicknames:add-package-local-nickname + (string nickname) + (find-package package) + destination-package))) + + (defun ensure-package (name &key + nicknames documentation use + shadow shadowing-import-from + import-from export intern + recycle mix reexport + unintern local-nicknames) + #+genera (declare (ignore documentation)) + (let* ((package-name (string name)) + (nicknames (mapcar #'string nicknames)) + (names (cons package-name nicknames)) + (previous (packages-from-names names)) + (discarded (cdr previous)) + (to-delete ()) + (package (or (first previous) (make-package package-name :nicknames nicknames))) + (recycle (packages-from-names recycle)) + (use (mapcar 'find-package* use)) + (mix (mapcar 'find-package* mix)) + (reexport (mapcar 'find-package* reexport)) + (shadow (mapcar 'string shadow)) + (export (mapcar 'string export)) + (intern (mapcar 'string intern)) + (unintern (mapcar 'string unintern)) + (local-nicknames (mapcar #'(lambda (pair) (mapcar 'string pair)) local-nicknames)) + (shadowed (make-hash-table :test 'equal)) ; string to bool + (imported (make-hash-table :test 'equal)) ; string to bool + (exported (make-hash-table :test 'equal)) ; string to bool + ;; string to list home package and use package: + (inherited (make-hash-table :test 'equal))) + #-package-local-nicknames + (declare (ignore local-nicknames)) ; if not supported + (when-package-fishiness (record-fishy package-name)) + ;; if supported, put package documentation + #-genera + (when documentation (setf (documentation package t) documentation)) + ;; remove unwanted packages from use list + (loop :for p :in (set-difference (package-use-list package) (append mix use)) + :do (note-package-fishiness :over-use name (package-names p)) + (unuse-package p package)) + ;; mark unwanted packages for deletion + (loop :for p :in discarded + :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) + (package-names p)) + :do (note-package-fishiness :nickname name (package-names p)) + (cond (n (rename-package p (first n) (rest n))) + (t (rename-package-away p) + (push p to-delete)))) + ;; give package its desired name + (rename-package package package-name nicknames) + ;; Handle local nicknames + #+package-local-nicknames + (install-package-local-nicknames package local-nicknames) + (dolist (name unintern) + (multiple-value-bind (existing status) (find-symbol name package) + (when status + (unless (eq status :inherited) + (note-package-fishiness + :unintern (package-name package) name (symbol-package-name existing) status) + (unintern* name package nil))))) + ;; handle exports + (dolist (name export) + (setf (gethash name exported) t)) + ;; handle reexportss + (dolist (p reexport) + (do-external-symbols (sym p) + (setf (gethash (string sym) exported) t))) + ;; unexport symbols not listed in (re)export + (do-external-symbols (sym package) + (let ((name (symbol-name sym))) + (unless (gethash name exported) + (note-package-fishiness + :over-export (package-name package) name + (or (home-package-p sym package) (symbol-package-name sym))) + (unexport sym package)))) + ;; handle explicitly listed shadowed ssymbols + (dolist (name shadow) + (setf (gethash name shadowed) t) + (multiple-value-bind (existing status) (find-symbol name package) + (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported) + (let ((shadowing (and status (symbol-shadowing-p existing package)))) + (cond + ((eq previous package)) + (previous + (rehome-symbol recycled package)) + ((or (member status '(nil :inherited)) + (home-package-p existing package))) + (t + (let ((dummy (make-symbol name))) + (note-package-fishiness + :shadow-imported (package-name package) name + (symbol-package-name existing) status shadowing) + (shadowing-import* dummy package) + (import* dummy package))))))) + (shadow* name package)) + ;; handle shadowing imports + (loop :for (p . syms) :in shadowing-import-from + :for pp = (find-package* p) :do + (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported))) + ;; handle mixed packages + (loop :for p :in mix + :for pp = (find-package* p) :do + (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited))) + ;; handle import-from packages + (loop :for (p . syms) :in import-from + :for pp = (find-package p) :do + (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported))) + ;; handle use-list and mix + (dolist (p (append use mix)) + (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited)) + (use-package p package)) + (loop :for name :being :the :hash-keys :of exported :do + (ensure-symbol name package t recycle shadowed imported inherited exported) + (ensure-export name package recycle)) + ;; intern dessired symbols + (dolist (name intern) + (ensure-symbol name package t recycle shadowed imported inherited exported)) + (do-symbols (sym package) + (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported)) + ;; delete now-deceased packages + (map () 'delete-package* to-delete) + package))) + + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun parse-define-package-form (package clauses) + (loop + :with use-p = nil :with recycle-p = nil + :with documentation = nil + :for (kw . args) :in clauses + :when (eq kw :nicknames) :append args :into nicknames :else + :when (eq kw :documentation) + :do (cond + (documentation (error "define-package: can't define documentation twice")) + ((or (atom args) (cdr args)) (error "define-package: bad documentation")) + (t (setf documentation (car args)))) :else + :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else + :when (eq kw :shadow) :append args :into shadow :else + :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else + :when (eq kw :import-from) :collect args :into import-from :else + :when (eq kw :export) :append args :into export :else + :when (eq kw :intern) :append args :into intern :else + :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else + :when (eq kw :mix) :append args :into mix :else + :when (eq kw :reexport) :append args :into reexport :else + :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport + :and :do (setf use-p t) :else + :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport + :and :do (setf use-p t) :else + :when (eq kw :unintern) :append args :into unintern :else + :when (eq kw :local-nicknames) + :if (symbol-call '#:uiop '#:featurep :package-local-nicknames) + :append args :into local-nicknames + :else + :do (error ":LOCAL-NICKAMES option is not supported on this lisp implementation.") + :end + :else + :do (error "unrecognized define-package keyword ~S" kw) + :finally (return `(',package + :nicknames ',nicknames :documentation ',documentation + :use ',(if use-p use '(:common-lisp)) + :shadow ',shadow :shadowing-import-from ',shadowing-import-from + :import-from ',import-from :export ',export :intern ',intern + :recycle ',(if recycle-p recycle (cons package nicknames)) + :mix ',mix :reexport ',reexport :unintern ',unintern + :local-nicknames ',local-nicknames))))) + +(defmacro define-package (package &rest clauses) + "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form +\(KEYWORD . ARGS\). +DEFINE-PACKAGE supports the following keywords: +USE, SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN, NICKNAMES, +DOCUMENTATION -- as per CL:DEFPACKAGE. +RECYCLE -- Recycle the package's exported symbols from the specified packages, +in order. For every symbol scheduled to be exported by the DEFINE-PACKAGE, +either through an :EXPORT option or a :REEXPORT option, if the symbol exists in +one of the :RECYCLE packages, the first such symbol is re-homed to the package +being defined. +For the sake of idempotence, it is important that the package being defined +should appear in first position if it already exists, and even if it doesn't, +ahead of any package that is not going to be deleted afterwards and never +created again. In short, except for special cases, always make it the first +package on the list if the list is not empty. +MIX -- Takes a list of package designators. MIX behaves like +\(:USE PKG1 PKG2 ... PKGn\) but additionally uses :SHADOWING-IMPORT-FROM to +resolve conflicts in favor of the first found symbol. It may still yield +an error if there is a conflict with an explicitly :IMPORT-FROM symbol. +REEXPORT -- Takes a list of package designators. For each package, p, in the list, +export symbols with the same name as those exported from p. Note that in the case +of shadowing, etc. the symbols with the same name may not be the same symbols. +UNINTERN -- Remove symbols here from PACKAGE. +LOCAL-NICKNAMES -- If the host implementation supports package local nicknames +\(check for the :PACKAGE-LOCAL-NICKNAMES feature\), then this should be a list of +nickname and package name pairs. Using this option will cause an error if the +host CL implementation does not support it. +USE-REEXPORT, MIX-REEXPORT -- Use or mix the specified packages as per the USE or +MIX directives, and reexport their contents as per the REEXPORT directive." + (let ((ensure-form + `(prog1 + (funcall 'ensure-package ,@(parse-define-package-form package clauses)) + #+sbcl (setf (sb-impl::package-source-location (find-package ',package)) + (sb-c:source-location))))) + `(progn + #+(or clasp ecl gcl mkcl) (defpackage ,package (:use)) + (eval-when (:compile-toplevel :load-toplevel :execute) + ,ensure-form)))) + +;; This package, unlike UIOP/PACKAGE, is allowed to evolve and acquire new symbols or drop old ones. +(define-package :uiop/package* + (:use-reexport :uiop/package + #+package-local-nicknames :uiop/package-local-nicknames)) +;;;; ------------------------------------------------------------------------- +;;;; Handle compatibility with multiple implementations. +;;; This file is for papering over the deficiencies and peculiarities +;;; of various Common Lisp implementations. +;;; For implementation-specific access to the system, see os.lisp instead. +;;; A few functions are defined here, but actually exported from utility; +;;; from this package only common-lisp symbols are exported. + +(uiop/package:define-package :uiop/common-lisp + (:nicknames :uiop/cl) + (:use :uiop/package) + (:use-reexport #-genera :common-lisp #+genera :future-common-lisp) + #+allegro (:intern #:*acl-warn-save*) + #+cormanlisp (:shadow #:user-homedir-pathname) + #+cormanlisp + (:export + #:logical-pathname #:translate-logical-pathname + #:make-broadcast-stream #:file-namestring) + #+genera (:shadowing-import-from :scl #:boolean) + #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence) + #+(or mcl cmucl) (:shadow #:user-homedir-pathname)) +(in-package :uiop/common-lisp) + +#-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl) +(error "ASDF is not supported on your implementation. Please help us port it.") + +;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults. + + +;;;; Early meta-level tweaks + +#+(or allegro clasp clisp clozure cmucl ecl lispworks mezzano mkcl sbcl) +(eval-when (:load-toplevel :compile-toplevel :execute) + (when (and #+allegro (member :ics *features*) + #+(or clasp clisp cmucl ecl lispworks mkcl) (member :unicode *features*) + #+clozure (member :openmcl-unicode-strings *features*) + #+sbcl (member :sb-unicode *features*)) + ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode + ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. + (pushnew :asdf-unicode *features*))) + +#+allegro +(eval-when (:load-toplevel :compile-toplevel :execute) + ;; We need to disable autoloading BEFORE any mention of package ASDF. + ;; In particular, there must NOT be a mention of package ASDF in the defpackage of this file + ;; or any previous file. + (setf excl::*autoload-package-name-alist* + (remove "asdf" excl::*autoload-package-name-alist* + :test 'equalp :key 'car)) + (defparameter *acl-warn-save* + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + excl:*warn-on-nested-reader-conditionals*)) + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + (setf excl:*warn-on-nested-reader-conditionals* nil)) + (setf *print-readably* nil)) + +#+clasp +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf *load-verbose* nil) + (defun use-ecl-byte-compiler-p () nil)) + +#+clozure (in-package :ccl) +#+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117 +(eval-when (:load-toplevel :compile-toplevel :execute) + (unless (fboundp 'external-process-wait) + (in-development-mode + (defun external-process-wait (proc) + (when (and (external-process-pid proc) (eq (external-process-%status proc) :running)) + (with-interrupts-enabled + (wait-on-semaphore (external-process-completed proc)))) + (values (external-process-%exit-code proc) + (external-process-%status proc)))))) +#+clozure (in-package :uiop/common-lisp) ;; back in this package. + +#+cmucl +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf ext:*gc-verbose* nil) + (defun user-homedir-pathname () + (first (ext:search-list (cl:user-homedir-pathname))))) + +#+cormanlisp +(eval-when (:load-toplevel :compile-toplevel :execute) + (deftype logical-pathname () nil) + (defun make-broadcast-stream () *error-output*) + (defun translate-logical-pathname (x) x) + (defun user-homedir-pathname (&optional host) + (declare (ignore host)) + (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname)))) + (defun file-namestring (p) + (setf p (pathname p)) + (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) + +#+ecl +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf *load-verbose* nil) + (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) + (unless (use-ecl-byte-compiler-p) (require :cmp))) + +#+gcl +(eval-when (:load-toplevel :compile-toplevel :execute) + (unless (member :ansi-cl *features*) + (error "ASDF only supports GCL in ANSI mode. Aborting.~%")) + (setf compiler::*compiler-default-type* (pathname "") + compiler::*lsp-ext* "") + #.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later. + (cond + #+gcl + ((or (< system::*gcl-major-version* 2) + (and (= system::*gcl-major-version* 2) + (< system::*gcl-minor-version* 7))) + '(error "GCL 2.7 or later required to use ASDF"))))) + (eval code) + code)) + +#+genera +(eval-when (:load-toplevel :compile-toplevel :execute) + (unless (fboundp 'lambda) + (defmacro lambda (&whole form &rest bvl-decls-and-body) + (declare (ignore bvl-decls-and-body)(zwei::indentation 1 1)) + `#',(cons 'lisp::lambda (cdr form)))) + (unless (fboundp 'ensure-directories-exist) + (defun ensure-directories-exist (path) + (fs:create-directories-recursively (pathname path)))) + (unless (fboundp 'read-sequence) + (defun read-sequence (sequence stream &key (start 0) end) + (scl:send stream :string-in nil sequence start end))) + (unless (fboundp 'write-sequence) + (defun write-sequence (sequence stream &key (start 0) end) + (scl:send stream :string-out sequence start end) + sequence))) + +#+lispworks +(eval-when (:load-toplevel :compile-toplevel :execute) + ;; lispworks 3 and earlier cannot be checked for so we always assume + ;; at least version 4 + (unless (member :lispworks4 *features*) + (pushnew :lispworks5+ *features*) + (unless (member :lispworks5 *features*) + (pushnew :lispworks6+ *features*) + (unless (member :lispworks6 *features*) + (pushnew :lispworks7+ *features*))))) + + +#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick + (read-from-string + "(eval-when (:load-toplevel :compile-toplevel :execute) + (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string) + (ccl:define-entry-point (_system \"system\") ((name :string)) :int) + ;; Note: ASDF may expect user-homedir-pathname to provide + ;; the pathname of the current user's home directory, whereas + ;; MCL by default provides the directory from which MCL was started. + ;; See http://code.google.com/p/mcl/wiki/Portability + (defun user-homedir-pathname () + (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType)) + (defun probe-posix (posix-namestring) + \"If a file exists for the posix namestring, return the pathname\" + (ccl::with-cstrs ((cpath posix-namestring)) + (ccl::rlet ((is-dir :boolean) + (fsref :fsref)) + (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir)) + (ccl::%path-from-fsref fsref is-dir))))))")) + +#+mkcl +(eval-when (:load-toplevel :compile-toplevel :execute) + (require :cmp) + (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics + + +;;;; compatfmt: avoid fancy format directives when unsupported +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun frob-substrings (string substrings &optional frob) + "for each substring in SUBSTRINGS, find occurrences of it within STRING +that don't use parts of matched occurrences of previous strings, and +FROB them, that is to say, remove them if FROB is NIL, +replace by FROB if FROB is a STRING, or if FROB is a FUNCTION, +call FROB with the match and a function that emits a string in the output. +Return a string made of the parts not omitted or emitted by FROB." + (declare (optimize (speed 0) (safety #-gcl 3 #+gcl 0) (debug 3))) + (let ((length (length string)) (stream nil)) + (labels ((emit-string (x &optional (start 0) (end (length x))) + (when (< start end) + (unless stream (setf stream (make-string-output-stream))) + (write-string x stream :start start :end end))) + (emit-substring (start end) + (when (and (zerop start) (= end length)) + (return-from frob-substrings string)) + (emit-string string start end)) + (recurse (substrings start end) + (cond + ((>= start end)) + ((null substrings) (emit-substring start end)) + (t (let* ((sub-spec (first substrings)) + (sub (if (consp sub-spec) (car sub-spec) sub-spec)) + (fun (if (consp sub-spec) (cdr sub-spec) frob)) + (found (search sub string :start2 start :end2 end)) + (more (rest substrings))) + (cond + (found + (recurse more start found) + (etypecase fun + (null) + (string (emit-string fun)) + (function (funcall fun sub #'emit-string))) + (recurse substrings (+ found (length sub)) end)) + (t + (recurse more start end)))))))) + (recurse substrings 0 length)) + (if stream (get-output-stream-string stream) ""))) + + (defmacro compatfmt (format) + #+(or gcl genera) + (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>"))) + #-(or gcl genera) format)) +;;;; ------------------------------------------------------------------------- +;;;; General Purpose Utilities for ASDF + +(uiop/package:define-package :uiop/utility + (:use :uiop/common-lisp :uiop/package) + ;; import and reexport a few things defined in :uiop/common-lisp + (:import-from :uiop/common-lisp #:compatfmt #:frob-substrings + #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix) + (:export #:compatfmt #:frob-substrings #:compatfmt + #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix) + (:export + ;; magic helper to define debugging functions: + #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility* + #:with-upgradability ;; (un)defining functions in an upgrade-friendly way + #:nest #:if-let ;; basic flow control + #:parse-body ;; macro definition helper + #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists + #:remove-plist-keys #:remove-plist-key ;; plists + #:emptyp ;; sequences + #:+non-base-chars-exist-p+ ;; characters + #:+max-character-type-index+ #:character-type-index #:+character-types+ + #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings + #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+ + #:string-prefix-p #:string-enclosed-p #:string-suffix-p + #:standard-case-symbol-name #:find-standard-case-symbol ;; symbols + #:coerce-class ;; CLOS + #:timestamp< #:timestamps< #:timestamp*< #:timestamp<= ;; timestamps + #:earlier-timestamp #:timestamps-earliest #:earliest-timestamp + #:later-timestamp #:timestamps-latest #:latest-timestamp #:latest-timestamp-f + #:list-to-hash-set #:ensure-gethash ;; hash-table + #:ensure-function #:access-at #:access-at-count ;; functions + #:call-function #:call-functions #:register-hook-function + #:lexicographic< #:lexicographic<= ;; version + #:simple-style-warning #:style-warn ;; simple style warnings + #:match-condition-p #:match-any-condition-p ;; conditions + #:call-with-muffled-conditions #:with-muffled-conditions + #:not-implemented-error #:parameter-error + #:symbol-test-to-feature-expression + #:boolean-to-feature-expression)) +(in-package :uiop/utility) + +;;;; Defining functions in a way compatible with hot-upgrade: +;; - The WTIH-UPGRADABILITY infrastructure below ensures that functions are declared NOTINLINE, +;; so that new definitions are always seen by all callers, even those up the stack. +;; - WITH-UPGRADABILITY also uses EVAL-WHEN so that definitions used by ASDF are in a limbo state +;; (especially for gf's) in between the COMPILE-OP and LOAD-OP operations on the defining file. +;; - THOU SHALT NOT redefine a function with a backward-incompatible semantics without renaming it, +;; at least if that function is used by ASDF while performing the plan to load ASDF. +;; - THOU SHALT change the name of a function whenever thou makest an incompatible change. +;; - For instance, when the meanings of NIL and T for timestamps was inverted, +;; functions in the STAMP<, STAMP<=, etc. family had to be renamed to TIMESTAMP<, TIMESTAMP<=, etc., +;; because the change other caused a huge incompatibility during upgrade. +;; - Whenever a function goes from a DEFUN to a DEFGENERIC, or the DEFGENERIC signature changes, etc., +;; even in a backward-compatible way, you MUST precede the definition by FMAKUNBOUND. +;; - Since FMAKUNBOUND will remove all the methods on the generic function, make sure that +;; all the methods required for ASDF to successfully continue compiling itself +;; shall be defined in the same file as the one with the FMAKUNBOUND, *after* the DEFGENERIC. +;; - When a function goes from DEFGENERIC to DEFUN, you may omit to use FMAKUNBOUND. +;; - For safety, you shall put the FMAKUNBOUND just before the DEFUN or DEFGENERIC, +;; in the same WITH-UPGRADABILITY form (and its implicit EVAL-WHEN). +;; - Any time you change a signature, please keep a comment specifying the first release after the change; +;; put that comment on the same line as FMAKUNBOUND, it you use FMAKUNBOUND. +(eval-when (:load-toplevel :compile-toplevel :execute) + (defun ensure-function-notinline (definition &aux (name (second definition))) + (assert (member (first definition) '(defun defgeneric))) + `(progn + ,(when (and #+(or clasp ecl) (symbolp name)) ; NB: fails for (SETF functions) on ECL + `(declaim (notinline ,name))) + ,definition)) + (defmacro with-upgradability ((&optional) &body body) + "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified +to also declare the functions NOTINLINE and to accept a wrapping the function name +specification into a list with keyword argument SUPERSEDE (which defaults to T if the name +is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION +to supersede any previous definition." + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(loop :for form :in body :collect + (if (consp form) + (case (first form) + ((defun defgeneric) (ensure-function-notinline form)) + (otherwise form)) + form))))) + +;;; Magic debugging help. See contrib/debug.lisp +(with-upgradability () + (defvar *uiop-debug-utility* + '(symbol-call :uiop :subpathname (symbol-call :uiop :uiop-directory) "contrib/debug.lisp") + "form that evaluates to the pathname to your favorite debugging utilities") + + (defmacro uiop-debug (&rest keys) + "Load the UIOP debug utility at compile-time as well as runtime" + `(eval-when (:compile-toplevel :load-toplevel :execute) + (load-uiop-debug-utility ,@keys))) + + (defun load-uiop-debug-utility (&key package utility-file) + "Load the UIOP debug utility in given PACKAGE (default *PACKAGE*). +Beware: The utility is located by EVAL'uating the UTILITY-FILE form (default *UIOP-DEBUG-UTILITY*)." + (let* ((*package* (if package (find-package package) *package*)) + (keyword (read-from-string + (format nil ":DBG-~:@(~A~)" (package-name *package*))))) + (unless (member keyword *features*) + (let* ((utility-file (or utility-file *uiop-debug-utility*)) + (file (ignore-errors (probe-file (eval utility-file))))) + (if file (load file) + (error "Failed to locate debug utility file: ~S" utility-file))))))) + +;;; Flow control +(with-upgradability () + (defmacro nest (&rest things) + "Macro to keep code nesting and indentation under control." ;; Thanks to mbaringer + (reduce #'(lambda (outer inner) `(,@outer ,inner)) + things :from-end t)) + + (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria + ;; bindings can be (var form) or ((var1 form1) ...) + (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) + (list bindings) + bindings)) + (variables (mapcar #'car binding-list))) + `(let ,binding-list + (if (and ,@variables) + ,then-form + ,else-form))))) + +;;; Macro definition helper +(with-upgradability () + (defun parse-body (body &key documentation whole) ;; from alexandria + "Parses BODY into (values remaining-forms declarations doc-string). +Documentation strings are recognized only if DOCUMENTATION is true. +Syntax errors in body are signalled and WHOLE is used in the signal +arguments when given." + (let ((doc nil) + (decls nil) + (current nil)) + (tagbody + :declarations + (setf current (car body)) + (when (and documentation (stringp current) (cdr body)) + (if doc + (error "Too many documentation strings in ~S." (or whole body)) + (setf doc (pop body))) + (go :declarations)) + (when (and (listp current) (eql (first current) 'declare)) + (push (pop body) decls) + (go :declarations))) + (values body (nreverse decls) doc)))) + + +;;; List manipulation +(with-upgradability () + (defmacro while-collecting ((&rest collectors) &body body) + "COLLECTORS should be a list of names for collections. A collector +defines a function that, when applied to an argument inside BODY, will +add its argument to the corresponding collection. Returns multiple values, +a list for each collection, in order. + E.g., +\(while-collecting \(foo bar\) + \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\) + \(foo \(first x\)\) + \(bar \(second x\)\)\)\) +Returns two values: \(A B C\) and \(1 2 3\)." + (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors)) + (initial-values (mapcar (constantly nil) collectors))) + `(let ,(mapcar #'list vars initial-values) + (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars) + ,@body + (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars)))))) + + (define-modify-macro appendf (&rest args) + append "Append onto list") ;; only to be used on short lists. + + (defun length=n-p (x n) ;is it that (= (length x) n) ? + (check-type n (integer 0 *)) + (loop + :for l = x :then (cdr l) + :for i :downfrom n :do + (cond + ((zerop i) (return (null l))) + ((not (consp l)) (return nil))))) + + (defun ensure-list (x) + (if (listp x) x (list x)))) + + +;;; Remove a key from a plist, i.e. for keyword argument cleanup +(with-upgradability () + (defun remove-plist-key (key plist) + "Remove a single key from a plist" + (loop :for (k v) :on plist :by #'cddr + :unless (eq k key) + :append (list k v))) + + (defun remove-plist-keys (keys plist) + "Remove a list of keys from a plist" + (loop :for (k v) :on plist :by #'cddr + :unless (member k keys) + :append (list k v)))) + + +;;; Sequences +(with-upgradability () + (defun emptyp (x) + "Predicate that is true for an empty sequence" + (or (null x) (and (vectorp x) (zerop (length x)))))) + + +;;; Characters +(with-upgradability () + ;; base-char != character on ECL, LW, SBCL, Genera. + ;; NB: We assume a total order on character types. + ;; If that's not true... this code will need to be updated. + (defparameter +character-types+ ;; assuming a simple hierarchy + #.(coerce (loop :for (type next) :on + '(;; In SCL, all characters seem to be 16-bit base-char + ;; Yet somehow character fails to be a subtype of base-char + #-scl base-char + ;; LW6 has BASE-CHAR < SIMPLE-CHAR < CHARACTER + ;; LW7 has BASE-CHAR < BMP-CHAR < SIMPLE-CHAR = CHARACTER + #+lispworks7+ lw:bmp-char + #+lispworks lw:simple-char + character) + :unless (and next (subtypep next type)) + :collect type) 'vector)) + (defparameter +max-character-type-index+ (1- (length +character-types+))) + (defconstant +non-base-chars-exist-p+ (plusp +max-character-type-index+)) + (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) + +(with-upgradability () + (defun character-type-index (x) + (declare (ignorable x)) + #.(case +max-character-type-index+ + (0 0) + (1 '(etypecase x + (character (if (typep x 'base-char) 0 1)) + (symbol (if (subtypep x 'base-char) 0 1)))) + (otherwise + '(or (position-if (etypecase x + (character #'(lambda (type) (typep x type))) + (symbol #'(lambda (type) (subtypep x type)))) + +character-types+) + (error "Not a character or character type: ~S" x)))))) + + +;;; Strings +(with-upgradability () + (defun base-string-p (string) + "Does the STRING only contain BASE-CHARs?" + (declare (ignorable string)) + (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string)))) + + (defun strings-common-element-type (strings) + "What least subtype of CHARACTER can contain all the elements of all the STRINGS?" + (declare (ignorable strings)) + #.(if +non-base-chars-exist-p+ + `(aref +character-types+ + (loop :with index = 0 :for s :in strings :do + (flet ((consider (i) + (cond ((= i ,+max-character-type-index+) (return i)) + ,@(when (> +max-character-type-index+ 1) `(((> i index) (setf index i))))))) + (cond + ((emptyp s)) ;; NIL or empty string + ((characterp s) (consider (character-type-index s))) + ((stringp s) (let ((string-type-index + (character-type-index (array-element-type s)))) + (unless (>= index string-type-index) + (loop :for c :across s :for i = (character-type-index c) + :do (consider i) + ,@(when (> +max-character-type-index+ 1) + `((when (= i string-type-index) (return)))))))) + (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type)))) + :finally (return index))) + ''character)) + + (defun reduce/strcat (strings &key key start end) + "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE. +NIL is interpreted as an empty string. A character is interpreted as a string of length one." + (when (or start end) (setf strings (subseq strings start end))) + (when key (setf strings (mapcar key strings))) + (loop :with output = (make-string (loop :for s :in strings + :sum (if (characterp s) 1 (length s))) + :element-type (strings-common-element-type strings)) + :with pos = 0 + :for input :in strings + :do (etypecase input + (null) + (character (setf (char output pos) input) (incf pos)) + (string (replace output input :start1 pos) (incf pos (length input)))) + :finally (return output))) + + (defun strcat (&rest strings) + "Concatenate strings. +NIL is interpreted as an empty string, a character as a string of length one." + (reduce/strcat strings)) + + (defun first-char (s) + "Return the first character of a non-empty string S, or NIL" + (and (stringp s) (plusp (length s)) (char s 0))) + + (defun last-char (s) + "Return the last character of a non-empty string S, or NIL" + (and (stringp s) (plusp (length s)) (char s (1- (length s))))) + + (defun split-string (string &key max (separator '(#\Space #\Tab))) + "Split STRING into a list of components separated by +any of the characters in the sequence SEPARATOR. +If MAX is specified, then no more than max(1,MAX) components will be returned, +starting the separation from the end, e.g. when called with arguments + \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." + (block () + (let ((list nil) (words 0) (end (length string))) + (when (zerop end) (return nil)) + (flet ((separatorp (char) (find char separator)) + (done () (return (cons (subseq string 0 end) list)))) + (loop + :for start = (if (and max (>= words (1- max))) + (done) + (position-if #'separatorp string :end end :from-end t)) + :do (when (null start) (done)) + (push (subseq string (1+ start) end) list) + (incf words) + (setf end start)))))) + + (defun string-prefix-p (prefix string) + "Does STRING begin with PREFIX?" + (let* ((x (string prefix)) + (y (string string)) + (lx (length x)) + (ly (length y))) + (and (<= lx ly) (string= x y :end2 lx)))) + + (defun string-suffix-p (string suffix) + "Does STRING end with SUFFIX?" + (let* ((x (string string)) + (y (string suffix)) + (lx (length x)) + (ly (length y))) + (and (<= ly lx) (string= x y :start1 (- lx ly))))) + + (defun string-enclosed-p (prefix string suffix) + "Does STRING begin with PREFIX and end with SUFFIX?" + (and (string-prefix-p prefix string) + (string-suffix-p string suffix))) + + (defvar +cr+ (coerce #(#\Return) 'string)) + (defvar +lf+ (coerce #(#\Linefeed) 'string)) + (defvar +crlf+ (coerce #(#\Return #\Linefeed) 'string)) + + (defun stripln (x) + "Strip a string X from any ending CR, LF or CRLF. +Return two values, the stripped string and the ending that was stripped, +or the original value and NIL if no stripping took place. +Since our STRCAT accepts NIL as empty string designator, +the two results passed to STRCAT always reconstitute the original string" + (check-type x string) + (block nil + (flet ((c (end) (when (string-suffix-p x end) + (return (values (subseq x 0 (- (length x) (length end))) end))))) + (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil))))) + + (defun standard-case-symbol-name (name-designator) + "Given a NAME-DESIGNATOR for a symbol, if it is a symbol, convert it to a string using STRING; +if it is a string, use STRING-UPCASE on an ANSI CL platform, or STRING on a so-called \"modern\" +platform such as Allegro with modern syntax." + (check-type name-designator (or string symbol)) + (cond + ((or (symbolp name-designator) #+allegro (eq excl:*current-case-mode* :case-sensitive-lower)) + (string name-designator)) + ;; Should we be doing something on CLISP? + (t (string-upcase name-designator)))) + + (defun find-standard-case-symbol (name-designator package-designator &optional (error t)) + "Find a symbol designated by NAME-DESIGNATOR in a package designated by PACKAGE-DESIGNATOR, +where STANDARD-CASE-SYMBOL-NAME is used to transform them if these designators are strings. +If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found." + (find-symbol* (standard-case-symbol-name name-designator) + (etypecase package-designator + ((or package symbol) package-designator) + (string (standard-case-symbol-name package-designator))) + error))) + +;;; timestamps: a REAL or a boolean where T=-infinity, NIL=+infinity +(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) + (deftype timestamp () '(or real boolean))) +(with-upgradability () + (defun timestamp< (x y) + (etypecase x + ((eql t) (not (eql y t))) + (real (etypecase y + ((eql t) nil) + (real (< x y)) + (null t))) + (null nil))) + (defun timestamps< (list) (loop :for y :in list :for x = nil :then y :always (timestamp< x y))) + (defun timestamp*< (&rest list) (timestamps< list)) + (defun timestamp<= (x y) (not (timestamp< y x))) + (defun earlier-timestamp (x y) (if (timestamp< x y) x y)) + (defun timestamps-earliest (list) (reduce 'earlier-timestamp list :initial-value nil)) + (defun earliest-timestamp (&rest list) (timestamps-earliest list)) + (defun later-timestamp (x y) (if (timestamp< x y) y x)) + (defun timestamps-latest (list) (reduce 'later-timestamp list :initial-value t)) + (defun latest-timestamp (&rest list) (timestamps-latest list)) + (define-modify-macro latest-timestamp-f (&rest timestamps) latest-timestamp)) + + +;;; Function designators +(with-upgradability () + (defun ensure-function (fun &key (package :cl)) + "Coerce the object FUN into a function. + +If FUN is a FUNCTION, return it. +If the FUN is a non-sequence literal constant, return constantly that, +i.e. for a boolean keyword character number or pathname. +Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION. +If FUN is a CONS, return the function that applies its CAR +to the appended list of the rest of its CDR and the arguments, +unless the CAR is LAMBDA, in which case the expression is evaluated. +If FUN is a string, READ a form from it in the specified PACKAGE (default: CL) +and EVAL that in a (FUNCTION ...) context." + (etypecase fun + (function fun) + ((or boolean keyword character number pathname) (constantly fun)) + (hash-table #'(lambda (x) (gethash x fun))) + (symbol (fdefinition fun)) + (cons (if (eq 'lambda (car fun)) + (eval fun) + #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))) + (string (eval `(function ,(with-standard-io-syntax + (let ((*package* (find-package package))) + (read-from-string fun)))))))) + + (defun access-at (object at) + "Given an OBJECT and an AT specifier, list of successive accessors, +call each accessor on the result of the previous calls. +An accessor may be an integer, meaning a call to ELT, +a keyword, meaning a call to GETF, +NIL, meaning identity, +a function or other symbol, meaning itself, +or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION. +As a degenerate case, the AT specifier may be an atom of a single such accessor +instead of a list." + (flet ((access (object accessor) + (etypecase accessor + (function (funcall accessor object)) + (integer (elt object accessor)) + (keyword (getf object accessor)) + (null object) + (symbol (funcall accessor object)) + (cons (funcall (ensure-function accessor) object))))) + (if (listp at) + (dolist (accessor at object) + (setf object (access object accessor))) + (access object at)))) + + (defun access-at-count (at) + "From an AT specification, extract a COUNT of maximum number +of sub-objects to read as per ACCESS-AT" + (cond + ((integerp at) + (1+ at)) + ((and (consp at) (integerp (first at))) + (1+ (first at))))) + + (defun call-function (function-spec &rest arguments) + "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION, +with the given ARGUMENTS" + (apply (ensure-function function-spec) arguments)) + + (defun call-functions (function-specs) + "For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION" + (map () 'call-function function-specs)) + + (defun register-hook-function (variable hook &optional call-now-p) + "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto the hook VARIABLE. +When CALL-NOW-P is true, also call the function immediately." + (pushnew hook (symbol-value variable) :test 'equal) + (when call-now-p (call-function hook)))) + + +;;; CLOS +(with-upgradability () + (defun coerce-class (class &key (package :cl) (super t) (error 'error)) + "Coerce CLASS to a class that is subclass of SUPER if specified, +or invoke ERROR handler as per CALL-FUNCTION. + +A keyword designates the name a symbol, which when found in either PACKAGE, designates a class. +-- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future. +A string is read as a symbol while in PACKAGE, the symbol designates a class. + +A class object designates itself. +NIL designates itself (no class). +A symbol otherwise designates a class by name." + (let* ((normalized + (typecase class + (keyword (or (find-symbol* class package nil) + (find-symbol* class *package* nil))) + (string (symbol-call :uiop :safe-read-from-string class :package package)) + (t class))) + (found + (etypecase normalized + ((or standard-class built-in-class) normalized) + ((or null keyword) nil) + (symbol (find-class normalized nil nil)))) + (super-class + (etypecase super + ((or standard-class built-in-class) super) + ((or null keyword) nil) + (symbol (find-class super nil nil))))) + #+allegro (when found (mop:finalize-inheritance found)) + (or (and found + (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super-class)) + found) + (call-function error "Can't coerce ~S to a ~:[class~;subclass of ~:*~S~]" class super))))) + + +;;; Hash-tables +(with-upgradability () + (defun ensure-gethash (key table default) + "Lookup the TABLE for a KEY as by GETHASH, but if not present, +call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION, +set the corresponding entry to the result in the table. +Return two values: the entry after its optional computation, and whether it was found" + (multiple-value-bind (value foundp) (gethash key table) + (values + (if foundp + value + (setf (gethash key table) (call-function default))) + foundp))) + + (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) + "Convert a LIST into hash-table that has the same elements when viewed as a set, +up to the given equality TEST" + (dolist (x list h) (setf (gethash x h) t)))) + + +;;; Lexicographic comparison of lists of numbers +(with-upgradability () + (defun lexicographic< (element< x y) + "Lexicographically compare two lists of using the function element< to compare elements. +element< is a strict total order; the resulting order on X and Y will also be strict." + (cond ((null y) nil) + ((null x) t) + ((funcall element< (car x) (car y)) t) + ((funcall element< (car y) (car x)) nil) + (t (lexicographic< element< (cdr x) (cdr y))))) + + (defun lexicographic<= (element< x y) + "Lexicographically compare two lists of using the function element< to compare elements. +element< is a strict total order; the resulting order on X and Y will be a non-strict total order." + (not (lexicographic< element< y x)))) + + +;;; Simple style warnings +(with-upgradability () + (define-condition simple-style-warning + #+sbcl (sb-int:simple-style-warning) #-sbcl (simple-condition style-warning) + ()) + + (defun style-warn (datum &rest arguments) + (etypecase datum + (string (warn (make-condition 'simple-style-warning :format-control datum :format-arguments arguments))) + (symbol (assert (subtypep datum 'style-warning)) (apply 'warn datum arguments)) + (style-warning (apply 'warn datum arguments))))) + + +;;; Condition control + +(with-upgradability () + (defparameter +simple-condition-format-control-slot+ + #+abcl 'system::format-control + #+allegro 'excl::format-control + #+(or clasp ecl mkcl) 'si::format-control + #+clisp 'system::$format-control + #+clozure 'ccl::format-control + #+(or cmucl scl) 'conditions::format-control + #+(or gcl lispworks) 'conditions::format-string + #+sbcl 'sb-kernel:format-control + #-(or abcl allegro clasp clisp clozure cmucl ecl gcl lispworks mkcl sbcl scl) nil + "Name of the slot for FORMAT-CONTROL in simple-condition") + + (defun match-condition-p (x condition) + "Compare received CONDITION to some pattern X: +a symbol naming a condition class, +a simple vector of length 2, arguments to find-symbol* with result as above, +or a string describing the format-control of a simple-condition." + (etypecase x + (symbol (typep condition x)) + ((simple-vector 2) + (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))) + (function (funcall x condition)) + (string (and (typep condition 'simple-condition) + ;; On SBCL, it's always set and the check triggers a warning + #+(or allegro clozure cmucl lispworks scl) + (slot-boundp condition +simple-condition-format-control-slot+) + (ignore-errors (equal (simple-condition-format-control condition) x)))))) + + (defun match-any-condition-p (condition conditions) + "match CONDITION against any of the patterns of CONDITIONS supplied" + (loop :for x :in conditions :thereis (match-condition-p x condition))) + + (defun call-with-muffled-conditions (thunk conditions) + "calls the THUNK in a context where the CONDITIONS are muffled" + (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions) + (muffle-warning c))))) + (funcall thunk))) + + (defmacro with-muffled-conditions ((conditions) &body body) + "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS" + `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions))) + +;;; Conditions + +(with-upgradability () + (define-condition not-implemented-error (error) + ((functionality :initarg :functionality) + (format-control :initarg :format-control) + (format-arguments :initarg :format-arguments)) + (:report (lambda (condition stream) + (format stream "Not (currently) implemented on ~A: ~S~@[ ~?~]" + (nth-value 1 (symbol-call :uiop :implementation-type)) + (slot-value condition 'functionality) + (slot-value condition 'format-control) + (slot-value condition 'format-arguments))))) + + (defun not-implemented-error (functionality &optional format-control &rest format-arguments) + "Signal an error because some FUNCTIONALITY is not implemented in the current version +of the software on the current platform; it may or may not be implemented in different combinations +of version of the software and of the underlying platform. Optionally, report a formatted error +message." + (error 'not-implemented-error + :functionality functionality + :format-control format-control + :format-arguments format-arguments)) + + (define-condition parameter-error (error) + ((functionality :initarg :functionality) + (format-control :initarg :format-control) + (format-arguments :initarg :format-arguments)) + (:report (lambda (condition stream) + (apply 'format stream + (slot-value condition 'format-control) + (slot-value condition 'functionality) + (slot-value condition 'format-arguments))))) + + ;; Note that functionality MUST be passed as the second argument to parameter-error, just after + ;; the format-control. If you want it to not appear in first position in actual message, use + ;; ~* and ~:* to adjust parameter order. + (defun parameter-error (format-control functionality &rest format-arguments) + "Signal an error because some FUNCTIONALITY or its specific implementation on a given underlying +platform does not accept a given parameter or combination of parameters. Report a formatted error +message, that takes the functionality as its first argument (that can be skipped with ~*)." + (error 'parameter-error + :functionality functionality + :format-control format-control + :format-arguments format-arguments))) + +(with-upgradability () + (defun boolean-to-feature-expression (value) + "Converts a boolean VALUE to a form suitable for testing with #+." + (if value + '(:and) + '(:or))) + + (defun symbol-test-to-feature-expression (name package) + "Check if a symbol with a given NAME exists in PACKAGE and returns a +form suitable for testing with #+." + (boolean-to-feature-expression + (find-symbol* name package nil)))) +(uiop/package:define-package :uiop/version + (:recycle :uiop/version :uiop/utility :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility) + (:export + #:*uiop-version* + #:parse-version #:unparse-version #:version< #:version<= ;; version support, moved from uiop/utility + #:next-version + #:deprecated-function-condition #:deprecated-function-name ;; deprecation control + #:deprecated-function-style-warning #:deprecated-function-warning + #:deprecated-function-error #:deprecated-function-should-be-deleted + #:version-deprecation #:with-deprecation)) +(in-package :uiop/version) + +(with-upgradability () + (defparameter *uiop-version* "3.3.5") + + (defun unparse-version (version-list) + "From a parsed version (a list of natural numbers), compute the version string" + (format nil "~{~D~^.~}" version-list)) + + (defun parse-version (version-string &optional on-error) + "Parse a VERSION-STRING as a series of natural numbers separated by dots. +Return a (non-null) list of integers if the string is valid; +otherwise return NIL. + +When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL, +with format arguments explaining why the version is invalid. +ON-ERROR is also called if the version is not canonical +in that it doesn't print back to itself, but the list is returned anyway." + (block nil + (unless (stringp version-string) + (call-function on-error "~S: ~S is not a string" 'parse-version version-string) + (return)) + (unless (loop :for prev = nil :then c :for c :across version-string + :always (or (digit-char-p c) + (and (eql c #\.) prev (not (eql prev #\.)))) + :finally (return (and c (digit-char-p c)))) + (call-function on-error "~S: ~S doesn't follow asdf version numbering convention" + 'parse-version version-string) + (return)) + (let* ((version-list + (mapcar #'parse-integer (split-string version-string :separator "."))) + (normalized-version (unparse-version version-list))) + (unless (equal version-string normalized-version) + (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string)) + version-list))) + + (defun next-version (version) + "When VERSION is not nil, it is a string, then parse it as a version, compute the next version +and return it as a string." + (when version + (let ((version-list (parse-version version))) + (incf (car (last version-list))) + (unparse-version version-list)))) + + (defun version< (version1 version2) + "Given two version strings, return T if the second is strictly newer" + (let ((v1 (parse-version version1 nil)) + (v2 (parse-version version2 nil))) + (lexicographic< '< v1 v2))) + + (defun version<= (version1 version2) + "Given two version strings, return T if the second is newer or the same" + (not (version< version2 version1)))) + + +(with-upgradability () + (define-condition deprecated-function-condition (condition) + ((name :initarg :name :reader deprecated-function-name))) + (define-condition deprecated-function-style-warning (deprecated-function-condition style-warning) ()) + (define-condition deprecated-function-warning (deprecated-function-condition warning) ()) + (define-condition deprecated-function-error (deprecated-function-condition error) ()) + (define-condition deprecated-function-should-be-deleted (deprecated-function-condition error) ()) + + (defun deprecated-function-condition-kind (type) + (ecase type + ((deprecated-function-style-warning) :style-warning) + ((deprecated-function-warning) :warning) + ((deprecated-function-error) :error) + ((deprecated-function-should-be-deleted) :delete))) + + (defmethod print-object ((c deprecated-function-condition) stream) + (let ((name (deprecated-function-name c))) + (cond + (*print-readably* + (let ((fmt "#.(make-condition '~S :name ~S)") + (args (list (type-of c) name))) + (if *read-eval* + (apply 'format stream fmt args) + (error "Can't print ~?" fmt args)))) + (*print-escape* + (print-unreadable-object (c stream :type t) (format stream ":name ~S" name))) + (t + (let ((*package* (find-package :cl)) + (type (type-of c))) + (format stream + (if (eq type 'deprecated-function-should-be-deleted) + "~A: Still defining deprecated function~:P ~{~S~^ ~} that promised to delete" + "~A: Using deprecated function ~S -- please update your code to use a newer API.~ +~@[~%The docstring for this function says:~%~A~%~]") + type name (when (symbolp name) (documentation name 'function)))))))) + + (defun notify-deprecated-function (status name) + (ecase status + ((nil) nil) + ((:style-warning) (style-warn 'deprecated-function-style-warning :name name)) + ((:warning) (warn 'deprecated-function-warning :name name)) + ((:error) (cerror "USE FUNCTION ANYWAY" 'deprecated-function-error :name name)))) + + (defun version-deprecation (version &key (style-warning nil) + (warning (next-version style-warning)) + (error (next-version warning)) + (delete (next-version error))) + "Given a VERSION string, and the starting versions for notifying the programmer of +various levels of deprecation, return the current level of deprecation as per WITH-DEPRECATION +that is the highest level that has a declared version older than the specified version. +Each start version for a level of deprecation can be specified by a keyword argument, or +if left unspecified, will be the NEXT-VERSION of the immediate lower level of deprecation." + (cond + ((and delete (version<= delete version)) :delete) + ((and error (version<= error version)) :error) + ((and warning (version<= warning version)) :warning) + ((and style-warning (version<= style-warning version)) :style-warning))) + + (defmacro with-deprecation ((level) &body definitions) + "Given a deprecation LEVEL (a form to be EVAL'ed at macro-expansion time), instrument the +DEFUN and DEFMETHOD forms in DEFINITIONS to notify the programmer of the deprecation of the function +when it is compiled or called. + +Increasing levels (as result from evaluating LEVEL) are: NIL (not deprecated yet), +:STYLE-WARNING (a style warning is issued when used), :WARNING (a full warning is issued when used), +:ERROR (a continuable error instead), and :DELETE (it's an error if the code is still there while +at that level). + +Forms other than DEFUN and DEFMETHOD are not instrumented, and you can protect a DEFUN or DEFMETHOD +from instrumentation by enclosing it in a PROGN." + (let ((level (eval level))) + (check-type level (member nil :style-warning :warning :error :delete)) + (when (eq level :delete) + (error 'deprecated-function-should-be-deleted :name + (mapcar 'second + (remove-if-not #'(lambda (x) (member x '(defun defmethod))) + definitions :key 'first)))) + (labels ((instrument (name head body whole) + (if level + (let ((notifiedp + (intern (format nil "*~A-~A-~A-~A*" + :deprecated-function level name :notified-p)))) + (multiple-value-bind (remaining-forms declarations doc-string) + (parse-body body :documentation t :whole whole) + `(progn + (defparameter ,notifiedp nil) + ;; tell some implementations to use the compiler-macro + (declaim (inline ,name)) + (define-compiler-macro ,name (&whole form &rest args) + (declare (ignore args)) + (notify-deprecated-function ,level ',name) + form) + (,@head ,@(when doc-string (list doc-string)) ,@declarations + (unless ,notifiedp + (setf ,notifiedp t) + (notify-deprecated-function ,level ',name)) + ,@remaining-forms)))) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (compiler-macro-function ',name) nil)) + (declaim (notinline ,name)) + (,@head ,@body))))) + `(progn + ,@(loop :for form :in definitions :collect + (cond + ((and (consp form) (eq (car form) 'defun)) + (instrument (second form) (subseq form 0 3) (subseq form 3) form)) + ((and (consp form) (eq (car form) 'defmethod)) + (let ((body-start (if (listp (third form)) 3 4))) + (instrument (second form) + (subseq form 0 body-start) + (subseq form body-start) + form))) + (t + form)))))))) +;;;; --------------------------------------------------------------------------- +;;;; Access to the Operating System + +(uiop/package:define-package :uiop/os + (:use :uiop/common-lisp :uiop/package :uiop/utility) + (:export + #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features + #:os-cond + #:getenv #:getenvp ;; environment variables + #:implementation-identifier ;; implementation identifier + #:implementation-type #:*implementation-type* + #:operating-system #:architecture #:lisp-version-string + #:hostname #:getcwd #:chdir + ;; Windows shortcut support + #:read-null-terminated-string #:read-little-endian + #:parse-file-location-info #:parse-windows-shortcut)) +(in-package :uiop/os) + +;;; Features +(with-upgradability () + (defun featurep (x &optional (*features* *features*)) + "Checks whether a feature expression X is true with respect to the *FEATURES* set, +as per the CLHS standard for #+ and #-. Beware that just like the CLHS, +we assume symbols from the KEYWORD package are used, but that unless you're using #+/#- +your reader will not have magically used the KEYWORD package, so you need specify +keywords explicitly." + (cond + ((atom x) (and (member x *features*) t)) + ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x)))) + ((eq :or (car x)) (some #'featurep (cdr x))) + ((eq :and (car x)) (every #'featurep (cdr x))) + (t (parameter-error "~S: malformed feature specification ~S" 'featurep x)))) + + ;; Starting with UIOP 3.1.5, these are runtime tests. + ;; You may bind *features* with a copy of what your target system offers to test its properties. + (defun os-macosx-p () + "Is the underlying operating system MacOS X?" + ;; OS-MACOSX is not mutually exclusive with OS-UNIX, + ;; in fact the former implies the latter. + (featurep '(:or :darwin (:and :allegro :macosx) (:and :clisp :macos)))) + + (defun os-unix-p () + "Is the underlying operating system some Unix variant?" + (or (featurep '(:or :unix :cygwin :haiku)) (os-macosx-p))) + + (defun os-windows-p () + "Is the underlying operating system Microsoft Windows?" + (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32 :mingw64)))) + + (defun os-genera-p () + "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?" + (featurep :genera)) + + (defun os-oldmac-p () + "Is the underlying operating system an (emulated?) MacOS 9 or earlier?" + (featurep :mcl)) + + (defun os-haiku-p () + "Is the underlying operating system Haiku?" + (featurep :haiku)) + + (defun os-mezzano-p () + "Is the underlying operating system Mezzano?" + (featurep :mezzano)) + + (defun detect-os () + "Detects the current operating system. Only needs be run at compile-time, +except on ABCL where it might change between FASL compilation and runtime." + (loop :with o + :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p) + (:os-windows . os-windows-p) + (:os-genera . os-genera-p) (:os-oldmac . os-oldmac-p) + (:os-haiku . os-haiku-p) + (:os-mezzano . os-mezzano-p)) + :when (and (or (not o) (eq feature :os-macosx) (eq feature :os-haiku)) (funcall detect)) + :do (setf o feature) (pushnew feature *features*) + :else :do (setf *features* (remove feature *features*)) + :finally + (return (or o (error "Congratulations for trying ASDF on an operating system~%~ +that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it."))))) + + (defmacro os-cond (&rest clauses) + #+abcl `(cond ,@clauses) + #-abcl (loop :for (test . body) :in clauses :when (eval test) :return `(progn ,@body))) + + (detect-os)) + +;;;; Environment variables: getting them, and parsing them. +(with-upgradability () + (defun getenv (x) + "Query the environment, as in C getenv. +Beware: may return empty string if a variable is present but empty; +use getenvp to return NIL in such a case." + (declare (ignorable x)) + #+(or abcl clasp clisp ecl xcl) (ext:getenv x) + #+allegro (sys:getenv x) + #+clozure (ccl:getenv x) + #+cmucl (unix:unix-getenv x) + #+scl (cdr (assoc x ext:*environment-list* :test #'string=)) + #+cormanlisp + (let* ((buffer (ct:malloc 1)) + (cname (ct:lisp-string-to-c-string x)) + (needed-size (win:getenvironmentvariable cname buffer 0)) + (buffer1 (ct:malloc (1+ needed-size)))) + (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) + nil + (ct:c-string-to-lisp-string buffer1)) + (ct:free buffer) + (ct:free buffer1))) + #+gcl (system:getenv x) + #+(or genera mezzano) nil + #+lispworks (lispworks:environment-variable x) + #+mcl (ccl:with-cstrs ((name x)) + (let ((value (_getenv name))) + (unless (ccl:%null-ptr-p value) + (ccl:%get-cstring value)))) + #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) + #+sbcl (sb-ext:posix-getenv x) + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl) + (not-implemented-error 'getenv)) + + (defsetf getenv (x) (val) + "Set an environment variable." + (declare (ignorable x val)) + #+allegro `(setf (sys:getenv ,x) ,val) + #+clasp `(ext:setenv ,x ,val) + #+clisp `(system::setenv ,x ,val) + #+clozure `(ccl:setenv ,x ,val) + #+cmucl `(unix:unix-setenv ,x ,val 1) + #+(or ecl clasp) `(ext:setenv ,x ,val) + #+lispworks `(setf (lispworks:environment-variable ,x) ,val) + #+mkcl `(mkcl:setenv ,x ,val) + #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1)) + #-(or allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl) + '(not-implemented-error '(setf getenv))) + + (defun getenvp (x) + "Predicate that is true if the named variable is present in the libc environment, +then returning the non-empty string value of the variable" + (let ((g (getenv x))) (and (not (emptyp g)) g)))) + + +;;;; implementation-identifier +;; +;; produce a string to identify current implementation. +;; Initially stolen from SLIME's SWANK, completely rewritten since. +;; We're back to runtime checking, for the sake of e.g. ABCL. + +(with-upgradability () + (defun first-feature (feature-sets) + "A helper for various feature detection functions" + (dolist (x feature-sets) + (multiple-value-bind (short long feature-expr) + (if (consp x) + (values (first x) (second x) (cons :or (rest x))) + (values x x x)) + (when (featurep feature-expr) + (return (values short long)))))) + + (defun implementation-type () + "The type of Lisp implementation used, as a short UIOP-standardized keyword" + (first-feature + '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) + (:cmu :cmucl :cmu) :clasp :ecl :gcl + (:lwpe :lispworks-personal-edition) (:lw :lispworks) + :mcl :mezzano :mkcl :sbcl :scl (:smbx :symbolics) :xcl))) + + (defvar *implementation-type* (implementation-type) + "The type of Lisp implementation used, as a short UIOP-standardized keyword") + + (defun operating-system () + "The operating system of the current host" + (first-feature + '(:cygwin + (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! + (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd + (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd + (:solaris :solaris :sunos) + (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly) + :unix + :genera + :mezzano))) + + (defun architecture () + "The CPU architecture of the current host" + (first-feature + '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386)) + (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) + (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) + :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) + :mipsel :mipseb :mips :alpha + (:arm64 :arm64 :aarch64 :armv8l :armv8b :aarch64_be :|aarch64|) + (:arm :arm :arm-target) :vlm :imach + ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI, + ;; we may have to segregate the code still by architecture. + (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) + + #+clozure + (defun ccl-fasl-version () + ;; the fasl version is target-dependent from CCL 1.8 on. + (or (let ((s 'ccl::target-fasl-version)) + (and (fboundp s) (funcall s))) + (and (boundp 'ccl::fasl-version) + (symbol-value 'ccl::fasl-version)) + (error "Can't determine fasl version."))) + + (defun lisp-version-string () + "return a string that identifies the current Lisp implementation version" + (let ((s (lisp-implementation-version))) + (car ; as opposed to OR, this idiom prevents some unreachable code warning + (list + #+allegro + (format nil "~A~@[~A~]~@[~A~]~@[~A~]" + excl::*common-lisp-version-number* + ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default) + (and (eq excl:*current-case-mode* :case-sensitive-lower) "M") + ;; Note if not using International ACL + ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm + (excl:ics-target-case (:-ics "8")) + (and (member :smp *features*) "S")) + #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) + #+clisp + (subseq s 0 (position #\space s)) ; strip build information (date, etc.) + #+clozure + (format nil "~d.~d-f~d" ; shorten for windows + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version* + (logand (ccl-fasl-version) #xFF)) + #+cmucl (substitute #\- #\/ s) + #+scl (format nil "~A~A" s + ;; ANSI upper case vs lower case. + (ecase ext:*case-mode* (:upper "") (:lower "l"))) + #+ecl (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (unless (equal vcs-id "UNKNOWN") + (subseq vcs-id 0 (min (length vcs-id) 8))))) + #+gcl (subseq s (1+ (position #\space s))) + #+genera + (multiple-value-bind (major minor) (sct:get-system-version "System") + (format nil "~D.~D" major minor)) + #+mcl (subseq s 8) ; strip the leading "Version " + #+mezzano (format nil "~A-~D" + (subseq s 0 (position #\space s)) ; strip commit hash + sys.int::*llf-version*) + ;; seems like there should be a shorter way to do this, like ACALL. + #+mkcl (or + (let ((fname (find-symbol* '#:git-describe-this-mkcl :mkcl nil))) + (when (and fname (fboundp fname)) + (funcall fname))) + s) + s)))) + + (defun implementation-identifier () + "Return a string that identifies the ABI of the current implementation, +suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc." + (substitute-if + #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) + (format nil "~(~a~@{~@[-~a~]~}~)" + (or (implementation-type) (lisp-implementation-type)) + (lisp-version-string) + (or (operating-system) (software-type)) + (or (architecture) (machine-type)))))) + + +;;;; Other system information + +(with-upgradability () + (defun hostname () + "return the hostname of the current host" + #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mezzano mkcl sbcl scl xcl) (machine-instance) + #+cormanlisp "localhost" ;; is there a better way? Does it matter? + #+allegro (symbol-call :excl.osi :gethostname) + #+clisp (first (split-string (machine-instance) :separator " ")) + #+gcl (system:gethostname))) + + +;;; Current directory +(with-upgradability () + + #+cmucl + (defun parse-unix-namestring* (unix-namestring) + "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object" + (multiple-value-bind (host device directory name type version) + (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring)) + (make-pathname :host (or host lisp::*unix-host*) :device device + :directory directory :name name :type type :version version))) + + (defun getcwd () + "Get the current working directory as per POSIX getcwd(3), as a pathname object" + (or #+(or abcl genera mezzano xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical! + #+allegro (excl::current-directory) + #+clisp (ext:default-directory) + #+clozure (ccl:current-directory) + #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring + (strcat (nth-value 1 (unix:unix-current-directory)) "/")) + #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? + #+(or clasp ecl) (ext:getcwd) + #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p"")) + #+lispworks (hcl:get-working-directory) + #+mkcl (mk-ext:getcwd) + #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/)) + #+xcl (extensions:current-directory) + (not-implemented-error 'getcwd))) + + (defun chdir (x) + "Change current directory, as per POSIX chdir(2), to a given pathname object" + (if-let (x (pathname x)) + #+(or abcl genera mezzano xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical! + #+allegro (excl:chdir x) + #+clisp (ext:cd x) + #+clozure (setf (ccl:current-directory) x) + #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x)) + #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) + (error "Could not set current directory to ~A" x)) + #+ecl (ext:chdir x) + #+clasp (ext:chdir x t) + #+gcl (system:chdir x) + #+lispworks (hcl:change-directory x) + #+mkcl (mk-ext:chdir x) + #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))) + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl) + (not-implemented-error 'chdir)))) + + +;;;; ----------------------------------------------------------------- +;;;; Windows shortcut support. Based on: +;;;; +;;;; Jesse Hager: The Windows Shortcut File Format. +;;;; http://www.wotsit.org/list.asp?fc=13 + +#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it +(with-upgradability () + (defparameter *link-initial-dword* 76) + (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) + + (defun read-null-terminated-string (s) + "Read a null-terminated string from an octet stream S" + ;; note: doesn't play well with UNICODE + (with-output-to-string (out) + (loop :for code = (read-byte s) + :until (zerop code) + :do (write-char (code-char code) out)))) + + (defun read-little-endian (s &optional (bytes 4)) + "Read a number in little-endian format from an byte (octet) stream S, +the number having BYTES octets (defaulting to 4)." + (loop :for i :from 0 :below bytes + :sum (ash (read-byte s) (* 8 i)))) + + (defun parse-file-location-info (s) + "helper to parse-windows-shortcut" + (let ((start (file-position s)) + (total-length (read-little-endian s)) + (end-of-header (read-little-endian s)) + (fli-flags (read-little-endian s)) + (local-volume-offset (read-little-endian s)) + (local-offset (read-little-endian s)) + (network-volume-offset (read-little-endian s)) + (remaining-offset (read-little-endian s))) + (declare (ignore total-length end-of-header local-volume-offset)) + (unless (zerop fli-flags) + (cond + ((logbitp 0 fli-flags) + (file-position s (+ start local-offset))) + ((logbitp 1 fli-flags) + (file-position s (+ start + network-volume-offset + #x14)))) + (strcat (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) + + (defun parse-windows-shortcut (pathname) + "From a .lnk windows shortcut, extract the pathname linked to" + ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE. + (with-open-file (s pathname :element-type '(unsigned-byte 8)) + (handler-case + (when (and (= (read-little-endian s) *link-initial-dword*) + (let ((header (make-array (length *link-guid*)))) + (read-sequence header s) + (equalp header *link-guid*))) + (let ((flags (read-little-endian s))) + (file-position s 76) ;skip rest of header + (when (logbitp 0 flags) + ;; skip shell item id list + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (cond + ((logbitp 1 flags) + (parse-file-location-info s)) + (t + (when (logbitp 2 flags) + ;; skip description string + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (when (logbitp 3 flags) + ;; finally, our pathname + (let* ((length (read-little-endian s 2)) + (buffer (make-array length))) + (read-sequence buffer s) + (map 'string #'code-char buffer))))))) + (end-of-file (c) + (declare (ignore c)) + nil))))) + + +;;;; ------------------------------------------------------------------------- +;;;; Portability layer around Common Lisp pathnames +;; This layer allows for portable manipulation of pathname objects themselves, +;; which all is necessary prior to any access the filesystem or environment. + +(uiop/package:define-package :uiop/pathname + (:nicknames :asdf/pathname) ;; deprecated. Used by ceramic + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os) + (:export + ;; Making and merging pathnames, portably + #:normalize-pathname-directory-component #:denormalize-pathname-directory-component + #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname* + #:make-pathname-component-logical #:make-pathname-logical + #:merge-pathnames* + #:nil-pathname #:*nil-pathname* #:with-pathname-defaults + ;; Predicates + #:pathname-equal #:logical-pathname-p #:physical-pathname-p #:physicalize-pathname + #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p + ;; Directories + #:pathname-directory-pathname #:pathname-parent-directory-pathname + #:directory-pathname-p #:ensure-directory-pathname + ;; Parsing filenames + #:split-name-type #:parse-unix-namestring #:unix-namestring + #:split-unix-namestring-directory-components + ;; Absolute and relative pathnames + #:subpathname #:subpathname* + #:ensure-absolute-pathname + #:pathname-root #:pathname-host-pathname + #:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enough-pathname + ;; Checking constraints + #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints + ;; Wildcard pathnames + #:*wild* #:*wild-file* #:*wild-file-for-directory* #:*wild-directory* + #:*wild-inferiors* #:*wild-path* #:wilden + ;; Translate a pathname + #:relativize-directory-component #:relativize-pathname-directory + #:directory-separator-for-host #:directorize-pathname-host-device + #:translate-pathname* + #:*output-translation-function*)) +(in-package :uiop/pathname) + +;;; Normalizing pathnames across implementations + +(with-upgradability () + (defun normalize-pathname-directory-component (directory) + "Convert the DIRECTORY component from a format usable by the underlying +implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format +that is a list and not a string." + (cond + #-(or cmucl sbcl scl) ;; these implementations already normalize directory components. + ((stringp directory) `(:absolute ,directory)) + ((or (null directory) + (and (consp directory) (member (first directory) '(:absolute :relative)))) + directory) + #+gcl + ((consp directory) + (cons :relative directory)) + (t + (parameter-error (compatfmt "~@<~S: Unrecognized pathname directory component ~S~@:>") + 'normalize-pathname-directory-component directory)))) + + (defun denormalize-pathname-directory-component (directory-component) + "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable +by the underlying implementation's MAKE-PATHNAME and other primitives" + directory-component) + + (defun merge-pathname-directory-components (specified defaults) + "Helper for MERGE-PATHNAMES* that handles directory components" + (let ((directory (normalize-pathname-directory-component specified))) + (ecase (first directory) + ((nil) defaults) + (:absolute specified) + (:relative + (let ((defdir (normalize-pathname-directory-component defaults)) + (reldir (cdr directory))) + (cond + ((null defdir) + directory) + ((not (eq :back (first reldir))) + (append defdir reldir)) + (t + (loop :with defabs = (first defdir) + :with defrev = (reverse (rest defdir)) + :while (and (eq :back (car reldir)) + (or (and (eq :absolute defabs) (null defrev)) + (stringp (car defrev)))) + :do (pop reldir) (pop defrev) + :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) + + ;; Giving :unspecific as :type argument to make-pathname is not portable. + ;; See CLHS make-pathname and 19.2.2.2.3. + ;; This will be :unspecific if supported, or NIL if not. + (defparameter *unspecific-pathname-type* + #+(or abcl allegro clozure cmucl lispworks sbcl scl) :unspecific + #+(or genera clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl mezzano) nil + "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") + + (defun make-pathname* (&rest keys &key directory host device name type version defaults + #+scl &allow-other-keys) + "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and + tries hard to make a pathname that will actually behave as documented, + despite the peculiarities of each implementation. DEPRECATED: just use MAKE-PATHNAME." + (declare (ignore host device directory name type version defaults)) + (apply 'make-pathname keys)) + + (defun make-pathname-component-logical (x) + "Make a pathname component suitable for use in a logical-pathname" + (typecase x + ((eql :unspecific) nil) + #+clisp (string (string-upcase x)) + #+clisp (cons (mapcar 'make-pathname-component-logical x)) + (t x))) + + (defun make-pathname-logical (pathname host) + "Take a PATHNAME's directory, name, type and version components, +and make a new pathname with corresponding components and specified logical HOST" + (make-pathname + :host host + :directory (make-pathname-component-logical (pathname-directory pathname)) + :name (make-pathname-component-logical (pathname-name pathname)) + :type (make-pathname-component-logical (pathname-type pathname)) + :version (make-pathname-component-logical (pathname-version pathname)))) + + (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) + "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that +if the SPECIFIED pathname does not have an absolute directory, +then the HOST and DEVICE both come from the DEFAULTS, whereas +if the SPECIFIED pathname does have an absolute directory, +then the HOST and DEVICE both come from the SPECIFIED pathname. +This is what users want on a modern Unix or Windows operating system, +unlike the MERGE-PATHNAMES behavior. +Also, if either argument is NIL, then the other argument is returned unmodified; +this is unlike MERGE-PATHNAMES which always merges with a pathname, +by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." + (when (null specified) (return-from merge-pathnames* defaults)) + (when (null defaults) (return-from merge-pathnames* specified)) + #+scl + (ext:resolve-pathname specified defaults) + #-scl + (let* ((specified (pathname specified)) + (defaults (pathname defaults)) + (directory (normalize-pathname-directory-component (pathname-directory specified))) + (name (or (pathname-name specified) (pathname-name defaults))) + (type (or (pathname-type specified) (pathname-type defaults))) + (version (or (pathname-version specified) (pathname-version defaults)))) + (labels ((unspecific-handler (p) + (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity))) + (multiple-value-bind (host device directory unspecific-handler) + (ecase (first directory) + ((:absolute) + (values (pathname-host specified) + (pathname-device specified) + directory + (unspecific-handler specified))) + ((nil :relative) + (values (pathname-host defaults) + (pathname-device defaults) + (merge-pathname-directory-components directory (pathname-directory defaults)) + (unspecific-handler defaults)))) + (make-pathname :host host :device device :directory directory + :name (funcall unspecific-handler name) + :type (funcall unspecific-handler type) + :version (funcall unspecific-handler version)))))) + + (defun logical-pathname-p (x) + "is X a logical-pathname?" + (typep x 'logical-pathname)) + + (defun physical-pathname-p (x) + "is X a pathname that is not a logical-pathname?" + (and (pathnamep x) (not (logical-pathname-p x)))) + + (defun physicalize-pathname (x) + "if X is a logical pathname, use translate-logical-pathname on it." + ;; Ought to be the same as translate-logical-pathname, except the latter borks on CLISP + (let ((p (when x (pathname x)))) + (if (logical-pathname-p p) (translate-logical-pathname p) p))) + + (defun nil-pathname (&optional (defaults *default-pathname-defaults*)) + "A pathname that is as neutral as possible for use as defaults +when merging, making or parsing pathnames" + ;; 19.2.2.2.1 says a NIL host can mean a default host; + ;; see also "valid physical pathname host" in the CLHS glossary, that suggests + ;; strings and lists of strings or :unspecific + ;; But CMUCL decides to die on NIL. + ;; MCL has issues with make-pathname, nil and defaulting + (declare (ignorable defaults)) + #.`(make-pathname :directory nil :name nil :type nil :version nil + :device (or #+(and mkcl os-unix) :unspecific) + :host (or #+cmucl lisp::*unix-host* #+(and mkcl os-unix) "localhost") + #+scl ,@'(:scheme nil :scheme-specific-part nil + :username nil :password nil :parameters nil :query nil :fragment nil) + ;; the default shouldn't matter, but we really want something physical + #-mcl ,@'(:defaults defaults))) + + (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname))) + "A pathname that is as neutral as possible for use as defaults +when merging, making or parsing pathnames") + + (defmacro with-pathname-defaults ((&optional defaults) &body body) + "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* is as specified, +where leaving the defaults NIL or unspecified means a (NIL-PATHNAME), except +on ABCL, Genera and XCL, where it remains unchanged for it doubles as current-directory." + `(let ((*default-pathname-defaults* + ,(or defaults + #-(or abcl genera xcl) '*nil-pathname* + #+(or abcl genera xcl) '*default-pathname-defaults*))) + ,@body))) + + +;;; Some pathname predicates +(with-upgradability () + (defun pathname-equal (p1 p2) + "Are the two pathnames P1 and P2 reasonably equal in the paths they denote?" + (when (stringp p1) (setf p1 (pathname p1))) + (when (stringp p2) (setf p2 (pathname p2))) + (flet ((normalize-component (x) + (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal) + x))) + (macrolet ((=? (&rest accessors) + (flet ((frob (x) + (reduce 'list (cons 'normalize-component accessors) + :initial-value x :from-end t))) + `(equal ,(frob 'p1) ,(frob 'p2))))) + (or (and (null p1) (null p2)) + (and (pathnamep p1) (pathnamep p2) + (and (=? pathname-host) + #-(and mkcl os-unix) (=? pathname-device) + (=? normalize-pathname-directory-component pathname-directory) + (=? pathname-name) + (=? pathname-type) + #-mkcl (=? pathname-version))))))) + + (defun absolute-pathname-p (pathspec) + "If PATHSPEC is a pathname or namestring object that parses as a pathname +possessing an :ABSOLUTE directory component, return the (parsed) pathname. +Otherwise return NIL" + (and pathspec + (typep pathspec '(or null pathname string)) + (let ((pathname (pathname pathspec))) + (and (eq :absolute (car (normalize-pathname-directory-component + (pathname-directory pathname)))) + pathname)))) + + (defun relative-pathname-p (pathspec) + "If PATHSPEC is a pathname or namestring object that parses as a pathname +possessing a :RELATIVE or NIL directory component, return the (parsed) pathname. +Otherwise return NIL" + (and pathspec + (typep pathspec '(or null pathname string)) + (let* ((pathname (pathname pathspec)) + (directory (normalize-pathname-directory-component + (pathname-directory pathname)))) + (when (or (null directory) (eq :relative (car directory))) + pathname)))) + + (defun hidden-pathname-p (pathname) + "Return a boolean that is true if the pathname is hidden as per Unix style, +i.e. its name starts with a dot." + (and pathname (equal (first-char (pathname-name pathname)) #\.))) + + (defun file-pathname-p (pathname) + "Does PATHNAME represent a file, i.e. has a non-null NAME component? + +Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME. + +Note that this does _not_ check to see that PATHNAME points to an +actually-existing file. + +Returns the (parsed) PATHNAME when true" + (when pathname + (let ((pathname (pathname pathname))) + (unless (and (member (pathname-name pathname) '(nil :unspecific "") :test 'equal) + (member (pathname-type pathname) '(nil :unspecific "") :test 'equal)) + pathname))))) + + +;;; Directory pathnames +(with-upgradability () + (defun pathname-directory-pathname (pathname) + "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME, +and NIL NAME, TYPE and VERSION components" + (when pathname + (make-pathname :name nil :type nil :version nil :defaults pathname))) + + (defun pathname-parent-directory-pathname (pathname) + "Returns a new pathname that corresponds to the parent of the current pathname's directory, +i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is +Unix pathname /foo/bar/baz/file.type then return /foo/bar/" + (when pathname + (make-pathname :name nil :type nil :version nil + :directory (merge-pathname-directory-components + '(:relative :back) (pathname-directory pathname)) + :defaults pathname))) + + (defun directory-pathname-p (pathname) + "Does PATHNAME represent a directory? + +A directory-pathname is a pathname _without_ a filename. The three +ways that the filename components can be missing are for it to be NIL, +:UNSPECIFIC or the empty string. + +Note that this does _not_ check to see that PATHNAME points to an +actually-existing directory." + (when pathname + ;; I tried using Allegro's excl:file-directory-p, but this cannot be done, + ;; because it rejects apparently legal pathnames as + ;; ill-formed. [2014/02/10:rpg] + (let ((pathname (pathname pathname))) + (flet ((check-one (x) + (member x '(nil :unspecific) :test 'equal))) + (and (not (wild-pathname-p pathname)) + (check-one (pathname-name pathname)) + (check-one (pathname-type pathname)) + t))))) + + (defun ensure-directory-pathname (pathspec &optional (on-error 'error)) + "Converts the non-wild pathname designator PATHSPEC to directory form." + (cond + ((stringp pathspec) + (ensure-directory-pathname (pathname pathspec))) + ((not (pathnamep pathspec)) + (call-function on-error (compatfmt "~@") pathspec)) + ((wild-pathname-p pathspec) + (call-function on-error (compatfmt "~@") pathspec)) + ((directory-pathname-p pathspec) + pathspec) + (t + (handler-case + (make-pathname :directory (append (or (normalize-pathname-directory-component + (pathname-directory pathspec)) + (list :relative)) + (list #-genera (file-namestring pathspec) + ;; On Genera's native filesystem (LMFS), + ;; directories have a type and version + ;; which must be ignored when converting + ;; to a directory pathname + #+genera (if (typep pathspec 'fs:lmfs-pathname) + (pathname-name pathspec) + (file-namestring pathspec)))) + :name nil :type nil :version nil :defaults pathspec) + (error (c) (call-function on-error (compatfmt "~@") pathspec c))))))) + + +;;; Parsing filenames +(with-upgradability () + (declaim (ftype function ensure-pathname)) ; forward reference + + (defun split-unix-namestring-directory-components + (unix-namestring &key ensure-directory dot-dot) + "Splits the path string UNIX-NAMESTRING, returning four values: +A flag that is either :absolute or :relative, indicating + how the rest of the values are to be interpreted. +A directory path --- a list of strings and keywords, suitable for + use with MAKE-PATHNAME when prepended with the flag value. + Directory components with an empty name or the name . are removed. + Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP). +A last-component, either a file-namestring including type extension, + or NIL in the case of a directory pathname. +A flag that is true iff the unix-style-pathname was just + a file-namestring without / path specification. +ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname: +the third return value will be NIL, and final component of the namestring +will be treated as part of the directory path. + +An empty string is thus read as meaning a pathname object with all fields nil. + +Note that colon characters #\: will NOT be interpreted as host specification. +Absolute pathnames are only appropriate on Unix-style systems. + +The intention of this function is to support structured component names, +e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames." + (check-type unix-namestring string) + (check-type dot-dot (member nil :back :up)) + (if (and (not (find #\/ unix-namestring)) (not ensure-directory) + (plusp (length unix-namestring))) + (values :relative () unix-namestring t) + (let* ((components (split-string unix-namestring :separator "/")) + (last-comp (car (last components)))) + (multiple-value-bind (relative components) + (if (equal (first components) "") + (if (equal (first-char unix-namestring) #\/) + (values :absolute (cdr components)) + (values :relative nil)) + (values :relative components)) + (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) + components)) + (setf components (substitute (or dot-dot :back) ".." components :test #'equal)) + (cond + ((equal last-comp "") + (values relative components nil nil)) ; "" already removed from components + (ensure-directory + (values relative components nil nil)) + (t + (values relative (butlast components) last-comp nil))))))) + + (defun split-name-type (filename) + "Split a filename into two values NAME and TYPE that are returned. +We assume filename has no directory component. +The last . if any separates name and type from from type, +except that if there is only one . and it is in first position, +the whole filename is the NAME with an empty type. +NAME is always a string. +For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned." + (check-type filename string) + (assert (plusp (length filename))) + (destructuring-bind (name &optional (type *unspecific-pathname-type*)) + (split-string filename :max 2 :separator ".") + (if (equal name "") + (values filename *unspecific-pathname-type*) + (values name type)))) + + (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory + &allow-other-keys) + "Coerce NAME into a PATHNAME using standard Unix syntax. + +Unix syntax is used whether or not the underlying system is Unix; +on such non-Unix systems it is reliably usable only for relative pathnames. +This function is especially useful to manipulate relative pathnames portably, +where it is crucial to possess a portable pathname syntax independent of the underlying OS. +This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF. + +When given a PATHNAME object, just return it untouched. +When given NIL, just return NIL. +When given a non-null SYMBOL, first downcase its name and treat it as a string. +When given a STRING, portably decompose it into a pathname as below. + +#\\/ separates directory components. + +The last #\\/-separated substring is interpreted as follows: +1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true, + the string is made the last directory component, and NAME and TYPE are NIL. + if the string is empty, it's the empty pathname with all slots NIL. +2- If TYPE is NIL, the substring is a file-namestring, and its NAME and TYPE + are separated by SPLIT-NAME-TYPE. +3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME. + +Directory components with an empty name or the name \".\" are removed. +Any directory named \"..\" is read as DOT-DOT, +which must be one of :BACK or :UP and defaults to :BACK. + +HOST, DEVICE and VERSION components are taken from DEFAULTS, +which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS is NIL. +No host or device can be specified in the string itself, +which makes it unsuitable for absolute pathnames outside Unix. + +For relative pathnames, these components (and hence the defaults) won't matter +if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES, +which is an important reason to always use MERGE-PATHNAMES*. + +Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME +with those keys, removing TYPE DEFAULTS and DOT-DOT. +When you're manipulating pathnames that are supposed to make sense portably +even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T +to throw an error if the pathname is absolute" + (block nil + (check-type type (or null string (eql :directory))) + (when ensure-directory + (setf type :directory)) + (etypecase name + ((or null pathname) (return name)) + (symbol + (setf name (string-downcase name))) + (string)) + (multiple-value-bind (relative path filename file-only) + (split-unix-namestring-directory-components + name :dot-dot dot-dot :ensure-directory (eq type :directory)) + (multiple-value-bind (name type) + (cond + ((or (eq type :directory) (null filename)) + (values nil nil)) + (type + (values filename type)) + (t + (split-name-type filename))) + (apply 'ensure-pathname + (make-pathname + :directory (unless file-only (cons relative path)) + :name name :type type + :defaults (or #-mcl defaults *nil-pathname*)) + (remove-plist-keys '(:type :dot-dot :defaults) keys)))))) + + (defun unix-namestring (pathname) + "Given a non-wild PATHNAME, return a Unix-style namestring for it. +If the PATHNAME is NIL or a STRING, return it unchanged. + +This only considers the DIRECTORY, NAME and TYPE components of the pathname. +This is a portable solution for representing relative pathnames, +But unless you are running on a Unix system, it is not a general solution +to representing native pathnames. + +An error is signaled if the argument is not NULL, a STRING or a PATHNAME, +or if it is a PATHNAME but some of its components are not recognized." + (etypecase pathname + ((or null string) pathname) + (pathname + (with-output-to-string (s) + (flet ((err () (parameter-error "~S: invalid unix-namestring ~S" + 'unix-namestring pathname))) + (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname))) + (name (pathname-name pathname)) + (name (and (not (eq name :unspecific)) name)) + (type (pathname-type pathname)) + (type (and (not (eq type :unspecific)) type))) + (cond + ((member dir '(nil :unspecific))) + ((eq dir '(:relative)) (princ "./" s)) + ((consp dir) + (destructuring-bind (relabs &rest dirs) dir + (or (member relabs '(:relative :absolute)) (err)) + (when (eq relabs :absolute) (princ #\/ s)) + (loop :for x :in dirs :do + (cond + ((member x '(:back :up)) (princ "../" s)) + ((equal x "") (err)) + ;;((member x '("." "..") :test 'equal) (err)) + ((stringp x) (format s "~A/" x)) + (t (err)))))) + (t (err))) + (cond + (name + (unless (and (stringp name) (or (null type) (stringp type))) (err)) + (format s "~A~@[.~A~]" name type)) + (t + (or (null type) (err))))))))))) + +;;; Absolute and relative pathnames +(with-upgradability () + (defun subpathname (pathname subpath &key type) + "This function takes a PATHNAME and a SUBPATH and a TYPE. +If SUBPATH is already a PATHNAME object (not namestring), +and is an absolute pathname at that, it is returned unchanged; +otherwise, SUBPATH is turned into a relative pathname with given TYPE +as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE, +then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." + (or (and (pathnamep subpath) (absolute-pathname-p subpath)) + (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t) + (pathname-directory-pathname pathname)))) + + (defun subpathname* (pathname subpath &key type) + "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME." + (and pathname + (subpathname (ensure-directory-pathname pathname) subpath :type type))) + + (defun pathname-root (pathname) + "return the root directory for the host and device of given PATHNAME" + (make-pathname :directory '(:absolute) + :name nil :type nil :version nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + + (defun pathname-host-pathname (pathname) + "return a pathname with the same host as given PATHNAME, and all other fields NIL" + (make-pathname :directory nil + :name nil :type nil :version nil :device nil + :defaults pathname ;; host device, and on scl, *some* + ;; scheme-specific parts: port username password, not others: + . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + + (defun ensure-absolute-pathname (path &optional defaults (on-error 'error)) + "Given a pathname designator PATH, return an absolute pathname as specified by PATH +considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior, +with a format control-string and other arguments as arguments" + (cond + ((absolute-pathname-p path)) + ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error)) + ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) + ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults)))) + (or (if (absolute-pathname-p default-pathname) + (absolute-pathname-p (merge-pathnames* path default-pathname)) + (call-function on-error "Default pathname ~S is not an absolute pathname" + default-pathname)) + (call-function on-error "Failed to merge ~S with ~S into an absolute pathname" + path default-pathname)))) + (t (call-function on-error + "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" + path defaults)))) + + (defun subpathp (maybe-subpath base-pathname) + "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that +when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." + (and (pathnamep maybe-subpath) (pathnamep base-pathname) + (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname) + (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname)) + (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname)) + (with-pathname-defaults (*nil-pathname*) + (let ((enough (enough-namestring maybe-subpath base-pathname))) + (and (relative-pathname-p enough) (pathname enough)))))) + + (defun enough-pathname (maybe-subpath base-pathname) + "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that +when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." + (let ((sub (when maybe-subpath (pathname maybe-subpath))) + (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname))))) + (or (and base (subpathp sub base)) sub))) + + (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk) + "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null, +or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH +given DEFAULTS-PATHNAME as a base pathname." + (let ((enough (enough-pathname maybe-subpath defaults-pathname)) + (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*))) + (funcall thunk enough))) + + (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var) + (defaults *default-pathname-defaults*)) + &body body) + "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME" + `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body)))) + + +;;; Wildcard pathnames +(with-upgradability () + (defparameter *wild* (or #+cormanlisp "*" :wild) + "Wild component for use with MAKE-PATHNAME") + (defparameter *wild-directory-component* (or :wild) + "Wild directory component for use with MAKE-PATHNAME") + (defparameter *wild-inferiors-component* (or :wild-inferiors) + "Wild-inferiors directory component for use with MAKE-PATHNAME") + (defparameter *wild-file* + (make-pathname :directory nil :name *wild* :type *wild* + :version (or #-(or allegro abcl xcl) *wild*)) + "A pathname object with wildcards for matching any file with TRANSLATE-PATHNAME") + (defparameter *wild-file-for-directory* + (make-pathname :directory nil :name *wild* :type (or #-(or clisp gcl) *wild*) + :version (or #-(or allegro abcl clisp gcl xcl) *wild*)) + "A pathname object with wildcards for matching any file with DIRECTORY") + (defparameter *wild-directory* + (make-pathname :directory `(:relative ,*wild-directory-component*) + :name nil :type nil :version nil) + "A pathname object with wildcards for matching any subdirectory") + (defparameter *wild-inferiors* + (make-pathname :directory `(:relative ,*wild-inferiors-component*) + :name nil :type nil :version nil) + "A pathname object with wildcards for matching any recursive subdirectory") + (defparameter *wild-path* + (merge-pathnames* *wild-file* *wild-inferiors*) + "A pathname object with wildcards for matching any file in any recursive subdirectory") + + (defun wilden (path) + "From a pathname, return a wildcard pathname matching any file in any subdirectory of given pathname's directory" + (merge-pathnames* *wild-path* path))) + + +;;; Translate a pathname +(with-upgradability () + (defun relativize-directory-component (directory-component) + "Given the DIRECTORY-COMPONENT of a pathname, return an otherwise similar relative directory component" + (let ((directory (normalize-pathname-directory-component directory-component))) + (cond + ((stringp directory) + (list :relative directory)) + ((eq (car directory) :absolute) + (cons :relative (cdr directory))) + (t + directory)))) + + (defun relativize-pathname-directory (pathspec) + "Given a PATHNAME, return a relative pathname with otherwise the same components" + (let ((p (pathname pathspec))) + (make-pathname + :directory (relativize-directory-component (pathname-directory p)) + :defaults p))) + + (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) + "Given a PATHNAME, return the character used to delimit directory names on this host and device." + (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) + (last-char (namestring foo)))) + + #-scl + (defun directorize-pathname-host-device (pathname) + "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components +added to its DIRECTORY component. This is useful for output translations." + (os-cond + ((os-unix-p) + (when (physical-pathname-p pathname) + (return-from directorize-pathname-host-device pathname)))) + (let* ((root (pathname-root pathname)) + (wild-root (wilden root)) + (absolute-pathname (merge-pathnames* pathname root)) + (separator (directory-separator-for-host root)) + (root-namestring (namestring root)) + (root-string + (substitute-if #\/ + #'(lambda (x) (or (eql x #\:) + (eql x separator))) + root-namestring))) + (multiple-value-bind (relative path filename) + (split-unix-namestring-directory-components root-string :ensure-directory t) + (declare (ignore relative filename)) + (let ((new-base (make-pathname :defaults root :directory `(:absolute ,@path)))) + (translate-pathname absolute-pathname wild-root (wilden new-base)))))) + + #+scl + (defun directorize-pathname-host-device (pathname) + (let ((scheme (ext:pathname-scheme pathname)) + (host (pathname-host pathname)) + (port (ext:pathname-port pathname)) + (directory (pathname-directory pathname))) + (flet ((specificp (x) (and x (not (eq x :unspecific))))) + (if (or (specificp port) + (and (specificp host) (plusp (length host))) + (specificp scheme)) + (let ((prefix "")) + (when (specificp port) + (setf prefix (format nil ":~D" port))) + (when (and (specificp host) (plusp (length host))) + (setf prefix (strcat host prefix))) + (setf prefix (strcat ":" prefix)) + (when (specificp scheme) + (setf prefix (strcat scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + pathname))) + + (defun translate-pathname* (path absolute-source destination &optional root source) + "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility. +PATH is the pathname to be translated. +ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname, +DESTINATION is either a function, to be called with PATH and ABSOLUTE-SOURCE, +or a relative pathname, to be merged with ROOT and used as destination for translate-pathname +or an absolute pathname, to be used as destination for translate-pathname. +In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZE-PATHNAME-HOST-DEVICE." + (declare (ignore source)) + (cond + ((functionp destination) + (funcall destination path absolute-source)) + ((eq destination t) + path) + ((not (pathnamep destination)) + (parameter-error "~S: Invalid destination" 'translate-pathname*)) + ((not (absolute-pathname-p destination)) + (translate-pathname path absolute-source (merge-pathnames* destination root))) + (root + (translate-pathname (directorize-pathname-host-device path) absolute-source destination)) + (t + (translate-pathname path absolute-source destination)))) + + (defvar *output-translation-function* 'identity + "Hook for output translations. + +This function needs to be idempotent, so that actions can work +whether their inputs were translated or not, +which they will be if we are composing operations. e.g. if some +create-lisp-op creates a lisp file from some higher-level input, +you need to still be able to use compile-op on that lisp file.")) +;;;; ------------------------------------------------------------------------- +;;;; Portability layer around Common Lisp filesystem access + +(uiop/package:define-package :uiop/filesystem + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname) + (:export + ;; Native namestrings + #:native-namestring #:parse-native-namestring + ;; Probing the filesystem + #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p + #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories + #:collect-sub*directories + ;; Resolving symlinks somewhat + #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks* + ;; merging with cwd + #:get-pathname-defaults #:call-with-current-directory #:with-current-directory + ;; Environment pathnames + #:inter-directory-separator #:split-native-pathnames-string + #:getenv-pathname #:getenv-pathnames + #:getenv-absolute-directory #:getenv-absolute-directories + #:lisp-implementation-directory #:lisp-implementation-pathname-p + ;; Simple filesystem operations + #:ensure-all-directories-exist + #:rename-file-overwriting-target + #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree)) +(in-package :uiop/filesystem) + +;;; Native namestrings, as seen by the operating system calls rather than Lisp +(with-upgradability () + (defun native-namestring (x) + "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system" + (when x + (let ((p (pathname x))) + #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978 + #+(or cmucl scl) (ext:unix-namestring p nil) + #+sbcl (sb-ext:native-namestring p) + #-(or clozure cmucl sbcl scl) + (os-cond + ((os-unix-p) (unix-namestring p)) + (t (namestring p)))))) + + (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys) + "From a native namestring suitable for use by the operating system, return +a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" + (check-type string (or string null)) + (let* ((pathname + (when string + (with-pathname-defaults () + #+clozure (ccl:native-to-pathname string) + #+cmucl (uiop/os::parse-unix-namestring* string) + #+sbcl (sb-ext:parse-native-namestring string) + #+scl (lisp::parse-unix-namestring string) + #-(or clozure cmucl sbcl scl) + (os-cond + ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory)) + (t (parse-namestring string)))))) + (pathname + (if ensure-directory + (and pathname (ensure-directory-pathname pathname)) + pathname))) + (apply 'ensure-pathname pathname constraints)))) + + +;;; Probing the filesystem +(with-upgradability () + (defun truename* (p) + "Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories" + (when p + (when (stringp p) (setf p (with-pathname-defaults () (parse-namestring p)))) + (values + (or (ignore-errors (truename p)) + ;; this is here because trying to find the truename of a directory pathname WITHOUT supplying + ;; a trailing directory separator, causes an error on some lisps. + #+(or clisp gcl) (if-let (d (ensure-directory-pathname p nil)) (ignore-errors (truename d))) + ;; On Genera, truename of a directory pathname will probably fail as Genera + ;; will merge in a filename/type/version from *default-pathname-defaults* and + ;; will try to get the truename of a file that probably doesn't exist. + #+genera (when (directory-pathname-p p) + (let ((d (scl:send p :directory-pathname-as-file))) + (ensure-directory-pathname (ignore-errors (truename d)) nil))))))) + + (defun safe-file-write-date (pathname) + "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error." + ;; If FILE-WRITE-DATE returns NIL, it's possible that + ;; the user or some other agent has deleted an input file. + ;; Also, generated files will not exist at the time planning is done + ;; and calls compute-action-stamp which calls safe-file-write-date. + ;; So it is very possible that we can't get a valid file-write-date, + ;; and we can survive and we will continue the planning + ;; as if the file were very old. + ;; (or should we treat the case in a different, special way?) + (and pathname + (handler-case (file-write-date (physicalize-pathname pathname)) + (file-error () nil)))) + + (defun probe-file* (p &key truename) + "when given a pathname P (designated by a string as per PARSE-NAMESTRING), +probes the filesystem for a file or directory with given pathname. +If it exists, return its truename if TRUENAME is true, +or the original (parsed) pathname if it is false (the default)." + (values + (ignore-errors + (setf p (funcall 'ensure-pathname p + :namestring :lisp + :ensure-physical t + :ensure-absolute t :defaults 'get-pathname-defaults + :want-non-wild t + :on-error nil)) + (when p + #+allegro + (probe-file p :follow-symlinks truename) + #+gcl + (if truename + (truename* p) + (let ((kind (car (si::stat p)))) + (when (eq kind :link) + (setf kind (ignore-errors (car (si::stat (truename* p)))))) + (ecase kind + ((nil) nil) + ((:file :link) + (cond + ((file-pathname-p p) p) + ((directory-pathname-p p) + (subpathname p (car (last (pathname-directory p))))))) + (:directory (ensure-directory-pathname p))))) + #+clisp + #.(let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil))) + (pp (find-symbol* '#:probe-pathname :ext nil))) + `(if truename + ,(if pp + `(values (,pp p)) + '(or (truename* p) + (truename* (ignore-errors (ensure-directory-pathname p))))) + ,(cond + (fs `(and (,fs p) p)) + (pp `(nth-value 1 (,pp p))) + (t '(or (and (truename* p) p) + (if-let (d (ensure-directory-pathname p)) + (and (truename* d) d))))))) + #-(or allegro clisp gcl) + (if truename + (probe-file p) + (and + #+(or cmucl scl) (unix:unix-stat (ext:unix-namestring p)) + #+(and lispworks os-unix) (system:get-file-stat p) + #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring p)) + #-(or cmucl (and lispworks os-unix) sbcl scl) (file-write-date p) + p)))))) + + (defun directory-exists-p (x) + "Is X the name of a directory that exists on the filesystem?" + #+allegro + (excl:probe-directory x) + #+clisp + (handler-case (ext:probe-directory x) + (sys::simple-file-error () + nil)) + #-(or allegro clisp) + (let ((p (probe-file* x :truename t))) + (and (directory-pathname-p p) p))) + + (defun file-exists-p (x) + "Is X the name of a file that exists on the filesystem?" + (let ((p (probe-file* x :truename t))) + (and (file-pathname-p p) p))) + + (defun directory* (pathname-spec &rest keys &key &allow-other-keys) + "Return a list of the entries in a directory by calling DIRECTORY. +Try to override the defaults to not resolving symlinks, if implementation allows." + (apply 'directory pathname-spec + (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) + #+(or clozure digitool) '(:follow-links nil) + #+clisp '(:circle t :if-does-not-exist :ignore) + #+(or cmucl scl) '(:follow-links nil :truenamep nil) + #+lispworks '(:link-transparency nil) + #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) + '(:resolve-symlinks nil)))))) + + (defun filter-logical-directory-results (directory entries merger) + "If DIRECTORY isn't a logical pathname, return ENTRIES. If it is, +given ENTRIES in the DIRECTORY, remove the entries which are physical yet +when transformed by MERGER have a different TRUENAME. +Also remove duplicates as may appear with some translation rules. +This function is used as a helper to DIRECTORY-FILES to avoid invalid entries +when using logical-pathnames." + (if (logical-pathname-p directory) + (remove-duplicates ;; on CLISP, querying ~/ will return duplicates + ;; Try hard to not resolve logical-pathname into physical pathnames; + ;; otherwise logical-pathname users/lovers will be disappointed. + ;; If directory* could use some implementation-dependent magic, + ;; we will have logical pathnames already; otherwise, + ;; we only keep pathnames for which specifying the name and + ;; translating the LPN commute. + (loop :for f :in entries + :for p = (or (and (logical-pathname-p f) f) + (let* ((u (ignore-errors (call-function merger f)))) + ;; The first u avoids a cumbersome (truename u) error. + ;; At this point f should already be a truename, + ;; but isn't quite in CLISP, for it doesn't have :version :newest + (and u (equal (truename* u) (truename* f)) u))) + :when p :collect p) + :test 'pathname-equal) + entries)) + + (defun directory-files (directory &optional (pattern *wild-file-for-directory*)) + "Return a list of the files in a directory according to the PATTERN. +Subdirectories should NOT be returned. + PATTERN defaults to a pattern carefully chosen based on the implementation; +override the default at your own risk. + DIRECTORY-FILES tries NOT to resolve symlinks if the implementation permits this, +but the behavior in presence of symlinks is not portable. Use IOlib to handle such situations." + (let ((dir (ensure-directory-pathname directory))) + (when (logical-pathname-p dir) + ;; Because of the filtering we do below, + ;; logical pathnames have restrictions on wild patterns. + ;; Not that the results are very portable when you use these patterns on physical pathnames. + (when (wild-pathname-p dir) + (parameter-error "~S: Invalid wild pattern in logical directory ~S" + 'directory-files directory)) + (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) + (parameter-error "~S: Invalid file pattern ~S for logical directory ~S" 'directory-files pattern directory)) + (setf pattern (make-pathname-logical pattern (pathname-host dir)))) + (let* ((pat (merge-pathnames* pattern dir)) + (entries (ignore-errors (directory* pat)))) + (remove-if 'directory-pathname-p + (filter-logical-directory-results + directory entries + #'(lambda (f) + (make-pathname :defaults dir + :name (make-pathname-component-logical (pathname-name f)) + :type (make-pathname-component-logical (pathname-type f)) + :version (make-pathname-component-logical (pathname-version f))))))))) + + (defun subdirectories (directory) + "Given a DIRECTORY pathname designator, return a list of the subdirectories under it. +The behavior in presence of symlinks is not portable. Use IOlib to handle such situations." + (let* ((directory (ensure-directory-pathname directory)) + #-(or abcl cormanlisp genera xcl) + (wild (merge-pathnames* + #-(or abcl allegro cmucl lispworks sbcl scl xcl) + *wild-directory* + #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*" + directory)) + (dirs + #-(or abcl cormanlisp genera xcl) + (ignore-errors + (directory* wild . #.(or #+clozure '(:directories t :files nil) + #+mcl '(:directories t)))) + #+(or abcl xcl) (system:list-directory directory) + #+cormanlisp (cl::directory-subdirs directory) + #+genera (handler-case (fs:directory-list directory) (fs:directory-not-found () nil))) + #+(or abcl allegro cmucl genera lispworks sbcl scl xcl) + (dirs (loop :for x :in dirs + :for d = #+(or abcl xcl) (extensions:probe-directory x) + #+allegro (excl:probe-directory x) + #+(or cmucl sbcl scl) (directory-pathname-p x) + #+genera (getf (cdr x) :directory) + #+lispworks (lw:file-directory-p x) + :when d :collect #+(or abcl allegro xcl) (ensure-directory-pathname d) + #+genera (ensure-directory-pathname (first x)) + #+(or cmucl lispworks sbcl scl) x))) + (filter-logical-directory-results + directory dirs + (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory)) + '(:absolute)))) ; because allegro returns NIL for #p"FOO:" + #'(lambda (d) + (let ((dir (normalize-pathname-directory-component (pathname-directory d)))) + (and (consp dir) (consp (cdr dir)) + (make-pathname + :defaults directory :name nil :type nil :version nil + :directory (append prefix (make-pathname-component-logical (last dir))))))))))) + + (defun collect-sub*directories (directory collectp recursep collector) + "Given a DIRECTORY, when COLLECTP returns true when CALL-FUNCTION'ed with the directory, +call-function the COLLECTOR function designator on the directory, +and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them. +This function will thus let you traverse a filesystem hierarchy, +superseding the functionality of CL-FAD:WALK-DIRECTORY. +The behavior in presence of symlinks is not portable. Use IOlib to handle such situations." + (when (call-function collectp directory) + (call-function collector directory) + (dolist (subdir (subdirectories directory)) + (when (call-function recursep subdir) + (collect-sub*directories subdir collectp recursep collector)))))) + +;;; Resolving symlinks somewhat +(with-upgradability () + (defun truenamize (pathname) + "Resolve as much of a pathname as possible" + (block nil + (when (typep pathname '(or null logical-pathname)) (return pathname)) + (let ((p pathname)) + (unless (absolute-pathname-p p) + (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil)) + (return p)))) + (when (logical-pathname-p p) (return p)) + (let ((found (probe-file* p :truename t))) + (when found (return found))) + (let* ((directory (normalize-pathname-directory-component (pathname-directory p))) + (up-components (reverse (rest directory))) + (down-components ())) + (assert (eq :absolute (first directory))) + (loop :while up-components :do + (if-let (parent + (ignore-errors + (probe-file* (make-pathname :directory `(:absolute ,@(reverse up-components)) + :name nil :type nil :version nil :defaults p)))) + (if-let (simplified + (ignore-errors + (merge-pathnames* + (make-pathname :directory `(:relative ,@down-components) + :defaults p) + (ensure-directory-pathname parent)))) + (return simplified))) + (push (pop up-components) down-components) + :finally (return p)))))) + + (defun resolve-symlinks (path) + "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH." + #-allegro (truenamize path) + #+allegro + (if (physical-pathname-p path) + (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path) + path)) + + (defvar *resolve-symlinks* t + "Determine whether or not ASDF resolves symlinks when defining systems. +Defaults to T.") + + (defun resolve-symlinks* (path) + "RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)." + (if *resolve-symlinks* + (and path (resolve-symlinks path)) + path))) + + +;;; Check pathname constraints +(with-upgradability () + (defun ensure-pathname + (pathname &key + on-error + defaults type dot-dot namestring + empty-is-nil + want-pathname + want-logical want-physical ensure-physical + want-relative want-absolute ensure-absolute ensure-subpath + want-non-wild want-wild wilden + want-file want-directory ensure-directory + want-existing ensure-directories-exist + truename resolve-symlinks truenamize + &aux (p pathname)) ;; mutable working copy, preserve original + "Coerces its argument into a PATHNAME, +optionally doing some transformations and checking specified constraints. + +If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified. + +If the argument is a STRING, it is first converted to a pathname via +PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively +depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively, +or else by using CALL-FUNCTION on the NAMESTRING argument; +if :UNIX is specified (or NIL, the default, which specifies the same thing), +then PARSE-UNIX-NAMESTRING it is called with the keywords +DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and +the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true. + +The pathname passed or resulting from parsing the string +is then subjected to all the checks and transformations below are run. + +Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE. +The boolean T is an alias for ERROR. +ERROR means that an error will be raised if the constraint is not satisfied. +CERROR means that an continuable error will be raised if the constraint is not satisfied. +IGNORE means just return NIL instead of the pathname. + +The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION) +that will be called with the the following arguments: +a generic format string for ensure pathname, the pathname, +the keyword argument corresponding to the failed check or transformation, +a format string for the reason ENSURE-PATHNAME failed, +and a list with arguments to that format string. +If ON-ERROR is NIL, ERROR is used instead, which does the right thing. +You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\"). + +The transformations and constraint checks are done in this order, +which is also the order in the lambda-list: + +EMPTY-IS-NIL returns NIL if the argument is an empty string. +WANT-PATHNAME checks that pathname (after parsing if needed) is not null. +Otherwise, if the pathname is NIL, ensure-pathname returns NIL. +WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME +WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME +ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME +WANT-RELATIVE checks that pathname has a relative directory component +WANT-ABSOLUTE checks that pathname does have an absolute directory component +ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again +that the result absolute is an absolute pathname indeed. +ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS. +WANT-FILE checks that pathname has a non-nil FILE component +WANT-DIRECTORY checks that pathname has nil FILE and TYPE components +ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret +any file and type components as being actually a last directory component. +WANT-NON-WILD checks that pathname is not a wild pathname +WANT-WILD checks that pathname is a wild pathname +WILDEN merges the pathname with **/*.*.* if it is not wild +WANT-EXISTING checks that a file (or directory) exists with that pathname. +ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST. +TRUENAME replaces the pathname by its truename, or errors if not possible. +RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS. +TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." + (block nil + (flet ((report-error (keyword description &rest arguments) + (call-function (or on-error 'error) + "Invalid pathname ~S: ~*~?" + pathname keyword description arguments))) + (macrolet ((err (constraint &rest arguments) + `(report-error ',(intern* constraint :keyword) ,@arguments)) + (check (constraint condition &rest arguments) + `(when ,constraint + (unless ,condition (err ,constraint ,@arguments)))) + (transform (transform condition expr) + `(when ,transform + (,@(if condition `(when ,condition) '(progn)) + (setf p ,expr))))) + (etypecase p + ((or null pathname)) + (string + (when (and (emptyp p) empty-is-nil) + (return-from ensure-pathname nil)) + (setf p (case namestring + ((:unix nil) + (parse-unix-namestring + p :defaults defaults :type type :dot-dot dot-dot + :ensure-directory ensure-directory :want-relative want-relative)) + ((:native) + (parse-native-namestring p)) + ((:lisp) + (parse-namestring p)) + (t + (call-function namestring p)))))) + (etypecase p + (pathname) + (null + (check want-pathname (pathnamep p) "Expected a pathname, not NIL") + (return nil))) + (check want-logical (logical-pathname-p p) "Expected a logical pathname") + (check want-physical (physical-pathname-p p) "Expected a physical pathname") + (transform ensure-physical () (physicalize-pathname p)) + (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname") + (check want-relative (relative-pathname-p p) "Expected a relative pathname") + (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname") + (transform ensure-absolute (not (absolute-pathname-p p)) + (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?"))) + (check ensure-absolute (absolute-pathname-p p) + "Could not make into an absolute pathname even after merging with ~S" defaults) + (check ensure-subpath (absolute-pathname-p defaults) + "cannot be checked to be a subpath of non-absolute pathname ~S" defaults) + (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults) + (check want-file (file-pathname-p p) "Expected a file pathname") + (check want-directory (directory-pathname-p p) "Expected a directory pathname") + (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p)) + (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname") + (check want-wild (wild-pathname-p p) "Expected a wildcard pathname") + (transform wilden (not (wild-pathname-p p)) (wilden p)) + (when want-existing + (let ((existing (probe-file* p :truename truename))) + (if existing + (when truename + (return existing)) + (err want-existing "Expected an existing pathname")))) + (when ensure-directories-exist (ensure-directories-exist p)) + (when truename + (let ((truename (truename* p))) + (if truename + (return truename) + (err truename "Can't get a truename for pathname")))) + (transform resolve-symlinks () (resolve-symlinks p)) + (transform truenamize () (truenamize p)) + p))))) + + +;;; Pathname defaults +(with-upgradability () + (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*)) + "Find the actual DEFAULTS to use for pathnames, including +resolving them with respect to GETCWD if the DEFAULTS were relative" + (or (absolute-pathname-p defaults) + (merge-pathnames* defaults (getcwd)))) + + (defun call-with-current-directory (dir thunk) + "call the THUNK in a context where the current directory was changed to DIR, if not NIL. +Note that this operation is usually NOT thread-safe." + (if dir + (let* ((dir (resolve-symlinks* + (get-pathname-defaults + (ensure-directory-pathname + dir)))) + (cwd (getcwd)) + (*default-pathname-defaults* dir)) + (chdir dir) + (unwind-protect + (funcall thunk) + (chdir cwd))) + (funcall thunk))) + + (defmacro with-current-directory ((&optional dir) &body body) + "Call BODY while the POSIX current working directory is set to DIR" + `(call-with-current-directory ,dir #'(lambda () ,@body)))) + + +;;; Environment pathnames +(with-upgradability () + (defun inter-directory-separator () + "What character does the current OS conventionally uses to separate directories?" + (os-cond ((os-unix-p) #\:) (t #\;))) + + (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys) + "Given a string of pathnames specified in native OS syntax, separate them in a list, +check constraints and normalize each one as per ENSURE-PATHNAME, +where an empty string denotes NIL." + (loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) + :collect (unless (emptyp namestring) (apply 'parse-native-namestring namestring constraints)))) + + (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys) + "Extract a pathname from a user-configured environment variable, as per native OS, +check constraints and normalize as per ENSURE-PATHNAME." + ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory + (apply 'parse-native-namestring (getenvp x) + :ensure-directory (or ensure-directory want-directory) + :on-error (or on-error + `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x)) + constraints)) + (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys) + "Extract a list of pathname from a user-configured environment variable, as per native OS, +check constraints and normalize each one as per ENSURE-PATHNAME. + Any empty entries in the environment variable X will be returned as NILs." + (unless (getf constraints :empty-is-nil t) + (parameter-error "Cannot have EMPTY-IS-NIL false for ~S" 'getenv-pathnames)) + (apply 'split-native-pathnames-string (getenvp x) + :on-error (or on-error + `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x)) + :empty-is-nil t + constraints)) + (defun getenv-absolute-directory (x) + "Extract an absolute directory pathname from a user-configured environment variable, +as per native OS" + (getenv-pathname x :want-absolute t :ensure-directory t)) + (defun getenv-absolute-directories (x) + "Extract a list of absolute directories from a user-configured environment variable, +as per native OS. Any empty entries in the environment variable X will be returned as +NILs." + (getenv-pathnames x :want-absolute t :ensure-directory t)) + + (defun lisp-implementation-directory (&key truename) + "Where are the system files of the current installation of the CL implementation?" + (declare (ignorable truename)) + (let ((dir + #+abcl extensions:*lisp-home* + #+(or allegro clasp ecl mkcl) #p"SYS:" + #+clisp custom:*lib-directory* + #+clozure #p"ccl:" + #+cmucl (ignore-errors (pathname-parent-directory-pathname (truename #p"modules:"))) + #+gcl system::*system-directory* + #+lispworks lispworks:*lispworks-directory* + #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) + (funcall it) + (getenv-pathname "SBCL_HOME" :ensure-directory t)) + #+scl (ignore-errors (pathname-parent-directory-pathname (truename #p"file://modules/"))) + #+xcl ext:*xcl-home*)) + (if (and dir truename) + (truename* dir) + dir))) + + (defun lisp-implementation-pathname-p (pathname) + "Is the PATHNAME under the current installation of the CL implementation?" + ;; Other builtin systems are those under the implementation directory + (and (when pathname + (if-let (impdir (lisp-implementation-directory)) + (or (subpathp pathname impdir) + (when *resolve-symlinks* + (if-let (truename (truename* pathname)) + (if-let (trueimpdir (truename* impdir)) + (subpathp truename trueimpdir))))))) + t))) + + +;;; Simple filesystem operations +(with-upgradability () + (defun ensure-all-directories-exist (pathnames) + "Ensure that for every pathname in PATHNAMES, we ensure its directories exist" + (dolist (pathname pathnames) + (when pathname + (ensure-directories-exist (physicalize-pathname pathname))))) + + (defun delete-file-if-exists (x) + "Delete a file X if it already exists" + (when x (handler-case (delete-file x) (file-error () nil)))) + + (defun rename-file-overwriting-target (source target) + "Rename a file, overwriting any previous file with the TARGET name, +in an atomic way if the implementation allows." + (let ((source (ensure-pathname source :namestring :lisp :ensure-physical t :want-file t)) + (target (ensure-pathname target :namestring :lisp :ensure-physical t :want-file t))) + #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic + (progn (funcall 'require "syscalls") + (symbol-call :posix :copy-file source target :method :rename)) + #+(and sbcl os-windows) (delete-file-if-exists target) ;; not atomic + #-clisp + (rename-file source target + #+(or clasp clozure ecl) :if-exists + #+clozure :rename-and-delete #+(or clasp ecl) t))) + + (defun delete-empty-directory (directory-pathname) + "Delete an empty directory" + #+(or abcl digitool gcl) (delete-file directory-pathname) + #+allegro (excl:delete-directory directory-pathname) + #+clisp (ext:delete-directory directory-pathname) + #+clozure (ccl::delete-empty-directory directory-pathname) + #+(or cmucl scl) (multiple-value-bind (ok errno) + (unix:unix-rmdir (native-namestring directory-pathname)) + (unless ok + #+cmucl (error "Error number ~A when trying to delete directory ~A" + errno directory-pathname) + #+scl (error "~@" + directory-pathname (unix:get-unix-error-msg errno)))) + #+cormanlisp (win32:delete-directory directory-pathname) + #+(or clasp ecl) (si:rmdir directory-pathname) + #+genera (fs:delete-directory directory-pathname) + #+lispworks (lw:delete-directory directory-pathname) + #+mkcl (mkcl:rmdir directory-pathname) + #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) + `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later + `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) + #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname))) + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) + (not-implemented-error 'delete-empty-directory "(on your platform)")) ; genera + + (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) + "Delete a directory including all its recursive contents, aka rm -rf. + +To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be +a physical non-wildcard directory pathname (not namestring). + +If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens: +if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done. + +Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass +the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument +which in practice is thus compulsory, and validates by returning a non-NIL result. +If you're suicidal or extremely confident, just use :VALIDATE T." + (check-type if-does-not-exist (member :error :ignore)) + (setf directory-pathname (ensure-pathname directory-pathname + :want-pathname t :want-non-wild t + :want-physical t :want-directory t)) + (cond + ((not validatep) + (parameter-error "~S was asked to delete ~S but was not provided a validation predicate" + 'delete-directory-tree directory-pathname)) + ((not (call-function validate directory-pathname)) + (parameter-error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]" + 'delete-directory-tree directory-pathname validate)) + ((not (directory-exists-p directory-pathname)) + (ecase if-does-not-exist + (:error + (error "~S was asked to delete ~S but the directory does not exist" + 'delete-directory-tree directory-pathname)) + (:ignore nil))) + #-(or allegro cmucl clozure genera sbcl scl) + ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, + ;; except on implementations where we can prevent DIRECTORY from following symlinks; + ;; instead spawn a standard external program to do the dirty work. + (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname)))) + (t + ;; On supported implementation, call supported system functions + #+allegro (symbol-call :excl.osi :delete-directory-and-files + directory-pathname :if-does-not-exist if-does-not-exist) + #+clozure (ccl:delete-directory directory-pathname) + #+genera (fs:delete-directory directory-pathname :confirm nil) + #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) + `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later + '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree)) + ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks, + ;; do things the hard way. + #-(or allegro clozure genera sbcl) + (let ((sub*directories + (while-collecting (c) + (collect-sub*directories directory-pathname t t #'c)))) + (dolist (d (nreverse sub*directories)) + (map () 'delete-file (directory-files d)) + (delete-empty-directory d))))))) +;;;; --------------------------------------------------------------------------- +;;;; Utilities related to streams + +(uiop/package:define-package :uiop/stream + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem) + (:export + #:*default-stream-element-type* + #:*stdin* #:setup-stdin #:*stdout* #:setup-stdout #:*stderr* #:setup-stderr + #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding + #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format + #:*default-encoding* #:*utf-8-external-format* + #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string + #:with-output #:output-string #:with-input #:input-string + #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file + #:null-device-pathname #:call-with-null-input #:with-null-input + #:call-with-null-output #:with-null-output + #:finish-outputs #:format! #:safe-format! + #:copy-stream-to-stream #:concatenate-files #:copy-file + #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line + #:slurp-stream-forms #:slurp-stream-form + #:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line + #:read-file-forms #:read-file-form #:safe-read-file-form + #:eval-input #:eval-thunk #:standard-eval-thunk + #:println #:writeln + #:file-stream-p #:file-or-synonym-stream-p + ;; Temporary files + #:*temporary-directory* #:temporary-directory #:default-temporary-directory + #:setup-temporary-directory + #:call-with-temporary-file #:with-temporary-file + #:add-pathname-suffix #:tmpize-pathname + #:call-with-staging-pathname #:with-staging-pathname)) +(in-package :uiop/stream) + +(with-upgradability () + (defvar *default-stream-element-type* + (or #+(or abcl cmucl cormanlisp scl xcl) 'character + #+lispworks 'lw:simple-char + :default) + "default element-type for open (depends on the current CL implementation)") + + (defvar *stdin* *standard-input* + "the original standard input stream at startup") + + (defun setup-stdin () + (setf *stdin* + #.(or #+clozure 'ccl::*stdin* + #+(or cmucl scl) 'system:*stdin* + #+(or clasp ecl) 'ext::+process-standard-input+ + #+sbcl 'sb-sys:*stdin* + '*standard-input*))) + + (defvar *stdout* *standard-output* + "the original standard output stream at startup") + + (defun setup-stdout () + (setf *stdout* + #.(or #+clozure 'ccl::*stdout* + #+(or cmucl scl) 'system:*stdout* + #+(or clasp ecl) 'ext::+process-standard-output+ + #+sbcl 'sb-sys:*stdout* + '*standard-output*))) + + (defvar *stderr* *error-output* + "the original error output stream at startup") + + (defun setup-stderr () + (setf *stderr* + #.(or #+allegro 'excl::*stderr* + #+clozure 'ccl::*stderr* + #+(or cmucl scl) 'system:*stderr* + #+(or clasp ecl) 'ext::+process-error-output+ + #+sbcl 'sb-sys:*stderr* + '*error-output*))) + + ;; Run them now. In image.lisp, we'll register them to be run at image restart. + (setup-stdin) (setup-stdout) (setup-stderr)) + + +;;; Encodings (mostly hooks only; full support requires asdf-encodings) +(with-upgradability () + (defparameter *default-encoding* + ;; preserve explicit user changes to something other than the legacy default :default + (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*))) + (unless (eq previous :default) previous)) + :utf-8) + "Default encoding for source files. +The default value :utf-8 is the portable thing. +The legacy behavior was :default. +If you (asdf:load-system :asdf-encodings) then +you will have autodetection via *encoding-detection-hook* below, +reading emacs-style -*- coding: utf-8 -*- specifications, +and falling back to utf-8 or latin1 if nothing is specified.") + + (defparameter *utf-8-external-format* + (if (featurep :asdf-unicode) + (or #+clisp charset:utf-8 :utf-8) + :default) + "Default :external-format argument to pass to CL:OPEN and also +CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file. +On modern implementations, this will decode UTF-8 code points as CL characters. +On legacy implementations, it may fall back on some 8-bit encoding, +with non-ASCII code points being read as several CL characters; +hopefully, if done consistently, that won't affect program behavior too much.") + + (defun always-default-encoding (pathname) + "Trivial function to use as *encoding-detection-hook*, +always 'detects' the *default-encoding*" + (declare (ignore pathname)) + *default-encoding*) + + (defvar *encoding-detection-hook* #'always-default-encoding + "Hook for an extension to define a function to automatically detect a file's encoding") + + (defun detect-encoding (pathname) + "Detects the encoding of a specified file, going through user-configurable hooks" + (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname)) + (funcall *encoding-detection-hook* pathname) + *default-encoding*)) + + (defun default-encoding-external-format (encoding) + "Default, ignorant, function to transform a character ENCODING as a +portable keyword to an implementation-dependent EXTERNAL-FORMAT specification. +Load system ASDF-ENCODINGS to hook in a better one." + (case encoding + (:default :default) ;; for backward-compatibility only. Explicit usage discouraged. + (:utf-8 *utf-8-external-format*) + (otherwise + (cerror "Continue using :external-format :default" (compatfmt "~@") encoding) + :default))) + + (defvar *encoding-external-format-hook* + #'default-encoding-external-format + "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping +from non-default encodings to and implementation-defined external-format's") + + (defun encoding-external-format (encoding) + "Transform a portable ENCODING keyword to an implementation-dependent EXTERNAL-FORMAT, +going through all the proper hooks." + (funcall *encoding-external-format-hook* (or encoding *default-encoding*)))) + + +;;; Safe syntax +(with-upgradability () + (defvar *standard-readtable* (with-standard-io-syntax *readtable*) + "The standard readtable, implementing the syntax specified by the CLHS. +It must never be modified, though only good implementations will even enforce that.") + + (defmacro with-safe-io-syntax ((&key (package :cl)) &body body) + "Establish safe CL reader options around the evaluation of BODY" + `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body)))) + + (defun call-with-safe-io-syntax (thunk &key (package :cl)) + (with-standard-io-syntax + (let ((*package* (find-package package)) + (*read-default-float-format* 'double-float) + (*print-readably* nil) + (*read-eval* nil)) + (funcall thunk)))) + + (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace) + "Read from STRING using a safe syntax, as per WITH-SAFE-IO-SYNTAX" + (with-safe-io-syntax (:package package) + (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace)))) + +;;; Output helpers + (with-upgradability () + (defun call-with-output-file (pathname thunk + &key + (element-type *default-stream-element-type*) + (external-format *utf-8-external-format*) + (if-exists :error) + (if-does-not-exist :create)) + "Open FILE for input with given recognizes options, call THUNK with the resulting stream. +Other keys are accepted but discarded." + (with-open-file (s pathname :direction :output + :element-type element-type + :external-format external-format + :if-exists if-exists + :if-does-not-exist if-does-not-exist) + (funcall thunk s))) + + (defmacro with-output-file ((var pathname &rest keys + &key element-type external-format if-exists if-does-not-exist) + &body body) + (declare (ignore element-type external-format if-exists if-does-not-exist)) + `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys)) + + (defun call-with-output (output function &key (element-type 'character)) + "Calls FUNCTION with an actual stream argument, +behaving like FORMAT with respect to how stream designators are interpreted: +If OUTPUT is a STREAM, use it as the stream. +If OUTPUT is NIL, use a STRING-OUTPUT-STREAM of given ELEMENT-TYPE as the stream, and +return the resulting string. +If OUTPUT is T, use *STANDARD-OUTPUT* as the stream. +If OUTPUT is a STRING with a fill-pointer, use it as a STRING-OUTPUT-STREAM of given ELEMENT-TYPE. +If OUTPUT is a PATHNAME, open the file and write to it, passing ELEMENT-TYPE to WITH-OUTPUT-FILE +-- this latter as an extension since ASDF 3.1. +\(Proper ELEMENT-TYPE treatment since ASDF 3.3.4 only.\) +Otherwise, signal an error." + (etypecase output + (null + (with-output-to-string (stream nil :element-type element-type) (funcall function stream))) + ((eql t) + (funcall function *standard-output*)) + (stream + (funcall function output)) + (string + (assert (fill-pointer output)) + (with-output-to-string (stream output :element-type element-type) (funcall function stream))) + (pathname + (call-with-output-file output function :element-type element-type))))) + +(with-upgradability () + (locally (declare #+sbcl (sb-ext:muffle-conditions style-warning)) + (handler-bind (#+sbcl (style-warning #'muffle-warning)) + (defmacro with-output ((output-var &optional (value output-var) &key element-type) &body body) + "Bind OUTPUT-VAR to an output stream obtained from VALUE (default: previous binding +of OUTPUT-VAR) treated as a stream designator per CALL-WITH-OUTPUT. Evaluate BODY in +the scope of this binding." + `(call-with-output ,value #'(lambda (,output-var) ,@body) + ,@(when element-type `(:element-type ,element-type))))))) + +(defun output-string (string &optional output) + "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string" + (if output + (with-output (output) (princ string output)) + string)) + + +;;; Input helpers +(with-upgradability () + (defun call-with-input-file (pathname thunk + &key + (element-type *default-stream-element-type*) + (external-format *utf-8-external-format*) + (if-does-not-exist :error)) + "Open FILE for input with given recognizes options, call THUNK with the resulting stream. +Other keys are accepted but discarded." + (with-open-file (s pathname :direction :input + :element-type element-type + :external-format external-format + :if-does-not-exist if-does-not-exist) + (funcall thunk s))) + + (defmacro with-input-file ((var pathname &rest keys + &key element-type external-format if-does-not-exist) + &body body) + (declare (ignore element-type external-format if-does-not-exist)) + `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)) + + (defun call-with-input (input function &key keys) + "Calls FUNCTION with an actual stream argument, interpreting +stream designators like READ, but also coercing strings to STRING-INPUT-STREAM, +and PATHNAME to FILE-STREAM. +If INPUT is a STREAM, use it as the stream. +If INPUT is NIL, use a *STANDARD-INPUT* as the stream. +If INPUT is T, use *TERMINAL-IO* as the stream. +If INPUT is a STRING, use it as a string-input-stream. +If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE +-- the latter is an extension since ASDF 3.1. +Otherwise, signal an error." + (etypecase input + (null (funcall function *standard-input*)) + ((eql t) (funcall function *terminal-io*)) + (stream (funcall function input)) + (string (with-input-from-string (stream input) (funcall function stream))) + (pathname (apply 'call-with-input-file input function keys)))) + + (defmacro with-input ((input-var &optional (value input-var)) &body body) + "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR) +as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding." + `(call-with-input ,value #'(lambda (,input-var) ,@body))) + + (defun input-string (&optional input) + "If the desired INPUT is a string, return that string; otherwise slurp the INPUT into a string +and return that" + (if (stringp input) + input + (with-input (input) (funcall 'slurp-stream-string input))))) + +;;; Null device +(with-upgradability () + (defun null-device-pathname () + "Pathname to a bit bucket device that discards any information written to it +and always returns EOF when read from" + (os-cond + ((os-unix-p) #p"/dev/null") + ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax? + (t (error "No /dev/null on your OS")))) + (defun call-with-null-input (fun &key element-type external-format if-does-not-exist) + "Call FUN with an input stream that always returns end of file. +The keyword arguments are allowed for backward compatibility, but are ignored." + (declare (ignore element-type external-format if-does-not-exist)) + (with-open-stream (input (make-concatenated-stream)) + (funcall fun input))) + (defmacro with-null-input ((var &rest keys + &key element-type external-format if-does-not-exist) + &body body) + (declare (ignore element-type external-format if-does-not-exist)) + "Evaluate BODY in a context when VAR is bound to an input stream that always returns end of file. +The keyword arguments are allowed for backward compatibility, but are ignored." + `(call-with-null-input #'(lambda (,var) ,@body) ,@keys)) + (defun call-with-null-output (fun + &key (element-type *default-stream-element-type*) + (external-format *utf-8-external-format*) + (if-exists :overwrite) + (if-does-not-exist :error)) + (declare (ignore element-type external-format if-exists if-does-not-exist)) + "Call FUN with an output stream that discards all output. +The keyword arguments are allowed for backward compatibility, but are ignored." + (with-open-stream (output (make-broadcast-stream)) + (funcall fun output))) + (defmacro with-null-output ((var &rest keys + &key element-type external-format if-does-not-exist if-exists) + &body body) + "Evaluate BODY in a context when VAR is bound to an output stream that discards all output. +The keyword arguments are allowed for backward compatibility, but are ignored." + (declare (ignore element-type external-format if-exists if-does-not-exist)) + `(call-with-null-output #'(lambda (,var) ,@body) ,@keys))) + +;;; Ensure output buffers are flushed +(with-upgradability () + (defun finish-outputs (&rest streams) + "Finish output on the main output streams as well as any specified one. +Useful for portably flushing I/O before user input or program exit." + ;; CCL notably buffers its stream output by default. + (dolist (s (append streams + (list *stdout* *stderr* *error-output* *standard-output* *trace-output* + *debug-io* *terminal-io* *query-io*))) + (ignore-errors (finish-output s))) + (values)) + + (defun format! (stream format &rest args) + "Just like format, but call finish-outputs before and after the output." + (finish-outputs stream) + (apply 'format stream format args) + (finish-outputs stream)) + + (defun safe-format! (stream format &rest args) + "Variant of FORMAT that is safe against both +dangerous syntax configuration and errors while printing." + (with-safe-io-syntax () + (ignore-errors (apply 'format! stream format args)) + (finish-outputs stream)))) ; just in case format failed + + +;;; Simple Whole-Stream processing +(with-upgradability () + (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix) + "Copy the contents of the INPUT stream into the OUTPUT stream. +If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX. +Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE." + (with-open-stream (input input) + (if linewise + (loop :for (line eof) = (multiple-value-list (read-line input nil nil)) + :while line :do + (when prefix (princ prefix output)) + (princ line output) + (unless eof (terpri output)) + (finish-output output) + (when eof (return))) + (loop + :with buffer-size = (or buffer-size 8192) + :with buffer = (make-array (list buffer-size) :element-type (or element-type 'character)) + :for end = (read-sequence buffer input) + :until (zerop end) + :do (write-sequence buffer output :end end) + (when (< end buffer-size) (return)))))) + + (defun concatenate-files (inputs output) + "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files." + (with-open-file (o output :element-type '(unsigned-byte 8) + :direction :output :if-exists :rename-and-delete) + (dolist (input inputs) + (with-open-file (i input :element-type '(unsigned-byte 8) + :direction :input :if-does-not-exist :error) + (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) + + (defun copy-file (input output) + "Copy contents of the INPUT file to the OUTPUT file" + ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f) + #+allegro + (excl.osi:copy-file input output) + #+ecl + (ext:copy-file input output) + #-(or allegro ecl) + (concatenate-files (list input) output)) + + (defun slurp-stream-string (input &key (element-type 'character) stripped) + "Read the contents of the INPUT stream as a string" + (let ((string + (with-open-stream (input input) + (with-output-to-string (output nil :element-type element-type) + (copy-stream-to-stream input output :element-type element-type))))) + (if stripped (stripln string) string))) + + (defun slurp-stream-lines (input &key count) + "Read the contents of the INPUT stream as a list of lines, return those lines. + +Note: relies on the Lisp's READ-LINE, but additionally removes any remaining CR +from the line-ending if the file or stream had CR+LF but Lisp only removed LF. + +Read no more than COUNT lines." + (check-type count (or null integer)) + (with-open-stream (input input) + (loop :for n :from 0 + :for l = (and (or (not count) (< n count)) + (read-line input nil nil)) + ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF + :while l :collect (stripln l)))) + + (defun slurp-stream-line (input &key (at 0)) + "Read the contents of the INPUT stream as a list of lines, +then return the ACCESS-AT of that list of lines using the AT specifier. +PATH defaults to 0, i.e. return the first line. +PATH is typically an integer, or a list of an integer and a function. +If PATH is NIL, it will return all the lines in the file. + +The stream will not be read beyond the Nth lines, +where N is the index specified by path +if path is either an integer or a list that starts with an integer." + (access-at (slurp-stream-lines input :count (access-at-count at)) at)) + + (defun slurp-stream-forms (input &key count) + "Read the contents of the INPUT stream as a list of forms, +and return those forms. + +If COUNT is null, read to the end of the stream; +if COUNT is an integer, stop after COUNT forms were read. + +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (check-type count (or null integer)) + (loop :with eof = '#:eof + :for n :from 0 + :for form = (if (and count (>= n count)) + eof + (read-preserving-whitespace input nil eof)) + :until (eq form eof) :collect form)) + + (defun slurp-stream-form (input &key (at 0)) + "Read the contents of the INPUT stream as a list of forms, +then return the ACCESS-AT of these forms following the AT. +AT defaults to 0, i.e. return the first form. +AT is typically a list of integers. +If AT is NIL, it will return all the forms in the file. + +The stream will not be read beyond the Nth form, +where N is the index specified by path, +if path is either an integer or a list that starts with an integer. + +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (access-at (slurp-stream-forms input :count (access-at-count at)) at)) + + (defun read-file-string (file &rest keys) + "Open FILE with option KEYS, read its contents as a string" + (apply 'call-with-input-file file 'slurp-stream-string keys)) + + (defun read-file-lines (file &rest keys) + "Open FILE with option KEYS, read its contents as a list of lines +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (apply 'call-with-input-file file 'slurp-stream-lines keys)) + + (defun read-file-line (file &rest keys &key (at 0) &allow-other-keys) + "Open input FILE with option KEYS (except AT), +and read its contents as per SLURP-STREAM-LINE with given AT specifier. +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (apply 'call-with-input-file file + #'(lambda (input) (slurp-stream-line input :at at)) + (remove-plist-key :at keys))) + + (defun read-file-forms (file &rest keys &key count &allow-other-keys) + "Open input FILE with option KEYS (except COUNT), +and read its contents as per SLURP-STREAM-FORMS with given COUNT. +If COUNT is null, read to the end of the stream; +if COUNT is an integer, stop after COUNT forms were read. +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (apply 'call-with-input-file file + #'(lambda (input) (slurp-stream-forms input :count count)) + (remove-plist-key :count keys))) + + (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys) + "Open input FILE with option KEYS (except AT), +and read its contents as per SLURP-STREAM-FORM with given AT specifier. +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (apply 'call-with-input-file file + #'(lambda (input) (slurp-stream-form input :at at)) + (remove-plist-key :at keys))) + + (defun safe-read-file-line (pathname &rest keys &key (package :cl) &allow-other-keys) + "Reads the specified line from the top of a file using a safe standardized syntax. +Extracts the line using READ-FILE-LINE, +within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE." + (with-safe-io-syntax (:package package) + (apply 'read-file-line pathname (remove-plist-key :package keys)))) + + (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys) + "Reads the specified form from the top of a file using a safe standardized syntax. +Extracts the form using READ-FILE-FORM, +within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE." + (with-safe-io-syntax (:package package) + (apply 'read-file-form pathname (remove-plist-key :package keys)))) + + (defun eval-input (input) + "Portably read and evaluate forms from INPUT, return the last values." + (with-input (input) + (loop :with results :with eof ='#:eof + :for form = (read input nil eof) + :until (eq form eof) + :do (setf results (multiple-value-list (eval form))) + :finally (return (values-list results))))) + + (defun eval-thunk (thunk) + "Evaluate a THUNK of code: +If a function, FUNCALL it without arguments. +If a constant literal and not a sequence, return it. +If a cons or a symbol, EVAL it. +If a string, repeatedly read and evaluate from it, returning the last values." + (etypecase thunk + ((or boolean keyword number character pathname) thunk) + ((or cons symbol) (eval thunk)) + (function (funcall thunk)) + (string (eval-input thunk)))) + + (defun standard-eval-thunk (thunk &key (package :cl)) + "Like EVAL-THUNK, but in a more standardized evaluation context." + ;; Note: it's "standard-" not "safe-", because evaluation is never safe. + (when thunk + (with-safe-io-syntax (:package package) + (let ((*read-eval* t)) + (eval-thunk thunk)))))) + +(with-upgradability () + (defun println (x &optional (stream *standard-output*)) + "Variant of PRINC that also calls TERPRI afterwards" + (princ x stream) (terpri stream) (finish-output stream) (values)) + + (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys) + "Variant of WRITE that also calls TERPRI afterwards" + (apply 'write x keys) (terpri stream) (finish-output stream) (values))) + + +;;; Using temporary files +(with-upgradability () + (defun default-temporary-directory () + "Return a default directory to use for temporary files" + (os-cond + ((os-unix-p) + (or (getenv-pathname "TMPDIR" :ensure-directory t) + (parse-native-namestring "/tmp/"))) + ((os-windows-p) + (getenv-pathname "TEMP" :ensure-directory t)) + (t (subpathname (user-homedir-pathname) "tmp/")))) + + (defvar *temporary-directory* nil "User-configurable location for temporary files") + + (defun temporary-directory () + "Return a directory to use for temporary files" + (or *temporary-directory* (default-temporary-directory))) + + (defun setup-temporary-directory () + "Configure a default temporary directory to use." + (setf *temporary-directory* (default-temporary-directory)) + #+gcl (setf system::*tmp-dir* *temporary-directory*)) + + (defun call-with-temporary-file + (thunk &key + (want-stream-p t) (want-pathname-p t) (direction :io) keep after + directory (type "tmp" typep) prefix (suffix (when typep "-tmp")) + (element-type *default-stream-element-type*) + (external-format *utf-8-external-format*)) + "Call a THUNK with stream and/or pathname arguments identifying a temporary file. + +The temporary file's pathname will be based on concatenating +PREFIX (or \"tmp\" if it's NIL), a random alphanumeric string, +and optional SUFFIX (defaults to \"-tmp\" if a type was provided) +and TYPE (defaults to \"tmp\", using a dot as separator if not NIL), +within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute. + +The file will be open with specified DIRECTION (defaults to :IO), +ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and +EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*). +If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed +with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T), +and stream will be closed after the THUNK exits (either normally or abnormally). +If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then +THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument. +Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument. +If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned. +Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true." + #+xcl (declare (ignorable typep)) + (check-type direction (member :output :io)) + (assert (or want-stream-p want-pathname-p)) + (loop + :with prefix-pn = (ensure-absolute-pathname + (or prefix "tmp") + (or (ensure-pathname + directory + :namestring :native + :ensure-directory t + :ensure-physical t) + #'temporary-directory)) + :with prefix-nns = (native-namestring prefix-pn) + :with results = (progn (ensure-directories-exist prefix-pn) + ()) + :for counter :from (random (expt 36 #-gcl 8 #+gcl 5)) + :for pathname = (parse-native-namestring + (format nil "~A~36R~@[~A~]~@[.~A~]" + prefix-nns counter suffix (unless (eq type :unspecific) type))) + :for okp = nil :do + ;; TODO: on Unix, do something about umask + ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL + ;; TODO: on Unix, use CFFI and mkstemp -- + ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr. + ;; Can we at least design some hook? + (unwind-protect + (progn + (ensure-directories-exist pathname) + (with-open-file (stream pathname + :direction direction + :element-type element-type + :external-format external-format + :if-exists nil :if-does-not-exist :create) + (when stream + (setf okp pathname) + (when want-stream-p + ;; Note: can't return directly from within with-open-file + ;; or the non-local return causes the file creation to be undone. + (setf results (multiple-value-list + (if want-pathname-p + (call-function thunk stream pathname) + (call-function thunk stream))))))) + ;; if we don't want a stream, then we must call the thunk *after* + ;; the stream is closed, but only if it was successfully opened. + (when okp + (when (and want-pathname-p (not want-stream-p)) + (setf results (multiple-value-list (call-function thunk okp)))) + ;; if the stream was successfully opened, then return a value, + ;; either one computed already, or one from AFTER, if that exists. + (if after + (return (call-function after pathname)) + (return (values-list results))))) + (when (and okp (not (call-function keep))) + (ignore-errors (delete-file-if-exists okp)))))) + + (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp) + (pathname (gensym "PATHNAME") pathnamep) + directory prefix suffix type + keep direction element-type external-format) + &body body) + "Evaluate BODY where the symbols specified by keyword arguments +STREAM and PATHNAME (if respectively specified) are bound corresponding +to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE. +At least one of STREAM or PATHNAME must be specified. +If the STREAM is not specified, it will be closed before the BODY is evaluated. +If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY, +separates forms run before and after the stream is closed. +The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned. +Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE." + (check-type stream symbol) + (check-type pathname symbol) + (assert (or streamp pathnamep)) + (let* ((afterp (position :close-stream body)) + (before (if afterp (subseq body 0 afterp) body)) + (after (when afterp (subseq body (1+ afterp)))) + (beforef (gensym "BEFORE")) + (afterf (gensym "AFTER"))) + (when (eql afterp 0) + (style-warn ":CLOSE-STREAM should not be the first form of BODY in WITH-TEMPORARY-FILE. Instead, do not provide a STREAM.")) + `(flet (,@(when before + `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) + ,@(when after `((declare (ignorable ,pathname)))) + ,@before))) + ,@(when after + (assert pathnamep) + `((,afterf (,pathname) ,@after)))) + #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf)))) + (call-with-temporary-file + ,(when before `#',beforef) + :want-stream-p ,streamp + :want-pathname-p ,pathnamep + ,@(when direction `(:direction ,direction)) + ,@(when directory `(:directory ,directory)) + ,@(when prefix `(:prefix ,prefix)) + ,@(when suffix `(:suffix ,suffix)) + ,@(when type `(:type ,type)) + ,@(when keep `(:keep ,keep)) + ,@(when after `(:after #',afterf)) + ,@(when element-type `(:element-type ,element-type)) + ,@(when external-format `(:external-format ,external-format)))))) + + (defun get-temporary-file (&key directory prefix suffix type (keep t)) + (with-temporary-file (:pathname pn :keep keep + :directory directory :prefix prefix :suffix suffix :type type) + pn)) + + ;; Temporary pathnames in simple cases where no contention is assumed + (defun add-pathname-suffix (pathname suffix &rest keys) + "Add a SUFFIX to the name of a PATHNAME, return a new pathname. +Further KEYS can be passed to MAKE-PATHNAME." + (apply 'make-pathname :name (strcat (pathname-name pathname) suffix) + :defaults pathname keys)) + + (defun tmpize-pathname (x) + "Return a new pathname modified from X by adding a trivial random suffix. +A new empty file with said temporary pathname is created, to ensure there is no +clash with any concurrent process attempting the same thing." + (let* ((px (ensure-pathname x :ensure-physical t)) + (prefix (if-let (n (pathname-name px)) (strcat n "-tmp") "tmp")) + (directory (pathname-directory-pathname px))) + ;; Genera uses versioned pathnames -- If we leave the empty file in place, + ;; the system will create a new version of the file when the caller opens + ;; it for output. That empty file will remain after the operation is completed. + ;; As Genera is a single core processor, the possibility of a name conflict is + ;; minimal if not nil. (And, in the event of a collision, the two processes + ;; would be writing to different versions of the file.) + (get-temporary-file :directory directory :prefix prefix :type (pathname-type px) + #+genera :keep #+genera nil))) + + (defun call-with-staging-pathname (pathname fun) + "Calls FUN with a staging pathname, and atomically +renames the staging pathname to the PATHNAME in the end. +NB: this protects only against failure of the program, not against concurrent attempts. +For the latter case, we ought pick a random suffix and atomically open it." + (let* ((pathname (pathname pathname)) + (staging (tmpize-pathname pathname))) + (unwind-protect + (multiple-value-prog1 + (funcall fun staging) + (rename-file-overwriting-target staging pathname)) + (delete-file-if-exists staging)))) + + (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) + "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME" + `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))) + +(with-upgradability () + (defun file-stream-p (stream) + (typep stream 'file-stream)) + (defun file-or-synonym-stream-p (stream) + (or (file-stream-p stream) + (and (typep stream 'synonym-stream) + (file-or-synonym-stream-p + (symbol-value (synonym-stream-symbol stream))))))) +;;;; ------------------------------------------------------------------------- +;;;; Starting, Stopping, Dumping a Lisp image + +(uiop/package:define-package :uiop/image + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os) + (:export + #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* + #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0 + #:*lisp-interaction* + #:fatal-condition #:fatal-condition-p + #:handle-fatal-condition + #:call-with-fatal-condition-handler #:with-fatal-condition-handler + #:*image-restore-hook* #:*image-prelude* #:*image-entry-point* + #:*image-postlude* #:*image-dump-hook* + #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace + #:shell-boolean-exit + #:register-image-restore-hook #:register-image-dump-hook + #:call-image-restore-hook #:call-image-dump-hook + #:restore-image #:dump-image #:create-image +)) +(in-package :uiop/image) + +(with-upgradability () + (defvar *lisp-interaction* t + "Is this an interactive Lisp environment, or is it batch processing?") + + (defvar *command-line-arguments* nil + "Command-line arguments") + + (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments + "Is this a dumped image? As a standalone executable?") + + (defvar *image-restore-hook* nil + "Functions to call (in reverse order) when the image is restored") + + (defvar *image-restored-p* nil + "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping") + + (defvar *image-prelude* nil + "a form to evaluate, or string containing forms to read and evaluate +when the image is restarted, but before the entry point is called.") + + (defvar *image-entry-point* nil + "a function with which to restart the dumped image when execution is restored from it.") + + (defvar *image-postlude* nil + "a form to evaluate, or string containing forms to read and evaluate +before the image dump hooks are called and before the image is dumped.") + + (defvar *image-dump-hook* nil + "Functions to call (in order) when before an image is dumped")) + +(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) + (deftype fatal-condition () + `(and serious-condition #+clozure (not ccl:process-reset)))) + +;;; Exiting properly or im- +(with-upgradability () + (defun quit (&optional (code 0) (finish-output t)) + "Quits from the Lisp world, with the given exit status if provided. +This is designed to abstract away the implementation specific quit forms." + (when finish-output ;; essential, for ClozureCL, and for standard compliance. + (finish-outputs)) + #+(or abcl xcl) (ext:quit :status code) + #+allegro (excl:exit code :quiet t) + #+(or clasp ecl) (si:quit code) + #+clisp (ext:quit code) + #+clozure (ccl:quit code) + #+cormanlisp (win32:exitprocess code) + #+(or cmucl scl) (unix:unix-exit code) + #+gcl (system:quit code) + #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code) + #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) + #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ? + #+mkcl (mk-ext:quit :exit-code code) + #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil)) + (quit (find-symbol* :quit :sb-ext nil))) + (cond + (exit `(,exit :code code :abort (not finish-output))) + (quit `(,quit :unix-status code :recklessly-p (not finish-output))))) + #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + (not-implemented-error 'quit "(called with exit code ~S)" code)) + + (defun die (code format &rest arguments) + "Die in error with some error message" + (with-safe-io-syntax () + (ignore-errors + (format! *stderr* "~&~?~&" format arguments))) + (quit code)) + + (defun raw-print-backtrace (&key (stream *debug-io*) count condition) + "Print a backtrace, directly accessing the implementation" + (declare (ignorable stream count condition)) + #+abcl + (loop :for i :from 0 + :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do + (safe-format! stream "~&~D: ~A~%" i frame)) + #+allegro + (let ((*terminal-io* stream) + (*standard-output* stream) + (tpl:*zoom-print-circle* *print-circle*) + (tpl:*zoom-print-level* *print-level*) + (tpl:*zoom-print-length* *print-length*)) + (tpl:do-command "zoom" + :from-read-eval-print-loop nil + :count (or count t) + :all t)) + #+clasp + (clasp-debug:print-backtrace :stream stream :count count) + #+(or ecl mkcl) + (let* ((top (si:ihs-top)) + (repeats (if count (min top count) top)) + (backtrace (loop :for ihs :from 0 :below top + :collect (list (si::ihs-fun ihs) + (si::ihs-env ihs))))) + (loop :for i :from 0 :below repeats + :for frame :in (nreverse backtrace) :do + (safe-format! stream "~&~D: ~S~%" i frame))) + #+clisp + (system::print-backtrace :out stream :limit count) + #+(or clozure mcl) + (let ((*debug-io* stream)) + #+clozure (ccl:print-call-history :count count :start-frame-number 1) + #+mcl (ccl:print-call-history :detailed-p nil) + (finish-output stream)) + #+(or cmucl scl) + (let ((debug:*debug-print-level* *print-level*) + (debug:*debug-print-length* *print-length*)) + (debug:backtrace (or count most-positive-fixnum) stream)) + #+gcl + (let ((*debug-io* stream)) + (ignore-errors + (with-safe-io-syntax () + (if condition + (conditions::condition-backtrace condition) + (system::simple-backtrace))))) + #+lispworks + (let ((dbg::*debugger-stack* + (dbg::grab-stack nil :how-many (or count most-positive-fixnum))) + (*debug-io* stream) + (dbg:*debug-print-level* *print-level*) + (dbg:*debug-print-length* *print-length*)) + (dbg:bug-backtrace nil)) + #+mezzano + (let ((*standard-output* stream)) + (sys.int::backtrace count)) + #+sbcl + (sb-debug:print-backtrace :stream stream :count (or count most-positive-fixnum)) + #+xcl + (loop :for i :from 0 :below (or count most-positive-fixnum) + :for frame :in (extensions:backtrace-as-list) :do + (safe-format! stream "~&~D: ~S~%" i frame))) + + (defun print-backtrace (&rest keys &key stream count condition) + "Print a backtrace" + (declare (ignore stream count condition)) + (with-safe-io-syntax (:package :cl) + (let ((*print-readably* nil) + (*print-circle* t) + (*print-miser-width* 75) + (*print-length* nil) + (*print-level* nil) + (*print-pretty* t)) + (ignore-errors (apply 'raw-print-backtrace keys))))) + + (defun print-condition-backtrace (condition &key (stream *stderr*) count) + "Print a condition after a backtrace triggered by that condition" + ;; We print the condition *after* the backtrace, + ;; for the sake of who sees the backtrace at a terminal. + ;; It is up to the caller to print the condition *before*, with some context. + (print-backtrace :stream stream :count count :condition condition) + (when condition + (safe-format! stream "~&Above backtrace due to this condition:~%~A~&" + condition))) + + (defun fatal-condition-p (condition) + "Is the CONDITION fatal?" + (typep condition 'fatal-condition)) + + (defun handle-fatal-condition (condition) + "Handle a fatal CONDITION: +depending on whether *LISP-INTERACTION* is set, enter debugger or die" + (cond + (*lisp-interaction* + (invoke-debugger condition)) + (t + (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition) + (print-condition-backtrace condition :stream *stderr*) + (die 99 "~A" condition)))) + + (defun call-with-fatal-condition-handler (thunk) + "Call THUNK in a context where fatal conditions are appropriately handled" + (handler-bind ((fatal-condition #'handle-fatal-condition)) + (funcall thunk))) + + (defmacro with-fatal-condition-handler ((&optional) &body body) + "Execute BODY in a context where fatal conditions are appropriately handled" + `(call-with-fatal-condition-handler #'(lambda () ,@body))) + + (defun shell-boolean-exit (x) + "Quit with a return code that is 0 iff argument X is true" + (quit (if x 0 1)))) + + +;;; Using image hooks +(with-upgradability () + (defun register-image-restore-hook (hook &optional (call-now-p t)) + "Regiter a hook function to be run when restoring a dumped image" + (register-hook-function '*image-restore-hook* hook call-now-p)) + + (defun register-image-dump-hook (hook &optional (call-now-p nil)) + "Register a the hook function to be run before to dump an image" + (register-hook-function '*image-dump-hook* hook call-now-p)) + + (defun call-image-restore-hook () + "Call the hook functions registered to be run when restoring a dumped image" + (call-functions (reverse *image-restore-hook*))) + + (defun call-image-dump-hook () + "Call the hook functions registered to be run before to dump an image" + (call-functions *image-dump-hook*))) + + +;;; Proper command-line arguments +(with-upgradability () + (defun raw-command-line-arguments () + "Find what the actual command line for this process was." + #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later! + #+allegro (sys:command-line-arguments) ; default: :application t + #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i)) + #+clisp (coerce (ext:argv) 'list) + #+clozure ccl:*command-line-argument-list* + #+(or cmucl scl) extensions:*command-line-strings* + #+gcl si:*command-args* + #+(or genera mcl mezzano) nil + #+lispworks sys:*line-arguments-list* + #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i)) + #+sbcl sb-ext:*posix-argv* + #+xcl system:*argv* + #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl) + (not-implemented-error 'raw-command-line-arguments)) + + (defun command-line-arguments (&optional (arguments (raw-command-line-arguments))) + "Extract user arguments from command-line invocation of current process. +Assume the calling conventions of a generated script that uses -- +if we are not called from a directly executable image." + (block nil + #+abcl (return arguments) + ;; SBCL and Allegro already separate user arguments from implementation arguments. + #-(or sbcl allegro) + (unless (eq *image-dumped-p* :executable) + ;; LispWorks command-line processing isn't transparent to the user + ;; unless you create a standalone executable; in that case, + ;; we rely on cl-launch or some other script to set the arguments for us. + #+lispworks (return *command-line-arguments*) + ;; On other implementations, on non-standalone executables, + ;; we trust cl-launch or whichever script starts the program + ;; to use -- as a delimiter between implementation arguments and user arguments. + #-lispworks (setf arguments (member "--" arguments :test 'string-equal))) + (rest arguments))) + + (defun argv0 () + "On supported implementations (most that matter), or when invoked by a proper wrapper script, +return a string that for the name with which the program was invoked, i.e. argv[0] in C. +Otherwise, return NIL." + (cond + ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 ! + ;; NB: not currently available on ABCL, Corman, Genera, MCL + (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl) + (first (raw-command-line-arguments)) + #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0))) + (t ;; argv[0] is the name of the interpreter. + ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8. + (getenvp "__CL_ARGV0")))) + + (defun setup-command-line-arguments () + (setf *command-line-arguments* (command-line-arguments))) + + (defun restore-image (&key + (lisp-interaction *lisp-interaction*) + (restore-hook *image-restore-hook*) + (prelude *image-prelude*) + (entry-point *image-entry-point*) + (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY"))) + "From a freshly restarted Lisp image, restore the saved Lisp environment +by setting appropriate variables, running various hooks, and calling any specified entry point. + +If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*, +call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return +immediately to the surrounding restore process if allowed to continue. + +Then, comes the restore process itself: +First, call each function in the RESTORE-HOOK, +in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK. +Second, evaluate the prelude, which is often Lisp text that is read, +as per EVAL-INPUT. +Third, call the ENTRY-POINT function, if any is specified, with no argument. + +The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL, +any unhandled error leads to a backtrace and an exit with an error status. +If LISP-INTERACTION is NIL, the process also exits when no error occurs: +if neither restart nor entry function is provided, the program will exit with status 0 (success); +if a function was provided, the program will exit after the function returns (if it returns), +with status 0 if and only if the primary return value of result is generalized boolean true, +and with status 1 if this value is NIL. + +If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result +of the function will be returned rather than interpreted as a boolean designating an exit code." + (when *image-restored-p* + (if if-already-restored + (call-function if-already-restored "Image already ~:[being ~;~]restored" + (eq *image-restored-p* t)) + (return-from restore-image))) + (with-fatal-condition-handler () + (setf *lisp-interaction* lisp-interaction) + (setf *image-restore-hook* restore-hook) + (setf *image-prelude* prelude) + (setf *image-restored-p* :in-progress) + (call-image-restore-hook) + (standard-eval-thunk prelude) + (setf *image-restored-p* t) + (let ((results (multiple-value-list + (if entry-point + (call-function entry-point) + t)))) + (if lisp-interaction + (values-list results) + (shell-boolean-exit (first results))))))) + + +;;; Dumping an image + +(with-upgradability () + (defun dump-image (filename &key output-name executable + (postlude *image-postlude*) + (dump-hook *image-dump-hook*) + #+clozure prepend-symbols #+clozure (purify t) + #+sbcl compression + #+(and sbcl os-windows) application-type) + "Dump an image of the current Lisp environment at pathname FILENAME, with various options. + +First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of + the functions in DUMP-HOOK, in reverse order of registration by REGISTER-IMAGE-DUMP-HOOK. + +If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup. + +Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL, +or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." + ;; Note: at least SBCL saves only global values of variables in the heap image, + ;; so make sure things you want to dump are NOT just local bindings shadowing the global values. + (declare (ignorable filename output-name executable)) + (setf *image-dumped-p* (if executable :executable t)) + (setf *image-restored-p* :in-regress) + (setf *image-postlude* postlude) + (standard-eval-thunk *image-postlude*) + (setf *image-dump-hook* dump-hook) + (call-image-dump-hook) + (setf *image-restored-p* nil) + #-(or clisp clozure (and cmucl executable) lispworks sbcl scl) + (when executable + (not-implemented-error 'dump-image "dumping an executable")) + #+allegro + (progn + (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000 + (excl:dumplisp :name filename :suppress-allegro-cl-banner t)) + #+clisp + (apply #'ext:saveinitmem filename + :quiet t + :start-package *package* + :keep-global-handlers nil + ;; Faré explains the odd executable value (slightly paraphrased): + ;; 0 is very different from t in clisp and there for a good reason: + ;; 0 turns the executable into one that has its own command-line handling, so hackers can't + ;; use the underlying -i or -x to turn your would-be restricted binary into an unrestricted evaluator. + :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x + (when executable + (list + ;; :parse-options nil ;--- requires a non-standard patch to clisp. + :norc t :script nil :init-function #'restore-image))) + #+clozure + (flet ((dump (prepend-kernel) + (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify + :toplevel-function (when executable #'restore-image)))) + ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system)) + (if prepend-symbols + (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path) + (require 'elf) + (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path) + (dump path)) + (dump t))) + #+(or cmucl scl) + (progn + (ext:gc :full t) + (setf ext:*batch-mode* nil) + (setf ext::*gc-run-time* 0) + (apply 'ext:save-lisp filename + :allow-other-keys t ;; hush SCL and old versions of CMUCL + #+(and cmucl executable) :executable #+(and cmucl executable) t + (when executable '(:init-function restore-image :process-command-line nil + :quiet t :load-init-file nil :site-init nil)))) + #+gcl + (progn + (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) + (si::save-system filename)) + #+lispworks + (if executable + (lispworks:deliver 'restore-image filename 0 :interface nil) + (hcl:save-image filename :environment nil)) + #+sbcl + (progn + ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself + (setf sb-ext::*gc-run-time* 0) + (apply 'sb-ext:save-lisp-and-die filename + :executable t ;--- always include the runtime that goes with the core + (append + (when compression (list :compression compression)) + ;;--- only save runtime-options for standalone executables + (when executable (list :toplevel #'restore-image :save-runtime-options t)) + #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window. + ;; the default is :console - only works with SBCL 1.1.15 or later. + (when application-type (list :application-type application-type))))) + #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl) + (not-implemented-error 'dump-image)) + + (defun create-image (destination lisp-object-files + &key kind output-name prologue-code epilogue-code extra-object-files + (prelude () preludep) (postlude () postludep) + (entry-point () entry-point-p) build-args no-uiop) + (declare (ignorable destination lisp-object-files extra-object-files kind output-name + prologue-code epilogue-code prelude preludep postlude postludep + entry-point entry-point-p build-args no-uiop)) + "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options" + ;; Is it meaningful to run these in the current environment? + ;; only if we also track the object files that constitute the "current" image, + ;; and otherwise simulate dump-image, including quitting at the end. + #-(or clasp ecl mkcl) (not-implemented-error 'create-image) + #+(or clasp ecl mkcl) + (let ((epilogue-code + (if no-uiop + epilogue-code + (let ((forms + (append + (when epilogue-code `(,epilogue-code)) + (when postludep `((setf *image-postlude* ',postlude))) + (when preludep `((setf *image-prelude* ',prelude))) + (when entry-point-p `((setf *image-entry-point* ',entry-point))) + (case kind + ((:image) + (setf kind :program) ;; to ECL, it's just another program. + `((setf *image-dumped-p* t) + (si::top-level #+(or clasp ecl) t) (quit))) + ((:program) + `((setf *image-dumped-p* :executable) + (shell-boolean-exit + (restore-image)))))))) + (when forms `(progn ,@forms)))))) + (check-type kind (member :dll :shared-library :lib :static-library + :fasl :fasb :program)) + (apply #+clasp 'cmp:builder #+clasp kind + #+(or ecl mkcl) + (ecase kind + ((:dll :shared-library) + #+ecl 'c::build-shared-library #+mkcl 'compiler:build-shared-library) + ((:lib :static-library) + #+ecl 'c::build-static-library #+mkcl 'compiler:build-static-library) + ((:fasl #+ecl :fasb) + #+ecl 'c::build-fasl #+mkcl 'compiler:build-fasl) + #+mkcl ((:fasb) 'compiler:build-bundle) + ((:program) + #+ecl 'c::build-program #+mkcl 'compiler:build-program)) + (pathname destination) + #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files + (append lisp-object-files #+(or clasp ecl) extra-object-files) + #+ecl :init-name + #+ecl (getf build-args :init-name) + (append + (when prologue-code `(:prologue-code ,prologue-code)) + (when epilogue-code `(:epilogue-code ,epilogue-code)) + #+mkcl (when extra-object-files `(:object-files ,extra-object-files)) + build-args))))) + + +;;; Some universal image restore hooks +(with-upgradability () + (map () 'register-image-restore-hook + '(setup-stdin setup-stdout setup-stderr + setup-command-line-arguments setup-temporary-directory + #+abcl detect-os))) +;;;; ------------------------------------------------------------------------- +;;;; Support to build (compile and load) Lisp files + +(uiop/package:define-package :uiop/lisp-build + (:nicknames :asdf/lisp-build) ;; OBSOLETE, used by slime/contrib/swank-asdf.lisp + (:use :uiop/common-lisp :uiop/package :uiop/utility + :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image) + (:export + ;; Variables + #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* + #:*output-translation-function* + #:*optimization-settings* #:*previous-optimization-settings* + #:*base-build-directory* + #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error + #:compile-warned-warning #:compile-failed-warning + #:check-lisp-compile-results #:check-lisp-compile-warnings + #:*uninteresting-conditions* #:*usual-uninteresting-conditions* + #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* + ;; Types + #+sbcl #:sb-grovel-unknown-constant-condition + ;; Functions & Macros + #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings + #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions + #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions + #:reify-simple-sexp #:unreify-simple-sexp + #:reify-deferred-warnings #:unreify-deferred-warnings + #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings + #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type* + #:enable-deferred-warnings-check #:disable-deferred-warnings-check + #:current-lisp-file-pathname #:load-pathname + #:lispize-pathname #:compile-file-type #:call-around-hook + #:compile-file* #:compile-file-pathname* #:*compile-check* + #:load* #:load-from-string #:combine-fasls) + (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body)) +(in-package :uiop/lisp-build) + +(with-upgradability () + (defvar *compile-file-warnings-behaviour* + (or #+clisp :ignore :warn) + "How should ASDF react if it encounters a warning when compiling a file? +Valid values are :error, :warn, and :ignore.") + + (defvar *compile-file-failure-behaviour* + (or #+(or mkcl sbcl) :error #+clisp :ignore :warn) + "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) +when compiling a file, which includes any non-style-warning warning. +Valid values are :error, :warn, and :ignore. +Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") + + (defvar *base-build-directory* nil + "When set to a non-null value, it should be an absolute directory pathname, +which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE, +what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it. +This can help you produce more deterministic output for FASLs.")) + +;;; Optimization settings +(with-upgradability () + (defvar *optimization-settings* nil + "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS") + (defvar *previous-optimization-settings* nil + "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS") + (defparameter +optimization-variables+ + ;; TODO: allegro genera corman mcl + (or #+(or abcl xcl) '(system::*speed* system::*space* system::*safety* system::*debug*) + #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents) + #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* + ccl::*nx-debug* ccl::*nx-cspeed*) + #+(or cmucl scl) '(c::*default-cookie*) + #+clasp nil + #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*)) + #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*) + #+lispworks '(compiler::*optimization-level*) + #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*) + #+sbcl '(sb-c::*policy*))) + (defun get-optimization-settings () + "Get current compiler optimization settings, ready to PROCLAIM again" + #-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) + (warn "~S does not support ~S. Please help me fix that." + 'get-optimization-settings (implementation-type)) + #+clasp (cleavir-env:optimize (cleavir-env:optimize-info CLASP-CLEAVIR:*CLASP-ENV*)) + #+(or abcl allegro clisp clozure cmucl ecl lispworks mkcl sbcl scl xcl) + (let ((settings '(speed space safety debug compilation-speed #+(or cmucl scl) c::brevity))) + #.`(loop #+(or allegro clozure) + ,@'(:with info = #+allegro (sys:declaration-information 'optimize) + #+clozure (ccl:declaration-information 'optimize nil)) + :for x :in settings + ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+)) + :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order + #+clisp (gethash x system::*optimize* 1) + #+(or abcl ecl mkcl xcl) (symbol-value v) + #+(or cmucl scl) (slot-value c::*default-cookie* + (case x (compilation-speed 'c::cspeed) + (otherwise x))) + #+lispworks (slot-value compiler::*optimization-level* x) + #+sbcl (sb-c::policy-quality sb-c::*policy* x)) + :when y :collect (list x y)))) + (defun proclaim-optimization-settings () + "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*" + (proclaim `(optimize ,@*optimization-settings*)) + (let ((settings (get-optimization-settings))) + (unless (equal *previous-optimization-settings* settings) + (setf *previous-optimization-settings* settings)))) + (defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body) + #+(or allegro clasp clisp) + (let ((previous-settings (gensym "PREVIOUS-SETTINGS")) + (reset-settings (gensym "RESET-SETTINGS"))) + `(let* ((,previous-settings (get-optimization-settings)) + (,reset-settings #+clasp (reverse ,previous-settings) #-clasp ,previous-settings)) + ,@(when settings `((proclaim `(optimize ,@,settings)))) + (unwind-protect (progn ,@body) + (proclaim `(optimize ,@,reset-settings))))) + #-(or allegro clasp clisp) + `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v)) + ,@(when settings `((proclaim `(optimize ,@,settings)))) + ,@body))) + + +;;; Condition control +(with-upgradability () + #+sbcl + (progn + (defun sb-grovel-unknown-constant-condition-p (c) + "Detect SB-GROVEL unknown-constant conditions on older versions of SBCL" + (ignore-errors + (and (typep c 'sb-int:simple-style-warning) + (string-enclosed-p + "Couldn't grovel for " + (simple-condition-format-control c) + " (unknown to the C compiler).")))) + (deftype sb-grovel-unknown-constant-condition () + '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p)))) + + (defvar *usual-uninteresting-conditions* + (append + ;;#+clozure '(ccl:compiler-warning) + #+cmucl '("Deleting unreachable code.") + #+lispworks '("~S being redefined in ~A (previously in ~A)." + "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when. + #+sbcl + '(sb-c::simple-compiler-note + "&OPTIONAL and &KEY found in the same lambda list: ~S" + sb-kernel:undefined-alien-style-warning + sb-grovel-unknown-constant-condition ; defined above. + sb-ext:implicit-generic-function-warning ;; Controversial. + sb-int:package-at-variance + sb-kernel:uninteresting-redefinition + ;; BEWARE: the below four are controversial to include here. + sb-kernel:redefinition-with-defun + sb-kernel:redefinition-with-defgeneric + sb-kernel:redefinition-with-defmethod + sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs + #+sbcl + (let ((condition (find-symbol* '#:lexical-environment-too-complex :sb-kernel nil))) + (when condition + (list condition))) + '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop + "A suggested value to which to set or bind *uninteresting-conditions*.") + + (defvar *uninteresting-conditions* '() + "Conditions that may be skipped while compiling or loading Lisp code.") + (defvar *uninteresting-compiler-conditions* '() + "Additional conditions that may be skipped while compiling Lisp code.") + (defvar *uninteresting-loader-conditions* + (append + '("Overwriting already existing readtable ~S." ;; from named-readtables + #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers + #+clisp '(clos::simple-gf-replacing-method-warning)) + "Additional conditions that may be skipped while loading Lisp code.")) + +;;;; ----- Filtering conditions while building ----- +(with-upgradability () + (defun call-with-muffled-compiler-conditions (thunk) + "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled" + (call-with-muffled-conditions + thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*))) + (defmacro with-muffled-compiler-conditions ((&optional) &body body) + "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS" + `(call-with-muffled-compiler-conditions #'(lambda () ,@body))) + (defun call-with-muffled-loader-conditions (thunk) + "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled" + (call-with-muffled-conditions + thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*))) + (defmacro with-muffled-loader-conditions ((&optional) &body body) + "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS" + `(call-with-muffled-loader-conditions #'(lambda () ,@body)))) + + +;;;; Handle warnings and failures +(with-upgradability () + (define-condition compile-condition (condition) + ((context-format + :initform nil :reader compile-condition-context-format :initarg :context-format) + (context-arguments + :initform nil :reader compile-condition-context-arguments :initarg :context-arguments) + (description + :initform nil :reader compile-condition-description :initarg :description)) + (:report (lambda (c s) + (format s (compatfmt "~@<~A~@[ while ~?~]~@:>") + (or (compile-condition-description c) (type-of c)) + (compile-condition-context-format c) + (compile-condition-context-arguments c))))) + (define-condition compile-file-error (compile-condition error) ()) + (define-condition compile-warned-warning (compile-condition warning) ()) + (define-condition compile-warned-error (compile-condition error) ()) + (define-condition compile-failed-warning (compile-condition warning) ()) + (define-condition compile-failed-error (compile-condition error) ()) + + (defun check-lisp-compile-warnings (warnings-p failure-p + &optional context-format context-arguments) + "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings, +raise an error or warning as appropriate" + (when failure-p + (case *compile-file-failure-behaviour* + (:warn (warn 'compile-failed-warning + :description "Lisp compilation failed" + :context-format context-format + :context-arguments context-arguments)) + (:error (error 'compile-failed-error + :description "Lisp compilation failed" + :context-format context-format + :context-arguments context-arguments)) + (:ignore nil))) + (when warnings-p + (case *compile-file-warnings-behaviour* + (:warn (warn 'compile-warned-warning + :description "Lisp compilation had style-warnings" + :context-format context-format + :context-arguments context-arguments)) + (:error (error 'compile-warned-error + :description "Lisp compilation had style-warnings" + :context-format context-format + :context-arguments context-arguments)) + (:ignore nil)))) + + (defun check-lisp-compile-results (output warnings-p failure-p + &optional context-format context-arguments) + "Given the results of COMPILE-FILE, raise an error or warning as appropriate" + (unless output + (error 'compile-file-error :context-format context-format :context-arguments context-arguments)) + (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments))) + + +;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman. +;;; +;;; To support an implementation, three functions must be implemented: +;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings +;;; See their respective docstrings. +(with-upgradability () + (defun reify-simple-sexp (sexp) + "Given a simple SEXP, return a representation of it as a portable SEXP. +Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells." + (etypecase sexp + (symbol (reify-symbol sexp)) + ((or number character simple-string pathname) sexp) + (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp)))) + (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list)))))) + + (defun unreify-simple-sexp (sexp) + "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents" + (etypecase sexp + ((or symbol number character simple-string pathname) sexp) + (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp)))) + ((simple-vector 2) (unreify-symbol sexp)) + ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector)))) + + #+clozure + (progn + (defun reify-source-note (source-note) + (when source-note + (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename) + (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note + (declare (ignorable source)) + (list :filename filename :start-pos start-pos :end-pos end-pos + #|:source (reify-source-note source)|#)))) + (defun unreify-source-note (source-note) + (when source-note + (destructuring-bind (&key filename start-pos end-pos source) source-note + (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos + :source (unreify-source-note source))))) + (defun unsymbolify-function-name (name) + (if-let (setfed (gethash name ccl::%setf-function-name-inverses%)) + `(setf ,setfed) + name)) + (defun symbolify-function-name (name) + (if (and (consp name) (eq (first name) 'setf)) + (let ((setfed (second name))) + (gethash setfed ccl::%setf-function-names%)) + name)) + (defun reify-function-name (function-name) + (let ((name (or (first function-name) ;; defun: extract the name + (let ((sec (second function-name))) + (or (and (atom sec) sec) ; scoped method: drop scope + (first sec)))))) ; method: keep gf name, drop method specializers + (list name))) + (defun unreify-function-name (function-name) + function-name) + (defun nullify-non-literals (sexp) + (typecase sexp + ((or number character simple-string symbol pathname) sexp) + (cons (cons (nullify-non-literals (car sexp)) + (nullify-non-literals (cdr sexp)))) + (t nil))) + (defun reify-deferred-warning (deferred-warning) + (with-accessors ((warning-type ccl::compiler-warning-warning-type) + (args ccl::compiler-warning-args) + (source-note ccl:compiler-warning-source-note) + (function-name ccl:compiler-warning-function-name)) deferred-warning + (list :warning-type warning-type :function-name (reify-function-name function-name) + :source-note (reify-source-note source-note) + :args (destructuring-bind (fun &rest more) + args + (cons (unsymbolify-function-name fun) + (nullify-non-literals more)))))) + (defun unreify-deferred-warning (reified-deferred-warning) + (destructuring-bind (&key warning-type function-name source-note args) + reified-deferred-warning + (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*)) + 'ccl::compiler-warning) + :function-name (unreify-function-name function-name) + :source-note (unreify-source-note source-note) + :warning-type warning-type + :args (destructuring-bind (fun . more) args + (cons (symbolify-function-name fun) more)))))) + #+(or cmucl scl) + (defun reify-undefined-warning (warning) + ;; Extracting undefined-warnings from the compilation-unit + ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" + (list* + (c::undefined-warning-kind warning) + (c::undefined-warning-name warning) + (c::undefined-warning-count warning) + (mapcar + #'(lambda (frob) + ;; the lexenv slot can be ignored for reporting purposes + `(:enclosing-source ,(c::compiler-error-context-enclosing-source frob) + :source ,(c::compiler-error-context-source frob) + :original-source ,(c::compiler-error-context-original-source frob) + :context ,(c::compiler-error-context-context frob) + :file-name ,(c::compiler-error-context-file-name frob) ; a pathname + :file-position ,(c::compiler-error-context-file-position frob) ; an integer + :original-source-path ,(c::compiler-error-context-original-source-path frob))) + (c::undefined-warning-warnings warning)))) + + #+sbcl + (defun reify-undefined-warning (warning) + ;; Extracting undefined-warnings from the compilation-unit + ;; To be passed through the above reify/unreify link, it must be a "simple-sexp" + (list* + (sb-c::undefined-warning-kind warning) + (sb-c::undefined-warning-name warning) + (sb-c::undefined-warning-count warning) + ;; the COMPILER-ERROR-CONTEXT struct has changed in SBCL, which means how we + ;; handle deferred warnings must change... TODO: when enough time has + ;; gone by, just assume all versions of SBCL are adequately + ;; up-to-date, and cut this material.[2018/05/30:rpg] + (mapcar + #'(lambda (frob) + ;; the lexenv slot can be ignored for reporting purposes + `( + #- #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c) + ,@`(:enclosing-source + ,(sb-c::compiler-error-context-enclosing-source frob) + :source + ,(sb-c::compiler-error-context-source frob) + :original-source + ,(sb-c::compiler-error-context-original-source frob)) + #+ #.(uiop/utility:symbol-test-to-feature-expression '#:compiler-error-context-%source '#:sb-c) + ,@ `(:%enclosing-source + ,(sb-c::compiler-error-context-enclosing-source frob) + :%source + ,(sb-c::compiler-error-context-source frob) + :original-form + ,(sb-c::compiler-error-context-original-form frob)) + :context ,(sb-c::compiler-error-context-context frob) + :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname + :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer + :original-source-path ,(sb-c::compiler-error-context-original-source-path frob))) + (sb-c::undefined-warning-warnings warning)))) + + (defun reify-deferred-warnings () + "return a portable S-expression, portably readable and writeable in any Common Lisp implementation +using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by +WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF." + #+allegro + (list :functions-defined excl::.functions-defined. + :functions-called excl::.functions-called.) + #+clozure + (mapcar 'reify-deferred-warning + (if-let (dw ccl::*outstanding-deferred-warnings*) + (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) + (ccl::deferred-warnings.warnings mdw)))) + #+(or cmucl scl) + (when lisp::*in-compilation-unit* + ;; Try to send nothing through the pipe if nothing needs to be accumulated + `(,@(when c::*undefined-warnings* + `((c::*undefined-warnings* + ,@(mapcar #'reify-undefined-warning c::*undefined-warnings*)))) + ,@(loop :for what :in '(c::*compiler-error-count* + c::*compiler-warning-count* + c::*compiler-note-count*) + :for value = (symbol-value what) + :when (plusp value) + :collect `(,what . ,value)))) + #+sbcl + (when sb-c::*in-compilation-unit* + ;; Try to send nothing through the pipe if nothing needs to be accumulated + `(,@(when sb-c::*undefined-warnings* + `((sb-c::*undefined-warnings* + ,@(mapcar #'reify-undefined-warning sb-c::*undefined-warnings*)))) + ,@(loop :for what :in '(sb-c::*aborted-compilation-unit-count* + sb-c::*compiler-error-count* + sb-c::*compiler-warning-count* + sb-c::*compiler-style-warning-count* + sb-c::*compiler-note-count*) + :for value = (symbol-value what) + :when (plusp value) + :collect `(,what . ,value))))) + + (defun unreify-deferred-warnings (reified-deferred-warnings) + "given a S-expression created by REIFY-DEFERRED-WARNINGS, reinstantiate the corresponding +deferred warnings as to be handled at the end of the current WITH-COMPILATION-UNIT. +Handle any warning that has been resolved already, +such as an undefined function that has been defined since. +One of three functions required for deferred-warnings support in ASDF." + (declare (ignorable reified-deferred-warnings)) + #+allegro + (destructuring-bind (&key functions-defined functions-called) + reified-deferred-warnings + (setf excl::.functions-defined. + (append functions-defined excl::.functions-defined.) + excl::.functions-called. + (append functions-called excl::.functions-called.))) + #+clozure + (let ((dw (or ccl::*outstanding-deferred-warnings* + (setf ccl::*outstanding-deferred-warnings* (ccl::%defer-warnings t))))) + (appendf (ccl::deferred-warnings.warnings dw) + (mapcar 'unreify-deferred-warning reified-deferred-warnings))) + #+(or cmucl scl) + (dolist (item reified-deferred-warnings) + ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. + ;; For *undefined-warnings*, the adjustment is a list of initargs. + ;; For everything else, it's an integer. + (destructuring-bind (symbol . adjustment) item + (case symbol + ((c::*undefined-warnings*) + (setf c::*undefined-warnings* + (nconc (mapcan + #'(lambda (stuff) + (destructuring-bind (kind name count . rest) stuff + (unless (case kind (:function (fboundp name))) + (list + (c::make-undefined-warning + :name name + :kind kind + :count count + :warnings + (mapcar #'(lambda (x) + (apply #'c::make-compiler-error-context x)) + rest)))))) + adjustment) + c::*undefined-warnings*))) + (otherwise + (set symbol (+ (symbol-value symbol) adjustment)))))) + #+sbcl + (dolist (item reified-deferred-warnings) + ;; Each item is (symbol . adjustment) where the adjustment depends on the symbol. + ;; For *undefined-warnings*, the adjustment is a list of initargs. + ;; For everything else, it's an integer. + (destructuring-bind (symbol . adjustment) item + (case symbol + ((sb-c::*undefined-warnings*) + (setf sb-c::*undefined-warnings* + (nconc (mapcan + #'(lambda (stuff) + (destructuring-bind (kind name count . rest) stuff + (unless (case kind (:function (fboundp name))) + (list + (sb-c::make-undefined-warning + :name name + :kind kind + :count count + :warnings + (mapcar #'(lambda (x) + (apply #'sb-c::make-compiler-error-context x)) + rest)))))) + adjustment) + sb-c::*undefined-warnings*))) + (otherwise + (set symbol (+ (symbol-value symbol) adjustment))))))) + + (defun reset-deferred-warnings () + "Reset the set of deferred warnings to be handled at the end of the current WITH-COMPILATION-UNIT. +One of three functions required for deferred-warnings support in ASDF." + #+allegro + (setf excl::.functions-defined. nil + excl::.functions-called. nil) + #+clozure + (if-let (dw ccl::*outstanding-deferred-warnings*) + (let ((mdw (ccl::ensure-merged-deferred-warnings dw))) + (setf (ccl::deferred-warnings.warnings mdw) nil))) + #+(or cmucl scl) + (when lisp::*in-compilation-unit* + (setf c::*undefined-warnings* nil + c::*compiler-error-count* 0 + c::*compiler-warning-count* 0 + c::*compiler-note-count* 0)) + #+sbcl + (when sb-c::*in-compilation-unit* + (setf sb-c::*undefined-warnings* nil + sb-c::*aborted-compilation-unit-count* 0 + sb-c::*compiler-error-count* 0 + sb-c::*compiler-warning-count* 0 + sb-c::*compiler-style-warning-count* 0 + sb-c::*compiler-note-count* 0))) + + (defun save-deferred-warnings (warnings-file) + "Save forward reference conditions so they may be issued at a latter time, +possibly in a different process." + (with-open-file (s warnings-file :direction :output :if-exists :supersede + :element-type *default-stream-element-type* + :external-format *utf-8-external-format*) + (with-safe-io-syntax () + (let ((*read-eval* t)) + (write (reify-deferred-warnings) :stream s :pretty t :readably t)) + (terpri s)))) + + (defun warnings-file-type (&optional implementation-type) + "The pathname type for warnings files on given IMPLEMENTATION-TYPE, +where NIL designates the current one" + (case (or implementation-type *implementation-type*) + ((:acl :allegro) "allegro-warnings") + ;;((:clisp) "clisp-warnings") + ((:cmu :cmucl) "cmucl-warnings") + ((:sbcl) "sbcl-warnings") + ((:clozure :ccl) "ccl-warnings") + ((:scl) "scl-warnings"))) + + (defvar *warnings-file-type* nil + "Pathname type for warnings files, or NIL if disabled") + + (defun enable-deferred-warnings-check () + "Enable the saving of deferred warnings" + (setf *warnings-file-type* (warnings-file-type))) + + (defun disable-deferred-warnings-check () + "Disable the saving of deferred warnings" + (setf *warnings-file-type* nil)) + + (defun warnings-file-p (file &optional implementation-type) + "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE? +If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead." + (if-let (type (if implementation-type + (warnings-file-type implementation-type) + *warnings-file-type*)) + (equal (pathname-type file) type))) + + (defun check-deferred-warnings (files &optional context-format context-arguments) + "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS, +re-intern and raise any warnings that are still meaningful." + (let ((file-errors nil) + (failure-p nil) + (warnings-p nil)) + (handler-bind + ((warning #'(lambda (c) + (setf warnings-p t) + (unless (typep c 'style-warning) + (setf failure-p t))))) + (with-compilation-unit (:override t) + (reset-deferred-warnings) + (dolist (file files) + (unreify-deferred-warnings + (handler-case + (with-safe-io-syntax () + (let ((*read-eval* t)) + (read-file-form file))) + (error (c) + ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging + (push c file-errors) + nil)))))) + (dolist (error file-errors) (error error)) + (check-lisp-compile-warnings + (or failure-p warnings-p) failure-p context-format context-arguments))) + + #| + Mini-guide to adding support for deferred warnings on an implementation. + + First, look at what such a warning looks like: + + (describe + (handler-case + (and (eval '(lambda () (some-undefined-function))) nil) + (t (c) c))) + + Then you can grep for the condition type in your compiler sources + and see how to catch those that have been deferred, + and/or read, clear and restore the deferred list. + + Also look at + (macroexpand-1 '(with-compilation-unit () foo)) + |# + + (defun call-with-saved-deferred-warnings (thunk warnings-file &key source-namestring) + "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK +and save those warnings to the given file for latter use, +possibly in a different process. Otherwise just call THUNK." + (declare (ignorable source-namestring)) + (if warnings-file + (with-compilation-unit (:override t #+sbcl :source-namestring #+sbcl source-namestring) + (unwind-protect + (let (#+sbcl (sb-c::*undefined-warnings* nil)) + (multiple-value-prog1 + (funcall thunk) + (save-deferred-warnings warnings-file))) + (reset-deferred-warnings))) + (funcall thunk))) + + (defmacro with-saved-deferred-warnings ((warnings-file &key source-namestring) &body body) + "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS" + `(call-with-saved-deferred-warnings + #'(lambda () ,@body) ,warnings-file :source-namestring ,source-namestring))) + + +;;; from ASDF +(with-upgradability () + (defun current-lisp-file-pathname () + "Portably return the PATHNAME of the current Lisp source file being compiled or loaded" + (or *compile-file-pathname* *load-pathname*)) + + (defun load-pathname () + "Portably return the LOAD-PATHNAME of the current source file or fasl. + May return a relative pathname." + *load-pathname*) ;; magic no longer needed for GCL. + + (defun lispize-pathname (input-file) + "From a INPUT-FILE pathname, return a corresponding .lisp source pathname" + (make-pathname :type "lisp" :defaults input-file)) + + (defun compile-file-type (&rest keys) + "pathname TYPE for lisp FASt Loading files" + (declare (ignorable keys)) + #-(or clasp ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) + #+(or clasp ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys))) + + (defun call-around-hook (hook function) + "Call a HOOK around the execution of FUNCTION" + (call-function (or hook 'funcall) function)) + + (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) + "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*" + (let* ((keys + (remove-plist-keys `(#+(or (and allegro (not (version>= 8 2)))) :external-format + ,@(unless output-file '(:output-file))) keys))) + (if (absolute-pathname-p output-file) + ;; what cfp should be doing, w/ mp* instead of mp + (let* ((type (pathname-type (apply 'compile-file-type keys))) + (defaults (make-pathname + :type type :defaults (merge-pathnames* input-file)))) + (merge-pathnames* output-file defaults)) + (funcall *output-translation-function* + (apply 'compile-file-pathname input-file keys))))) + + (defvar *compile-check* nil + "A hook for user-defined compile-time invariants") + + (defun compile-file* (input-file &rest keys + &key (compile-check *compile-check*) output-file warnings-file + #+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl + &allow-other-keys) + "This function provides a portable wrapper around COMPILE-FILE. +It ensures that the OUTPUT-FILE value is only returned and +the file only actually created if the compilation was successful, +even though your implementation may not do that. It also checks an optional +user-provided consistency function COMPILE-CHECK to determine success; +it will call this function if not NIL at the end of the compilation +with the arguments sent to COMPILE-FILE*, except with :OUTPUT-FILE TMP-FILE +where TMP-FILE is the name of a temporary output-file. +It also checks two flags (with legacy british spelling from ASDF1), +*COMPILE-FILE-FAILURE-BEHAVIOUR* and *COMPILE-FILE-WARNINGS-BEHAVIOUR* +with appropriate implementation-dependent defaults, +and if a failure (respectively warnings) are reported by COMPILE-FILE, +it will consider that an error unless the respective behaviour flag +is one of :SUCCESS :WARN :IGNORE. +If WARNINGS-FILE is defined, deferred warnings are saved to that file. +On ECL or MKCL, it creates both the linkable object and loadable fasl files. +On implementations that erroneously do not recognize standard keyword arguments, +it will filter them appropriately." + #+(or clasp ecl) + (when (and object-file (equal (compile-file-type) (pathname object-file))) + (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%" + 'compile-file* output-file object-file) + (rotatef output-file object-file)) + (let* ((keywords (remove-plist-keys + `(:output-file :compile-check :warnings-file + #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys)) + (output-file + (or output-file + (apply 'compile-file-pathname* input-file :output-file output-file keywords))) + (physical-output-file (physicalize-pathname output-file)) + #+(or clasp ecl) + (object-file + (unless (use-ecl-byte-compiler-p) + (or object-file + #+ecl (compile-file-pathname output-file :type :object) + #+clasp (compile-file-pathname output-file :output-type :object)))) + #+mkcl + (object-file + (or object-file + (compile-file-pathname output-file :fasl-p nil))) + (tmp-file (tmpize-pathname physical-output-file)) + #+clasp + (tmp-object-file (compile-file-pathname tmp-file :output-type :object)) + #+sbcl + (cfasl-file (etypecase emit-cfasl + (null nil) + ((eql t) (make-pathname :type "cfasl" :defaults physical-output-file)) + (string (parse-namestring emit-cfasl)) + (pathname emit-cfasl))) + #+sbcl + (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file))) + #+clisp + (tmp-lib (make-pathname :type "lib" :defaults tmp-file))) + (multiple-value-bind (output-truename warnings-p failure-p) + (with-enough-pathname (input-file :defaults *base-build-directory*) + (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file)) + (with-muffled-compiler-conditions () + (or #-(or clasp ecl mkcl) + (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t)) + (apply 'compile-file input-file :output-file tmp-file + #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) + #-sbcl keywords)) + #+ecl (apply 'compile-file input-file :output-file + (if object-file + (list* object-file :system-p t keywords) + (list* tmp-file keywords))) + #+clasp (apply 'compile-file input-file :output-file + (if object-file + (list* tmp-object-file :output-type :object #|:system-p t|# keywords) + (list* tmp-file keywords))) + #+mkcl (apply 'compile-file input-file + :output-file object-file :fasl-p nil keywords))))) + (cond + ((and output-truename + (flet ((check-flag (flag behaviour) + (or (not flag) (member behaviour '(:success :warn :ignore))))) + (and (check-flag failure-p *compile-file-failure-behaviour*) + (check-flag warnings-p *compile-file-warnings-behaviour*))) + (progn + #+(or clasp ecl mkcl) + (when (and #+(or clasp ecl) object-file) + (setf output-truename + (compiler::build-fasl tmp-file + #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (list #+clasp tmp-object-file #-clasp object-file)))) + (or (not compile-check) + (apply compile-check input-file + :output-file output-truename + keywords)))) + (delete-file-if-exists physical-output-file) + (when output-truename + ;; see CLISP bug 677 + #+clisp + (progn + (setf tmp-lib (make-pathname :type "lib" :defaults output-truename)) + (unless lib-file (setf lib-file (make-pathname :type "lib" :defaults physical-output-file))) + (rename-file-overwriting-target tmp-lib lib-file)) + #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file)) + #+clasp + (progn + ;;; the following 4 rename-file-overwriting-target better be atomic, but we can't implement this right now + #+:target-os-darwin + (let ((temp-dwarf (pathname (strcat (namestring output-truename) ".dwarf"))) + (target-dwarf (pathname (strcat (namestring physical-output-file) ".dwarf")))) + (when (probe-file temp-dwarf) + (rename-file-overwriting-target temp-dwarf target-dwarf))) + ;;; need to rename the bc or ll file as well or test-bundle.script fails + ;;; They might not exist with parallel compilation + (let ((bitcode-src (compile-file-pathname tmp-file :output-type :bitcode)) + (bitcode-target (compile-file-pathname physical-output-file :output-type :bitcode))) + (when (probe-file bitcode-src) + (rename-file-overwriting-target bitcode-src bitcode-target))) + (rename-file-overwriting-target tmp-object-file object-file)) + (rename-file-overwriting-target output-truename physical-output-file) + (setf output-truename (truename physical-output-file))) + #+clasp (delete-file-if-exists tmp-file) + #+clisp (progn (delete-file-if-exists tmp-file) ;; this one works around clisp BUG 677 + (delete-file-if-exists tmp-lib))) ;; this one is "normal" defensive cleanup + (t ;; error or failed check + (delete-file-if-exists output-truename) + #+clisp (delete-file-if-exists tmp-lib) + #+sbcl (delete-file-if-exists tmp-cfasl) + (setf output-truename nil))) + (values output-truename warnings-p failure-p)))) + + (defun load* (x &rest keys &key &allow-other-keys) + "Portable wrapper around LOAD that properly handles loading from a stream." + (with-muffled-loader-conditions () + (let (#+genera (si:*common-lisp-syntax-is-ansi-common-lisp* t)) + (etypecase x + ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream) + (apply 'load x keys)) + ;; Genera can't load from a string-input-stream + ;; ClozureCL 1.6 can only load from file input stream + ;; Allegro 5, I don't remember but it must have been broken when I tested. + #+(or allegro clozure genera) + (stream ;; make do this way + (let ((*package* *package*) + (*readtable* *readtable*) + (*load-pathname* nil) + (*load-truename* nil)) + (eval-input x))))))) + + (defun load-from-string (string) + "Portably read and evaluate forms from a STRING." + (with-input-from-string (s string) (load* s)))) + +;;; Links FASLs together +(with-upgradability () + (defun combine-fasls (inputs output) + "Combine a list of FASLs INPUTS into a single FASL OUTPUT" + #-(or abcl allegro clisp clozure cmucl lispworks sbcl scl xcl) + (not-implemented-error 'combine-fasls "~%inputs: ~S~%output: ~S" inputs output) + #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0 + #+(or allegro clisp cmucl sbcl scl xcl) (concatenate-files inputs output) + #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) + #+lispworks + (let (fasls) + (unwind-protect + (progn + (loop :for i :in inputs + :for n :from 1 + :for f = (add-pathname-suffix + output (format nil "-FASL~D" n)) + :do (copy-file i f) + (push f fasls)) + (ignore-errors (lispworks:delete-system :fasls-to-concatenate)) + (eval `(scm:defsystem :fasls-to-concatenate + (:default-pathname ,(pathname-directory-pathname output)) + :members + ,(loop :for f :in (reverse fasls) + :collect `(,(namestring f) :load-only t)))) + (scm:concatenate-system output :fasls-to-concatenate :force t)) + (loop :for f :in fasls :do (ignore-errors (delete-file f))) + (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))) +;;;; ------------------------------------------------------------------------- +;;;; launch-program - semi-portably spawn asynchronous subprocesses + +(uiop/package:define-package :uiop/launch-program + (:use :uiop/common-lisp :uiop/package :uiop/utility + :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream + :uiop/version) + (:export + ;;; Escaping the command invocation madness + #:easy-sh-character-p #:escape-sh-token #:escape-sh-command + #:escape-windows-token #:escape-windows-command + #:escape-shell-token #:escape-shell-command + #:escape-token #:escape-command + + ;;; launch-program + #:launch-program + #:close-streams #:process-alive-p #:terminate-process #:wait-process + #:process-info-error-output #:process-info-input #:process-info-output #:process-info-pid)) +(in-package :uiop/launch-program) + +;;;; ----- Escaping strings for the shell ----- +(with-upgradability () + (defun requires-escaping-p (token &key good-chars bad-chars) + "Does this token require escaping, given the specification of +either good chars that don't need escaping or bad chars that do need escaping, +as either a recognizing function or a sequence of characters." + (some + (cond + ((and good-chars bad-chars) + (parameter-error "~S: only one of good-chars and bad-chars can be provided" + 'requires-escaping-p)) + ((typep good-chars 'function) + (complement good-chars)) + ((typep bad-chars 'function) + bad-chars) + ((and good-chars (typep good-chars 'sequence)) + #'(lambda (c) (not (find c good-chars)))) + ((and bad-chars (typep bad-chars 'sequence)) + #'(lambda (c) (find c bad-chars))) + (t (parameter-error "~S: no good-char criterion" 'requires-escaping-p))) + token)) + + (defun escape-token (token &key stream quote good-chars bad-chars escaper) + "Call the ESCAPER function on TOKEN string if it needs escaping as per +REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN, +using STREAM as output (or returning result as a string if NIL)" + (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars) + (with-output (stream) + (apply escaper token stream (when quote `(:quote ,quote)))) + (output-string token stream))) + + (defun escape-windows-token-within-double-quotes (x &optional s) + "Escape a string token X within double-quotes +for use within a MS Windows command-line, outputing to S." + (labels ((issue (c) (princ c s)) + (issue-backslash (n) (loop :repeat n :do (issue #\\)))) + (loop + :initially (issue #\") :finally (issue #\") + :with l = (length x) :with i = 0 + :for i+1 = (1+ i) :while (< i l) :do + (case (char x i) + ((#\") (issue-backslash 1) (issue #\") (setf i i+1)) + ((#\\) + (let* ((j (and (< i+1 l) (position-if-not + #'(lambda (c) (eql c #\\)) x :start i+1))) + (n (- (or j l) i))) + (cond + ((null j) + (issue-backslash (* 2 n)) (setf i l)) + ((and (< j l) (eql (char x j) #\")) + (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j))) + (t + (issue-backslash n) (setf i j))))) + (otherwise + (issue (char x i)) (setf i i+1)))))) + + (defun easy-windows-character-p (x) + "Is X an \"easy\" character that does not require quoting by the shell?" + (or (alphanumericp x) (find x "+-_.,@:/="))) + + (defun escape-windows-token (token &optional s) + "Escape a string TOKEN within double-quotes if needed +for use within a MS Windows command-line, outputing to S." + (escape-token token :stream s :good-chars #'easy-windows-character-p :quote nil + :escaper 'escape-windows-token-within-double-quotes)) + + (defun escape-sh-token-within-double-quotes (x s &key (quote t)) + "Escape a string TOKEN within double-quotes +for use within a POSIX Bourne shell, outputing to S; +omit the outer double-quotes if key argument :QUOTE is NIL" + (when quote (princ #\" s)) + (loop :for c :across x :do + (when (find c "$`\\\"") (princ #\\ s)) + (princ c s)) + (when quote (princ #\" s))) + + (defun easy-sh-character-p (x) + "Is X an \"easy\" character that does not require quoting by the shell?" + (or (alphanumericp x) (find x "+-_.,%@:/="))) + + (defun escape-sh-token (token &optional s) + "Escape a string TOKEN within double-quotes if needed +for use within a POSIX Bourne shell, outputing to S." + (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p + :escaper 'escape-sh-token-within-double-quotes)) + + (defun escape-shell-token (token &optional s) + "Escape a token for the current operating system shell" + (os-cond + ((os-unix-p) (escape-sh-token token s)) + ((os-windows-p) (escape-windows-token token s)))) + + (defun escape-command (command &optional s + (escaper 'escape-shell-token)) + "Given a COMMAND as a list of tokens, return a string of the +spaced, escaped tokens, using ESCAPER to escape." + (etypecase command + (string (output-string command s)) + (list (with-output (s) + (loop :for first = t :then nil :for token :in command :do + (unless first (princ #\space s)) + (funcall escaper token s)))))) + + (defun escape-windows-command (command &optional s) + "Escape a list of command-line arguments into a string suitable for parsing +by CommandLineToArgv in MS Windows" + ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx + ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx + (escape-command command s 'escape-windows-token)) + + (defun escape-sh-command (command &optional s) + "Escape a list of command-line arguments into a string suitable for parsing +by /bin/sh in POSIX" + (escape-command command s 'escape-sh-token)) + + (defun escape-shell-command (command &optional stream) + "Escape a command for the current operating system's shell" + (escape-command command stream 'escape-shell-token))) + + +(with-upgradability () + ;;; Internal helpers for run-program + (defun %normalize-io-specifier (specifier &optional role) + "Normalizes a portable I/O specifier for LAUNCH-PROGRAM into an implementation-dependent +argument to pass to the internal RUN-PROGRAM" + (declare (ignorable role)) + (typecase specifier + (null (or #+(or allegro lispworks) (null-device-pathname))) + (string (parse-native-namestring specifier)) + (pathname specifier) + (stream specifier) + ((eql :stream) :stream) + ((eql :interactive) + #+(or allegro lispworks) nil + #+clisp :terminal + #+(or abcl clozure cmucl ecl mkcl sbcl scl) t + #-(or abcl clozure cmucl ecl mkcl sbcl scl allegro lispworks clisp) + (not-implemented-error :interactive-output + "On this lisp implementation, cannot interpret ~a value of ~a" + specifier role)) + ((eql :output) + (cond ((eq role :error-output) + #+(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl) + :output + #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl) + (not-implemented-error :error-output-redirect + "Can't send ~a to ~a on this lisp implementation." + role specifier)) + (t (parameter-error "~S IO specifier invalid for ~S" specifier role)))) + ((eql t) + #+ (or lispworks abcl) + (not-implemented-error :interactive-output + "On this lisp implementation, cannot interpret ~a value of ~a" + specifier role) + #- (or lispworks abcl) + (cond ((eq role :error-output) *error-output*) + ((eq role :output) #+lispworks *terminal-io* #-lispworks *standard-output*) + ((eq role :input) *standard-input*))) + (otherwise + (parameter-error "Incorrect I/O specifier ~S for ~S" + specifier role)))) + + (defun %interactivep (input output error-output) + (member :interactive (list input output error-output))) + + (defun %signal-to-exit-code (signum) + (+ 128 signum)) + + (defun %code-to-status (exit-code signal-code) + (cond ((null exit-code) :running) + ((null signal-code) (values :exited exit-code)) + (t (values :signaled signal-code)))) + + #+mkcl + (defun %mkcl-signal-to-number (signal) + (require :mk-unix) + (symbol-value (find-symbol signal :mk-unix))) + + (defclass process-info () + (;; The process field is highly platform-, implementation-, and + ;; even version-dependent. + ;; Prior to LispWorks 7, the only information that + ;; `sys:run-shell-command` with `:wait nil` was certain to return + ;; is a PID (e.g. when all streams are nil), hence we stored it + ;; and used `sys:pid-exit-status` to obtain an exit status + ;; later. That is still what we do. + ;; From LispWorks 7 on, if `sys:run-shell-command` does not + ;; return a proper stream, we are instead given a dummy stream. + ;; We can thus always store a stream and use + ;; `sys:pipe-exit-status` to obtain an exit status later. + ;; The advantage of dealing with streams instead of PID is the + ;; availability of functions like `sys:pipe-kill-process`. + (process :initform nil) + (input-stream :initform nil) + (output-stream :initform nil) + (bidir-stream :initform nil) + (error-output-stream :initform nil) + ;; For backward-compatibility, to maintain the property (zerop + ;; exit-code) <-> success, an exit in response to a signal is + ;; encoded as 128+signum. + (exit-code :initform nil) + ;; If the platform allows it, distinguish exiting with a code + ;; >128 from exiting in response to a signal by setting this code + (signal-code :initform nil))) + +;;;--------------------------------------------------------------------------- +;;; The following two helper functions take care of handling the IF-EXISTS and +;;; IF-DOES-NOT-EXIST arguments for RUN-PROGRAM. In particular, they process the +;;; :ERROR, :APPEND, and :SUPERSEDE arguments *here*, allowing the master +;;; function to treat input and output files unconditionally for reading and +;;; writing. +;;;--------------------------------------------------------------------------- + + (defun %handle-if-exists (file if-exists) + (when (or (stringp file) (pathnamep file)) + (ecase if-exists + ((:append :supersede :error) + (with-open-file (dummy file :direction :output :if-exists if-exists) + (declare (ignorable dummy))))))) + + (defun %handle-if-does-not-exist (file if-does-not-exist) + (when (or (stringp file) (pathnamep file)) + (ecase if-does-not-exist + ((:create :error) + (with-open-file (dummy file :direction :probe + :if-does-not-exist if-does-not-exist) + (declare (ignorable dummy))))))) + + (defun process-info-error-output (process-info) + (slot-value process-info 'error-output-stream)) + (defun process-info-input (process-info) + (or (slot-value process-info 'bidir-stream) + (slot-value process-info 'input-stream))) + (defun process-info-output (process-info) + (or (slot-value process-info 'bidir-stream) + (slot-value process-info 'output-stream))) + + (defun process-info-pid (process-info) + (let ((process (slot-value process-info 'process))) + (declare (ignorable process)) + #+abcl (symbol-call :sys :process-pid process) + #+allegro process + #+clozure (ccl:external-process-id process) + #+ecl (ext:external-process-pid process) + #+(or cmucl scl) (ext:process-pid process) + #+lispworks7+ (sys:pipe-pid process) + #+(and lispworks (not lispworks7+)) process + #+mkcl (mkcl:process-id process) + #+sbcl (sb-ext:process-pid process) + #-(or abcl allegro clozure cmucl ecl mkcl lispworks sbcl scl) + (not-implemented-error 'process-info-pid))) + + (defun %process-status (process-info) + (if-let (exit-code (slot-value process-info 'exit-code)) + (return-from %process-status + (if-let (signal-code (slot-value process-info 'signal-code)) + (values :signaled signal-code) + (values :exited exit-code)))) + #-(or allegro clozure cmucl ecl lispworks mkcl sbcl scl) + (not-implemented-error '%process-status) + (if-let (process (slot-value process-info 'process)) + (multiple-value-bind (status code) + (progn + #+allegro (multiple-value-bind (exit-code pid signal-code) + (sys:reap-os-subprocess :pid process :wait nil) + (assert pid) + (%code-to-status exit-code signal-code)) + #+clozure (ccl:external-process-status process) + #+(or cmucl scl) (let ((status (ext:process-status process))) + (if (member status '(:exited :signaled)) + ;; Calling ext:process-exit-code on + ;; processes that are still alive + ;; yields an undefined result + (values status (ext:process-exit-code process)) + status)) + #+ecl (ext:external-process-status process) + #+lispworks + ;; a signal is only returned on LispWorks 7+ + (multiple-value-bind (exit-code signal-code) + (symbol-call :sys + #+lispworks7+ :pipe-exit-status + #-lispworks7+ :pid-exit-status + process :wait nil) + (%code-to-status exit-code signal-code)) + #+mkcl (let ((status (mk-ext:process-status process))) + (if (eq status :exited) + ;; Only call mk-ext:process-exit-code when + ;; necessary since it leads to another waitpid() + (let ((code (mk-ext:process-exit-code process))) + (if (stringp code) + (values :signaled (%mkcl-signal-to-number code)) + (values :exited code))) + status)) + #+sbcl (let ((status (sb-ext:process-status process))) + (if (eq status :running) + :running + ;; sb-ext:process-exit-code can also be + ;; called for stopped processes to determine + ;; the signal that stopped them + (values status (sb-ext:process-exit-code process))))) + (case status + (:exited (setf (slot-value process-info 'exit-code) code)) + (:signaled (let ((%code (%signal-to-exit-code code))) + (setf (slot-value process-info 'exit-code) %code + (slot-value process-info 'signal-code) code)))) + (if code + (values status code) + status)))) + + (defun process-alive-p (process-info) + "Check if a process has yet to exit." + (unless (slot-value process-info 'exit-code) + #+abcl (sys:process-alive-p (slot-value process-info 'process)) + #+(or cmucl scl) (ext:process-alive-p (slot-value process-info 'process)) + #+sbcl (sb-ext:process-alive-p (slot-value process-info 'process)) + #-(or abcl cmucl sbcl scl) (find (%process-status process-info) + '(:running :stopped :continued :resumed)))) + + (defun wait-process (process-info) + "Wait for the process to terminate, if it is still running. +Otherwise, return immediately. An exit code (a number) will be +returned, with 0 indicating success, and anything else indicating +failure. If the process exits after receiving a signal, the exit code +will be the sum of 128 and the (positive) numeric signal code. A second +value may be returned in this case: the numeric signal code itself. +Any asynchronously spawned process requires this function to be run +before it is garbage-collected in order to free up resources that +might otherwise be irrevocably lost." + (if-let (exit-code (slot-value process-info 'exit-code)) + (if-let (signal-code (slot-value process-info 'signal-code)) + (values exit-code signal-code) + exit-code) + (let ((process (slot-value process-info 'process))) + #-(or abcl allegro clozure cmucl ecl lispworks mkcl sbcl scl) + (not-implemented-error 'wait-process) + (when process + ;; 1- wait + #+clozure (ccl::external-process-wait process) + #+(or cmucl scl) (ext:process-wait process) + #+sbcl (sb-ext:process-wait process) + ;; 2- extract result + (multiple-value-bind (exit-code signal-code) + (progn + #+abcl (sys:process-wait process) + #+allegro (multiple-value-bind (exit-code pid signal) + (sys:reap-os-subprocess :pid process :wait t) + (assert pid) + (values exit-code signal)) + #+clozure (multiple-value-bind (status code) + (ccl:external-process-status process) + (if (eq status :signaled) + (values nil code) + code)) + #+(or cmucl scl) (let ((status (ext:process-status process)) + (code (ext:process-exit-code process))) + (if (eq status :signaled) + (values nil code) + code)) + #+ecl (multiple-value-bind (status code) + (ext:external-process-wait process t) + (if (eq status :signaled) + (values nil code) + code)) + #+lispworks (symbol-call :sys + #+lispworks7+ :pipe-exit-status + #-lispworks7+ :pid-exit-status + process :wait t) + #+mkcl (let ((code (mkcl:join-process process))) + (if (stringp code) + (values nil (%mkcl-signal-to-number code)) + code)) + #+sbcl (let ((status (sb-ext:process-status process)) + (code (sb-ext:process-exit-code process))) + (if (eq status :signaled) + (values nil code) + code))) + (if signal-code + (let ((%exit-code (%signal-to-exit-code signal-code))) + (setf (slot-value process-info 'exit-code) %exit-code + (slot-value process-info 'signal-code) signal-code) + (values %exit-code signal-code)) + (progn (setf (slot-value process-info 'exit-code) exit-code) + exit-code))))))) + + ;; WARNING: For signals other than SIGTERM and SIGKILL this may not + ;; do what you expect it to. Sending SIGSTOP to a process spawned + ;; via LAUNCH-PROGRAM, e.g., will stop the shell /bin/sh that is used + ;; to run the command (via `sh -c command`) but not the actual + ;; command. + #+os-unix + (defun %posix-send-signal (process-info signal) + #+allegro (excl.osi:kill (slot-value process-info 'process) signal) + #+clozure (ccl:signal-external-process (slot-value process-info 'process) + signal :error-if-exited nil) + #+(or cmucl scl) (ext:process-kill (slot-value process-info 'process) signal) + #+sbcl (sb-ext:process-kill (slot-value process-info 'process) signal) + #-(or allegro clozure cmucl sbcl scl) + (if-let (pid (process-info-pid process-info)) + (symbol-call :uiop :run-program + (format nil "kill -~a ~a" signal pid) :ignore-error-status t))) + + ;;; this function never gets called on Windows, but the compiler cannot tell + ;;; that. [2016/09/25:rpg] + #+os-windows + (defun %posix-send-signal (process-info signal) + (declare (ignore process-info signal)) + (values)) + + (defun terminate-process (process-info &key urgent) + "Cause the process to exit. To that end, the process may or may +not be sent a signal, which it will find harder (or even impossible) +to ignore if URGENT is T. On some platforms, it may also be subject to +race conditions." + (declare (ignorable urgent)) + #+abcl (sys:process-kill (slot-value process-info 'process)) + ;; On ECL, this will only work on versions later than 2016-09-06, + ;; but we still want to compile on earlier versions, so we use symbol-call + #+ecl (symbol-call :ext :terminate-process (slot-value process-info 'process) urgent) + #+lispworks7+ (sys:pipe-kill-process (slot-value process-info 'process)) + #+mkcl (mk-ext:terminate-process (slot-value process-info 'process) + :force urgent) + #-(or abcl ecl lispworks7+ mkcl) + (os-cond + ((os-unix-p) (%posix-send-signal process-info (if urgent 9 15))) + ((os-windows-p) (if-let (pid (process-info-pid process-info)) + (symbol-call :uiop :run-program + (format nil "taskkill ~:[~;/f ~]/pid ~a" urgent pid) + :ignore-error-status t))) + (t (not-implemented-error 'terminate-process)))) + + (defun close-streams (process-info) + "Close any stream that the process might own. Needs to be run +whenever streams were requested by passing :stream to :input, :output, +or :error-output." + (dolist (stream + (cons (slot-value process-info 'error-output-stream) + (if-let (bidir-stream (slot-value process-info 'bidir-stream)) + (list bidir-stream) + (list (slot-value process-info 'input-stream) + (slot-value process-info 'output-stream))))) + (when stream (close stream)))) + + (defun launch-program (command &rest keys + &key + input (if-input-does-not-exist :error) + output (if-output-exists :supersede) + error-output (if-error-output-exists :supersede) + (element-type #-clozure *default-stream-element-type* + #+clozure 'character) + (external-format *utf-8-external-format*) + directory + #+allegro separate-streams + &allow-other-keys) + "Launch program specified by COMMAND, +either a list of strings specifying a program and list of arguments, +or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on +Windows) _asynchronously_. + +If OUTPUT is a pathname, a string designating a pathname, or NIL (the +default) designating the null device, the file at that path is used as +output. +If it's :INTERACTIVE, output is inherited from the current process; +beware that this may be different from your *STANDARD-OUTPUT*, and +under SLIME will be on your *inferior-lisp* buffer. If it's T, output +goes to your current *STANDARD-OUTPUT* stream. If it's :STREAM, a new +stream will be made available that can be accessed via +PROCESS-INFO-OUTPUT and read from. Otherwise, OUTPUT should be a value +that the underlying lisp implementation knows how to handle. + +IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a +pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the +default). The meaning of these values and their effect on the case +where OUTPUT does not exist, is analogous to the IF-EXISTS parameter +to OPEN with :DIRECTION :OUTPUT. + +ERROR-OUTPUT is similar to OUTPUT. T designates the *ERROR-OUTPUT*, +:OUTPUT means redirecting the error output to the output stream, +and :STREAM causes a stream to be made available via +PROCESS-INFO-ERROR-OUTPUT. + +IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it +affects ERROR-OUTPUT rather than OUTPUT. + +INPUT is similar to OUTPUT, except that T designates the +*STANDARD-INPUT* and a stream requested through the :STREAM keyword +would be available through PROCESS-INFO-INPUT. + +IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string +or a pathname, can take the values :CREATE and :ERROR (the +default). The meaning of these values is analogous to the +IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT. + +ELEMENT-TYPE and EXTERNAL-FORMAT are passed on to your Lisp +implementation, when applicable, for creation of the output stream. + +LAUNCH-PROGRAM returns a PROCESS-INFO object. + +LAUNCH-PROGRAM currently does not smooth over all the differences between +implementations. Of particular note is when streams are provided for OUTPUT or +ERROR-OUTPUT. Some implementations don't support this at all, some support only +certain subclasses of streams, and some support any arbitrary +stream. Additionally, the implementations that support streams may have +differing behavior on how those streams are filled with data. If data is not +periodically read from the child process and sent to the stream, the child +could block because its output buffers are full." + #-(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) + (progn command keys input output error-output directory element-type external-format + if-input-does-not-exist if-output-exists if-error-output-exists ;; ignore + (not-implemented-error 'launch-program)) + #+allegro + (when (some #'(lambda (stream) + (and (streamp stream) + (not (file-stream-p stream)))) + (list input output error-output)) + (parameter-error "~S: Streams passed as I/O parameters need to be file streams on this lisp" + 'launch-program)) + #+(or abcl clisp lispworks) + (when (some #'streamp (list input output error-output)) + (parameter-error "~S: I/O parameters cannot be foreign streams on this lisp" + 'launch-program)) + #+clisp + (unless (eq error-output :interactive) + (parameter-error "~S: The only admissible value for ~S is ~S on this lisp" + 'launch-program :error-output :interactive)) + #+ecl + (when (and (version< (lisp-implementation-version) "20.4.24") + (some #'(lambda (stream) + (and (streamp stream) + (not (file-or-synonym-stream-p stream)))) + (list input output error-output))) + (parameter-error "~S: Streams passed as I/O parameters need to be (synonymous with) file streams on this lisp" + 'launch-program)) + #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) + (nest + (progn ;; see comments for these functions + (%handle-if-does-not-exist input if-input-does-not-exist) + (%handle-if-exists output if-output-exists) + (%handle-if-exists error-output if-error-output-exists)) + #+ecl (let ((*standard-input* *stdin*) + (*standard-output* *stdout*) + (*error-output* *stderr*))) + (let ((process-info (make-instance 'process-info)) + (input (%normalize-io-specifier input :input)) + (output (%normalize-io-specifier output :output)) + (error-output (%normalize-io-specifier error-output :error-output)) + #+(and allegro os-windows) (interactive (%interactivep input output error-output)) + (command + (etypecase command + #+os-unix (string `("/bin/sh" "-c" ,command)) + #+os-unix (list command) + #+os-windows + (string + ;; NB: On other Windows implementations, this is utterly bogus + ;; except in the most trivial cases where no quoting is needed. + ;; Use at your own risk. + #-(or allegro clisp clozure ecl) + (nest + #+(or ecl sbcl) (unless (find-symbol* :escape-arguments #+ecl :ext #+sbcl :sb-impl nil)) + (parameter-error "~S doesn't support string commands on Windows on this Lisp" + 'launch-program command)) + ;; NB: We add cmd /c here. Behavior without going through cmd is not well specified + ;; when the command contains spaces or special characters: + ;; IIUC, the system will use space as a separator, + ;; but the C++ argv-decoding libraries won't, and + ;; you're supposed to use an extra argument to CreateProcess to bridge the gap, + ;; yet neither allegro nor clisp provide access to that argument. + #+(or allegro clisp) (strcat "cmd /c " command) + ;; On ClozureCL for Windows, we assume you are using + ;; r15398 or later in 1.9 or later, + ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858 + ;; On ECL, commit 2040629 https://gitlab.com/embeddable-common-lisp/ecl/issues/304 + ;; On SBCL, we assume the patch from fcae0fd (to be part of SBCL 1.3.13) + #+(or clozure ecl sbcl) (cons "cmd" (strcat "/c " command))) + #+os-windows + (list + #+allegro (escape-windows-command command) + #-allegro command))))) + #+(or abcl (and allegro os-unix) clozure cmucl ecl mkcl sbcl) + (let ((program (car command)) + #-allegro (arguments (cdr command)))) + #+(and (or ecl sbcl) os-windows) + (multiple-value-bind (arguments escape-arguments) + (if (listp arguments) + (values arguments t) + (values (list arguments) nil))) + #-(or allegro mkcl sbcl) (with-current-directory (directory)) + (multiple-value-bind + #+(or abcl clozure cmucl sbcl scl) (process) + #+allegro (in-or-io out-or-err err-or-pid pid-or-nil) + #+ecl (stream code process) + #+lispworks (io-or-pid err-or-nil #-lispworks7+ pid-or-nil) + #+mkcl (stream process code) + #.`(apply + #+abcl 'sys:run-program + #+allegro ,@'('excl:run-shell-command + #+os-unix (coerce (cons program command) 'vector) + #+os-windows command) + #+clozure 'ccl:run-program + #+(or cmucl ecl scl) 'ext:run-program + #+lispworks ,@'('system:run-shell-command `("/usr/bin/env" ,@command)) ; full path needed + #+mkcl 'mk-ext:run-program + #+sbcl 'sb-ext:run-program + #+(or abcl clozure cmucl ecl mkcl sbcl) ,@'(program arguments) + #+(and (or ecl sbcl) os-windows) ,@'(:escape-arguments escape-arguments) + :input input :if-input-does-not-exist :error + :output output :if-output-exists :append + ,(or #+(or allegro lispworks) :error-output :error) error-output + ,(or #+(or allegro lispworks) :if-error-output-exists :if-error-exists) :append + :wait nil :element-type element-type :external-format external-format + :allow-other-keys t + #+allegro ,@`(:directory directory + #+os-windows ,@'(:show-window (if interactive nil :hide))) + #+lispworks ,@'(:save-exit-status t) + #+mkcl ,@'(:directory (native-namestring directory)) + #-sbcl keys ;; on SBCL, don't pass :directory nil but remove it from the keys + #+sbcl ,@'(:search t (if directory keys (remove-plist-key :directory keys))))) + (labels ((prop (key value) (setf (slot-value process-info key) value))) + #+allegro + (cond + (separate-streams + (prop 'process pid-or-nil) + (when (eq input :stream) (prop 'input-stream in-or-io)) + (when (eq output :stream) (prop 'output-stream out-or-err)) + (when (eq error-output :stream) (prop 'error-output-stream err-or-pid))) + (t + (prop 'process err-or-pid) + (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)) + (0) + (1 (prop 'input-stream in-or-io)) + (2 (prop 'output-stream in-or-io)) + (3 (prop 'bidir-stream in-or-io))) + (when (eq error-output :stream) + (prop 'error-output-stream out-or-err)))) + #+(or abcl clozure cmucl sbcl scl) + (progn + (prop 'process process) + (when (eq input :stream) + (nest + (prop 'input-stream) + #+abcl (symbol-call :sys :process-input) + #+clozure (ccl:external-process-input-stream) + #+(or cmucl scl) (ext:process-input) + #+sbcl (sb-ext:process-input) + process)) + (when (eq output :stream) + (nest + (prop 'output-stream) + #+abcl (symbol-call :sys :process-output) + #+clozure (ccl:external-process-output-stream) + #+(or cmucl scl) (ext:process-output) + #+sbcl (sb-ext:process-output) + process)) + (when (eq error-output :stream) + (nest + (prop 'error-output-stream) + #+abcl (symbol-call :sys :process-error) + #+clozure (ccl:external-process-error-stream) + #+(or cmucl scl) (ext:process-error) + #+sbcl (sb-ext:process-error) + process))) + #+(or ecl mkcl) + (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) + code ;; ignore + (unless (zerop mode) + (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream)) + (when (eq error-output :stream) + (prop 'error-output-stream + (if (version< (lisp-implementation-version) "16.0.0") + (symbol-call :ext :external-process-error process) + (symbol-call :ext :external-process-error-stream process)))) + (prop 'process process)) + #+lispworks + ;; See also the comments on the process-info class + (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) + (cond + ((or (plusp mode) (eq error-output :stream)) + (prop 'process #+lispworks7+ io-or-pid #-lispworks7+ pid-or-nil) + (when (plusp mode) + (prop (ecase mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) + io-or-pid)) + (when (eq error-output :stream) + (prop 'error-output-stream err-or-nil))) + ;; Prior to Lispworks 7, this returned (pid); now it + ;; returns (io err pid) of which we keep io. + (t (prop 'process io-or-pid))))) + process-info))) + +;;;; ------------------------------------------------------------------------- +;;;; run-program initially from xcvb-driver. + +(uiop/package:define-package :uiop/run-program + (:nicknames :asdf/run-program) ; OBSOLETE. Used by cl-sane, printv. + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version + :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream :uiop/launch-program) + (:export + #:run-program + #:slurp-input-stream #:vomit-output-stream + #:subprocess-error + #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process) + (:import-from :uiop/launch-program + #:%handle-if-does-not-exist #:%handle-if-exists #:%interactivep + #:input-stream #:output-stream #:error-output-stream)) +(in-package :uiop/run-program) + +;;;; Slurping a stream, typically the output of another program +(with-upgradability () + (defun call-stream-processor (fun processor stream) + "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM, +a PROCESSOR specification which is either an atom or a list specifying +a processor an keyword arguments, call the specified processor with +the given STREAM as input" + (if (consp processor) + (apply fun (first processor) stream (rest processor)) + (funcall fun processor stream))) + + (defgeneric slurp-input-stream (processor input-stream &key) + (:documentation + "SLURP-INPUT-STREAM is a generic function with two positional arguments +PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps) +the contents of the INPUT-STREAM and processes them according to a method +specified by PROCESSOR. + +Built-in methods include the following: +* if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument +* if PROCESSOR is a list, its first element should be a function. It will be applied to a cons of the + INPUT-STREAM and the rest of the list. That is (x . y) will be treated as + \(APPLY x y\) +* if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream, + per copy-stream-to-stream, with appropriate keyword arguments. +* if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM + are returned as a string, as per SLURP-STREAM-STRING. +* if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES. +* if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE. +* if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS. +* if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM. +* if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned. + +Programmers are encouraged to define their own methods for this generic function.")) + + #-genera + (defmethod slurp-input-stream ((function function) input-stream &key) + (funcall function input-stream)) + + (defmethod slurp-input-stream ((list cons) input-stream &key) + (apply (first list) input-stream (rest list))) + + #-genera + (defmethod slurp-input-stream ((output-stream stream) input-stream + &key linewise prefix (element-type 'character) buffer-size) + (copy-stream-to-stream + input-stream output-stream + :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) + + (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped) + (slurp-stream-string stream :stripped stripped)) + + (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped) + (slurp-stream-string stream :stripped stripped)) + + (defmethod slurp-input-stream ((x (eql :lines)) stream &key count) + (slurp-stream-lines stream :count count)) + + (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0)) + (slurp-stream-line stream :at at)) + + (defmethod slurp-input-stream ((x (eql :forms)) stream &key count) + (slurp-stream-forms stream :count count)) + + (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0)) + (slurp-stream-form stream :at at)) + + (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) + (apply 'slurp-input-stream *standard-output* stream keys)) + + (defmethod slurp-input-stream ((x null) (stream t) &key) + nil) + + (defmethod slurp-input-stream ((pathname pathname) input + &key + (element-type *default-stream-element-type*) + (external-format *utf-8-external-format*) + (if-exists :rename-and-delete) + (if-does-not-exist :create) + buffer-size + linewise) + (with-output-file (output pathname + :element-type element-type + :external-format external-format + :if-exists if-exists + :if-does-not-exist if-does-not-exist) + (copy-stream-to-stream + input output + :element-type element-type :buffer-size buffer-size :linewise linewise))) + + (defmethod slurp-input-stream (x stream + &key linewise prefix (element-type 'character) buffer-size) + (declare (ignorable stream linewise prefix element-type buffer-size)) + (cond + #+genera + ((functionp x) (funcall x stream)) + #+genera + ((output-stream-p x) + (copy-stream-to-stream + stream x + :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) + (t + (parameter-error "Invalid ~S destination ~S" 'slurp-input-stream x))))) + +;;;; Vomiting a stream, typically into the input of another program. +(with-upgradability () + (defgeneric vomit-output-stream (processor output-stream &key) + (:documentation + "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments +PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits) +some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR. + +Built-in methods include the following: +* if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument +* if PROCESSOR is a list, its first element should be a function. + It will be applied to a cons of the OUTPUT-STREAM and the rest of the list. + That is (x . y) will be treated as \(APPLY x y\) +* if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM, + per copy-stream-to-stream, with appropriate keyword arguments. +* if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM. +* if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done. + +Programmers are encouraged to define their own methods for this generic function.")) + + #-genera + (defmethod vomit-output-stream ((function function) output-stream &key) + (funcall function output-stream)) + + (defmethod vomit-output-stream ((list cons) output-stream &key) + (apply (first list) output-stream (rest list))) + + #-genera + (defmethod vomit-output-stream ((input-stream stream) output-stream + &key linewise prefix (element-type 'character) buffer-size) + (copy-stream-to-stream + input-stream output-stream + :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) + + (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri) + (princ x stream) + (when fresh-line (fresh-line stream)) + (when terpri (terpri stream)) + (values)) + + (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) + (apply 'vomit-output-stream *standard-input* stream keys)) + + (defmethod vomit-output-stream ((x null) (stream t) &key) + (values)) + + (defmethod vomit-output-stream ((pathname pathname) input + &key + (element-type *default-stream-element-type*) + (external-format *utf-8-external-format*) + (if-exists :rename-and-delete) + (if-does-not-exist :create) + buffer-size + linewise) + (with-output-file (output pathname + :element-type element-type + :external-format external-format + :if-exists if-exists + :if-does-not-exist if-does-not-exist) + (copy-stream-to-stream + input output + :element-type element-type :buffer-size buffer-size :linewise linewise))) + + (defmethod vomit-output-stream (x stream + &key linewise prefix (element-type 'character) buffer-size) + (declare (ignorable stream linewise prefix element-type buffer-size)) + (cond + #+genera + ((functionp x) (funcall x stream)) + #+genera + ((input-stream-p x) + (copy-stream-to-stream + x stream + :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) + (t + (parameter-error "Invalid ~S source ~S" 'vomit-output-stream x))))) + + +;;;; Run-program: synchronously run a program in a subprocess, handling input, output and error-output. +(with-upgradability () + (define-condition subprocess-error (error) + ((code :initform nil :initarg :code :reader subprocess-error-code) + (command :initform nil :initarg :command :reader subprocess-error-command) + (process :initform nil :initarg :process :reader subprocess-error-process)) + (:report (lambda (condition stream) + (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D~]" + (subprocess-error-process condition) + (subprocess-error-command condition) + (subprocess-error-code condition))))) + + (defun %check-result (exit-code &key command process ignore-error-status) + (unless ignore-error-status + (unless (eql exit-code 0) + (cerror "IGNORE-ERROR-STATUS" + 'subprocess-error :command command :code exit-code :process process))) + exit-code) + + (defun %active-io-specifier-p (specifier) + "Determines whether a run-program I/O specifier requires Lisp-side processing +via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T), +or whether it's already taken care of by the implementation's underlying run-program." + (not (typep specifier '(or null string pathname (member :interactive :output) + #+(or cmucl (and sbcl os-unix) scl) (or stream (eql t)) + #+lispworks file-stream)))) + + (defun %run-program (command &rest keys &key &allow-other-keys) + "DEPRECATED. Use LAUNCH-PROGRAM instead." + (apply 'launch-program command keys)) + + (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner + &key + (element-type #-clozure *default-stream-element-type* #+clozure 'character) + (external-format *utf-8-external-format*) &allow-other-keys) + ;; handle redirection for run-program and system + ;; SPEC is the specification for the subprocess's input or output or error-output + ;; TVAL is the value used if the spec is T + ;; GF is the generic function to call to handle arbitrary values of SPEC + ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background + ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it) + ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument + ;; FUN is a function of the new reduced spec and an activity function to call with a stream + ;; when the subprocess is active and communicating through that stream. + ;; ACTIVEP is a boolean true if we will get to run code while the process is running + ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open. + ;; RETURNER is a function called with the value of the activity. + ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way. + (declare (ignorable stream-easy-p)) + (let* ((actual-spec (if (eq spec t) tval spec)) + (activity-spec (if (eq actual-spec :output) + (ecase direction + ((:input :output) + (parameter-error "~S does not allow ~S as a ~S spec" + 'run-program :output direction)) + ((:error-output) + nil)) + actual-spec))) + (labels ((activity (stream) + (call-function returner (call-stream-processor gf activity-spec stream))) + (easy-case () + (funcall fun actual-spec nil)) + (hard-case () + (if activep + (funcall fun :stream #'activity) + (with-temporary-file (:pathname tmp) + (ecase direction + (:input + (with-output-file (s tmp :if-exists :overwrite + :external-format external-format + :element-type element-type) + (activity s)) + (funcall fun tmp nil)) + ((:output :error-output) + (multiple-value-prog1 (funcall fun tmp nil) + (with-input-file (s tmp + :external-format external-format + :element-type element-type) + (activity s))))))))) + (typecase activity-spec + ((or null string pathname (eql :interactive)) + (easy-case)) + #+(or cmucl (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard + (stream + (if stream-easy-p (easy-case) (hard-case))) + (t + (hard-case)))))) + + (defmacro place-setter (place) + (when place + (let ((value (gensym))) + `#'(lambda (,value) (setf ,place ,value))))) + + (defmacro with-program-input (((reduced-input-var + &optional (input-activity-var (gensym) iavp)) + input-form &key setf stream-easy-p active keys) &body body) + `(apply '%call-with-program-io 'vomit-output-stream *standard-input* ,stream-easy-p + #'(lambda (,reduced-input-var ,input-activity-var) + ,@(unless iavp `((declare (ignore ,input-activity-var)))) + ,@body) + :input ,input-form ,active (place-setter ,setf) ,keys)) + + (defmacro with-program-output (((reduced-output-var + &optional (output-activity-var (gensym) oavp)) + output-form &key setf stream-easy-p active keys) &body body) + `(apply '%call-with-program-io 'slurp-input-stream *standard-output* ,stream-easy-p + #'(lambda (,reduced-output-var ,output-activity-var) + ,@(unless oavp `((declare (ignore ,output-activity-var)))) + ,@body) + :output ,output-form ,active (place-setter ,setf) ,keys)) + + (defmacro with-program-error-output (((reduced-error-output-var + &optional (error-output-activity-var (gensym) eoavp)) + error-output-form &key setf stream-easy-p active keys) + &body body) + `(apply '%call-with-program-io 'slurp-input-stream *error-output* ,stream-easy-p + #'(lambda (,reduced-error-output-var ,error-output-activity-var) + ,@(unless eoavp `((declare (ignore ,error-output-activity-var)))) + ,@body) + :error-output ,error-output-form ,active (place-setter ,setf) ,keys)) + + (defun %use-launch-program (command &rest keys + &key input output error-output ignore-error-status &allow-other-keys) + ;; helper for RUN-PROGRAM when using LAUNCH-PROGRAM + #+(or cormanlisp gcl (and lispworks os-windows) mcl xcl) + (progn + command keys input output error-output ignore-error-status ;; ignore + (not-implemented-error '%use-launch-program)) + (when (member :stream (list input output error-output)) + (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument" + 'run-program :stream)) + (let* ((active-input-p (%active-io-specifier-p input)) + (active-output-p (%active-io-specifier-p output)) + (active-error-output-p (%active-io-specifier-p error-output)) + (activity + (cond + (active-output-p :output) + (active-input-p :input) + (active-error-output-p :error-output) + (t nil))) + output-result error-output-result exit-code process-info) + (with-program-output ((reduced-output output-activity) + output :keys keys :setf output-result + :stream-easy-p t :active (eq activity :output)) + (with-program-error-output ((reduced-error-output error-output-activity) + error-output :keys keys :setf error-output-result + :stream-easy-p t :active (eq activity :error-output)) + (with-program-input ((reduced-input input-activity) + input :keys keys + :stream-easy-p t :active (eq activity :input)) + (setf process-info + (apply 'launch-program command + :input reduced-input :output reduced-output + :error-output (if (eq error-output :output) :output reduced-error-output) + keys)) + (labels ((get-stream (stream-name &optional fallbackp) + (or (slot-value process-info stream-name) + (when fallbackp + (slot-value process-info 'bidir-stream)))) + (run-activity (activity stream-name &optional fallbackp) + (if-let (stream (get-stream stream-name fallbackp)) + (funcall activity stream) + (error 'subprocess-error + :code `(:missing ,stream-name) + :command command :process process-info)))) + (unwind-protect + (ecase activity + ((nil)) + (:input (run-activity input-activity 'input-stream t)) + (:output (run-activity output-activity 'output-stream t)) + (:error-output (run-activity error-output-activity 'error-output-stream))) + (close-streams process-info) + (setf exit-code (wait-process process-info))))))) + (%check-result exit-code + :command command :process process-info + :ignore-error-status ignore-error-status) + (values output-result error-output-result exit-code))) + + (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM + (etypecase command + (string command) + (list (escape-shell-command + (os-cond + ((os-unix-p) (cons "exec" command)) + (t command)))))) + + (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM + (flet ((redirect (spec operator) + (let ((pathname + (typecase spec + (null (null-device-pathname)) + (string (parse-native-namestring spec)) + (pathname spec) + ((eql :output) + (unless (equal operator " 2>>") + (parameter-error "~S: only the ~S argument can be ~S" + 'run-program :error-output :output)) + (return-from redirect '(" 2>&1")))))) + (when pathname + (list operator " " + (escape-shell-token (native-namestring pathname))))))) + (let* ((redirections (append (redirect in " <") (redirect out " >>") (redirect err " 2>>"))) + (normalized (%normalize-system-command command)) + (directory (or directory #+(or abcl xcl) (getcwd))) + (chdir (when directory + (let ((dir-arg (escape-shell-token (native-namestring directory)))) + (os-cond + ((os-unix-p) `("cd " ,dir-arg " ; ")) + ((os-windows-p) `("cd /d " ,dir-arg " & "))))))) + (reduce/strcat + (os-cond + ((os-unix-p) `(,@(when redirections `("exec " ,@redirections " ; ")) ,@chdir ,normalized)) + ((os-windows-p) `(,@redirections " (" ,@chdir ,normalized ")"))))))) + + (defun %system (command &rest keys &key directory + input (if-input-does-not-exist :error) + output (if-output-exists :supersede) + error-output (if-error-output-exists :supersede) + &allow-other-keys) + "A portable abstraction of a low-level call to libc's system()." + (declare (ignorable keys directory input if-input-does-not-exist output + if-output-exists error-output if-error-output-exists)) + (when (member :stream (list input output error-output)) + (parameter-error "~S: ~S is not allowed as synchronous I/O redirection argument" + 'run-program :stream)) + #+(or abcl allegro clozure cmucl ecl (and lispworks os-unix) mkcl sbcl scl) + (let (#+(or abcl ecl mkcl) + (version (parse-version + #-abcl + (lisp-implementation-version) + #+abcl + (second (split-string (implementation-identifier) :separator '(#\-)))))) + (nest + #+abcl (unless (lexicographic< '< version '(1 4 0))) + #+ecl (unless (lexicographic<= '< version '(16 0 0))) + #+mkcl (unless (lexicographic<= '< version '(1 1 9))) + (return-from %system + (wait-process + (apply 'launch-program (%normalize-system-command command) keys))))) + #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl) + (let ((%command (%redirected-system-command command input output error-output directory))) + ;; see comments for these functions + (%handle-if-does-not-exist input if-input-does-not-exist) + (%handle-if-exists output if-output-exists) + (%handle-if-exists error-output if-error-output-exists) + #+abcl (ext:run-shell-command %command) + #+(or clasp ecl) (let ((*standard-input* *stdin*) + (*standard-output* *stdout*) + (*error-output* *stderr*)) + (ext:system %command)) + #+clisp + (let ((raw-exit-code + (or + #.`(#+os-windows ,@'(ext:run-shell-command %command) + #+os-unix ,@'(ext:run-program "/bin/sh" :arguments `("-c" ,%command)) + :wait t :input :terminal :output :terminal) + 0))) + (if (minusp raw-exit-code) + (- 128 raw-exit-code) + raw-exit-code)) + #+cormanlisp (win32:system %command) + #+gcl (system:system %command) + #+genera (not-implemented-error '%system) + #+(and lispworks os-windows) + (system:call-system %command :current-directory directory :wait t) + #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command)) + #+mkcl (mkcl:system %command) + #+xcl (system:%run-shell-command %command))) + + (defun %use-system (command &rest keys + &key input output error-output ignore-error-status &allow-other-keys) + ;; helper for RUN-PROGRAM when using %system + (let (output-result error-output-result exit-code) + (with-program-output ((reduced-output) + output :keys keys :setf output-result) + (with-program-error-output ((reduced-error-output) + error-output :keys keys :setf error-output-result) + (with-program-input ((reduced-input) input :keys keys) + (setf exit-code (apply '%system command + :input reduced-input :output reduced-output + :error-output reduced-error-output keys))))) + (%check-result exit-code + :command command + :ignore-error-status ignore-error-status) + (values output-result error-output-result exit-code))) + + (defun run-program (command &rest keys + &key ignore-error-status (force-shell nil force-shell-suppliedp) + input (if-input-does-not-exist :error) + output (if-output-exists :supersede) + error-output (if-error-output-exists :supersede) + (element-type #-clozure *default-stream-element-type* #+clozure 'character) + (external-format *utf-8-external-format*) + &allow-other-keys) + "Run program specified by COMMAND, +either a list of strings specifying a program and list of arguments, +or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows); +_synchronously_ process its output as specified and return the processing results +when the program and its output processing are complete. + +Always call a shell (rather than directly execute the command when possible) +if FORCE-SHELL is specified. Similarly, never call a shell if FORCE-SHELL is +specified to be NIL. + +Signal a continuable SUBPROCESS-ERROR if the process wasn't successful (exit-code 0), +unless IGNORE-ERROR-STATUS is specified. + +If OUTPUT is a pathname, a string designating a pathname, or NIL (the default) +designating the null device, the file at that path is used as output. +If it's :INTERACTIVE, output is inherited from the current process; +beware that this may be different from your *STANDARD-OUTPUT*, +and under SLIME will be on your *inferior-lisp* buffer. +If it's T, output goes to your current *STANDARD-OUTPUT* stream. +Otherwise, OUTPUT should be a value that is a suitable first argument to +SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments. +In this case, RUN-PROGRAM will create a temporary stream for the program output; +the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM, +using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords). +The primary value resulting from that call (or NIL if no call was needed) +will be the first value returned by RUN-PROGRAM. +E.g., using :OUTPUT :STRING will have it return the entire output stream as a string. +And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string +stripped of any ending newline. + +IF-OUTPUT-EXISTS, which is only meaningful if OUTPUT is a string or a +pathname, can take the values :ERROR, :APPEND, and :SUPERSEDE (the +default). The meaning of these values and their effect on the case +where OUTPUT does not exist, is analogous to the IF-EXISTS parameter +to OPEN with :DIRECTION :OUTPUT. + +ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned +as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*. +Also :OUTPUT means redirecting the error output to the output stream, +in which case NIL is returned. + +IF-ERROR-OUTPUT-EXISTS is similar to IF-OUTPUT-EXIST, except that it +affects ERROR-OUTPUT rather than OUTPUT. + +INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used, +no value is returned, and T designates the *STANDARD-INPUT*. + +IF-INPUT-DOES-NOT-EXIST, which is only meaningful if INPUT is a string +or a pathname, can take the values :CREATE and :ERROR (the +default). The meaning of these values is analogous to the +IF-DOES-NOT-EXIST parameter to OPEN with :DIRECTION :INPUT. + +ELEMENT-TYPE and EXTERNAL-FORMAT are passed on +to your Lisp implementation, when applicable, for creation of the output stream. + +One and only one of the stream slurping or vomiting may or may not happen +in parallel in parallel with the subprocess, +depending on options and implementation, +and with priority being given to output processing. +Other streams are completely produced or consumed +before or after the subprocess is spawned, using temporary files. + +RUN-PROGRAM returns 3 values: +0- the result of the OUTPUT slurping if any, or NIL +1- the result of the ERROR-OUTPUT slurping if any, or NIL +2- either 0 if the subprocess exited with success status, +or an indication of failure via the EXIT-CODE of the process" + (declare (ignorable input output error-output if-input-does-not-exist if-output-exists + if-error-output-exists element-type external-format ignore-error-status)) + #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl) + (not-implemented-error 'run-program) + (apply (if (or force-shell + ;; Per doc string, set FORCE-SHELL to T if we get command as a string. + ;; But don't override user's specified preference. [2015/06/29:rpg] + (and (stringp command) + (or (not force-shell-suppliedp) + #-(or allegro clisp clozure sbcl) (os-cond ((os-windows-p) t)))) + #+(or clasp clisp cormanlisp gcl (and lispworks os-windows) mcl xcl) t + ;; A race condition in ECL <= 16.0.0 prevents using ext:run-program + #+ecl #.(if-let (ver (parse-version (lisp-implementation-version))) + (lexicographic<= '< ver '(16 0 0))) + #+(and lispworks os-unix) (%interactivep input output error-output)) + '%use-system '%use-launch-program) + command keys))) + +;;;; --------------------------------------------------------------------------- +;;;; Generic support for configuration files + +(uiop/package:define-package :uiop/configuration + (:recycle :uiop/configuration :asdf/configuration) ;; necessary to upgrade from 2.27. + (:use :uiop/package :uiop/common-lisp :uiop/utility + :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build) + (:export + #:user-configuration-directories #:system-configuration-directories ;; implemented in backward-driver + #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory ;; idem + #:get-folder-path + #:xdg-data-home #:xdg-config-home #:xdg-data-dirs #:xdg-config-dirs + #:xdg-cache-home #:xdg-runtime-dir #:system-config-pathnames + #:filter-pathname-set #:xdg-data-pathnames #:xdg-config-pathnames + #:find-preferred-file #:xdg-data-pathname #:xdg-config-pathname + #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory + #:configuration-inheritance-directive-p + #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache* + #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook + #:resolve-location #:location-designator-p #:location-function-p #:*here-directory* + #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration + #:uiop-directory)) +(in-package :uiop/configuration) + +(with-upgradability () + (define-condition invalid-configuration () + ((form :reader condition-form :initarg :form) + (location :reader condition-location :initarg :location) + (format :reader condition-format :initarg :format) + (arguments :reader condition-arguments :initarg :arguments :initform nil)) + (:report (lambda (c s) + (format s (compatfmt "~@<~? (will be skipped)~@:>") + (condition-format c) + (list* (condition-form c) (condition-location c) + (condition-arguments c)))))) + + (defun configuration-inheritance-directive-p (x) + "Is X a configuration inheritance directive?" + (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) + (or (member x kw) + (and (length=n-p x 1) (member (car x) kw))))) + + (defun report-invalid-form (reporter &rest args) + "Report an invalid form according to REPORTER and various ARGS" + (etypecase reporter + (null + (apply 'error 'invalid-configuration args)) + (function + (apply reporter args)) + ((or symbol string) + (apply 'error reporter args)) + (cons + (apply 'apply (append reporter args))))) + + (defvar *ignored-configuration-form* nil + "Have configuration forms been ignored while parsing the configuration?") + + (defun validate-configuration-form (form tag directive-validator + &key location invalid-form-reporter) + "Validate a configuration FORM. By default it will raise an error if the +FORM is not valid. Otherwise it will return the validated form. + Arguments control the behavior: + The configuration FORM should be of the form (TAG . ) + Each element of will be checked by first seeing if it's a configuration inheritance +directive (see CONFIGURATION-INHERITANCE-DIRECTIVE-P) then invoking DIRECTIVE-VALIDATOR +on it. + In the event of an invalid form, INVALID-FORM-REPORTER will be used to control +reporting (see REPORT-INVALID-FORM) with LOCATION providing information about where +the configuration form appeared." + (unless (and (consp form) (eq (car form) tag)) + (setf *ignored-configuration-form* t) + (report-invalid-form invalid-form-reporter :form form :location location) + (return-from validate-configuration-form nil)) + (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag) + :for directive :in (cdr form) + :when (cond + ((configuration-inheritance-directive-p directive) + (incf inherit) t) + ((eq directive :ignore-invalid-entries) + (setf ignore-invalid-p t) t) + ((funcall directive-validator directive) + t) + (ignore-invalid-p + nil) + (t + (setf *ignored-configuration-form* t) + (report-invalid-form invalid-form-reporter :form directive :location location) + nil)) + :do (push directive x) + :finally + (unless (= inherit 1) + (report-invalid-form invalid-form-reporter + :form form :location location + ;; we throw away the form and location arguments, hence the ~2* + ;; this is necessary because of the report in INVALID-CONFIGURATION + :format (compatfmt "~@") + :arguments '(:inherit-configuration :ignore-inherited-configuration))) + (return (nreverse x)))) + + (defun validate-configuration-file (file validator &key description) + "Validate a configuration FILE. The configuration file should have only one s-expression +in it, which will be checked with the VALIDATOR FORM. DESCRIPTION argument used for error +reporting." + (let ((forms (read-file-forms file))) + (unless (length=n-p forms 1) + (error (compatfmt "~@~%") + description forms)) + (funcall validator (car forms) :location file))) + + (defun validate-configuration-directory (directory tag validator &key invalid-form-reporter) + "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will +be applied to the results to yield a configuration form. Current +values of TAG include :source-registry and :output-translations." + (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list + (remove-if + 'hidden-pathname-p + (directory* (make-pathname :name *wild* :type "conf" :defaults directory)))) + #'string< :key #'namestring))) + `(,tag + ,@(loop :for file :in files :append + (loop :with ignore-invalid-p = nil + :for form :in (read-file-forms file) + :when (eq form :ignore-invalid-entries) + :do (setf ignore-invalid-p t) + :else + :when (funcall validator form) + :collect form + :else + :when ignore-invalid-p + :do (setf *ignored-configuration-form* t) + :else + :do (report-invalid-form invalid-form-reporter :form form :location file))) + :inherit-configuration))) + + (defun resolve-relative-location (x &key ensure-directory wilden) + "Given a designator X for an relative location, resolve it to a pathname." + (ensure-pathname + (etypecase x + (null nil) + (pathname x) + (string (parse-unix-namestring + x :ensure-directory ensure-directory)) + (cons + (if (null (cdr x)) + (resolve-relative-location + (car x) :ensure-directory ensure-directory :wilden wilden) + (let* ((car (resolve-relative-location + (car x) :ensure-directory t :wilden nil))) + (merge-pathnames* + (resolve-relative-location + (cdr x) :ensure-directory ensure-directory :wilden wilden) + car)))) + ((eql :*/) *wild-directory*) + ((eql :**/) *wild-inferiors*) + ((eql :*.*.*) *wild-file*) + ((eql :implementation) + (parse-unix-namestring + (implementation-identifier) :ensure-directory t)) + ((eql :implementation-type) + (parse-unix-namestring + (string-downcase (implementation-type)) :ensure-directory t)) + ((eql :hostname) + (parse-unix-namestring (hostname) :ensure-directory t))) + :wilden (and wilden (not (pathnamep x)) (not (member x '(:*/ :**/ :*.*.*)))) + :want-relative t)) + + (defvar *here-directory* nil + "This special variable is bound to the currect directory during calls to +PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here +directive.") + + (defvar *user-cache* nil + "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache") + + (defun resolve-absolute-location (x &key ensure-directory wilden) + "Given a designator X for an absolute location, resolve it to a pathname" + (ensure-pathname + (etypecase x + (null nil) + (pathname x) + (string + (let ((p #-mcl (parse-namestring x) + #+mcl (probe-posix x))) + #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) + (if ensure-directory (ensure-directory-pathname p) p))) + (cons + (return-from resolve-absolute-location + (if (null (cdr x)) + (resolve-absolute-location + (car x) :ensure-directory ensure-directory :wilden wilden) + (merge-pathnames* + (resolve-relative-location + (cdr x) :ensure-directory ensure-directory :wilden wilden) + (resolve-absolute-location + (car x) :ensure-directory t :wilden nil))))) + ((eql :root) + ;; special magic! we return a relative pathname, + ;; but what it means to the output-translations is + ;; "relative to the root of the source pathname's host and device". + (return-from resolve-absolute-location + (let ((p (make-pathname :directory '(:relative)))) + (if wilden (wilden p) p)))) + ((eql :home) (user-homedir-pathname)) + ((eql :here) (resolve-absolute-location + (or *here-directory* (pathname-directory-pathname (truename (load-pathname)))) + :ensure-directory t :wilden nil)) + ((eql :user-cache) (resolve-absolute-location + *user-cache* :ensure-directory t :wilden nil))) + :wilden (and wilden (not (pathnamep x))) + :resolve-symlinks *resolve-symlinks* + :want-absolute t)) + + ;; Try to override declaration in previous versions of ASDF. + (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean) + (:ensure-directory boolean)) t) resolve-location)) + + (defun resolve-location (x &key ensure-directory wilden directory) + "Resolve location designator X into a PATHNAME" + ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory + (loop :with dirp = (or directory ensure-directory) + :with (first . rest) = (if (atom x) (list x) x) + :with path = (or (resolve-absolute-location + first :ensure-directory (and (or dirp rest) t) + :wilden (and wilden (null rest))) + (return nil)) + :for (element . morep) :on rest + :for dir = (and (or morep dirp) t) + :for wild = (and wilden (not morep)) + :for sub = (merge-pathnames* + (resolve-relative-location + element :ensure-directory dir :wilden wild) + path) + :do (setf path (if (absolute-pathname-p sub) (resolve-symlinks* sub) sub)) + :finally (return path))) + + (defun location-designator-p (x) + "Is X a designator for a location?" + ;; NIL means "skip this entry", or as an output translation, same as translation input. + ;; T means "any input" for a translation, or as output, same as translation input. + (flet ((absolute-component-p (c) + (typep c '(or string pathname + (member :root :home :here :user-cache)))) + (relative-component-p (c) + (typep c '(or string pathname + (member :*/ :**/ :*.*.* :implementation :implementation-type))))) + (or (typep x 'boolean) + (absolute-component-p x) + (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) + + (defun location-function-p (x) + "Is X the specification of a location function?" + ;; Location functions are allowed in output translations, and notably used by ABCL for JAR file support. + (and (length=n-p x 2) (eq (car x) :function))) + + (defvar *clear-configuration-hook* '()) + + (defun register-clear-configuration-hook (hook-function &optional call-now-p) + "Register a function to be called when clearing configuration" + (register-hook-function '*clear-configuration-hook* hook-function call-now-p)) + + (defun clear-configuration () + "Call the functions in *CLEAR-CONFIGURATION-HOOK*" + (call-functions *clear-configuration-hook*)) + + (register-image-dump-hook 'clear-configuration) + + (defun upgrade-configuration () + "If a previous version of ASDF failed to read some configuration, try again now." + (when *ignored-configuration-form* + (clear-configuration) + (setf *ignored-configuration-form* nil))) + + + (defun get-folder-path (folder) + "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path, +this function tries to locate the Windows FOLDER for one of +:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA. + Returns NIL when the folder is not defined (e.g., not on Windows)." + (or #+(and lispworks os-windows) (sys:get-folder-path folder) + ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData + (ecase folder + (:local-appdata (or (getenv-absolute-directory "LOCALAPPDATA") + (subpathname* (get-folder-path :appdata) "Local"))) + (:appdata (getenv-absolute-directory "APPDATA")) + (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA") + (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) + + + ;; Support for the XDG Base Directory Specification + (defun xdg-data-home (&rest more) + "Returns an absolute pathname for the directory containing user-specific data files. +MORE may contain specifications for a subpath relative to this directory: a +subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see +also \"Configuration DSL\"\) in the ASDF manual." + (resolve-absolute-location + `(,(or (getenv-absolute-directory "XDG_DATA_HOME") + (os-cond + ((os-windows-p) (get-folder-path :local-appdata)) + (t (subpathname (user-homedir-pathname) ".local/share/")))) + ,more))) + + (defun xdg-config-home (&rest more) + "Returns a pathname for the directory containing user-specific configuration files. +MORE may contain specifications for a subpath relative to this directory: a +subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see +also \"Configuration DSL\"\) in the ASDF manual." + (resolve-absolute-location + `(,(or (getenv-absolute-directory "XDG_CONFIG_HOME") + (os-cond + ((os-windows-p) (xdg-data-home "config/")) + (t (subpathname (user-homedir-pathname) ".config/")))) + ,more))) + + (defun xdg-data-dirs (&rest more) + "The preference-ordered set of additional paths to search for data files. +Returns a list of absolute directory pathnames. +MORE may contain specifications for a subpath relative to these directories: a +subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see +also \"Configuration DSL\"\) in the ASDF manual." + (mapcar #'(lambda (d) (resolve-location `(,d ,more))) + (or (remove nil (getenv-absolute-directories "XDG_DATA_DIRS")) + (os-cond + ((os-windows-p) (mapcar 'get-folder-path '(:appdata :common-appdata))) + ;; macOS' separate read-only system volume means that the contents + ;; of /usr/share are frozen by Apple. Unlike when running natively + ;; on macOS, Genera must access the filesystem through NFS. Attempting + ;; to export either the root (/) or /usr/share simply doesn't work. + ;; (Genera will go into an infinite loop trying to access those mounts.) + ;; So, when running Genera on macOS, only search /usr/local/share. + ((os-genera-p) + #+Genera (sys:system-case + (darwin-vlm (mapcar 'parse-unix-namestring '("/usr/local/share/"))) + (otherwise (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/"))))) + (t (mapcar 'parse-unix-namestring '("/usr/local/share/" "/usr/share/"))))))) + + (defun xdg-config-dirs (&rest more) + "The preference-ordered set of additional base paths to search for configuration files. +Returns a list of absolute directory pathnames. +MORE may contain specifications for a subpath relative to these directories: +subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see +also \"Configuration DSL\"\) in the ASDF manual." + (mapcar #'(lambda (d) (resolve-location `(,d ,more))) + (or (remove nil (getenv-absolute-directories "XDG_CONFIG_DIRS")) + (os-cond + ((os-windows-p) (xdg-data-dirs "config/")) + (t (mapcar 'parse-unix-namestring '("/etc/xdg/"))))))) + + (defun xdg-cache-home (&rest more) + "The base directory relative to which user specific non-essential data files should be stored. +Returns an absolute directory pathname. +MORE may contain specifications for a subpath relative to this directory: a +subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see +also \"Configuration DSL\"\) in the ASDF manual." + (resolve-absolute-location + `(,(or (getenv-absolute-directory "XDG_CACHE_HOME") + (os-cond + ((os-windows-p) (xdg-data-home "cache/")) + (t (subpathname* (user-homedir-pathname) ".cache/")))) + ,more))) + + (defun xdg-runtime-dir (&rest more) + "Pathname for user-specific non-essential runtime files and other file objects, +such as sockets, named pipes, etc. +Returns an absolute directory pathname. +MORE may contain specifications for a subpath relative to this directory: a +subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see +also \"Configuration DSL\"\) in the ASDF manual." + ;; The XDG spec says that if not provided by the login system, the application should + ;; issue a warning and provide a replacement. UIOP is not equipped to do that and returns NIL. + (resolve-absolute-location `(,(getenv-absolute-directory "XDG_RUNTIME_DIR") ,more))) + + ;;; NOTE: modified the docstring because "system user configuration + ;;; directories" seems self-contradictory. I'm not sure my wording is right. + (defun system-config-pathnames (&rest more) + "Return a list of directories where are stored the system's default user configuration information. +MORE may contain specifications for a subpath relative to these directories: a +subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see +also \"Configuration DSL\"\) in the ASDF manual." + (declare (ignorable more)) + (os-cond + ((os-unix-p) (list (resolve-absolute-location `(,(parse-unix-namestring "/etc/") ,more)))))) + + (defun filter-pathname-set (dirs) + "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list." + (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) :from-end t :test 'equal)) + + (defun xdg-data-pathnames (&rest more) + "Return a list of absolute pathnames for application data directories. With APP, +returns directory for data for that application, without APP, returns the set of directories +for storing all application configurations. +MORE may contain specifications for a subpath relative to these directories: a +subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see +also \"Configuration DSL\"\) in the ASDF manual." + (filter-pathname-set + `(,(xdg-data-home more) + ,@(xdg-data-dirs more)))) + + (defun xdg-config-pathnames (&rest more) + "Return a list of pathnames for application configuration. +MORE may contain specifications for a subpath relative to these directories: a +subpathname specification and keyword arguments as per RESOLVE-LOCATION \(see +also \"Configuration DSL\"\) in the ASDF manual." + (filter-pathname-set + `(,(xdg-config-home more) + ,@(xdg-config-dirs more)))) + + (defun find-preferred-file (files &key (direction :input)) + "Find first file in the list of FILES that exists (for direction :input or :probe) +or just the first one (for direction :output or :io). + Note that when we say \"file\" here, the files in question may be directories." + (find-if (ecase direction ((:probe :input) 'probe-file*) ((:output :io) 'identity)) files)) + + (defun xdg-data-pathname (&optional more (direction :input)) + (find-preferred-file (xdg-data-pathnames more) :direction direction)) + + (defun xdg-config-pathname (&optional more (direction :input)) + (find-preferred-file (xdg-config-pathnames more) :direction direction)) + + (defun compute-user-cache () + "Compute (and return) the location of the default user-cache for translate-output +objects. Side-effects for cached file location computation." + (setf *user-cache* (xdg-cache-home "common-lisp" :implementation))) + (register-image-restore-hook 'compute-user-cache) + + (defun uiop-directory () + "Try to locate the UIOP source directory at runtime" + (labels ((pf (x) (ignore-errors (probe-file* x))) + (sub (x y) (pf (subpathname x y))) + (ssd (x) (ignore-errors (symbol-call :asdf :system-source-directory x)))) + ;; NB: conspicuously *not* including searches based on #.(current-lisp-pathname) + (or + ;; Look under uiop if available as source override, under asdf if avaiable as source + (ssd "uiop") + (sub (ssd "asdf") "uiop/") + ;; Look in recommended path for user-visible source installation + (sub (user-homedir-pathname) "common-lisp/asdf/uiop/") + ;; Look in XDG paths under known package names for user-invisible source installation + (xdg-data-pathname "common-lisp/source/asdf/uiop/") + (xdg-data-pathname "common-lisp/source/cl-asdf/uiop/") ; traditional Debian location + ;; The last one below is useful for Fare, primary (sole?) known user + (sub (user-homedir-pathname) "cl/asdf/uiop/") + (cerror "Configure source registry to include UIOP source directory and retry." + "Unable to find UIOP directory") + (uiop-directory))))) +;;; ------------------------------------------------------------------------- +;;; Hacks for backward-compatibility with older versions of UIOP + +(uiop/package:define-package :uiop/backward-driver + (:recycle :uiop/backward-driver :asdf/backward-driver :uiop) + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/version + :uiop/pathname :uiop/stream :uiop/os :uiop/image + :uiop/run-program :uiop/lisp-build :uiop/configuration) + (:export + #:coerce-pathname + #:user-configuration-directories #:system-configuration-directories + #:in-first-directory #:in-user-configuration-directory #:in-system-configuration-directory + #:version-compatible-p)) +(in-package :uiop/backward-driver) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(with-deprecation ((version-deprecation *uiop-version* :style-warning "3.2" :warning "3.4")) + ;; Backward compatibility with ASDF 2.000 to 2.26 + + ;; For backward-compatibility only, for people using internals + ;; Reported users in quicklisp 2015-11: hu.dwim.asdf (removed in next release) + ;; Will be removed after 2015-12. + (defun coerce-pathname (name &key type defaults) + "DEPRECATED. Please use UIOP:PARSE-UNIX-NAMESTRING instead." + (parse-unix-namestring name :type type :defaults defaults)) + + ;; Backward compatibility for ASDF 2.27 to 3.1.4 + (defun user-configuration-directories () + "Return the current user's list of user configuration directories +for configuring common-lisp. +DEPRECATED. Use UIOP:XDG-CONFIG-PATHNAMES instead." + (xdg-config-pathnames "common-lisp")) + (defun system-configuration-directories () + "Return the list of system configuration directories for common-lisp. +DEPRECATED. Use UIOP:SYSTEM-CONFIG-PATHNAMES (with argument \"common-lisp\"), +instead." + (system-config-pathnames "common-lisp")) + (defun in-first-directory (dirs x &key (direction :input)) + "Finds the first appropriate file named X in the list of DIRS for I/O +in DIRECTION \(which may be :INPUT, :OUTPUT, :IO, or :PROBE). +If direction is :INPUT or :PROBE, will return the first extant file named +X in one of the DIRS. +If direction is :OUTPUT or :IO, will simply return the file named X in the +first element of DIRS that exists. DEPRECATED." + (find-preferred-file + (mapcar #'(lambda (dir) (subpathname (ensure-directory-pathname dir) x)) dirs) + :direction direction)) + (defun in-user-configuration-directory (x &key (direction :input)) + "Return the file named X in the user configuration directory for common-lisp. +DEPRECATED." + (xdg-config-pathname `("common-lisp" ,x) direction)) + (defun in-system-configuration-directory (x &key (direction :input)) + "Return the pathname for the file named X under the system configuration directory +for common-lisp. DEPRECATED." + (find-preferred-file (system-config-pathnames "common-lisp" x) :direction direction)) + + + ;; Backward compatibility with ASDF 1 to ASDF 2.32 + + (defun version-compatible-p (provided-version required-version) + "Is the provided version a compatible substitution for the required-version? +If major versions differ, it's not compatible. +If they are equal, then any later version is compatible, +with later being determined by a lexicographical comparison of minor numbers. +DEPRECATED." + (let ((x (parse-version provided-version nil)) + (y (parse-version required-version nil))) + (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x))))))) + +;;;; --------------------------------------------------------------------------- +;;;; Re-export all the functionality in UIOP + +(uiop/package:define-package :uiop/driver + (:nicknames :uiop ;; Official name we recommend should be used for all references to uiop symbols. + :asdf/driver) ;; DO NOT USE, a deprecated name, not supported anymore. + ;; We should remove the name :asdf/driver at some point, + ;; but not until it has been eradicated from Quicklisp for a year or two. + ;; The last known user was cffi (PR merged in May 2020). + (:use :uiop/common-lisp) + ;; NB: We are not reexporting uiop/common-lisp + ;; which include all of CL with compatibility modifications on select platforms, + ;; because that would cause potential conflicts for packages that + ;; might want to :use (:cl :uiop) or :use (:closer-common-lisp :uiop), etc. + (:use-reexport + :uiop/package* :uiop/utility :uiop/version + :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image + :uiop/launch-program :uiop/run-program + :uiop/lisp-build :uiop/configuration :uiop/backward-driver)) + +;; Provide both lowercase and uppercase, to satisfy more implementations. +(provide "uiop") (provide "UIOP") +;;;; ------------------------------------------------------------------------- +;;;; Handle upgrade as forward- and backward-compatibly as possible +;; See https://bugs.launchpad.net/asdf/+bug/485687 + +(uiop/package:define-package :asdf/upgrade + (:recycle :asdf/upgrade :asdf) + (:use :uiop/common-lisp :uiop) + (:export + #:asdf-version #:*previous-asdf-versions* #:*asdf-version* + #:asdf-message #:*verbose-out* + #:upgrading-p #:when-upgrading #:upgrade-asdf #:defparameter* + #:*post-upgrade-cleanup-hook* #:cleanup-upgraded-asdf + ;; There will be no symbol left behind! + #:with-asdf-deprecation + #:intern*) + (:import-from :uiop/package #:intern* #:find-symbol*)) +(in-package :asdf/upgrade) + +;;; Special magic to detect if this is an upgrade + +(with-upgradability () + (defun asdf-version () + "Exported interface to the version of ASDF currently installed. A string. +You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"3.4.5.67\")." + (when (find-package :asdf) + (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) + (let* ((revsym (find-symbol (string :*asdf-revision*) :asdf)) + (rev (and revsym (boundp revsym) (symbol-value revsym)))) + (etypecase rev + (string rev) + (cons (format nil "~{~D~^.~}" rev)) + (null "1.0")))))) + ;; This (private) variable contains a list of versions of previously loaded variants of ASDF, + ;; from which ASDF was upgraded. + ;; Important: define *p-a-v* /before/ *a-v* so that they initialize correctly. + (defvar *previous-asdf-versions* + (let ((previous (asdf-version))) + (when previous + ;; Punt on upgrade from ASDF1 or ASDF2, by renaming (or deleting) the package. + (when (version< previous "2.27") ;; 2.27 is the first to have the :asdf3 feature. + (let ((away (format nil "~A-~A" :asdf previous))) + (rename-package :asdf away) + (when *load-verbose* + (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))) + (list previous)))) + ;; This public variable will be bound shortly to the currently loaded version of ASDF. + (defvar *asdf-version* nil) + ;; We need to clear systems from versions older than the one in this (private) parameter. + ;; The latest incompatible defclass is 2.32.13 renaming a slot in component, + ;; or 3.2.0.2 for CCL (incompatibly changing some superclasses). + ;; the latest incompatible gf change is in 3.1.7.20 (see redefined-functions below). + (defparameter *oldest-forward-compatible-asdf-version* "3.2.0.2") + ;; Semi-private variable: a designator for a stream on which to output ASDF progress messages + (defvar *verbose-out* nil) + ;; Private function by which ASDF outputs progress messages and warning messages: + (defun asdf-message (format-string &rest format-args) + (when *verbose-out* (apply 'format *verbose-out* format-string format-args))) + ;; Private hook for functions to run after ASDF has upgraded itself from an older variant: + (defvar *post-upgrade-cleanup-hook* ()) + ;; Private function to detect whether the current upgrade counts as an incompatible + ;; data schema upgrade implying the need to drop data. + (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*)) + (and *previous-asdf-versions* + (version< (first *previous-asdf-versions*) oldest-compatible-version))) + ;; Private variant of defparameter that works in presence of incompatible upgrades: + ;; behaves like defvar in a compatible upgrade (e.g. reloading system after simple code change), + ;; but behaves like defparameter if in presence of an incompatible upgrade. + (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*)) + (let* ((name (string-trim "*" var)) + (valfun (intern (format nil "%~A-~A-~A" :compute name :value)))) + `(progn + (defun ,valfun () ,value) + (defvar ,var (,valfun) ,@(ensure-list docstring)) + (when (upgrading-p ,version) + (setf ,var (,valfun)))))) + ;; Private macro to declare sections of code that are only compiled and run when upgrading. + ;; The use of eval portably ensures that the code will not have adverse compile-time side-effects, + ;; whereas the use of handler-bind portably ensures that it will not issue warnings when it runs. + (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*) + (upgrading-p `(upgrading-p ,version)) when) &body body) + "A wrapper macro for code that should only be run when upgrading a +previously-loaded version of ASDF." + `(with-upgradability () + (when (and ,upgrading-p ,@(when when `(,when))) + (handler-bind ((style-warning #'muffle-warning)) + (eval '(progn ,@body)))))) + ;; Only now can we safely update the version. + (let* (;; For bug reporting sanity, please always bump this version when you modify this file. + ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8 + ;; can help you do these changes in synch (look at the source for documentation). + ;; Relying on its automation, the version is now redundantly present on top of asdf.lisp. + ;; "3.4" would be the general branch for major version 3, minor version 4. + ;; "3.4.5" would be an official release in the 3.4 branch. + ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5. + ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 + ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 + (asdf-version "3.3.5") + (existing-version (asdf-version))) + (setf *asdf-version* asdf-version) + (when (and existing-version (not (equal asdf-version existing-version))) + (push existing-version *previous-asdf-versions*) + (when (or *verbose-out* *load-verbose*) + (format (or *verbose-out* *trace-output*) + (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") + existing-version asdf-version))))) + +;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined +(when-upgrading () + (let* ((previous-version (first *previous-asdf-versions*)) + (redefined-functions ;; List of functions that changed incompatibly since 2.27: + ;; gf signature changed, defun that became a generic function (but not way around), + ;; method removed that will mess up with new ones + ;; (especially :around :before :after, more specific or call-next-method'ed method) + ;; and/or semantics otherwise modified. Oops. + ;; NB: it's too late to do anything about functions in UIOP! + ;; If you introduce some critical incompatibility there, you MUST change the function name. + ;; Note that we don't need do anything about functions that changed incompatibly + ;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade. + ;; Also, the strong constraints apply most importantly for functions called from + ;; the continuation of compiling or loading some of the code in ASDF or UIOP. + ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36 + ;; and at https://gitlab.common-lisp.net/asdf/asdf/-/merge_requests/141 + `(,@(when (version< previous-version "2.31") '(#:normalize-version)) ;; pathname became &key + ,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2 + ,@(when (version< previous-version "3.1.7.20") '(#:find-component)))) ;; added &key registered + (redefined-classes + ;; with the old ASDF during upgrade, and many implementations bork + (when (or #+(or clozure mkcl) t) + '((#:compile-concatenated-source-op (#:operation) ()) + (#:compile-bundle-op (#:operation) ()) + (#:concatenate-source-op (#:operation) ()) + (#:dll-op (#:operation) ()) + (#:lib-op (#:operation) ()) + (#:monolithic-compile-bundle-op (#:operation) ()) + (#:monolithic-concatenate-source-op (#:operation) ()))))) + (loop :for name :in redefined-functions + :for sym = (find-symbol* name :asdf nil) + :do (when sym (fmakunbound sym))) + (labels ((asym (x) (multiple-value-bind (s p) + (if (consp x) (values (car x) (cadr x)) (values x :asdf)) + (find-symbol* s p nil))) + (asyms (l) (mapcar #'asym l))) + (loop :for (name superclasses slots) :in redefined-classes + :for sym = (find-symbol* name :asdf nil) + :when (and sym (find-class sym)) + :do #+ccl (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots))) + #-ccl (setf (find-class sym) nil))))) ;; mkcl + +;;; Self-upgrade functions +(with-upgradability () + ;; This private function is called at the end of asdf/footer and ensures that, + ;; *if* this loading of ASDF was an upgrade, then all registered cleanup functions will be called. + (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*))) + (let ((new-version (asdf-version))) + (unless (equal old-version new-version) + (push new-version *previous-asdf-versions*) + (when old-version + (if (version<= new-version old-version) + (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + ;; In case the previous version was too old to be forward-compatible, clear systems. + ;; TODO: if needed, we may have to define a separate hook to run + ;; in case of forward-compatible upgrade. + ;; Or to move the tests forward-compatibility test inside each hook function? + (unless (version<= *oldest-forward-compatible-asdf-version* old-version) + (call-functions (reverse *post-upgrade-cleanup-hook*))) + t)))) + + (defun upgrade-asdf () + "Try to upgrade of ASDF. If a different version was used, return T. + We need do that before we operate on anything that may possibly depend on ASDF." + (let ((*load-print* nil) + (*compile-print* nil)) + (handler-bind (((or style-warning) #'muffle-warning)) + (symbol-call :asdf :load-system :asdf :verbose nil)))) + + (defmacro with-asdf-deprecation ((&rest keys &key &allow-other-keys) &body body) + `(with-upgradability () + (with-deprecation ((version-deprecation *asdf-version* ,@keys)) + ,@body)))) +;;;; ------------------------------------------------------------------------- +;;;; Session + +(uiop/package:define-package :asdf/session + (:recycle :asdf/session :asdf/cache :asdf/component + :asdf/action :asdf/find-system :asdf/plan :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade) + (:export + #:get-file-stamp #:compute-file-stamp #:register-file-stamp + #:asdf-cache #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache + #:do-asdf-cache #:normalize-namestring + #:call-with-asdf-session #:with-asdf-session + #:*asdf-session* #:*asdf-session-class* #:session #:toplevel-asdf-session + #:session-cache #:forcing #:asdf-upgraded-p + #:visited-actions #:visiting-action-set #:visiting-action-list + #:total-action-count #:planned-action-count #:planned-output-action-count + #:clear-configuration-and-retry #:retry + #:operate-level + ;; conditions + #:system-definition-error ;; top level, moved here because this is the earliest place for it. + #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error)) +(in-package :asdf/session) + + +(with-upgradability () + ;; The session variable. + ;; NIL when outside a session. + (defvar *asdf-session* nil) + (defparameter* *asdf-session-class* 'session + "The default class for sessions") + + (defclass session () + (;; The ASDF session cache is used to memoize some computations. + ;; It is instrumental in achieving: + ;; * Consistency in the view of the world relied on by ASDF within a given session. + ;; Inconsistencies in file stamps, system definitions, etc., could cause infinite loops + ;; (a.k.a. stack overflows) and other erratic behavior. + ;; * Speed and reliability of ASDF, with fewer side-effects from access to the filesystem, and + ;; no expensive recomputations of transitive dependencies for input-files or output-files. + ;; * Testability of ASDF with the ability to fake timestamps without actually touching files. + (ancestor + :initform nil :initarg :ancestor :reader session-ancestor + :documentation "Top level session that this is part of") + (session-cache + :initform (make-hash-table :test 'equal) :initarg :session-cache :reader session-cache + :documentation "Memoize expensive computations") + (operate-level + :initform 0 :initarg :operate-level :accessor session-operate-level + :documentation "Number of nested calls to operate we're under (for toplevel session only)") + ;; shouldn't the below be superseded by the session-wide caching of action-status + ;; for (load-op "asdf") ? + (asdf-upgraded-p + :initform nil :initarg :asdf-upgraded-p :accessor asdf-upgraded-p + :documentation "Was ASDF already upgraded in this session - only valid for toplevel-asdf-session.") + (forcing + :initform nil :initarg :forcing :accessor forcing + :documentation "Forcing parameters for the session") + ;; Table that to actions already visited while walking the dependencies associates status + (visited-actions :initform (make-hash-table :test 'equal) :accessor visited-actions) + ;; Actions that depend on those being currently walked through, to detect circularities + (visiting-action-set ;; as a set + :initform (make-hash-table :test 'equal) :accessor visiting-action-set) + (visiting-action-list :initform () :accessor visiting-action-list) ;; as a list + ;; Counts of total actions in plan + (total-action-count :initform 0 :accessor total-action-count) + ;; Count of actions that need to be performed + (planned-action-count :initform 0 :accessor planned-action-count) + ;; Count of actions that need to be performed that have a non-empty list of output-files. + (planned-output-action-count :initform 0 :accessor planned-output-action-count)) + (:documentation "An ASDF session with a cache to memoize some computations")) + + (defun toplevel-asdf-session () + (when *asdf-session* (or (session-ancestor *asdf-session*) *asdf-session*))) + + (defun operate-level () + (session-operate-level (toplevel-asdf-session))) + + (defun (setf operate-level) (new-level) + (setf (session-operate-level (toplevel-asdf-session)) new-level)) + + (defun asdf-cache () + (session-cache *asdf-session*)) + + ;; Set a session cache entry for KEY to a list of values VALUE-LIST, when inside a session. + ;; Return those values. + (defun set-asdf-cache-entry (key value-list) + (values-list (if *asdf-session* + (setf (gethash key (asdf-cache)) value-list) + value-list))) + + ;; Unset the session cache entry for KEY, when inside a session. + (defun unset-asdf-cache-entry (key) + (when *asdf-session* + (remhash key (session-cache *asdf-session*)))) + + ;; Consult the session cache entry for KEY if present and in a session; + ;; if not present, compute it by calling the THUNK, + ;; and set the session cache entry accordingly, if in a session. + ;; Return the values from the cache and/or the thunk computation. + (defun consult-asdf-cache (key &optional thunk) + (if *asdf-session* + (multiple-value-bind (results foundp) (gethash key (session-cache *asdf-session*)) + (if foundp + (values-list results) + (set-asdf-cache-entry key (multiple-value-list (call-function thunk))))) + (call-function thunk))) + + ;; Syntactic sugar for consult-asdf-cache + (defmacro do-asdf-cache (key &body body) + `(consult-asdf-cache ,key #'(lambda () ,@body))) + + ;; Compute inside a ASDF session with a cache. + ;; First, make sure an ASDF session is underway, by binding the session cache variable + ;; to a new hash-table if it's currently null (or even if it isn't, if OVERRIDE is true). + ;; Second, if a new session was started, establish restarts for retrying the overall computation. + ;; Finally, consult the cache if a KEY was specified with the THUNK as a fallback when the cache + ;; entry isn't found, or just call the THUNK if no KEY was specified. + (defun call-with-asdf-session (thunk &key override key override-cache override-forcing) + (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) + (if (and (not override) *asdf-session*) + (funcall fun) + (loop + (restart-case + (let ((*asdf-session* + (apply 'make-instance *asdf-session-class* + (when *asdf-session* + `(:ancestor ,(toplevel-asdf-session) + ,@(unless override-forcing + `(:forcing ,(forcing *asdf-session*))) + ,@(unless override-cache + `(:session-cache ,(session-cache *asdf-session*)))))))) + (return (funcall fun))) + (retry () + :report (lambda (s) + (format s (compatfmt "~@")))) + (clear-configuration-and-retry () + :report (lambda (s) + (format s (compatfmt "~@"))) + (clrhash (session-cache *asdf-session*)) + (clear-configuration))))))) + + ;; Syntactic sugar for call-with-asdf-session + (defmacro with-asdf-session ((&key key override override-cache override-forcing) &body body) + `(call-with-asdf-session + #'(lambda () ,@body) + :override ,override :key ,key + :override-cache ,override-cache :override-forcing ,override-forcing)) + + + ;;; Define specific accessor for file (date) stamp. + + ;; Normalize a namestring for use as a key in the session cache. + (defun normalize-namestring (pathname) + (let ((resolved (resolve-symlinks* + (ensure-absolute-pathname + (physicalize-pathname pathname) + 'get-pathname-defaults)))) + (with-pathname-defaults () (namestring resolved)))) + + ;; Compute the file stamp for a normalized namestring + (defun compute-file-stamp (normalized-namestring) + (with-pathname-defaults () + (or (safe-file-write-date normalized-namestring) t))) + + ;; Override the time STAMP associated to a given FILE in the session cache. + ;; If no STAMP is specified, recompute a new one from the filesystem. + (defun register-file-stamp (file &optional (stamp nil stampp)) + (let* ((namestring (normalize-namestring file)) + (stamp (if stampp stamp (compute-file-stamp namestring)))) + (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp)))) + + ;; Get or compute a memoized stamp for given FILE from the session cache. + (defun get-file-stamp (file) + (when file + (let ((namestring (normalize-namestring file))) + (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))) + + + ;;; Conditions + + (define-condition system-definition-error (error) () + ;; [this use of :report should be redundant, but unfortunately it's not. + ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function + ;; over print-object; this is always conditions::%print-condition for + ;; condition objects, which in turn does inheritance of :report options at + ;; run-time. fortunately, inheritance means we only need this kludge here in + ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] + #+cmucl (:report print-object)) + + (define-condition formatted-system-definition-error (system-definition-error) + ((format-control :initarg :format-control :reader format-control) + (format-arguments :initarg :format-arguments :reader format-arguments)) + (:report (lambda (c s) + (apply 'format s (format-control c) (format-arguments c))))) + + (defun sysdef-error (format &rest arguments) + (error 'formatted-system-definition-error :format-control + format :format-arguments arguments))) +;;;; ------------------------------------------------------------------------- +;;;; Components + +(uiop/package:define-package :asdf/component + (:recycle :asdf/component :asdf/find-component :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session) + (:export + #:component #:component-find-path + #:find-component ;; methods defined in find-component + #:component-name #:component-pathname #:component-relative-pathname + #:component-parent #:component-system #:component-parent-pathname + #:child-component #:parent-component #:module + #:file-component + #:source-file #:c-source-file #:java-source-file + #:static-file #:doc-file #:html-file + #:file-type + #:source-file-type #:source-file-explicit-type ;; backward-compatibility + #:component-in-order-to #:component-sideway-dependencies + #:component-if-feature #:around-compile-hook + #:component-description #:component-long-description + #:component-version #:version-satisfies + #:component-inline-methods ;; backward-compatibility only. DO NOT USE! + #:component-operation-times ;; For internal use only. + ;; portable ASDF encoding and implementation-specific external-format + #:component-external-format #:component-encoding + #:component-children-by-name #:component-children #:compute-children-by-name + #:component-build-operation + #:module-default-component-class + #:module-components ;; backward-compatibility. DO NOT USE. + #:sub-components + + ;; conditions + #:duplicate-names + + ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes + #:name #:version #:description #:long-description #:author #:maintainer #:licence + #:components-by-name #:components #:children #:children-by-name + #:default-component-class #:source-file + #:defsystem-depends-on ; This symbol retained for backward compatibility. + #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods + #:relative-pathname #:absolute-pathname #:operation-times #:around-compile + #:%encoding #:properties #:component-properties #:parent)) +(in-package :asdf/component) + +(with-upgradability () + (defgeneric component-name (component) + (:documentation "Name of the COMPONENT, unique relative to its parent")) + (defgeneric component-system (component) + (:documentation "Top-level system containing the COMPONENT")) + (defgeneric component-pathname (component) + (:documentation "Pathname of the COMPONENT if any, or NIL.")) + (defgeneric component-relative-pathname (component) + ;; in ASDF4, rename that to component-specified-pathname ? + (:documentation "Specified pathname of the COMPONENT, +intended to be merged with the pathname of that component's parent if any, using merged-pathnames*. +Despite the function's name, the return value can be an absolute pathname, in which case the merge +will leave it unmodified.")) + (defgeneric component-external-format (component) + (:documentation "The external-format of the COMPONENT. +By default, deduced from the COMPONENT-ENCODING.")) + (defgeneric component-encoding (component) + (:documentation "The encoding of the COMPONENT. By default, only :utf-8 is supported. +Use asdf-encodings to support more encodings.")) + (defgeneric version-satisfies (component version) + (:documentation "Check whether a COMPONENT satisfies the constraint of being at least as recent +as the specified VERSION, which must be a string of dot-separated natural numbers, or NIL.")) + (defgeneric component-version (component) + (:documentation "Return the version of a COMPONENT, which must be a string of dot-separated +natural numbers, or NIL.")) + (defgeneric (setf component-version) (new-version component) + (:documentation "Updates the version of a COMPONENT, which must be a string of dot-separated +natural numbers, or NIL.")) + (defgeneric component-parent (component) + (:documentation "The parent of a child COMPONENT, +or NIL for top-level components (a.k.a. systems)")) + ;; NIL is a designator for the absence of a component, in which case the parent is also absent. + (defmethod component-parent ((component null)) nil) + + ;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component. + (with-asdf-deprecation (:style-warning "3.4") + (defgeneric source-file-type (component system) + (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead."))) + + (define-condition duplicate-names (system-definition-error) + ((name :initarg :name :reader duplicate-names-name)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (duplicate-names-name c)))))) + + +(with-upgradability () + (defclass component () + ((name :accessor component-name :initarg :name :type string :documentation + "Component name: designator for a string composed of portable pathname characters") + ;; We might want to constrain version with + ;; :type (and string (satisfies parse-version)) + ;; but we cannot until we fix all systems that don't use it correctly! + (version :accessor component-version :initarg :version :initform nil) + (description :accessor component-description :initarg :description :initform nil) + (long-description :accessor component-long-description :initarg :long-description :initform nil) + (sideway-dependencies :accessor component-sideway-dependencies :initform nil) + (if-feature :accessor component-if-feature :initform nil :initarg :if-feature) + ;; In the ASDF object model, dependencies exist between *actions*, + ;; where an action is a pair of an operation and a component. + ;; Dependencies are represented as alists of operations + ;; to a list where each entry is a pair of an operation and a list of component specifiers. + ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies: + ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to. + ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl) + ;; and do-first things that modify the current image (such as loading a fasl). + ;; These are now unified because we now correctly propagate timestamps between dependencies. + ;; Happily, no one seems to have used do-first too much (especially since until ASDF 2.017, + ;; anything you specified was overridden by ASDF itself anyway), but the name in-order-to remains. + ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52! + ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively. + ;; Maybe rename the slots in ASDF? But that's not very backward-compatible. + ;; See our ASDF 2 paper for more complete explanations. + (in-order-to :initform nil :initarg :in-order-to + :accessor component-in-order-to) + ;; Methods defined using the "inline" style inside a defsystem form: + ;; we store them here so we can delete them when the system is re-evaluated. + (inline-methods :accessor component-inline-methods :initform nil) + ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative. + ;; There is no initform and no direct accessor for this specified pathname, + ;; so we only access the information through appropriate methods, after it has been processed. + ;; Unhappily, some braindead systems directly access the slot. Make them stop before ASDF4. + (relative-pathname :initarg :pathname) + ;; The absolute-pathname is computed based on relative-pathname and parent pathname. + ;; The slot is but a cache used by component-pathname. + (absolute-pathname) + (operation-times :initform (make-hash-table) + :accessor component-operation-times) + (around-compile :initarg :around-compile) + ;; Properties are for backward-compatibility with ASDF2 only. DO NOT USE! + (properties :accessor component-properties :initarg :properties + :initform nil) + (%encoding :accessor %component-encoding :initform nil :initarg :encoding) + ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it. + (parent :initarg :parent :initform nil :reader component-parent) + (build-operation + :initarg :build-operation :initform nil :reader component-build-operation) + ;; Cache for ADDITIONAL-INPUT-FILES function. + (additional-input-files :accessor %additional-input-files :initform nil)) + (:documentation "Base class for all components of a build")) + + (defgeneric find-component (base path &key registered) + (:documentation "Find a component by resolving the PATH starting from BASE parent. +If REGISTERED is true, only search currently registered systems.")) + + (defun component-find-path (component) + "Return a path from a root system to the COMPONENT. +The return value is a list of component NAMES; a list of strings." + (check-type component (or null component)) + (reverse + (loop :for c = component :then (component-parent c) + :while c :collect (component-name c)))) + + (defmethod print-object ((c component) stream) + (print-unreadable-object (c stream :type t :identity nil) + (format stream "~{~S~^ ~}" (component-find-path c)))) + + (defmethod component-system ((component component)) + (if-let (system (component-parent component)) + (component-system system) + component))) + + +;;;; Component hierarchy within a system +;; The tree typically but not necessarily follows the filesystem hierarchy. +(with-upgradability () + (defclass child-component (component) () + (:documentation "A CHILD-COMPONENT is a COMPONENT that may be part of +a PARENT-COMPONENT.")) + + (defclass file-component (child-component) + ((type :accessor file-type :initarg :type)) ; no default + (:documentation "a COMPONENT that represents a file")) + (defclass source-file (file-component) + ((type :accessor source-file-explicit-type ;; backward-compatibility + :initform nil))) ;; NB: many systems have come to rely on this default. + (defclass c-source-file (source-file) + ((type :initform "c"))) + (defclass java-source-file (source-file) + ((type :initform "java"))) + (defclass static-file (source-file) + ((type :initform nil)) + (:documentation "Component for a file to be included as is in the build output")) + (defclass doc-file (static-file) ()) + (defclass html-file (doc-file) + ((type :initform "html"))) + + (defclass parent-component (component) + ((children + :initform nil + :initarg :components + :reader module-components ; backward-compatibility + :accessor component-children) + (children-by-name + :reader module-components-by-name ; backward-compatibility + :accessor component-children-by-name) + (default-component-class + :initform nil + :initarg :default-component-class + :accessor module-default-component-class)) + (:documentation "A PARENT-COMPONENT is a component that may have children."))) + +(with-upgradability () + ;; (Private) Function that given a PARENT component, + ;; the list of children of which has been initialized, + ;; compute the hash-table in slot children-by-name that allows to retrieve its children by name. + ;; If ONLY-IF-NEEDED-P is defined, skip any (re)computation if the slot is already populated. + (defun compute-children-by-name (parent &key only-if-needed-p) + (unless (and only-if-needed-p (slot-boundp parent 'children-by-name)) + (let ((hash (make-hash-table :test 'equal))) + (setf (component-children-by-name parent) hash) + (loop :for c :in (component-children parent) + :for name = (component-name c) + :for previous = (gethash name hash) + :do (when previous (error 'duplicate-names :name name)) + (setf (gethash name hash) c)) + hash)))) + +(with-upgradability () + (defclass module (child-component parent-component) + (#+clisp (components)) ;; backward compatibility during upgrade only + (:documentation "A module is a intermediate component with both a parent and children, +typically but not necessarily representing the files in a subdirectory of the build source."))) + + +;;;; component pathnames +(with-upgradability () + (defgeneric component-parent-pathname (component) + (:documentation "The pathname of the COMPONENT's parent, if any, or NIL")) + (defmethod component-parent-pathname (component) + (component-pathname (component-parent component))) + + ;; The default method for component-pathname tries to extract a cached precomputed + ;; absolute-pathname from the relevant slot, and if not, computes it by merging the + ;; component-relative-pathname (which should be component-specified-pathname, it can be absolute) + ;; with the directory of the component-parent-pathname. + (defmethod component-pathname ((component component)) + (if (slot-boundp component 'absolute-pathname) + (slot-value component 'absolute-pathname) + (let ((pathname + (merge-pathnames* + (component-relative-pathname component) + (pathname-directory-pathname (component-parent-pathname component))))) + (unless (or (null pathname) (absolute-pathname-p pathname)) + (error (compatfmt "~@") + pathname (component-find-path component))) + (setf (slot-value component 'absolute-pathname) pathname) + pathname))) + + ;; Default method for component-relative-pathname: + ;; combine the contents of slot relative-pathname (from specified initarg :pathname) + ;; with the appropriate source-file-type, which defaults to the file-type of the component. + (defmethod component-relative-pathname ((component component)) + ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1. + ;; We ought to be able to extract this from the component alone with FILE-TYPE. + ;; TODO: track who uses it in Quicklisp, and have them not use it anymore; + ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge? + (parse-unix-namestring + (or (and (slot-boundp component 'relative-pathname) + (slot-value component 'relative-pathname)) + (component-name component)) + :want-relative t + :type (source-file-type component (component-system component)) + :defaults (component-parent-pathname component))) + + (defmethod source-file-type ((component parent-component) (system parent-component)) + :directory) + + (defmethod source-file-type ((component file-component) (system parent-component)) + (file-type component))) + + +;;;; Encodings +(with-upgradability () + (defmethod component-encoding ((c component)) + (or (loop :for x = c :then (component-parent x) + :while x :thereis (%component-encoding x)) + (detect-encoding (component-pathname c)))) + + (defmethod component-external-format ((c component)) + (encoding-external-format (component-encoding c)))) + + +;;;; around-compile-hook +(with-upgradability () + (defgeneric around-compile-hook (component) + (:documentation "An optional hook function that will be called with one argument, a thunk. +The hook function must call the thunk, that will compile code from the component, and may or may not +also evaluate the compiled results. The hook function may establish dynamic variable bindings around +this compilation, or check its results, etc.")) + (defmethod around-compile-hook ((c component)) + (cond + ((slot-boundp c 'around-compile) + (slot-value c 'around-compile)) + ((component-parent c) + (around-compile-hook (component-parent c)))))) + + +;;;; version-satisfies +(with-upgradability () + ;; short-circuit testing of null version specifications. + ;; this is an all-pass, without warning + (defmethod version-satisfies :around ((c t) (version null)) + t) + (defmethod version-satisfies ((c component) version) + (unless (and version (slot-boundp c 'version) (component-version c)) + (when version + (warn "Requested version ~S but ~S has no version" version c)) + (return-from version-satisfies nil)) + (version-satisfies (component-version c) version)) + + (defmethod version-satisfies ((cver string) version) + (version<= version cver))) + + +;;; all sub-components (of a given type) +(with-upgradability () + (defun sub-components (component &key (type t)) + "Compute the transitive sub-components of given COMPONENT that are of given TYPE" + (while-collecting (c) + (labels ((recurse (x) + (when (if-let (it (component-if-feature x)) (featurep it) t) + (when (typep x type) + (c x)) + (when (typep x 'parent-component) + (map () #'recurse (component-children x)))))) + (recurse component))))) + +;;;; ------------------------------------------------------------------------- +;;;; Operations + +(uiop/package:define-package :asdf/operation + (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5. + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session) + (:export + #:operation + #:*operations* #:make-operation #:find-operation + #:feature)) ;; TODO: stop exporting the deprecated FEATURE feature. +(in-package :asdf/operation) + +;;; Operation Classes +(when-upgrading (:version "2.27" :when (find-class 'operation nil)) + ;; override any obsolete shared-initialize method when upgrading from ASDF2. + (defmethod shared-initialize :after ((o operation) (slot-names t) &key) + (values))) + +(with-upgradability () + (defclass operation () + () + (:documentation "The base class for all ASDF operations. + +ASDF does NOT and never did distinguish between multiple operations of the same class. +Therefore, all slots of all operations MUST have :allocation :class and no initargs. No exceptions. +")) + + (defvar *in-make-operation* nil) + + (defun check-operation-constructor () + "Enforce that OPERATION instances must be created with MAKE-OPERATION." + (unless *in-make-operation* + (sysdef-error "OPERATION instances must only be created through MAKE-OPERATION."))) + + (defmethod print-object ((o operation) stream) + (print-unreadable-object (o stream :type t :identity nil))) + + ;;; Override previous methods (from 3.1.7 and earlier) and add proper error checking. + #-genera ;; Genera adds its own system initargs, e.g. clos-internals:storage-area 8 + (defmethod initialize-instance :after ((o operation) &rest initargs &key &allow-other-keys) + (unless (null initargs) + (parameter-error "~S does not accept initargs" 'operation)))) + + +;;; make-operation, find-operation + +(with-upgradability () + ;; A table to memoize instances of a given operation. There shall be only one. + (defparameter* *operations* (make-hash-table :test 'equal)) + + ;; A memoizing way of creating instances of operation. + (defun make-operation (operation-class) + "This function creates and memoizes an instance of OPERATION-CLASS. +All operation instances MUST be created through this function. + +Use of INITARGS is not supported at this time." + (let ((class (coerce-class operation-class + :package :asdf/interface :super 'operation :error 'sysdef-error)) + (*in-make-operation* t)) + (ensure-gethash class *operations* `(make-instance ,class)))) + + ;; This function is mostly for backward and forward compatibility: + ;; operations used to preserve the operation-original-initargs of the context, + ;; and may in the future preserve some operation-canonical-initargs. + ;; Still, the treatment of NIL as a disabling context is useful in some cases. + (defgeneric find-operation (context spec) + (:documentation "Find an operation by resolving the SPEC in the CONTEXT")) + (defmethod find-operation ((context t) (spec operation)) + spec) + (defmethod find-operation ((context t) (spec symbol)) + (when spec ;; NIL designates itself, i.e. absence of operation + (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context) + (defmethod find-operation ((context t) (spec string)) + (make-operation spec))) ;; TODO: preserve the (operation-canonical-initargs context) + +;;;; ------------------------------------------------------------------------- +;;;; Systems + +(uiop/package:define-package :asdf/system + (:recycle :asdf :asdf/system :asdf/find-system) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component) + (:export + #:system #:proto-system #:undefined-system #:reset-system-class + #:system-source-file #:system-source-directory #:system-relative-pathname + #:system-description #:system-long-description + #:system-author #:system-maintainer #:system-licence #:system-license + #:system-version + #:definition-dependency-list #:definition-dependency-set #:system-defsystem-depends-on + #:system-depends-on #:system-weakly-depends-on + #:component-build-pathname #:build-pathname + #:component-entry-point #:entry-point + #:homepage #:system-homepage + #:bug-tracker #:system-bug-tracker + #:mailto #:system-mailto + #:long-name #:system-long-name + #:source-control #:system-source-control + #:coerce-name #:primary-system-name #:primary-system-p #:coerce-filename + #:find-system #:builtin-system-p)) ;; forward-reference, defined in find-system +(in-package :asdf/system) + +(with-upgradability () + ;; The method is actually defined in asdf/find-system, + ;; but we declare the function here to avoid a forward reference. + (defgeneric find-system (system &optional error-p) + (:documentation "Given a system designator, find the actual corresponding system object. +If no system is found, then signal an error if ERROR-P is true (the default), or else return NIL. +A system designator is usually a string (conventionally all lowercase) or a symbol, designating +the same system as its downcased name; it can also be a system object (designating itself).")) + + (defgeneric system-source-file (system) + (:documentation "Return the source file in which system is defined.")) + + ;; This is bad design, but was the easiest kluge I found to let the user specify that + ;; some special actions create outputs at locations controled by the user that are not affected + ;; by the usual output-translations. + ;; TODO: Fix operate to stop passing flags to operation (which in the current design shouldn't + ;; have any flags, since the stamp cache, etc., can't distinguish them), and instead insert + ;; *there* the ability of specifying special output paths, not in the system definition. + (defgeneric component-build-pathname (component) + (:documentation "The COMPONENT-BUILD-PATHNAME, when defined and not null, specifies the +output pathname for the action using the COMPONENT-BUILD-OPERATION. + +NB: This interface is subject to change. Please contact ASDF maintainers if you use it.")) + + ;; TODO: Should this have been made a SYSTEM-ENTRY-POINT instead? + (defgeneric component-entry-point (component) + (:documentation "The COMPONENT-ENTRY-POINT, when defined, specifies what function to call +(with no argument) when running an image dumped from the COMPONENT. + +NB: This interface is subject to change. Please contact ASDF maintainers if you use it.")) + + (defmethod component-entry-point ((c component)) + nil)) + + +;;;; The system class + +(with-upgradability () + (defclass proto-system () ; slots to keep when resetting a system + ;; To preserve identity for all objects, we'd need keep the components slots + ;; but also to modify parse-component-form to reset the recycled objects. + ((name) + (source-file) + ;; These two slots contains the *inferred* dependencies of define-op, + ;; from loading the .asd file, as list and as set. + (definition-dependency-list + :initform nil :accessor definition-dependency-list) + (definition-dependency-set + :initform (list-to-hash-set nil) :accessor definition-dependency-set)) + (:documentation "PROTO-SYSTEM defines the elements of identity that are preserved when +a SYSTEM is redefined and its class is modified.")) + + (defclass system (module proto-system) + ;; Backward-compatibility: inherit from module. ASDF4: only inherit from parent-component. + (;; {,long-}description is now inherited from component, but we add the legacy accessors + (description :writer (setf system-description)) + (long-description :writer (setf system-long-description)) + (author :writer (setf system-author) :initarg :author :initform nil) + (maintainer :writer (setf system-maintainer) :initarg :maintainer :initform nil) + (licence :writer (setf system-licence) :initarg :licence + :writer (setf system-license) :initarg :license + :initform nil) + (homepage :writer (setf system-homepage) :initarg :homepage :initform nil) + (bug-tracker :writer (setf system-bug-tracker) :initarg :bug-tracker :initform nil) + (mailto :writer (setf system-mailto) :initarg :mailto :initform nil) + (long-name :writer (setf system-long-name) :initarg :long-name :initform nil) + ;; Conventions for this slot aren't clear yet as of ASDF 2.27, but whenever they are, they will be enforced. + ;; I'm introducing the slot before the conventions are set for maximum compatibility. + (source-control :writer (setf system-source-control) :initarg :source-control :initform nil) + + (builtin-system-p :accessor builtin-system-p :initform nil :initarg :builtin-system-p) + (build-pathname + :initform nil :initarg :build-pathname :accessor component-build-pathname) + (entry-point + :initform nil :initarg :entry-point :accessor component-entry-point) + (source-file :initform nil :initarg :source-file :accessor system-source-file) + ;; This slot contains the *declared* defsystem-depends-on dependencies + (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on + :initform nil) + ;; these two are specially set in parse-component-form, so have no :INITARGs. + (depends-on :reader system-depends-on :initform nil) + (weakly-depends-on :reader system-weakly-depends-on :initform nil)) + (:documentation "SYSTEM is the base class for top-level components that users may request +ASDF to build.")) + + (defclass undefined-system (system) () + (:documentation "System that was not defined yet.")) + + (defun reset-system-class (system new-class &rest keys &key &allow-other-keys) + "Erase any data from a SYSTEM except its basic identity, then reinitialize it +based on supplied KEYS." + (change-class (change-class system 'proto-system) new-class) + (apply 'reinitialize-instance system keys))) + + +;;; Canonicalizing system names + +(with-upgradability () + (defun coerce-name (name) + "Given a designator for a component NAME, return the name as a string. +The designator can be a COMPONENT (designing its name; note that a SYSTEM is a component), +a SYMBOL (designing its name, downcased), or a STRING (designing itself)." + (typecase name + (component (component-name name)) + (symbol (string-downcase name)) + (string name) + (t (sysdef-error (compatfmt "~@") name)))) + + (defun primary-system-name (system-designator) + "Given a system designator NAME, return the name of the corresponding +primary system, after which the .asd file in which it is defined is named. +If given a string or symbol (to downcase), do it syntactically + by stripping anything from the first slash on. +If given a component, do it semantically by extracting +the system-primary-system-name of its system from its source-file if any, +falling back to the syntactic criterion if none." + (etypecase system-designator + (string (if-let (p (position #\/ system-designator)) + (subseq system-designator 0 p) system-designator)) + (symbol (primary-system-name (coerce-name system-designator))) + (component (let* ((system (component-system system-designator)) + (source-file (physicalize-pathname (system-source-file system)))) + (if source-file + (and (equal (pathname-type source-file) "asd") + (pathname-name source-file)) + (primary-system-name (component-name system))))))) + + (defun primary-system-p (system) + "Given a system designator SYSTEM, return T if it designates a primary system, or else NIL. +If given a string, do it syntactically and return true if the name does not contain a slash. +If given a symbol, downcase to a string then fallback to previous case (NB: for NIL return T). +If given a component, do it semantically and return T if it's a SYSTEM and its primary-system-name +is the same as its component-name." + (etypecase system + (string (not (find #\/ system))) + (symbol (primary-system-p (coerce-name system))) + (component (and (typep system 'system) + (equal (component-name system) (primary-system-name system)))))) + + (defun coerce-filename (name) + "Coerce a system designator NAME into a string suitable as a filename component. +The (current) transformation is to replace characters /:\\ each by --, +the former being forbidden in a filename component. +NB: The onus is unhappily on the user to avoid clashes." + (frob-substrings (coerce-name name) '("/" ":" "\\") "--"))) + + +;;; System virtual slot readers, recursing to the primary system if needed. +(with-upgradability () + (defvar *system-virtual-slots* '(long-name description long-description + author maintainer mailto + homepage source-control + licence version bug-tracker) + "The list of system virtual slot names.") + (defun system-virtual-slot-value (system slot-name) + "Return SYSTEM's virtual SLOT-NAME value. +If SYSTEM's SLOT-NAME value is NIL and SYSTEM is a secondary system, look in +the primary one." + (or (slot-value system slot-name) + (unless (primary-system-p system) + (slot-value (find-system (primary-system-name system)) + slot-name)))) + (defmacro define-system-virtual-slot-reader (slot-name) + (let ((name (intern (strcat (string :system-) (string slot-name))))) + `(progn + (fmakunbound ',name) ;; These were gf from defgeneric before 3.3.2.11 + (declaim (notinline ,name)) + (defun ,name (system) (system-virtual-slot-value system ',slot-name))))) + (defmacro define-system-virtual-slot-readers () + `(progn ,@(mapcar (lambda (slot-name) + `(define-system-virtual-slot-reader ,slot-name)) + *system-virtual-slots*))) + (define-system-virtual-slot-readers) + (defun system-license (system) + (system-virtual-slot-value system 'licence))) + + +;;;; Pathnames + +(with-upgradability () + ;; Resolve a system designator to a system before extracting its system-source-file + (defmethod system-source-file ((system-name string)) + (system-source-file (find-system system-name))) + (defmethod system-source-file ((system-name symbol)) + (when system-name + (system-source-file (find-system system-name)))) + + (defun system-source-directory (system-designator) + "Return a pathname object corresponding to the directory +in which the system specification (.asd file) is located." + (pathname-directory-pathname (system-source-file system-designator))) + + (defun system-relative-pathname (system name &key type) + "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE, +return the absolute pathname of a corresponding file under that system's source code pathname." + (subpathname (system-source-directory system) name :type type)) + + (defmethod component-pathname ((system system)) + "Given a SYSTEM, and a (Unix-style relative path) NAME of a file (or directory) of given TYPE, +return the absolute pathname of a corresponding file under that system's source code pathname." + (let ((pathname (or (call-next-method) (system-source-directory system)))) + (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age + (slot-value system 'relative-pathname)) ;; systems that directly access this slot. + (setf (slot-value system 'relative-pathname) pathname)) + pathname)) + + ;; The default method of component-relative-pathname for a system: + ;; if a pathname was specified in the .asd file, it must be relative to the .asd file + ;; (actually, to its truename* if *resolve-symlinks* it true, the default). + ;; The method will return an *absolute* pathname, once again showing that the historical name + ;; component-relative-pathname is misleading and should have been component-specified-pathname. + (defmethod component-relative-pathname ((system system)) + (parse-unix-namestring + (and (slot-boundp system 'relative-pathname) + (slot-value system 'relative-pathname)) + :want-relative t + :type :directory + :ensure-absolute t + :defaults (system-source-directory system))) + + ;; A system has no parent; if some method wants to make a path "relative to its parent", + ;; it will instead be relative to the system itself. + (defmethod component-parent-pathname ((system system)) + (system-source-directory system)) + + ;; Most components don't have a specified component-build-pathname, and therefore + ;; no magic redirection of their output that disregards the output-translations. + (defmethod component-build-pathname ((c component)) + nil)) + +;;;; ------------------------------------------------------------------------- +;;;; Finding systems + +(uiop/package:define-package :asdf/system-registry + (:recycle :asdf/system-registry :asdf/find-system :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade + :asdf/session :asdf/component :asdf/system) + (:export + #:remove-entry-from-registry #:coerce-entry-to-directory + #:registered-system #:register-system + #:registered-systems* #:registered-systems + #:clear-system #:map-systems + #:*system-definition-search-functions* #:search-for-system-definition + #:*central-registry* #:probe-asd #:sysdef-central-registry-search + #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed + #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* + #:find-system-if-being-defined #:mark-component-preloaded ;; forward references to asdf/find-system + #:sysdef-immutable-system-search #:register-immutable-system #:*immutable-systems* + #:*registered-systems* #:clear-registered-systems + ;; defined in source-registry, but specially mentioned here: + #:sysdef-source-registry-search)) +(in-package :asdf/system-registry) + +(with-upgradability () + ;;; Registry of Defined Systems + + (defvar *registered-systems* (make-hash-table :test 'equal) + "This is a hash table whose keys are strings -- the names of systems -- +and whose values are systems. +A system is referred to as \"registered\" if it is present in this table.") + + (defun registered-system (name) + "Return a system of given NAME that was registered already, +if such a system exists. NAME is a system designator, to be +normalized by COERCE-NAME. The value returned is a system object, +or NIL if not found." + (gethash (coerce-name name) *registered-systems*)) + + (defun registered-systems* () + "Return a list containing every registered system (as a system object)." + (loop :for registered :being :the :hash-values :of *registered-systems* + :collect registered)) + + (defun registered-systems () + "Return a list of the names of every registered system." + (mapcar 'coerce-name (registered-systems*))) + + (defun register-system (system) + "Given a SYSTEM object, register it." + (check-type system system) + (let ((name (component-name system))) + (check-type name string) + (asdf-message (compatfmt "~&~@<; ~@;Registering system ~3i~_~A~@:>~%") name) + (setf (gethash name *registered-systems*) system))) + + (defun map-systems (fn) + "Apply FN to each defined system. + +FN should be a function of one argument. It will be +called with an object of type asdf:system." + (loop :for registered :being :the :hash-values :of *registered-systems* + :do (funcall fn registered))) + + + ;;; Preloaded systems: in the image even if you can't find source files backing them. + + (defvar *preloaded-systems* (make-hash-table :test 'equal) + "Registration table for preloaded systems.") + + (declaim (ftype (function (t) t) mark-component-preloaded)) ; defined in asdf/find-system + + (defun make-preloaded-system (name keys) + "Make a preloaded system of given NAME with build information from KEYS" + (let ((system (apply 'make-instance (getf keys :class 'system) + :name name :source-file (getf keys :source-file) + (remove-plist-keys '(:class :name :source-file) keys)))) + (mark-component-preloaded system) + system)) + + (defun sysdef-preloaded-system-search (requested) + "If REQUESTED names a system registered as preloaded, return a new system +with its registration information." + (let ((name (coerce-name requested))) + (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) + (when foundp + (make-preloaded-system name keys))))) + + (defun ensure-preloaded-system-registered (name) + "If there isn't a registered _defined_ system of given NAME, +and a there is a registered _preloaded_ system of given NAME, +then define and register said preloaded system." + (if-let (system (and (not (registered-system name)) (sysdef-preloaded-system-search name))) + (register-system system))) + + (defun register-preloaded-system (system-name &rest keys &key (version t) &allow-other-keys) + "Register a system as being preloaded. If the system has not been loaded from the filesystem +yet, or if its build information is later cleared with CLEAR-SYSTEM, a dummy system will be +registered without backing filesystem information, based on KEYS (e.g. to provide a VERSION). +If VERSION is the default T, and a system was already loaded, then its version will be preserved." + (let ((name (coerce-name system-name))) + (when (eql version t) + (if-let (system (registered-system name)) + (setf (getf keys :version) (component-version system)))) + (setf (gethash name *preloaded-systems*) keys) + (ensure-preloaded-system-registered system-name))) + + + ;;; Immutable systems: in the image and can't be reloaded from source. + + (defvar *immutable-systems* nil + "A hash-set (equal hash-table mapping keys to T) of systems that are immutable, +i.e. already loaded in memory and not to be refreshed from the filesystem. +They will be treated specially by find-system, and passed as :force-not argument to make-plan. + +For instance, to can deliver an image with many systems precompiled, that *will not* check the +filesystem for them every time a user loads an extension, what more risk a problematic upgrade + or catastrophic downgrade, before you dump an image, you may use: + (map () 'asdf:register-immutable-system (asdf:already-loaded-systems)) + +Note that direct access to this variable from outside ASDF is not supported. +Please call REGISTER-IMMUTABLE-SYSTEM to add new immutable systems, and +contact maintainers if you need a stable API to do more than that.") + + (defun sysdef-immutable-system-search (requested) + (let ((name (coerce-name requested))) + (when (and *immutable-systems* (gethash name *immutable-systems*)) + (or (registered-system requested) + (error 'formatted-system-definition-error + :format-control "Requested system ~A registered as an immutable-system, ~ +but not even registered as defined" + :format-arguments (list name)))))) + + (defun register-immutable-system (system-name &rest keys) + "Register SYSTEM-NAME as preloaded and immutable. +It will automatically be considered as passed to FORCE-NOT in a plan." + (let ((system-name (coerce-name system-name))) + (apply 'register-preloaded-system system-name keys) + (unless *immutable-systems* + (setf *immutable-systems* (list-to-hash-set nil))) + (setf (gethash system-name *immutable-systems*) t))) + + + ;;; Making systems undefined. + + (defun clear-system (system) + "Clear the entry for a SYSTEM in the database of systems previously defined. +However if the system was registered as PRELOADED (which it is if it is IMMUTABLE), +then a new system with the same name will be defined and registered in its place +from which build details will have been cleared. +Note that this does NOT in any way cause any of the code of the system to be unloaded. +Returns T if system was or is now undefined, NIL if a new preloaded system was redefined." + ;; There is no "unload" operation in Common Lisp, and + ;; a general such operation cannot be portably written, + ;; considering how much CL relies on side-effects to global data structures. + (let ((name (coerce-name system))) + (remhash name *registered-systems*) + (unset-asdf-cache-entry `(find-system ,name)) + (not (ensure-preloaded-system-registered name)))) + + (defun clear-registered-systems () + "Clear all currently registered defined systems. +Preloaded systems (including immutable ones) will be reset, other systems will be de-registered." + (map () 'clear-system (registered-systems))) + + + ;;; Searching for system definitions + + ;; For the sake of keeping things reasonably neat, we adopt a convention that + ;; only symbols are to be pushed to this list (rather than e.g. function objects), + ;; which makes upgrade easier. Also, the name of these symbols shall start with SYSDEF- + (defvar *system-definition-search-functions* '() + "A list that controls the ways that ASDF looks for system definitions. +It contains symbols to be funcalled in order, with a requested system name as argument, +until one returns a non-NIL result (if any), which must then be a fully initialized system object +with that name.") + + ;; Initialize and/or upgrade the *system-definition-search-functions* + ;; so it doesn't contain obsolete symbols, and does contain the current ones. + (defun cleanup-system-definition-search-functions () + (setf *system-definition-search-functions* + (append + ;; Remove known-incompatible sysdef functions from old versions of asdf. + ;; Order matters, so we can't just use set-difference. + (let ((obsolete + '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search))) + (remove-if #'(lambda (x) (member x obsolete)) *system-definition-search-functions*)) + ;; Tuck our defaults at the end of the list if they were absent. + ;; This is imperfect, in case they were removed on purpose, + ;; but then it will be the responsibility of whoever removes these symmbols + ;; to upgrade asdf before he does such a thing rather than after. + (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) + '(sysdef-central-registry-search + sysdef-source-registry-search))))) + (cleanup-system-definition-search-functions) + + ;; This (private) function does the search for a system definition using *s-d-s-f*; + ;; it is to be called by locate-system. + (defun search-for-system-definition (system) + ;; Search for valid definitions of the system available in the current session. + ;; Previous definitions as registered in *registered-systems* MUST NOT be considered; + ;; they will be reconciled by locate-system then find-system. + ;; There are two special treatments: first, specially search for objects being defined + ;; in the current session, to avoid definition races between several files; + ;; second, specially search for immutable systems, so they cannot be redefined. + ;; Finally, use the search functions specified in *system-definition-search-functions*. + (let ((name (coerce-name system))) + (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x)))) + (try 'find-system-if-being-defined) + (try 'sysdef-immutable-system-search) + (map () #'try *system-definition-search-functions*)))) + + + ;;; The legacy way of finding a system: the *central-registry* + + ;; This variable contains a list of directories to be lazily searched for the requested asd + ;; by sysdef-central-registry-search. + (defvar *central-registry* nil + "A list of 'system directory designators' ASDF uses to find systems. + +A 'system directory designator' is a pathname or an expression +which evaluates to a pathname. For example: + + (setf asdf:*central-registry* + (list '*default-pathname-defaults* + #p\"/home/me/cl/systems/\" + #p\"/usr/share/common-lisp/systems/\")) + +This variable is for backward compatibility. +Going forward, we recommend new users should be using the source-registry.") + + ;; Function to look for an asd file of given NAME under a directory provided by DEFAULTS. + ;; Return the truename of that file if it is found and TRUENAME is true. + ;; Return NIL if the file is not found. + ;; On Windows, follow shortcuts to .asd files. + (defun probe-asd (name defaults &key truename) + (block nil + (when (directory-pathname-p defaults) + (if-let (file (probe-file* + (ensure-absolute-pathname + (parse-unix-namestring name :type "asd") + #'(lambda () (ensure-absolute-pathname defaults 'get-pathname-defaults nil)) + nil) + :truename truename)) + (return file)) + #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) + (os-cond + ((os-windows-p) + (when (physical-pathname-p defaults) + (let ((shortcut + (make-pathname + :defaults defaults :case :local + :name (strcat name ".asd") + :type "lnk"))) + (when (probe-file* shortcut) + (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native))))))))) + + ;; Function to push onto *s-d-s-f* to use the *central-registry* + (defun sysdef-central-registry-search (system) + (let ((name (primary-system-name system)) + (to-remove nil) + (to-replace nil)) + (block nil + (unwind-protect + (dolist (dir *central-registry*) + (let ((defaults (eval dir)) + directorized) + (when defaults + (cond ((directory-pathname-p defaults) + (let* ((file (probe-asd name defaults :truename *resolve-symlinks*))) + (when file + (return file)))) + (t + (restart-case + (let* ((*print-circle* nil) + (message + (format nil + (compatfmt "~@") + system dir defaults))) + (error message)) + (remove-entry-from-registry () + :report "Remove entry from *central-registry* and continue" + (push dir to-remove)) + (coerce-entry-to-directory () + :test (lambda (c) (declare (ignore c)) + (and (not (directory-pathname-p defaults)) + (directory-pathname-p + (setf directorized + (ensure-directory-pathname defaults))))) + :report (lambda (s) + (format s (compatfmt "~@") + directorized dir)) + (push (cons dir directorized) to-replace)))))))) + ;; cleanup + (dolist (dir to-remove) + (setf *central-registry* (remove dir *central-registry*))) + (dolist (pair to-replace) + (let* ((current (car pair)) + (new (cdr pair)) + (position (position current *central-registry*))) + (setf *central-registry* + (append (subseq *central-registry* 0 position) + (list new) + (subseq *central-registry* (1+ position))))))))))) + +;;;; ------------------------------------------------------------------------- +;;;; Actions + +(uiop/package:define-package :asdf/action + (:nicknames :asdf-action) + (:recycle :asdf/action :asdf/plan :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session :asdf/component :asdf/operation) + (:import-from :asdf/operation #:check-operation-constructor) + (:import-from :asdf/component #:%additional-input-files) + (:export + #:action #:define-convenience-action-methods + #:action-description #:format-action + #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation + #:non-propagating-operation + #:component-depends-on + #:input-files #:output-files #:output-file #:operation-done-p + #:action-operation #:action-component #:make-action + #:component-operation-time #:mark-operation-done #:compute-action-stamp + #:perform #:perform-with-restarts #:retry #:accept + #:action-path #:find-action + #:operation-definition-warning #:operation-definition-error ;; condition + #:action-valid-p + #:circular-dependency #:circular-dependency-actions + #:call-while-visiting-action #:while-visiting-action + #:additional-input-files)) +(in-package :asdf/action) + +(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning + + (deftype action () + "A pair of operation and component uniquely identifies a node in the dependency graph +of steps to be performed while building a system." + '(cons operation component)) + + (deftype operation-designator () + "An operation designates itself. NIL designates a context-dependent current operation, +and a class-name or class designates the canonical instance of the designated class." + '(or operation null symbol class))) + +;;; these are pseudo accessors -- let us abstract away the CONS cell representation of plan +;;; actions. +(with-upgradability () + (defun make-action (operation component) + (cons operation component)) + (defun action-operation (action) + (car action)) + (defun action-component (action) + (cdr action))) + +;;;; Reified representation for storage or debugging. Note: an action is identified by its class. +(with-upgradability () + (defun action-path (action) + "A readable data structure that identifies the action." + (when action + (let ((o (action-operation action)) + (c (action-component action))) + (cons (type-of o) (component-find-path c))))) + (defun find-action (path) + "Reconstitute an action from its action-path" + (destructuring-bind (o . c) path (make-action (make-operation o) (find-component () c))))) + +;;;; Convenience methods +(with-upgradability () + ;; A macro that defines convenience methods for a generic function (gf) that + ;; dispatches on operation and component. The convenience methods allow users + ;; to call the gf with operation and/or component designators, that the + ;; methods will resolve into actual operation and component objects, so that + ;; the users can interact using readable designators, but developers only have + ;; to write methods that handle operation and component objects. + ;; FUNCTION is the generic function name + ;; FORMALS is its list of arguments, which must include OPERATION and COMPONENT. + ;; IF-NO-OPERATION is a form (defaults to NIL) describing what to do if no operation is found. + ;; IF-NO-COMPONENT is a form (defaults to NIL) describing what to do if no component is found. + (defmacro define-convenience-action-methods + (function formals &key if-no-operation if-no-component) + (let* ((rest (gensym "REST")) + (found (gensym "FOUND")) + (keyp (equal (last formals) '(&key))) + (formals-no-key (if keyp (butlast formals) formals)) + (len (length formals-no-key)) + (operation 'operation) + (component 'component) + (opix (position operation formals)) + (coix (position component formals)) + (prefix (subseq formals 0 opix)) + (suffix (subseq formals (1+ coix) len)) + (more-args (when keyp `(&rest ,rest &key &allow-other-keys)))) + (assert (and (integerp opix) (integerp coix) (= coix (1+ opix)))) + (flet ((next-method (o c) + (if keyp + `(apply ',function ,@prefix ,o ,c ,@suffix ,rest) + `(,function ,@prefix ,o ,c ,@suffix)))) + `(progn + (defmethod ,function (,@prefix (,operation string) ,component ,@suffix ,@more-args) + (declare (notinline ,function)) + (let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on + ,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component))) + (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args) + (declare (notinline ,function)) + (if ,operation + ,(next-method + `(make-operation ,operation) + `(or (find-component () ,component) ,if-no-component)) + ,if-no-operation)) + (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args) + (declare (notinline ,function)) + (if (typep ,component 'component) + (error "No defined method for ~S on ~/asdf-action:format-action/" + ',function (make-action ,operation ,component)) + (if-let (,found (find-component () ,component)) + ,(next-method operation found) + ,if-no-component)))))))) + + +;;;; Self-description +(with-upgradability () + (defgeneric action-description (operation component) + (:documentation "returns a phrase that describes performing this operation +on this component, e.g. \"loading /a/b/c\". +You can put together sentences using this phrase.")) + (defmethod action-description (operation component) + (format nil (compatfmt "~@<~A on ~A~@:>") + operation component)) + + (defun format-action (stream action &optional colon-p at-sign-p) + "FORMAT helper to display an action's action-description. +Use it in FORMAT control strings as ~/asdf-action:format-action/" + (assert (null colon-p)) (assert (null at-sign-p)) + (destructuring-bind (operation . component) action + (princ (action-description operation component) stream)))) + + +;;;; Detection of circular dependencies +(with-upgradability () + (defun action-valid-p (operation component) + "Is this action valid to include amongst dependencies?" + ;; If either the operation or component was resolved to nil, the action is invalid. + ;; :if-feature will invalidate actions on components for which the features don't apply. + (and operation component + (if-let (it (component-if-feature component)) (featurep it) t))) + + (define-condition circular-dependency (system-definition-error) + ((actions :initarg :actions :reader circular-dependency-actions)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (first (circular-dependency-actions c)) + (circular-dependency-actions c))))) + + (defun call-while-visiting-action (operation component fun) + "Detect circular dependencies" + (with-asdf-session () + (with-accessors ((action-set visiting-action-set) + (action-list visiting-action-list)) *asdf-session* + (let ((action (cons operation component))) + (when (gethash action action-set) + (error 'circular-dependency :actions + (member action (reverse action-list) :test 'equal))) + (setf (gethash action action-set) t) + (push action action-list) + (unwind-protect + (funcall fun) + (pop action-list) + (setf (gethash action action-set) nil)))))) + + ;; Syntactic sugar for call-while-visiting-action + (defmacro while-visiting-action ((o c) &body body) + `(call-while-visiting-action ,o ,c #'(lambda () ,@body)))) + + +;;;; Dependencies +(with-upgradability () + (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies + (:documentation + "Returns a list of dependencies needed by the component to perform + the operation. A dependency has one of the following forms: + + ( *), where is an operation designator + with respect to FIND-OPERATION in the context of the OPERATION argument, + and each is a component designator with respect to + FIND-COMPONENT in the context of the COMPONENT argument, + and means that the component depends on + having been performed on each ; + + [Note: an is an operation designator -- it can be either an + operation name or an operation object. Similarly, a may be + a component name or a component object. Also note that, the degenerate + case of () is a no-op.] + + Methods specialized on subclasses of existing component types + should usually append the results of CALL-NEXT-METHOD to the list.")) + (define-convenience-action-methods component-depends-on (operation component)) + + (defmethod component-depends-on :around ((o operation) (c component)) + (do-asdf-cache `(component-depends-on ,o ,c) + (call-next-method)))) + + +;;;; upward-operation, downward-operation, sideway-operation, selfward-operation +;; These together handle actions that propagate along the component hierarchy or operation universe. +(with-upgradability () + (defclass downward-operation (operation) + ((downward-operation + :initform nil :reader downward-operation + :type operation-designator :allocation :class)) + (:documentation "A DOWNWARD-OPERATION's dependencies propagate down the component hierarchy. +I.e., if O is a DOWNWARD-OPERATION and its DOWNWARD-OPERATION slot designates operation D, then +the action (O . M) of O on module M will depends on each of (D . C) for each child C of module M. +The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself. +E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the +children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP.")) + (defun downward-operation-depends-on (o c) + `((,(or (downward-operation o) o) ,@(component-children c)))) + (defmethod component-depends-on ((o downward-operation) (c parent-component)) + `(,@(downward-operation-depends-on o c) ,@(call-next-method))) + + (defclass upward-operation (operation) + ((upward-operation + :initform nil :reader upward-operation + :type operation-designator :allocation :class)) + (:documentation "An UPWARD-OPERATION has dependencies that propagate up the component hierarchy. +I.e., if O is an instance of UPWARD-OPERATION, and its UPWARD-OPERATION slot designates operation U, +then the action (O . C) of O on a component C that has the parent P will depends on (U . P). +The default value for slot UPWARD-OPERATION is NIL, which designates the operation O itself. +E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, its PARENT +must first be prepared for loading or compiling with PREPARE-OP.")) + ;; For backward-compatibility reasons, a system inherits from module and is a child-component + ;; so we must guard against this case. ASDF4: remove that. + (defun upward-operation-depends-on (o c) + (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p)))) + (defmethod component-depends-on ((o upward-operation) (c child-component)) + `(,@(upward-operation-depends-on o c) ,@(call-next-method))) + + (defclass sideway-operation (operation) + ((sideway-operation + :initform nil :reader sideway-operation + :type operation-designator :allocation :class)) + (:documentation "A SIDEWAY-OPERATION has dependencies that propagate \"sideway\" to siblings +that a component depends on. I.e. if O is a SIDEWAY-OPERATION, and its SIDEWAY-OPERATION slot +designates operation S (where NIL designates O itself), then the action (O . C) of O on component C +depends on each of (S . D) where D is a declared dependency of C. +E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, +each of its declared dependencies must first be loaded as by LOAD-OP.")) + (defun sideway-operation-depends-on (o c) + `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c)))) + (defmethod component-depends-on ((o sideway-operation) (c component)) + `(,@(sideway-operation-depends-on o c) ,@(call-next-method))) + + (defclass selfward-operation (operation) + ((selfward-operation + ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which + :type (or operation-designator list) :reader selfward-operation :allocation :class)) + (:documentation "A SELFWARD-OPERATION depends on another operation on the same component. +I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L, +then the action (O . C) of O on component C depends on each (S . C) for S in L. +E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP. +A operation-designator designates a singleton list of the designated operation; +a list of operation-designators designates the list of designated operations; +NIL is not a valid operation designator in that context. Note that any dependency +ordering between the operations in a list of SELFWARD-OPERATION should be specified separately +in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly.")) + (defun selfward-operation-depends-on (o c) + (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c))) + (defmethod component-depends-on ((o selfward-operation) (c component)) + `(,@(selfward-operation-depends-on o c) ,@(call-next-method))) + + (defclass non-propagating-operation (operation) + () + (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates +no dependencies whatsoever. It is supplied in order that the programmer be able +to specify that s/he is intentionally specifying an operation which invokes no +dependencies."))) + + +;;;--------------------------------------------------------------------------- +;;; Help programmers catch obsolete OPERATION subclasses +;;;--------------------------------------------------------------------------- +(with-upgradability () + (define-condition operation-definition-warning (simple-warning) + () + (:documentation "Warning condition related to definition of obsolete OPERATION objects.")) + + (define-condition operation-definition-error (simple-error) + () + (:documentation "Error condition related to definition of incorrect OPERATION objects.")) + + (defmethod initialize-instance :before ((o operation) &key) + (check-operation-constructor) + (unless (typep o '(or downward-operation upward-operation sideway-operation + selfward-operation non-propagating-operation)) + (warn 'operation-definition-warning + :format-control + "No dependency propagating scheme specified for operation class ~S. +The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins." + :format-arguments (list (type-of o))))) + + (defmethod initialize-instance :before ((o non-propagating-operation) &key) + (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation)) + (error 'operation-definition-error + :format-control + "Inconsistent class: ~S + NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses." + :format-arguments + (list (type-of o))))) + + (defun backward-compatible-depends-on (o c) + "DEPRECATED: all subclasses of OPERATION used in ASDF should inherit from one of + DOWNWARD-OPERATION UPWARD-OPERATION SIDEWAY-OPERATION SELFWARD-OPERATION NON-PROPAGATING-OPERATION. + The function BACKWARD-COMPATIBLE-DEPENDS-ON temporarily provides ASDF2 behaviour for those that + don't. In the future this functionality will be removed, and the default will be no propagation." + (uiop/version::notify-deprecated-function + (version-deprecation *asdf-version* :style-warning "3.2") + `(backward-compatible-depends-on :for-operation ,o)) + `(,@(sideway-operation-depends-on o c) + ,@(when (typep c 'parent-component) (downward-operation-depends-on o c)))) + + (defmethod component-depends-on ((o operation) (c component)) + `(;; Normal behavior, to allow user-specified in-order-to dependencies + ,@(cdr (assoc (type-of o) (component-in-order-to c))) + ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation + ;; or non-propagation through an appropriate mixin will be downward and sideway. + ,@(unless (typep o '(or downward-operation upward-operation sideway-operation + selfward-operation non-propagating-operation)) + (backward-compatible-depends-on o c)))) + + (defmethod downward-operation ((o operation)) nil) + (defmethod sideway-operation ((o operation)) nil)) + + +;;;--------------------------------------------------------------------------- +;;; End of OPERATION class checking +;;;--------------------------------------------------------------------------- + + +;;;; Inputs, Outputs, and invisible dependencies +(with-upgradability () + (defgeneric output-files (operation component) + (:documentation "Methods for this function return two values: a list of output files +corresponding to this action, and a boolean indicating if they have already been subjected +to relevant output translations and should not be further translated. + +Methods on PERFORM *must* call this function to determine where their outputs are to be located. +They may rely on the order of the files to discriminate between outputs. +")) + (defgeneric input-files (operation component) + (:documentation "A list of input files corresponding to this action. + +Methods on PERFORM *must* call this function to determine where their inputs are located. +They may rely on the order of the files to discriminate between inputs. +")) + (defgeneric operation-done-p (operation component) + (:documentation "Returns a boolean which is NIL if the action must be performed (again).")) + (define-convenience-action-methods output-files (operation component)) + (define-convenience-action-methods input-files (operation component)) + (define-convenience-action-methods operation-done-p (operation component)) + + (defmethod operation-done-p ((o operation) (c component)) + t) + + ;; Translate output files, unless asked not to. Memoize the result. + (defmethod output-files :around ((operation t) (component t)) + (do-asdf-cache `(output-files ,operation ,component) + (values + (multiple-value-bind (pathnames fixedp) (call-next-method) + ;; 1- Make sure we have absolute pathnames + (let* ((directory (pathname-directory-pathname + (component-pathname (find-component () component)))) + (absolute-pathnames + (loop + :for pathname :in pathnames + :collect (ensure-absolute-pathname pathname directory)))) + ;; 2- Translate those pathnames as required + (if fixedp + absolute-pathnames + (mapcar *output-translation-function* absolute-pathnames)))) + t))) + (defmethod output-files ((o operation) (c component)) + nil) + (defun output-file (operation component) + "The unique output file of performing OPERATION on COMPONENT" + (let ((files (output-files operation component))) + (assert (length=n-p files 1)) + (first files))) + + (defgeneric additional-input-files (operation component) + (:documentation "Additional input files for the operation on this + component. These are files that are inferred, rather than + explicitly specified, and these are typically NOT files that + undergo operations directly. Instead, they are files that it is + important for ASDF to know about in order to compute operation times,etc.")) + (define-convenience-action-methods additional-input-files (operation component)) + (defmethod additional-input-files ((op operation) (comp component)) + (cdr (assoc op (%additional-input-files comp)))) + + ;; Memoize input files. + (defmethod input-files :around (operation component) + (do-asdf-cache `(input-files ,operation ,component) + ;; get the additional input files, if any + (append (call-next-method) + ;; must come after the first, for other code that + ;; assumes the first will be the "key" file + (additional-input-files operation component)))) + + ;; By default an action has no input-files. + (defmethod input-files ((o operation) (c component)) + nil) + + ;; An action with a selfward-operation by default gets its input-files from the output-files of + ;; the actions using selfward-operations it depends on (and the same component), + ;; or if there are none, on the component-pathname of the component if it's a file + ;; -- and then on the results of the next-method. + (defmethod input-files ((o selfward-operation) (c component)) + `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o)) + :append (or (output-files dep-o c) (input-files dep-o c))) + (if-let ((pathname (component-pathname c))) + (and (file-pathname-p pathname) (list pathname)))) + ,@(call-next-method)))) + + +;;;; Done performing +(with-upgradability () + ;; ASDF4: hide it behind plan-action-stamp + (defgeneric component-operation-time (operation component) + (:documentation "Return the timestamp for when an action was last performed")) + (defgeneric (setf component-operation-time) (time operation component) + (:documentation "Update the timestamp for when an action was last performed")) + (define-convenience-action-methods component-operation-time (operation component)) + + ;; ASDF4: hide it behind (setf plan-action-stamp) + (defgeneric mark-operation-done (operation component) + (:documentation "Mark a action as having been just done. + +Updates the action's COMPONENT-OPERATION-TIME to match the COMPUTE-ACTION-STAMP +using the JUST-DONE flag.")) + (defgeneric compute-action-stamp (plan- operation component &key just-done) + ;; NB: using plan- rather than plan above allows clisp to upgrade from 2.26(!) + (:documentation "Has this action been successfully done already, +and at what known timestamp has it been done at or will it be done at? +* PLAN is a plan object modelling future effects of actions, + or NIL to denote what actually happened. +* OPERATION and COMPONENT denote the action. +Takes keyword JUST-DONE: +* JUST-DONE is a boolean that is true if the action was just successfully performed, + at which point we want compute the actual stamp and warn if files are missing; + otherwise we are making plans, anticipating the effects of the action. +Returns two values: +* a STAMP saying when it was done or will be done, + or T if the action involves files that need to be recomputed. +* a boolean DONE-P that indicates whether the action has actually been done, + and both its output-files and its in-image side-effects are up to date.")) + + (defmethod component-operation-time ((o operation) (c component)) + (gethash o (component-operation-times c))) + + (defmethod (setf component-operation-time) (stamp (o operation) (c component)) + (assert stamp () "invalid null stamp for ~A" (action-description o c)) + (setf (gethash o (component-operation-times c)) stamp)) + + (defmethod mark-operation-done ((o operation) (c component)) + (let ((stamp (compute-action-stamp nil o c :just-done t))) + (assert stamp () "Failed to compute a stamp for completed action ~A" (action-description o c))1 + (setf (component-operation-time o c) stamp)))) + + +;;;; Perform +(with-upgradability () + (defgeneric perform (operation component) + (:documentation "PERFORM an action, consuming its input-files and building its output-files")) + (define-convenience-action-methods perform (operation component)) + + (defmethod perform :around ((o operation) (c component)) + (while-visiting-action (o c) (call-next-method))) + (defmethod perform :before ((o operation) (c component)) + (ensure-all-directories-exist (output-files o c))) + (defmethod perform :after ((o operation) (c component)) + (mark-operation-done o c)) + (defmethod perform ((o operation) (c parent-component)) + nil) + (defmethod perform ((o operation) (c source-file)) + ;; For backward compatibility, don't error on operations that don't specify propagation. + (when (typep o '(or downward-operation upward-operation sideway-operation + selfward-operation non-propagating-operation)) + (sysdef-error + (compatfmt "~@") + 'perform (make-action o c)))) + + ;; The restarts of the perform-with-restarts variant matter in an interactive context. + ;; The retry strategies of p-w-r itself, and/or the background workers of a multiprocess build + ;; may call perform directly rather than call p-w-r. + (defgeneric perform-with-restarts (operation component) + (:documentation "PERFORM an action in a context where suitable restarts are in place.")) + (defmethod perform-with-restarts (operation component) + (perform operation component)) + (defmethod perform-with-restarts :around (operation component) + (loop + (restart-case + (return (call-next-method)) + (retry () + :report + (lambda (s) + (format s (compatfmt "~@") + (action-description operation component)))) + (accept () + :report + (lambda (s) + (format s (compatfmt "~@") + (action-description operation component))) + (mark-operation-done operation component) + (return)))))) +;;;; ------------------------------------------------------------------------- +;;;; Actions to build Common Lisp software + +(uiop/package:define-package :asdf/lisp-action + (:recycle :asdf/lisp-action :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/system :asdf/operation :asdf/action) + (:export + #:try-recompiling + #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp + #:basic-load-op #:basic-compile-op + #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op + #:call-with-around-compile-hook + #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source + #:lisp-compilation-output-files)) +(in-package :asdf/lisp-action) + + +;;;; Component classes +(with-upgradability () + (defclass cl-source-file (source-file) + ((type :initform "lisp")) + (:documentation "Component class for a Common Lisp source file (using type \"lisp\")")) + (defclass cl-source-file.cl (cl-source-file) + ((type :initform "cl")) + (:documentation "Component class for a Common Lisp source file using type \"cl\"")) + (defclass cl-source-file.lsp (cl-source-file) + ((type :initform "lsp")) + (:documentation "Component class for a Common Lisp source file using type \"lsp\""))) + + +;;;; Operation classes +(with-upgradability () + (defclass basic-load-op (operation) () + (:documentation "Base class for operations that apply the load-time effects of a file")) + (defclass basic-compile-op (operation) () + (:documentation "Base class for operations that apply the compile-time effects of a file"))) + + +;;; Our default operations: loading into the current lisp image +(with-upgradability () + (defclass prepare-op (upward-operation sideway-operation) + ((sideway-operation :initform 'load-op :allocation :class)) + (:documentation "Load the dependencies for the COMPILE-OP or LOAD-OP of a given COMPONENT.")) + (defclass load-op (basic-load-op downward-operation selfward-operation) + ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p, + ;; so we need to directly depend on prepare-op for its side-effects in the current image. + ((selfward-operation :initform '(prepare-op compile-op) :allocation :class)) + (:documentation "Operation for loading the compiled FASL for a Lisp file")) + (defclass compile-op (basic-compile-op downward-operation selfward-operation) + ((selfward-operation :initform 'prepare-op :allocation :class)) + (:documentation "Operation for compiling a Lisp file to a FASL")) + + + (defclass prepare-source-op (upward-operation sideway-operation) + ((sideway-operation :initform 'load-source-op :allocation :class)) + (:documentation "Operation for loading the dependencies of a Lisp file as source.")) + (defclass load-source-op (basic-load-op downward-operation selfward-operation) + ((selfward-operation :initform 'prepare-source-op :allocation :class)) + (:documentation "Operation for loading a Lisp file as source.")) + + (defclass test-op (selfward-operation) + ((selfward-operation :initform 'load-op :allocation :class)) + (:documentation "Operation for running the tests for system. +If the tests fail, an error will be signaled."))) + + +;;;; Methods for prepare-op, compile-op and load-op + +;;; prepare-op +(with-upgradability () + (defmethod action-description ((o prepare-op) (c component)) + (format nil (compatfmt "~@") c)) + (defmethod perform ((o prepare-op) (c component)) + nil) + (defmethod input-files ((o prepare-op) (s system)) + (if-let (it (system-source-file s)) (list it)))) + +;;; compile-op +(with-upgradability () + (defmethod action-description ((o compile-op) (c component)) + (format nil (compatfmt "~@") c)) + (defmethod action-description ((o compile-op) (c parent-component)) + (format nil (compatfmt "~@") c)) + (defgeneric call-with-around-compile-hook (component thunk) + (:documentation "A method to be called around the PERFORM'ing of actions that apply the +compile-time side-effects of file (i.e., COMPILE-OP or LOAD-SOURCE-OP). This method can be used +to setup readtables and other variables that control reading, macroexpanding, and compiling, etc. +Note that it will NOT be called around the performing of LOAD-OP.")) + (defmethod call-with-around-compile-hook ((c component) function) + (call-around-hook (around-compile-hook c) function)) + (defun perform-lisp-compilation (o c) + "Perform the compilation of the Lisp file associated to the specified action (O . C)." + (let (;; Before 2.26.53, that was unfortunately component-pathname. Now, + ;; we consult input-files, the first of which should be the one to compile-file + (input-file (first (input-files o c))) + ;; On some implementations, there are more than one output-file, + ;; but the first one should always be the primary fasl that gets loaded. + (outputs (output-files o c))) + (multiple-value-bind (output warnings-p failure-p) + (destructuring-bind + (output-file + &optional + #+(or clasp ecl mkcl) object-file + #+clisp lib-file + warnings-file &rest rest) outputs + ;; Allow for extra outputs that are not of type warnings-file + ;; The way we do it is kludgy. In ASDF4, output-files shall not be positional. + (declare (ignore rest)) + (when warnings-file + (unless (equal (pathname-type warnings-file) (warnings-file-type)) + (setf warnings-file nil))) + (call-with-around-compile-hook + c #'(lambda (&rest flags) + (apply 'compile-file* input-file + :output-file output-file + :external-format (component-external-format c) + :warnings-file warnings-file + (append + #+clisp (list :lib-file lib-file) + #+(or clasp ecl mkcl) (list :object-file object-file) + flags))))) + (check-lisp-compile-results output warnings-p failure-p + "~/asdf-action::format-action/" (list (cons o c)))))) + (defun report-file-p (f) + "Is F a build report file containing, e.g., warnings to check?" + (equalp (pathname-type f) "build-report")) + (defun perform-lisp-warnings-check (o c) + "Check the warnings associated with the dependencies of an action." + (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c))) + (actual-warnings-files (loop :for w :in expected-warnings-files + :when (get-file-stamp w) + :collect w + :else :do (warn "Missing warnings file ~S while ~A" + w (action-description o c))))) + (check-deferred-warnings actual-warnings-files) + (let* ((output (output-files o c)) + (report (find-if #'report-file-p output))) + (when report + (with-open-file (s report :direction :output :if-exists :supersede) + (format s ":success~%")))))) + (defmethod perform ((o compile-op) (c cl-source-file)) + (perform-lisp-compilation o c)) + (defun lisp-compilation-output-files (o c) + "Compute the output-files for compiling the Lisp file for the specified action (O . C), +an OPERATION and a COMPONENT." + (let* ((i (first (input-files o c))) + (f (compile-file-pathname + i #+clasp :output-type #+ecl :type #+(or clasp ecl) :fasl + #+mkcl :fasl-p #+mkcl t))) + `(,f ;; the fasl is the primary output, in first position + #+clasp + ,@(unless nil ;; was (use-ecl-byte-compiler-p) + `(,(compile-file-pathname i :output-type :object))) + #+clisp + ,@`(,(make-pathname :type "lib" :defaults f)) + #+ecl + ,@(unless (use-ecl-byte-compiler-p) + `(,(compile-file-pathname i :type :object))) + #+mkcl + ,(compile-file-pathname i :fasl-p nil) ;; object file + ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c)))) + `(,(make-pathname :type *warnings-file-type* :defaults f)))))) + (defmethod output-files ((o compile-op) (c cl-source-file)) + (lisp-compilation-output-files o c)) + (defmethod perform ((o compile-op) (c static-file)) + nil) + + ;; Performing compile-op on a system will check the deferred warnings for the system + (defmethod perform ((o compile-op) (c system)) + (when (and *warnings-file-type* (not (builtin-system-p c))) + (perform-lisp-warnings-check o c))) + (defmethod input-files ((o compile-op) (c system)) + (when (and *warnings-file-type* (not (builtin-system-p c))) + ;; The most correct way to do it would be to use: + ;; (collect-dependencies o c :other-systems nil :keep-operation 'compile-op :keep-component 'cl-source-file) + ;; but it's expensive and we don't care too much about file order or ASDF extensions. + (loop :for sub :in (sub-components c :type 'cl-source-file) + :nconc (remove-if-not 'warnings-file-p (output-files o sub))))) + (defmethod output-files ((o compile-op) (c system)) + (when (and *warnings-file-type* (not (builtin-system-p c))) + (if-let ((pathname (component-pathname c))) + (list (subpathname pathname (coerce-filename c) :type "build-report")))))) + +;;; load-op +(with-upgradability () + (defmethod action-description ((o load-op) (c cl-source-file)) + (format nil (compatfmt "~@") c)) + (defmethod action-description ((o load-op) (c parent-component)) + (format nil (compatfmt "~@") c)) + (defmethod action-description ((o load-op) (c component)) + (format nil (compatfmt "~@") c)) + (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) + (loop + (restart-case + (return (call-next-method)) + (try-recompiling () + :report (lambda (s) + (format s "Recompile ~a and try loading it again" + (component-name c))) + (perform (find-operation o 'compile-op) c))))) + (defun perform-lisp-load-fasl (o c) + "Perform the loading of a FASL associated to specified action (O . C), +an OPERATION and a COMPONENT." + (if-let (fasl (first (input-files o c))) + (load* fasl))) + (defmethod perform ((o load-op) (c cl-source-file)) + (perform-lisp-load-fasl o c)) + (defmethod perform ((o load-op) (c static-file)) + nil)) + + +;;;; prepare-source-op, load-source-op + +;;; prepare-source-op +(with-upgradability () + (defmethod action-description ((o prepare-source-op) (c component)) + (format nil (compatfmt "~@") c)) + (defmethod input-files ((o prepare-source-op) (s system)) + (if-let (it (system-source-file s)) (list it))) + (defmethod perform ((o prepare-source-op) (c component)) + nil)) + +;;; load-source-op +(with-upgradability () + (defmethod action-description ((o load-source-op) (c component)) + (format nil (compatfmt "~@") c)) + (defmethod action-description ((o load-source-op) (c parent-component)) + (format nil (compatfmt "~@") c)) + (defun perform-lisp-load-source (o c) + "Perform the loading of a Lisp file as associated to specified action (O . C)" + (call-with-around-compile-hook + c #'(lambda () + (load* (first (input-files o c)) + :external-format (component-external-format c))))) + + (defmethod perform ((o load-source-op) (c cl-source-file)) + (perform-lisp-load-source o c)) + (defmethod perform ((o load-source-op) (c static-file)) + nil)) + + +;;;; test-op +(with-upgradability () + (defmethod perform ((o test-op) (c component)) + nil) + (defmethod operation-done-p ((o test-op) (c system)) + "Testing a system is _never_ done." + nil)) +;;;; ------------------------------------------------------------------------- +;;;; Finding components + +(uiop/package:define-package :asdf/find-component + (:recycle :asdf/find-component :asdf/find-system :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/system :asdf/system-registry) + (:export + #:find-component + #:resolve-dependency-name #:resolve-dependency-spec + #:resolve-dependency-combination + ;; Conditions + #:missing-component #:missing-requires #:missing-parent #:missing-component-of-version #:retry + #:missing-dependency #:missing-dependency-of-version + #:missing-requires #:missing-parent + #:missing-required-by #:missing-version)) +(in-package :asdf/find-component) + +;;;; Missing component conditions + +(with-upgradability () + (define-condition missing-component (system-definition-error) + ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) + (parent :initform nil :reader missing-parent :initarg :parent))) + + (define-condition missing-component-of-version (missing-component) + ((version :initform nil :reader missing-version :initarg :version))) + + (define-condition missing-dependency (missing-component) + ((required-by :initarg :required-by :reader missing-required-by))) + + (defmethod print-object ((c missing-dependency) s) + (format s (compatfmt "~@<~A, required by ~A~@:>") + (call-next-method c nil) (missing-required-by c))) + + (define-condition missing-dependency-of-version (missing-dependency + missing-component-of-version) + ()) + + (defmethod print-object ((c missing-component) s) + (format s (compatfmt "~@") + (missing-requires c) + (when (missing-parent c) + (coerce-name (missing-parent c))))) + + (defmethod print-object ((c missing-component-of-version) s) + (format s (compatfmt "~@") + (missing-requires c) + (missing-version c) + (when (missing-parent c) + (coerce-name (missing-parent c)))))) + + +;;;; Finding components + +(with-upgradability () + (defgeneric resolve-dependency-combination (component combinator arguments) + (:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS) +in the context of COMPONENT")) + + ;; Methods for find-component + + ;; If the base component is a string, resolve it as a system, then if not nil follow the path. + (defmethod find-component ((base string) path &key registered) + (if-let ((s (if registered + (registered-system base) + (find-system base nil)))) + (find-component s path :registered registered))) + + ;; If the base component is a symbol, coerce it to a name if not nil, and resolve that. + ;; If nil, use the path as base if not nil, or else return nil. + (defmethod find-component ((base symbol) path &key registered) + (cond + (base (find-component (coerce-name base) path :registered registered)) + (path (find-component path nil :registered registered)) + (t nil))) + + ;; If the base component is a cons cell, resolve its car, and add its cdr to the path. + (defmethod find-component ((base cons) path &key registered) + (find-component (car base) (cons (cdr base) path) :registered registered)) + + ;; If the base component is a parent-component and the path a string, find the named child. + (defmethod find-component ((parent parent-component) (name string) &key registered) + (declare (ignorable registered)) + (compute-children-by-name parent :only-if-needed-p t) + (values (gethash name (component-children-by-name parent)))) + + ;; If the path is a symbol, coerce it to a name if non-nil, or else just return the base. + (defmethod find-component (base (name symbol) &key registered) + (if name + (find-component base (coerce-name name) :registered registered) + base)) + + ;; If the path is a cons, first resolve its car as path, then its cdr. + (defmethod find-component ((c component) (name cons) &key registered) + (find-component (find-component c (car name) :registered registered) + (cdr name) :registered registered)) + + ;; If the path is a component, return it, disregarding the base. + (defmethod find-component ((base t) (actual component) &key registered) + (declare (ignorable registered)) + actual) + + ;; Resolve dependency NAME in the context of a COMPONENT, with given optional VERSION constraint. + ;; This (private) function is used below by RESOLVE-DEPENDENCY-SPEC and by the :VERSION spec. + (defun resolve-dependency-name (component name &optional version) + (loop + (restart-case + (return + (let ((comp (find-component (component-parent component) name))) + (unless comp + (error 'missing-dependency + :required-by component + :requires name)) + (when version + (unless (version-satisfies comp version) + (error 'missing-dependency-of-version + :required-by component + :version version + :requires name))) + comp)) + (retry () + :report (lambda (s) + (format s (compatfmt "~@") name)) + :test + (lambda (c) + (or (null c) + (and (typep c 'missing-dependency) + (eq (missing-required-by c) component) + (equal (missing-requires c) name)))) + (unless (component-parent component) + (let ((name (coerce-name name))) + (unset-asdf-cache-entry `(find-system ,name)))))))) + + ;; Resolve dependency specification DEP-SPEC in the context of COMPONENT. + ;; This is notably used by MAP-DIRECT-DEPENDENCIES to process the results of COMPONENT-DEPENDS-ON + ;; and by PARSE-DEFSYSTEM to process DEFSYSTEM-DEPENDS-ON. + (defun resolve-dependency-spec (component dep-spec) + (let ((component (find-component () component))) + (if (atom dep-spec) + (resolve-dependency-name component dep-spec) + (resolve-dependency-combination component (car dep-spec) (cdr dep-spec))))) + + ;; Methods for RESOLVE-DEPENDENCY-COMBINATION to parse lists as dependency specifications. + (defmethod resolve-dependency-combination (component combinator arguments) + (parameter-error (compatfmt "~@") + 'resolve-dependency-combination (cons combinator arguments) component)) + + (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments) + (when (featurep (first arguments)) + (resolve-dependency-spec component (second arguments)))) + + (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments) + (resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788 + +;;;; ------------------------------------------------------------------------- +;;;; Forcing + +(uiop/package:define-package :asdf/forcing + (:recycle :asdf/forcing :asdf/plan :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/operation :asdf/system :asdf/system-registry) + (:export + #:forcing #:make-forcing #:forced #:forced-not #:performable-p + #:normalize-forced-systems #:normalize-forced-not-systems + #:action-forced-p #:action-forced-not-p)) +(in-package :asdf/forcing) + +;;;; Forcing +(with-upgradability () + (defclass forcing () + (;; Can plans using this forcing be PERFORMed? A plan that has different force and force-not + ;; settings than the session can only be used for read-only queries that do not cause the + ;; status of any action to be raised. + (performable-p :initform nil :initarg :performable-p :reader performable-p) + ;; Parameters + (parameters :initform nil :initarg :parameters :reader parameters) + ;; Table of systems specified via :force arguments + (forced :initarg :forced :reader forced) + ;; Table of systems specified via :force-not argument (and/or immutable) + (forced-not :initarg :forced-not :reader forced-not))) + + (defgeneric action-forced-p (forcing operation component) + (:documentation "Is this action forced to happen in this plan?")) + (defgeneric action-forced-not-p (forcing operation component) + (:documentation "Is this action forced to not happen in this plan? +Takes precedence over action-forced-p.")) + + (defun normalize-forced-systems (force system) + "Given a SYSTEM on which operate is called and the specified FORCE argument, +extract a hash-set of systems that are forced, or a predicate on system names, +or NIL if none are forced, or :ALL if all are." + (etypecase force + ((or (member nil :all) hash-table function) force) + (cons (list-to-hash-set (mapcar #'coerce-name force))) + ((eql t) (when system (list-to-hash-set (list (coerce-name system))))))) + + (defun normalize-forced-not-systems (force-not system) + "Given a SYSTEM on which operate is called, the specified FORCE-NOT argument, +and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not, +or predicate on system names, or NIL if none are forced, or :ALL if all are." + (let ((requested + (etypecase force-not + ((or (member nil :all) hash-table function) force-not) + (cons (list-to-hash-set (mapcar #'coerce-name force-not))) + ((eql t) (if system (let ((name (coerce-name system))) + #'(lambda (x) (not (equal x name)))) + :all))))) + (if (and *immutable-systems* requested) + #'(lambda (x) (or (call-function requested x) + (call-function *immutable-systems* x))) + (or *immutable-systems* requested)))) + + ;; TODO: shouldn't we be looking up the primary system name, rather than the system name? + (defun action-override-p (forcing operation component override-accessor) + "Given a plan, an action, and a function that given the plan accesses a set of overrides, +i.e. force or force-not, see if the override applies to the current action." + (declare (ignore operation)) + (call-function (funcall override-accessor forcing) + (coerce-name (component-system (find-component () component))))) + + (defmethod action-forced-p (forcing operation component) + (and + ;; Did the user ask us to re-perform the action? + (action-override-p forcing operation component 'forced) + ;; You really can't force a builtin system and :all doesn't apply to it. + (not (builtin-system-p (component-system component))))) + + (defmethod action-forced-not-p (forcing operation component) + ;; Did the user ask us to not re-perform the action? + ;; NB: force-not takes precedence over force, as it should + (action-override-p forcing operation component 'forced-not)) + + ;; Null forcing means no forcing either way + (defmethod action-forced-p ((forcing null) (operation operation) (component component)) + nil) + (defmethod action-forced-not-p ((forcing null) (operation operation) (component component)) + nil) + + (defun or-function (fun1 fun2) + (cond + ((or (null fun2) (eq fun1 :all)) fun1) + ((or (null fun1) (eq fun2 :all)) fun2) + (t #'(lambda (x) (or (call-function fun1 x) (call-function fun2 x)))))) + + (defun make-forcing (&key performable-p system + (force nil force-p) (force-not nil force-not-p) &allow-other-keys) + (let* ((session-forcing (when *asdf-session* (forcing *asdf-session*))) + (system (and system (coerce-name system))) + (forced (normalize-forced-systems force system)) + (forced-not (normalize-forced-not-systems force-not system)) + (parameters `(,@(when force `(:force ,force)) + ,@(when force-not `(:force-not ,force-not)) + ,@(when (or (eq force t) (eq force-not t)) `(:system ,system)) + ,@(when performable-p `(:performable-p t)))) + forcing) + (cond + ((not session-forcing) + (setf forcing (make-instance 'forcing + :performable-p performable-p :parameters parameters + :forced forced :forced-not forced-not)) + (when (and performable-p *asdf-session*) + (setf (forcing *asdf-session*) forcing))) + (performable-p + (when (and (not (equal parameters (parameters session-forcing))) + (or force-p force-not-p)) + (parameter-error "~*~S and ~S arguments not allowed in a nested call to ~3:*~S ~ +unless identically to toplevel" + (find-symbol* :operate :asdf) :force :force-not)) + (setf forcing session-forcing)) + (t + (setf forcing (make-instance 'forcing + ;; Combine force and force-not with values from the toplevel-plan + :parameters `(,@parameters :on-top-of ,(parameters session-forcing)) + :forced (or-function (forced session-forcing) forced) + :forced-not (or-function (forced-not session-forcing) forced-not))))) + forcing)) + + (defmethod print-object ((forcing forcing) stream) + (print-unreadable-object (forcing stream :type t) + (format stream "~{~S~^ ~}" (parameters forcing)))) + + ;; During upgrade, the *asdf-session* may legitimately be NIL, so we must handle that case. + (defmethod forcing ((x null)) + (if-let (session (toplevel-asdf-session)) + (forcing session) + (make-forcing :performable-p t))) + + ;; When performing a plan that is a list of actions, use the toplevel asdf sesssion forcing. + (defmethod forcing ((x cons)) (forcing (toplevel-asdf-session)))) +;;;; ------------------------------------------------------------------------- +;;;; Plan + +(uiop/package:define-package :asdf/plan + ;; asdf/action below is needed for required-components, traverse-action and traverse-sub-actions + ;; that used to live there before 3.2.0. + (:recycle :asdf/plan :asdf/action :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/operation :asdf/action :asdf/lisp-action + :asdf/system :asdf/system-registry :asdf/find-component :asdf/forcing) + (:export + #:plan #:plan-traversal #:sequential-plan #:*plan-class* + #:action-status #:status-stamp #:status-index #:status-done-p #:status-keep-p #:status-need-p + #:action-already-done-p + #:+status-good+ #:+status-todo+ #:+status-void+ + #:system-out-of-date #:action-up-to-date-p + #:circular-dependency #:circular-dependency-actions + #:needed-in-image-p + #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies + #:compute-action-stamp #:traverse-action #:record-dependency + #:make-plan #:plan-actions #:plan-actions-r #:perform-plan #:mark-as-done + #:required-components #:filtered-sequential-plan + #:plan-component-type #:plan-keep-operation #:plan-keep-component)) +(in-package :asdf/plan) + +;;;; Generic plan traversal class +(with-upgradability () + (defclass plan () () + (:documentation "Base class for a plan based on which ASDF can build a system")) + (defclass plan-traversal (plan) + (;; The forcing parameters for this plan. Also indicates whether the plan is performable, + ;; in which case the forcing is the same as for the entire session. + (forcing :initform (forcing (toplevel-asdf-session)) :initarg :forcing :reader forcing)) + (:documentation "Base class for plans that simply traverse dependencies")) + ;; Sequential plans (the default) + (defclass sequential-plan (plan-traversal) + ((actions-r :initform nil :accessor plan-actions-r)) + (:documentation "Simplest, default plan class, accumulating a sequence of actions")) + + (defgeneric plan-actions (plan) + (:documentation "Extract from a plan a list of actions to perform in sequence")) + (defmethod plan-actions ((plan list)) + plan) + (defmethod plan-actions ((plan sequential-plan)) + (reverse (plan-actions-r plan))) + + (defgeneric record-dependency (plan operation component) + (:documentation "Record that, within PLAN, performing OPERATION on COMPONENT depends on all +of the (OPERATION . COMPONENT) actions in the current ASDF session's VISITING-ACTION-LIST. + +You can get a single action which dominates the set of dependencies corresponding to this call with +(first (visiting-action-list *asdf-session*)) +since VISITING-ACTION-LIST is a stack whose top action depends directly on its second action, +and whose second action depends directly on its third action, and so forth.")) + + ;; No need to record a dependency to build a full graph, just accumulate nodes in order. + (defmethod record-dependency ((plan sequential-plan) (o operation) (c component)) + (values))) + +(when-upgrading (:version "3.3.0") + (defmethod initialize-instance :after ((plan plan-traversal) &key &allow-other-keys))) + + +;;;; Planned action status +(with-upgradability () + (defclass action-status () + ((bits + :type fixnum :initarg :bits :reader status-bits + :documentation "bitmap describing the status of the action.") + (stamp + :type (or integer boolean) :initarg :stamp :reader status-stamp + :documentation "STAMP associated with the ACTION if it has been completed already in some +previous session or image, T if it was done and builtin the image, or NIL if it needs to be done.") + (level + :type fixnum :initarg :level :initform 0 :reader status-level + :documentation "the highest (operate-level) at which the action was needed") + (index + :type (or integer null) :initarg :index :initform nil :reader status-index + :documentation "INDEX associated with the ACTION in the current session, +or NIL if no the status is considered outside of a specific plan.")) + (:documentation "Status of an action in a plan")) + + ;; STAMP KEEP-P DONE-P NEED-P symbol bitmap previously currently + ;; not-nil T T T => GOOD 7 up-to-date done (e.g. file previously loaded) + ;; not-nil T T NIL => HERE 6 up-to-date unplanned yet done + ;; not-nil T NIL T => REDO 5 up-to-date planned (e.g. file to load) + ;; not-nil T NIL NIL => SKIP 4 up-to-date unplanned (e.g. file compiled) + ;; not-nil NIL T T => DONE 3 out-of-date done + ;; not-nil NIL T NIL => WHAT 2 out-of-date unplanned yet done(?) + ;; NIL NIL NIL T => TODO 1 out-of-date planned + ;; NIL NIL NIL NIL => VOID 0 out-of-date unplanned + ;; + ;; Note that a VOID status cannot happen as part of a transitive dependency of a wanted node + ;; while traversing a node with TRAVERSE-ACTION; it can only happen while checking whether an + ;; action is up-to-date with ACTION-UP-TO-DATE-P. + ;; + ;; When calling TRAVERSE-ACTION, the +need-bit+ is set, + ;; unless the action is up-to-date and not needed-in-image (HERE, SKIP). + ;; When PERFORMing an action, the +done-bit+ is set. + ;; When the +need-bit+ is set but not the +done-bit+, the level slot indicates which level of + ;; OPERATE it was last marked needed for; if it happens to be needed at a higher-level, then + ;; its urgency (and that of its transitive dependencies) must be escalated so that it will be + ;; done before the end of this level of operate. + ;; + ;; Also, when no ACTION-STATUS is associated to an action yet, NIL serves as a bottom value. + ;; + (defparameter +keep-bit+ 4) + (defparameter +done-bit+ 2) + (defparameter +need-bit+ 1) + (defparameter +good-bits+ 7) + (defparameter +todo-bits+ 1) + (defparameter +void-bits+ 0) + + (defparameter +status-good+ + (make-instance 'action-status :bits +good-bits+ :stamp t)) + (defparameter +status-todo+ + (make-instance 'action-status :bits +todo-bits+ :stamp nil)) + (defparameter +status-void+ + (make-instance 'action-status :bits +void-bits+ :stamp nil))) + +(with-upgradability () + (defun make-action-status (&key bits stamp (level 0) index) + (check-type bits (integer 0 7)) + (check-type stamp (or integer boolean)) + (check-type level (integer 0 #.most-positive-fixnum)) + (check-type index (or integer null)) + (assert (eq (null stamp) (zerop (logand bits #.(logior +keep-bit+ +done-bit+)))) () + "Bad action-status :bits ~S :stamp ~S" bits stamp) + (block nil + (when (and (null index) (zerop level)) + (case bits + (#.+void-bits+ (return +status-void+)) + (#.+todo-bits+ (return +status-todo+)) + (#.+good-bits+ (when (eq stamp t) (return +status-good+))))) + (make-instance 'action-status :bits bits :stamp stamp :level level :index index))) + + (defun status-keep-p (status) + (plusp (logand (status-bits status) #.+keep-bit+))) + (defun status-done-p (status) + (plusp (logand (status-bits status) #.+done-bit+))) + (defun status-need-p (status) + (plusp (logand (status-bits status) #.+need-bit+))) + + (defun merge-action-status (status1 status2) ;; status-and + "Return the earliest status later than both status1 and status2" + (make-action-status + :bits (logand (status-bits status1) (status-bits status2)) + :stamp (latest-timestamp (status-stamp status1) (status-stamp status2)) + :level (min (status-level status1) (status-level status2)) + :index (or (status-index status1) (status-index status2)))) + + (defun mark-status-needed (status &optional (level (operate-level))) ;; limited status-or + "Return the same status but with the need bit set, for the given level" + (if (and (status-need-p status) + (>= (status-level status) level)) + status + (make-action-status + :bits (logior (status-bits status) +need-bit+) + :level (max level (status-level status)) + :stamp (status-stamp status) + :index (status-index status)))) + + (defmethod print-object ((status action-status) stream) + (print-unreadable-object (status stream :type t) + (with-slots (bits stamp level index) status + (format stream "~{~S~^ ~}" `(:bits ,bits :stamp ,stamp :level ,level :index ,index))))) + + (defgeneric action-status (plan operation component) + (:documentation "Returns the ACTION-STATUS associated to the action of OPERATION on COMPONENT +in the PLAN, or NIL if the action wasn't visited yet as part of the PLAN.")) + + (defgeneric (setf action-status) (new-status plan operation component) + (:documentation "Sets the ACTION-STATUS associated to +the action of OPERATION on COMPONENT in the PLAN")) + + (defmethod action-status ((plan null) (o operation) (c component)) + (multiple-value-bind (stamp done-p) (component-operation-time o c) + (if done-p + (make-action-status :bits #.+keep-bit+ :stamp stamp) + +status-void+))) + + (defmethod (setf action-status) (new-status (plan null) (o operation) (c component)) + (let ((times (component-operation-times c))) + (if (status-done-p new-status) + (setf (gethash o times) (status-stamp new-status)) + (remhash o times))) + new-status) + + ;; Handle FORCED-NOT: it makes an action return its current timestamp as status + (defmethod action-status ((p plan) (o operation) (c component)) + ;; TODO: should we instead test something like: + ;; (action-forced-not-p plan operation (primary-system component)) + (or (gethash (make-action o c) (visited-actions *asdf-session*)) + (when (action-forced-not-p (forcing p) o c) + (let ((status (action-status nil o c))) + (setf (gethash (make-action o c) (visited-actions *asdf-session*)) + (make-action-status + :bits +good-bits+ + :stamp (or (and status (status-stamp status)) t) + :index (incf (total-action-count *asdf-session*)))))))) + + (defmethod (setf action-status) (new-status (p plan) (o operation) (c component)) + (setf (gethash (make-action o c) (visited-actions *asdf-session*)) new-status)) + + (defmethod (setf action-status) :after + (new-status (p sequential-plan) (o operation) (c component)) + (unless (status-done-p new-status) + (push (make-action o c) (plan-actions-r p))))) + + +;;;; Is the action needed in this image? +(with-upgradability () + (defgeneric needed-in-image-p (operation component) + (:documentation "Is the action of OPERATION on COMPONENT needed in the current image +to be meaningful, or could it just as well have been done in another Lisp image?")) + + (defmethod needed-in-image-p ((o operation) (c component)) + ;; We presume that actions that modify the filesystem don't need be run + ;; in the current image if they have already been done in another, + ;; and can be run in another process (e.g. a fork), + ;; whereas those that don't are meant to side-effect the current image and can't. + (not (output-files o c)))) + + +;;;; Visiting dependencies of an action and computing action stamps +(with-upgradability () + (defun map-direct-dependencies (operation component fun) + "Call FUN on all the valid dependencies of the given action in the given plan" + (loop :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component) + :for dep-o = (find-operation operation dep-o-spec) + :when dep-o + :do (loop :for dep-c-spec :in dep-c-specs + :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec)) + :when (action-valid-p dep-o dep-c) + :do (funcall fun dep-o dep-c)))) + + (defun reduce-direct-dependencies (operation component combinator seed) + "Reduce the direct dependencies to a value computed by iteratively calling COMBINATOR +for each dependency action on the dependency's operation and component and an accumulator +initialized with SEED." + (map-direct-dependencies + operation component + #'(lambda (dep-o dep-c) (setf seed (funcall combinator dep-o dep-c seed)))) + seed) + + (defun direct-dependencies (operation component) + "Compute a list of the direct dependencies of the action within the plan" + (reverse (reduce-direct-dependencies operation component #'acons nil))) + + ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp + ;; shall also be parametrized by the plan, or by a second model object, + ;; so they need not refer to the state of the filesystem, + ;; and the stamps could be cryptographic checksums rather than timestamps. + ;; Such a change remarkably would only affect COMPUTE-ACTION-STAMP. + (define-condition dependency-not-done (warning) + ((op + :initarg :op) + (component + :initarg :component) + (dep-op + :initarg :dep-op) + (dep-component + :initarg :dep-component) + (plan + :initarg :plan + :initform nil)) + (:report (lambda (condition stream) + (with-slots (op component dep-op dep-component plan) condition + (format stream "Computing just-done stamp ~@[in plan ~S~] for action ~S, but dependency ~S wasn't done yet!" + plan + (action-path (make-action op component)) + (action-path (make-action dep-op dep-component))))))) + + (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) + ;; Given an action, figure out at what time in the past it has been done, + ;; or if it has just been done, return the time that it has. + ;; Returns two values: + ;; 1- the TIMESTAMP of the action if it has already been done and is up to date, + ;; or NIL is either hasn't been done or is out of date. + ;; (An ASDF extension could use a cryptographic digest instead.) + ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done + ;; in the current image, or NIL if it hasn't. + ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but + ;; hasn't been done in the current image yet, then it can have a non-NIL timestamp, + ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded, + ;; i.e. that of the input-files. + ;; If just-done is NIL, these values return are the notional fields of + ;; a KEEP, REDO or TODO status (VOID is possible, but probably an error). + ;; If just-done is T, they are the notional fields of DONE status + ;; (or, if something went wrong, TODO). + (nest + (block ()) + (let* ((dep-status ; collect timestamp from dependencies (or T if forced or out-of-date) + (reduce-direct-dependencies + o c + #'(lambda (do dc status) + ;; out-of-date dependency: don't bother looking further + (let ((action-status (action-status plan do dc))) + (cond + ((and action-status (or (status-keep-p action-status) + (and just-done (status-stamp action-status)))) + (merge-action-status action-status status)) + (just-done + ;; It's OK to lose some ASDF action stamps during self-upgrade + (unless (equal "asdf" (primary-system-name dc)) + (warn 'dependency-not-done + :plan plan + :op o :component c + :dep-op do :dep-component dc)) + status) + (t + (return (values nil nil)))))) + +status-good+)) + (dep-stamp (status-stamp dep-status)))) + (let* (;; collect timestamps from inputs, and exit early if any is missing + (in-files (input-files o c)) + (in-stamps (mapcar #'get-file-stamp in-files)) + (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) + (latest-in (timestamps-latest (cons dep-stamp in-stamps)))) + (when (and missing-in (not just-done)) (return (values nil nil)))) + (let* (;; collect timestamps from outputs, and exit early if any is missing + (out-files (remove-if 'null (output-files o c))) + (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) + (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) + (earliest-out (timestamps-earliest out-stamps))) + (when (and missing-out (not just-done)) (return (values nil nil)))) + (let (;; Time stamps from the files at hand, and whether any is missing + (all-present (not (or missing-in missing-out))) + ;; Has any input changed since we last generated the files? + ;; Note that we use timestamp<= instead of timestamp< to play nice with generated files. + ;; Any race condition is intrinsic to the limited timestamp resolution. + (up-to-date-p (timestamp<= latest-in earliest-out)) + ;; If everything is up to date, the latest of inputs and outputs is our stamp + (done-stamp (timestamps-latest (cons latest-in out-stamps)))) + ;; Warn if some files are missing: + ;; either our model is wrong or some other process is messing with our files. + (when (and just-done (not all-present)) + ;; Shouldn't that be an error instead? + (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ + ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" + (action-description o c) + missing-in (length missing-in) (and missing-in missing-out) + missing-out (length missing-out)))) + (let (;; There are three kinds of actions: + (out-op (and out-files t)) ; those that create files on the filesystem + ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image + ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing + )) + (if (or just-done ;; The done-stamp is valid: if we're just done, or + (and all-present ;; if all filesystem effects are up-to-date + up-to-date-p + (operation-done-p o c) ;; and there's no invalidating reason. + (not (action-forced-p (forcing (or plan *asdf-session*)) o c)))) + (values done-stamp ;; return the hard-earned timestamp + (or just-done + out-op ;; A file-creating op is done when all files are up to date. + ;; An image-effecting operation is done when + (and (status-done-p dep-status) ;; all the dependencies were done, and + (multiple-value-bind (perform-stamp perform-done-p) + (component-operation-time o c) + (and perform-done-p ;; the op was actually run, + (equal perform-stamp done-stamp)))))) ;; with a matching stamp. + ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet + (values nil nil))))) + + +;;;; The four different actual traversals: +;; * TRAVERSE-ACTION o c T: Ensure all dependencies are either up-to-date in-image, or planned +;; * TRAVERSE-ACTION o c NIL: Ensure all dependencies are up-to-date or planned, in-image or not +;; * ACTION-UP-TO-DATE-P: Check whether some (defsystem-depends-on ?) dependencies are up to date +;; * COLLECT-ACTION-DEPENDENCIES: Get the dependencies (filtered), don't change any status +(with-upgradability () + + ;; Compute the action status for a newly visited action. + (defun compute-action-status (plan operation component need-p) + (multiple-value-bind (stamp done-p) + (compute-action-stamp plan operation component) + (assert (or stamp (not done-p))) + (make-action-status + :bits (logior (if stamp #.+keep-bit+ 0) + (if done-p #.+done-bit+ 0) + (if need-p #.+need-bit+ 0)) + :stamp stamp + :level (operate-level) + :index (incf (total-action-count *asdf-session*))))) + + ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data, + ;; visits the action defined by its OPERATION and COMPONENT arguments, + ;; and all its transitive dependencies (unless already visited), + ;; in the context of the action being (or not) NEEDED-IN-IMAGE-P, + ;; i.e. needs to be done in the current image vs merely have been done in a previous image. + ;; + ;; TRAVERSE-ACTION updates the VISITED-ACTIONS entries for the action and for all its + ;; transitive dependencies (that haven't been sufficiently visited so far). + ;; It does not return any usable value. + ;; + ;; Note that for an XCVB-like plan with one-image-per-file-outputting-action, + ;; the below method would be insufficient, since it assumes a single image + ;; to traverse each node at most twice; non-niip actions would be traversed only once, + ;; but niip nodes could be traversed once per image, i.e. once plus once per non-niip action. + + (defun traverse-action (plan operation component needed-in-image-p) + (block nil + (unless (action-valid-p operation component) (return)) + ;; Record the dependency. This hook is needed by POIU, which tracks a full dependency graph, + ;; instead of just a dependency order as in vanilla ASDF. + ;; TODO: It is also needed to detect OPERATE-in-PERFORM. + (record-dependency plan operation component) + (while-visiting-action (operation component) ; maintain context, handle circularity. + ;; needed-in-image distinguishes b/w things that must happen in the + ;; current image and those things that simply need to have been done in a previous one. + (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image + ;; effective niip: meaningful for the action and required by the plan as traversed + (eniip (and aniip needed-in-image-p)) + ;; status: have we traversed that action previously, and if so what was its status? + (status (action-status plan operation component)) + (level (operate-level))) + (when (and status + (or (status-done-p status) ;; all done + (and (status-need-p status) (<= level (status-level status))) ;; already visited + (and (status-keep-p status) (not eniip)))) ;; up-to-date and not eniip + (return)) ; Already visited with sufficient need-in-image level! + (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T + (map-direct-dependencies ; recursively traverse dependencies + operation component #'(lambda (o c) (traverse-action plan o c niip))) + ;; AFTER dependencies have been traversed, compute action stamp + (let* ((status (if status + (mark-status-needed status level) + (compute-action-status plan operation component t))) + (out-of-date-p (not (status-keep-p status))) + (to-perform-p (or out-of-date-p (and niip (not (status-done-p status)))))) + (cond ; it needs be done if it's out of date or needed in image but absent + ((and out-of-date-p (not niip)) ; if we need to do it, + (visit-action t)) ; then we need to do it *in the (current) image*! + (t + (setf (action-status plan operation component) status) + (when (status-done-p status) + (setf (component-operation-time operation component) + (status-stamp status))) + (when to-perform-p ; if it needs to be added to the plan, count it + (incf (planned-action-count *asdf-session*)) + (unless aniip ; if it's output-producing, count it + (incf (planned-output-action-count *asdf-session*))))))))) + (visit-action eniip)))))) ; visit the action + + ;; NB: This is not an error, not a warning, but a normal expected condition, + ;; to be to signaled by FIND-SYSTEM when it detects an out-of-date system, + ;; *before* it tries to replace it with a new definition. + (define-condition system-out-of-date (condition) + ((name :initarg :name :reader component-name)) + (:documentation "condition signaled when a system is detected as being out of date") + (:report (lambda (c s) + (format s "system ~A is out of date" (component-name c))))) + + (defun action-up-to-date-p (plan operation component) + "Check whether an action was up-to-date at the beginning of the session. +Update the VISITED-ACTIONS table with the known status, but don't add anything to the PLAN." + (block nil + (unless (action-valid-p operation component) (return t)) + (while-visiting-action (operation component) ; maintain context, handle circularity. + ;; Do NOT record the dependency: it might be out of date. + (let ((status (or (action-status plan operation component) + (setf (action-status plan operation component) + (let ((dependencies-up-to-date-p + (handler-case + (block nil + (map-direct-dependencies + operation component + #'(lambda (o c) + (unless (action-up-to-date-p plan o c) + (return nil)))) + t) + (system-out-of-date () nil)))) + (if dependencies-up-to-date-p + (compute-action-status plan operation component nil) + +status-void+)))))) + (and (status-keep-p status) (status-stamp status))))))) + + +;;;; Incidental traversals + +;;; Making a FILTERED-SEQUENTIAL-PLAN can be used to, e.g., all of the source +;;; files required by a bundling operation. +(with-upgradability () + (defclass filtered-sequential-plan (sequential-plan) + ((component-type :initform t :initarg :component-type :reader plan-component-type) + (keep-operation :initform t :initarg :keep-operation :reader plan-keep-operation) + (keep-component :initform t :initarg :keep-component :reader plan-keep-component)) + (:documentation "A variant of SEQUENTIAL-PLAN that only records a subset of actions.")) + + (defmethod initialize-instance :after ((plan filtered-sequential-plan) + &key system other-systems) + ;; Ignore force and force-not, rely on other-systems: + ;; force traversal of what we're interested in, i.e. current system or also others; + ;; force-not traversal of what we're not interested in, i.e. other systems unless other-systems. + (setf (slot-value plan 'forcing) + (make-forcing :system system :force :all :force-not (if other-systems nil t)))) + + (defmethod plan-actions ((plan filtered-sequential-plan)) + (with-slots (keep-operation keep-component) plan + (loop :for action :in (call-next-method) + :as o = (action-operation action) + :as c = (action-component action) + :when (and (typep o keep-operation) (typep c keep-component)) + :collect (make-action o c)))) + + (defun collect-action-dependencies (plan operation component) + (when (action-valid-p operation component) + (while-visiting-action (operation component) ; maintain context, handle circularity. + (let ((action (make-action operation component))) + (unless (nth-value 1 (gethash action (visited-actions *asdf-session*))) + (setf (gethash action (visited-actions *asdf-session*)) nil) + (when (and (typep component (plan-component-type plan)) + (not (action-forced-not-p (forcing plan) operation component))) + (map-direct-dependencies operation component + #'(lambda (o c) (collect-action-dependencies plan o c))) + (push action (plan-actions-r plan)))))))) + + (defgeneric collect-dependencies (operation component &key &allow-other-keys) + (:documentation "Given an action, build a plan for all of its dependencies.")) + (define-convenience-action-methods collect-dependencies (operation component &key)) + (defmethod collect-dependencies ((operation operation) (component component) + &rest keys &key &allow-other-keys) + (let ((plan (apply 'make-instance 'filtered-sequential-plan + :system (component-system component) keys))) + (loop :for action :in (direct-dependencies operation component) + :do (collect-action-dependencies plan (action-operation action) (action-component action))) + (plan-actions plan))) + + (defun required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) + "Given a SYSTEM and a GOAL-OPERATION (default LOAD-OP), traverse the dependencies and +return a list of the components involved in building the desired action." + (with-asdf-session (:override t) + (remove-duplicates + (mapcar 'action-component + (apply 'collect-dependencies goal-operation system + (remove-plist-key :goal-operation keys))) + :from-end t)))) + + +;;;; High-level interface: make-plan, perform-plan +(with-upgradability () + (defgeneric make-plan (plan-class operation component &key &allow-other-keys) + (:documentation "Generate and return a plan for performing OPERATION on COMPONENT.")) + (define-convenience-action-methods make-plan (plan-class operation component &key)) + + (defgeneric mark-as-done (plan-class operation component) + (:documentation "Mark an action as done in a plan, after performing it.")) + (define-convenience-action-methods mark-as-done (plan-class operation component)) + + (defgeneric perform-plan (plan &key) + (:documentation "Actually perform a plan and build the requested actions")) + + (defparameter* *plan-class* 'sequential-plan + "The default plan class to use when building with ASDF") + + (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys) + (with-asdf-session () + (let ((plan (apply 'make-instance (or plan-class *plan-class*) keys))) + (traverse-action plan o c t) + plan))) + + (defmethod perform-plan :around ((plan t) &key) + (assert (performable-p (forcing plan)) () "plan not performable") + (let ((*package* *package*) + (*readtable* *readtable*)) + (with-compilation-unit () ;; backward-compatibility. + (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. + + (defun action-already-done-p (plan operation component) + (if-let (status (action-status plan operation component)) + (status-done-p status))) + + (defmethod perform-plan ((plan t) &key) + (loop :for action :in (plan-actions plan) + :as o = (action-operation action) + :as c = (action-component action) :do + (unless (action-already-done-p plan o c) + (perform-with-restarts o c) + (mark-as-done plan o c)))) + + (defmethod mark-as-done ((plan plan) (o operation) (c component)) + (let ((plan-status (action-status plan o c)) + (perform-status (action-status nil o c))) + (assert (and (status-stamp perform-status) (status-keep-p perform-status)) () + "Just performed ~A but failed to mark it done" (action-description o c)) + (setf (action-status plan o c) + (make-action-status + :bits (logior (status-bits plan-status) +done-bit+) + :stamp (status-stamp perform-status) + :level (status-level plan-status) + :index (status-index plan-status)))))) +;;;; ------------------------------------------------------------------------- +;;;; Invoking Operations + +(uiop/package:define-package :asdf/operate + (:recycle :asdf/operate :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/system :asdf/system-registry :asdf/find-component + :asdf/operation :asdf/action :asdf/lisp-action :asdf/forcing :asdf/plan) + (:export + #:operate #:oos #:build-op #:make + #:load-system #:load-systems #:load-systems* + #:compile-system #:test-system #:require-system #:module-provide-asdf + #:component-loaded-p #:already-loaded-systems + #:recursive-operate)) +(in-package :asdf/operate) + +(with-upgradability () + (defgeneric operate (operation component &key) + (:documentation + "Operate does mainly four things for the user: + +1. Resolves the OPERATION designator into an operation object. + OPERATION is typically a symbol denoting an operation class, instantiated with MAKE-OPERATION. +2. Resolves the COMPONENT designator into a component object. + COMPONENT is typically a string or symbol naming a system, loaded from disk using FIND-SYSTEM. +3. It then calls MAKE-PLAN with the operation and system as arguments. +4. Finally calls PERFORM-PLAN on the resulting plan to actually build the system. + +The entire computation is wrapped in WITH-COMPILATION-UNIT and error handling code. +If a VERSION argument is supplied, then operate also ensures that the system found satisfies it +using the VERSION-SATISFIES method. +If a PLAN-CLASS argument is supplied, that class is used for the plan. +If a PLAN-OPTIONS argument is supplied, the options are passed to the plan. + +The :FORCE or :FORCE-NOT argument to OPERATE can be: + T to force the inside of the specified system to be rebuilt (resp. not), + without recursively forcing the other systems we depend on. + :ALL to force all systems including other systems we depend on to be rebuilt (resp. not). + (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list +:FORCE-NOT has precedence over :FORCE; builtin systems cannot be forced. + +For backward compatibility, all keyword arguments are passed to MAKE-OPERATION +when instantiating a new operation, that will in turn be inherited by new operations. +But do NOT depend on it, for this is deprecated behavior.")) + + (define-convenience-action-methods operate (operation component &key) + :if-no-component (error 'missing-component :requires component)) + + ;; This method ensures that an ASDF upgrade is attempted as the very first thing, + ;; with suitable state preservation in case in case it actually happens, + ;; and that a few suitable dynamic bindings are established. + (defmethod operate :around (operation component &rest keys + &key verbose + (on-warnings *compile-file-warnings-behaviour*) + (on-failure *compile-file-failure-behaviour*)) + (nest + (with-asdf-session ()) + (let* ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was) + (etypecase operation + (operation (let ((name (type-of operation))) + #'(lambda () (make-operation name)))) + ((or symbol string) (constantly operation)))) + (component-path (typecase component ;; to remake the component after ASDF upgrade + (component (component-find-path component)) + (t component))) + (system-name (labels ((first-name (x) + (etypecase x + ((or string symbol) x) ; NB: includes the NIL case. + (cons (or (first-name (car x)) (first-name (cdr x))))))) + (coerce-name (first-name component-path))))) + (apply 'make-forcing :performable-p t :system system-name keys) + ;; Before we operate on any system, make sure ASDF is up-to-date, + ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble. + (unless (asdf-upgraded-p (toplevel-asdf-session)) + (setf (asdf-upgraded-p (toplevel-asdf-session)) t) + (when (upgrade-asdf) + ;; If we were upgraded, restart OPERATE the hardest of ways, for + ;; its function may have been redefined. + (return-from operate + (with-asdf-session (:override t :override-cache t) + (apply 'operate (funcall operation-remaker) component-path keys)))))) + ;; Setup proper bindings around any operate call. + (let* ((*verbose-out* (and verbose *standard-output*)) + (*compile-file-warnings-behaviour* on-warnings) + (*compile-file-failure-behaviour* on-failure))) + (unwind-protect + (progn + (incf (operate-level)) + (call-next-method)) + (decf (operate-level))))) + + (defmethod operate :before ((operation operation) (component component) + &key version) + (unless (version-satisfies component version) + (error 'missing-component-of-version :requires component :version version)) + (record-dependency nil operation component)) + + (defmethod operate ((operation operation) (component component) + &key plan-class plan-options) + (let ((plan (apply 'make-plan plan-class operation component + :forcing (forcing *asdf-session*) plan-options))) + (perform-plan plan) + (values operation plan))) + + (defun oos (operation component &rest args &key &allow-other-keys) + (apply 'operate operation component args)) + + (setf (documentation 'oos 'function) + (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" + (documentation 'operate 'function))) + + (define-condition recursive-operate (warning) + ((operation :initarg :operation :reader condition-operation) + (component :initarg :component :reader condition-component) + (action :initarg :action :reader condition-action)) + (:report (lambda (c s) + (format s (compatfmt "~@") + 'operate + (type-of (condition-operation c)) + (component-find-path (condition-component c)) + (action-path (condition-action c))))))) + +;;;; Common operations +(when-upgrading () + (defmethod component-depends-on ((o prepare-op) (s system)) + (call-next-method))) +(with-upgradability () + (defclass build-op (non-propagating-operation) () + (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation, +to operate by default on a system or component, via the function BUILD. +Its meaning is configurable via the :BUILD-OPERATION option of a component. +which typically specifies the name of a specific operation to which to delegate the build, +as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on); +if NIL is specified (the default), BUILD-OP falls back to LOAD-OP, +that will load the system in the current image.")) + (defmethod component-depends-on ((o build-op) (c component)) + `((,(or (component-build-operation c) 'load-op) ,c) + ,@(call-next-method))) + + (defun make (system &rest keys) + "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO). +It will build system FOO using the operation BUILD-OP, +the meaning of which is configurable by the system, and +defaults to LOAD-OP, to load it in current image." + (apply 'operate 'build-op system keys) + t) + + (defun load-system (system &rest keys &key force force-not verbose version &allow-other-keys) + "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details." + (declare (ignore force force-not verbose version)) + (apply 'operate 'load-op system keys) + t) + + (defun load-systems* (systems &rest keys) + "Loading multiple systems at once." + (dolist (s systems) (apply 'load-system s keys))) + + (defun load-systems (&rest systems) + "Loading multiple systems at once." + (load-systems* systems)) + + (defun compile-system (system &rest args &key force force-not verbose version &allow-other-keys) + "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details." + (declare (ignore force force-not verbose version)) + (apply 'operate 'compile-op system args) + t) + + (defun test-system (system &rest args &key force force-not verbose version &allow-other-keys) + "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details." + (declare (ignore force force-not verbose version)) + (apply 'operate 'test-op system args) + t)) + +;;;;; Define the function REQUIRE-SYSTEM, that, similarly to REQUIRE, +;; only tries to load its specified target if it's not loaded yet. +(with-upgradability () + (defun component-loaded-p (component) + "Has the given COMPONENT been successfully loaded in the current image (yet)? +Note that this returns true even if the component is not up to date." + (if-let ((component (find-component component () :registered t))) + (nth-value 1 (component-operation-time (make-operation 'load-op) component)))) + + (defun already-loaded-systems () + "return a list of the names of the systems that have been successfully loaded so far" + (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*))))) + + +;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible, +;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL +;; Note that despite the two being homonyms, the _function_ require-system +;; and the _class_ require-system are quite distinct entities, fulfilling independent purposes. +(with-upgradability () + (defvar *modules-being-required* nil) + + (defclass require-system (system) + ((module :initarg :module :initform nil :accessor required-module)) + (:documentation "A SYSTEM subclass whose processing is handled by +the implementation's REQUIRE rather than by internal ASDF mechanisms.")) + + (defmethod perform ((o compile-op) (c require-system)) + nil) + + (defmethod perform ((o load-op) (s require-system)) + (let* ((module (or (required-module s) (coerce-name s))) + (*modules-being-required* (cons module *modules-being-required*))) + (assert (null (component-children s))) + (require module))) + + (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments) + (unless (and (length=n-p arguments 1) + (typep (car arguments) '(or string (and symbol (not null))))) + (parameter-error (compatfmt "~@") + 'resolve-dependency-combination + (cons combinator arguments) component combinator)) + ;; :require must be prepared for some implementations providing modules using ASDF, + ;; as SBCL used to do, and others may might do. Thus, the system provided in the end + ;; would be a downcased name as per module-provide-asdf above. For the same reason, + ;; we cannot assume that the system in the end will be of type require-system, + ;; but must check whether we can use find-system and short-circuit cl:require. + ;; Otherwise, calling cl:require could result in nasty reentrant calls between + ;; cl:require and asdf:operate that could potentially blow up the stack, + ;; all the while defeating the consistency of the dependency graph. + (let* ((module (car arguments)) ;; NB: we already checked that it was not null + ;; CMUCL, MKCL, SBCL like their module names to be all upcase. + (module-name (string module)) + (system-name (string-downcase module)) + (system (find-system system-name nil))) + (or system (let ((system (make-instance 'require-system :name system-name :module module-name))) + (register-system system) + system)))) + + (defun module-provide-asdf (name) + ;; We must use string-downcase, because modules are traditionally specified as symbols, + ;; that implementations traditionally normalize as uppercase, for which we seek a system + ;; with a name that is traditionally in lowercase. Case is lost along the way. That's fine. + ;; We could make complex, non-portable rules to try to preserve case, and just documenting + ;; them would be a hell that it would be a disservice to inflict on users. + (let ((module-name (string name)) + (system-name (string-downcase name))) + (unless (member module-name *modules-being-required* :test 'equal) + (let ((*modules-being-required* (cons module-name *modules-being-required*)) + #+sbcl (sb-impl::*requiring* (remove module-name sb-impl::*requiring* :test 'equal))) + (handler-bind + (((or style-warning recursive-operate) #'muffle-warning) + (missing-component (constantly nil)) + (fatal-condition + #'(lambda (e) + (format *error-output* (compatfmt "~@~%") + name e)))) + (let ((*verbose-out* (make-broadcast-stream))) + (let ((system (find-system system-name nil))) + (when system + ;; Do not use require-system after all, use load-system: + ;; on the one hand, REQUIRE already uses *MODULES* not to load something twice, + ;; on the other hand, REQUIRE-SYSTEM uses FORCE-NOT which may conflict with + ;; the toplevel session forcing settings. + (load-system system :verbose nil) + t))))))))) + + +;;;; Some upgrade magic +(with-upgradability () + (defun restart-upgraded-asdf () + ;; If we're in the middle of something, restart it. + (let ((systems-being-defined + (when *asdf-session* + (prog1 + (loop :for k :being :the hash-keys :of (asdf-cache) + :when (eq (first k) 'find-system) :collect (second k)) + (clrhash (asdf-cache)))))) + ;; Regardless, clear defined systems, since they might be invalid + ;; after an incompatible ASDF upgrade. + (clear-registered-systems) + ;; The configuration also may have to be upgraded. + (upgrade-configuration) + ;; If we were in the middle of an operation, be sure to restore the system being defined. + (dolist (s systems-being-defined) (find-system s nil)))) + (register-hook-function '*post-upgrade-cleanup-hook* 'restart-upgraded-asdf)) +;;;; ------------------------------------------------------------------------- +;;;; Finding systems + +(uiop/package:define-package :asdf/find-system + (:recycle :asdf/find-system :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade + :asdf/session :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/lisp-action + :asdf/find-component :asdf/system-registry :asdf/plan :asdf/operate) + (:import-from #:asdf/component #:%additional-input-files) + (:export + #:find-system #:locate-system #:load-asd #:define-op + #:load-system-definition-error #:error-name #:error-pathname #:error-condition)) +(in-package :asdf/find-system) + +(with-upgradability () + (define-condition load-system-definition-error (system-definition-error) + ((name :initarg :name :reader error-name) + (pathname :initarg :pathname :reader error-pathname) + (condition :initarg :condition :reader error-condition)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (error-name c) (error-pathname c) (error-condition c))))) + + + ;;; Methods for find-system + + ;; Reject NIL as a system designator. + (defmethod find-system ((name null) &optional (error-p t)) + (when error-p + (sysdef-error (compatfmt "~@")))) + + ;; Default method for find-system: resolve the argument using COERCE-NAME. + (defmethod find-system (name &optional (error-p t)) + (find-system (coerce-name name) error-p)) + + (defun find-system-if-being-defined (name) + ;; This function finds systems being defined *in the current ASDF session*, as embodied by + ;; its session cache, even before they are fully defined and registered in *registered-systems*. + ;; The purpose of this function is to prevent races between two files that might otherwise + ;; try overwrite each other's system objects, resulting in infinite loops and stack overflow. + ;; This function explicitly MUST NOT find definitions merely registered in previous sessions. + ;; NB: this function depends on a corresponding side-effect in parse-defsystem; + ;; the precise protocol between the two functions may change in the future (or not). + (first (gethash `(find-system ,(coerce-name name)) (asdf-cache)))) + + (defclass define-op (non-propagating-operation) () + (:documentation "An operation to record dependencies on loading a .asd file.")) + + (defmethod record-dependency ((plan null) (operation t) (component t)) + (unless (or (typep operation 'define-op) + (and (typep operation 'load-op) + (typep component 'system) + (equal "asdf" (coerce-name component)))) + (if-let ((action (first (visiting-action-list *asdf-session*)))) + (let ((parent-operation (action-operation action)) + (parent-component (action-component action))) + (cond + ((and (typep parent-operation 'define-op) + (typep parent-component 'system)) + (let ((action (cons operation component))) + (unless (gethash action (definition-dependency-set parent-component)) + (push (cons operation component) (definition-dependency-list parent-component)) + (setf (gethash action (definition-dependency-set parent-component)) t)))) + (t + (warn 'recursive-operate + :operation operation :component component :action action))))))) + + (defmethod component-depends-on ((o define-op) (s system)) + `(;;NB: 1- ,@(system-defsystem-depends-on s)) ; Should be already included in the below. + ;; 2- We don't call-next-method to avoid other methods + ,@(loop :for (o . c) :in (definition-dependency-list s) :collect (list o c)))) + + (defmethod component-depends-on ((o operation) (s system)) + `(,@(when (and (not (typep o 'define-op)) + (or (system-source-file s) (definition-dependency-list s))) + `((define-op ,(primary-system-name s)))) + ,@(call-next-method))) + + (defmethod perform ((o operation) (c undefined-system)) + (sysdef-error "Trying to use undefined or incompletely defined system ~A" (coerce-name c))) + + ;; TODO: could this file be refactored so that locate-system is merely + ;; the cache-priming call to input-files here? + (defmethod input-files ((o define-op) (s system)) + (if-let ((asd (system-source-file s))) (list asd))) + + (defmethod perform ((o define-op) (s system)) + (nest + (if-let ((pathname (first (input-files o s))))) + (let ((readtable *readtable*) ;; save outer syntax tables. TODO: proper syntax-control + (print-pprint-dispatch *print-pprint-dispatch*))) + (with-standard-io-syntax) + (let ((*print-readably* nil) + ;; Note that our backward-compatible *readtable* is + ;; a global readtable that gets globally side-effected. Ouch. + ;; Same for the *print-pprint-dispatch* table. + ;; We should do something about that for ASDF3 if possible, or else ASDF4. + (*readtable* readtable) ;; restore inside syntax table + (*print-pprint-dispatch* print-pprint-dispatch) + (*package* (find-package :asdf-user)) + (*default-pathname-defaults* + ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. + (pathname-directory-pathname (physicalize-pathname pathname))))) + (handler-bind + (((and error (not missing-component)) + #'(lambda (condition) + (error 'load-system-definition-error + :name (coerce-name s) :pathname pathname :condition condition)))) + (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") + (coerce-name s) pathname) + ;; dependencies will depend on what's loaded via definition-dependency-list + (unset-asdf-cache-entry `(component-depends-on ,o ,s)) + (unset-asdf-cache-entry `(input-files ,o ,s))) + (load* pathname :external-format (encoding-external-format (detect-encoding pathname))))) + + (defun load-asd (pathname &key name) + "Load system definitions from PATHNAME. +NAME if supplied is the name of a system expected to be defined in that file. + +Do NOT try to load a .asd file directly with CL:LOAD. Always use ASDF:LOAD-ASD." + (with-asdf-session () + ;; TODO: use OPERATE, so we consult the cache and only load once per session. + (flet ((do-it (o c) (operate o c))) + (let ((primary-name (primary-system-name (or name (pathname-name pathname)))) + (operation (make-operation 'define-op))) + (if-let (system (registered-system primary-name)) + (progn + ;; We already determine this to be obsolete --- + ;; or should we move some tests from find-system to check for up-to-date-ness here? + (setf (component-operation-time operation system) t + (definition-dependency-list system) nil + (definition-dependency-set system) (list-to-hash-set nil)) + (do-it operation system)) + (let ((system (make-instance 'undefined-system + :name primary-name :source-file pathname))) + (register-system system) + (unwind-protect (do-it operation system) + (when (typep system 'undefined-system) + (clear-system system))))))))) + + (defvar *old-asdf-systems* (make-hash-table :test 'equal)) + + ;; (Private) function to check that a system that was found isn't an asdf downgrade. + ;; Returns T if everything went right, NIL if the system was an ASDF at an older version, + ;; or UIOP of the same or older version, that shall not be loaded. + ;; Also issue a warning if it was a strictly older version of ASDF. + (defun check-not-old-asdf-system (name pathname) + (or (not (member name '("asdf" "uiop") :test 'equal)) + (null pathname) + (let* ((asdfp (equal name "asdf")) ;; otherwise, it's uiop + (version-pathname + (subpathname pathname "version" :type (if asdfp "lisp-expr" "lisp"))) + (version (and (probe-file* version-pathname :truename nil) + (read-file-form version-pathname :at (if asdfp '(0) '(2 2 2))))) + (old-version (asdf-version))) + (cond + ;; Same version is OK for ASDF, to allow loading from modified source. + ;; However, do *not* load UIOP of the exact same version: + ;; it was already loaded it as part of ASDF and would only be double-loading. + ;; Be quiet about it, though, since it's a normal situation. + ((equal old-version version) asdfp) + ((version< old-version version) t) ;; newer version: Good! + (t ;; old version: bad + (ensure-gethash + (list (namestring pathname) version) *old-asdf-systems* + #'(lambda () + (let ((old-pathname (system-source-file (registered-system "asdf")))) + (if asdfp + (warn "~@<~ + You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~ + or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~ + ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~ + Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~ + and having an old version registered is a configuration error. ~ + ASDF will ignore this configured system rather than downgrade itself. ~ + In the future, you may want to either: ~ + (a) upgrade this configured ASDF to a newer version, ~ + (b) install a newer ASDF and register it in front of the former in your configuration, or ~ + (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~ + Note that the older ASDF might be registered implicitly through configuration inherited ~ + from your system installation, in which case you might have to specify ~ + :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~ + or other source-registry configuration file, environment variable or lisp parameter. ~ + Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~ + that you might want to upgrade (if a recent enough version is available) ~ + or else remove altogether (since most implementations ship with a recent asdf); ~ + if you lack the system administration rights to upgrade or remove this package, ~ + then you might indeed want to either install and register a more recent version, ~ + or use :ignore-inherited-configuration to avoid registering the old one. ~ + Please consult ASDF documentation and/or experts.~@:>~%" + old-version old-pathname version pathname) + ;; NB: for UIOP, don't warn, just ignore. + (warn "ASDF ~A (from ~A), UIOP ~A (from ~A)" + old-version old-pathname version pathname) + )))) + nil))))) ;; only issue the warning the first time, but always return nil + + (defun locate-system (name) + "Given a system NAME designator, try to locate where to load the system from. +Returns six values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME PREVIOUS-PRIMARY +FOUNDP is true when a system was found, +either a new unregistered one or a previously registered one. +FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed. +PATHNAME when not null is a path from which to load the system, +either associated with FOUND-SYSTEM, or with the PREVIOUS system. +PREVIOUS when not null is a previously loaded SYSTEM object of same name. +PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. +PREVIOUS-PRIMARY when not null is the primary system for the PREVIOUS system." + (with-asdf-session () ;; NB: We don't cache the results. We once used to, but it wasn't useful, + ;; and keeping a negative cache was a bug (see lp#1335323), which required + ;; explicit invalidation in clear-system and find-system (when unsucccessful). + (let* ((name (coerce-name name)) + (previous (registered-system name)) ; load from disk if absent or newer on disk + (previous-primary-name (and previous (primary-system-name previous))) + (previous-primary-system (and previous-primary-name + (registered-system previous-primary-name))) + (previous-time (and previous-primary-system + (component-operation-time 'define-op previous-primary-system))) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (ensure-pathname + (or (and (typep found '(or pathname string)) (pathname found)) + (system-source-file found-system) + (system-source-file previous)) + :want-absolute t :resolve-symlinks *resolve-symlinks*)) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (unless (check-not-old-asdf-system name pathname) + (check-type previous system) ;; asdf is preloaded, so there should be a previous one. + (setf found-system nil pathname nil)) + (values foundp found-system pathname previous previous-time previous-primary-system)))) + + ;; TODO: make a prepare-define-op node for this + ;; so we can properly cache the answer rather than recompute it. + (defun definition-dependencies-up-to-date-p (system) + (check-type system system) + (or (not (primary-system-p system)) + (handler-case + (loop :with plan = (make-instance *plan-class*) + :for action :in (definition-dependency-list system) + :always (action-up-to-date-p + plan (action-operation action) (action-component action)) + :finally + (let ((o (make-operation 'define-op))) + (multiple-value-bind (stamp done-p) + (compute-action-stamp plan o system) + (return (and (timestamp<= stamp (component-operation-time o system)) + done-p))))) + (system-out-of-date () nil)))) + + ;; Main method for find-system: first, make sure the computation is memoized in a session cache. + ;; Unless the system is immutable, use locate-system to find the primary system; + ;; reconcile the finding (if any) with any previous definition (in a previous session, + ;; preloaded, with a previous configuration, or before filesystem changes), and + ;; load a found .asd if appropriate. Finally, update registration table and return results. + (defmethod find-system ((name string) &optional (error-p t)) + (nest + (with-asdf-session (:key `(find-system ,name))) + (let ((name-primary-p (primary-system-p name))) + (unless name-primary-p (find-system (primary-system-name name) nil))) + (or (and *immutable-systems* (gethash name *immutable-systems*) (registered-system name))) + (multiple-value-bind (foundp found-system pathname previous previous-time previous-primary) + (locate-system name) + (assert (eq foundp (and (or found-system pathname previous) t)))) + (let ((previous-pathname (system-source-file previous)) + (system (or previous found-system))) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and system pathname) + (setf (system-source-file system) pathname)) + (if-let ((stamp (get-file-stamp pathname))) + (let ((up-to-date-p + (and previous previous-primary + (or (pathname-equal pathname previous-pathname) + (and pathname previous-pathname + (pathname-equal + (physicalize-pathname pathname) + (physicalize-pathname previous-pathname)))) + (timestamp<= stamp previous-time) + ;; Check that all previous definition-dependencies are up-to-date, + ;; traversing them without triggering the adding of nodes to the plan. + ;; TODO: actually have a prepare-define-op, extract its timestamp, + ;; and check that it is less than the stamp of the previous define-op ? + (definition-dependencies-up-to-date-p previous-primary)))) + (unless up-to-date-p + (restart-case + (signal 'system-out-of-date :name name) + (continue () :report "continue")) + (load-asd pathname :name name))))) + ;; Try again after having loaded from disk if needed + (or (registered-system name) + (when error-p (error 'missing-component :requires name))))) + + ;; Resolved forward reference for asdf/system-registry. + (defun mark-component-preloaded (component) + "Mark a component as preloaded." + (let ((component (find-component component nil :registered t))) + ;; Recurse to children, so asdf/plan will hopefully be happy. + (map () 'mark-component-preloaded (component-children component)) + ;; Mark the timestamps of the common lisp-action operations as 0. + (let ((cot (component-operation-times component))) + (dolist (o `(,@(when (primary-system-p component) '(define-op)) + prepare-op compile-op load-op)) + (setf (gethash (make-operation o) cot) 0)))))) +;;;; ------------------------------------------------------------------------- +;;;; Defsystem + +(uiop/package:define-package :asdf/parse-defsystem + (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf) + (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares + (:use :uiop/common-lisp :asdf/driver :asdf/upgrade + :asdf/session :asdf/component :asdf/system :asdf/system-registry + :asdf/find-component :asdf/action :asdf/lisp-action :asdf/operate) + (:import-from :asdf/system #:depends-on #:weakly-depends-on) + ;; these needed for record-additional-system-input-file + (:import-from :asdf/operation #:make-operation) + (:import-from :asdf/component #:%additional-input-files) + (:import-from :asdf/find-system #:define-op) + (:export + #:defsystem #:register-system-definition + #:*default-component-class* + #:determine-system-directory #:parse-component-form + #:non-toplevel-system #:non-system-system #:bad-system-name + #:*known-systems-with-bad-secondary-system-names* + #:known-system-with-bad-secondary-system-names-p + #:sysdef-error-component #:check-component-input + #:explain + ;; for extending the component types + #:compute-component-children + #:class-for-type)) +(in-package :asdf/parse-defsystem) + +;;; Pathname +(with-upgradability () + (defun determine-system-directory (pathname) + ;; The defsystem macro calls this function to determine the pathname of a system as follows: + ;; 1. If the pathname argument is an pathname object (NOT a namestring), + ;; that is already an absolute pathname, return it. + ;; 2. Otherwise, the directory containing the LOAD-PATHNAME + ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and + ;; if it is indeed available and an absolute pathname, then + ;; the PATHNAME argument is normalized to a relative pathname + ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T) + ;; and merged into that DIRECTORY as per SUBPATHNAME. + ;; Note: avoid *COMPILE-FILE-PATHNAME* because the .asd is loaded as source, + ;; but may be from within the EVAL-WHEN of a file compilation. + ;; If no absolute pathname was found, we return NIL. + (check-type pathname (or null string pathname)) + (pathname-directory-pathname + (resolve-symlinks* + (ensure-absolute-pathname + (parse-unix-namestring pathname :type :directory) + #'(lambda () (ensure-absolute-pathname + (load-pathname) 'get-pathname-defaults nil)) + nil))))) + + +(when-upgrading (:version "3.3.4.17") + ;; This turned into a generic function in 3.3.4.17 + (fmakunbound 'class-for-type)) + +;;; Component class +(with-upgradability () + ;; What :file gets interpreted as, unless overridden by a :default-component-class + (defvar *default-component-class* 'cl-source-file) + + (defgeneric class-for-type (parent type-designator) + (:documentation + "Return a CLASS object to be used to instantiate components specified by TYPE-DESIGNATOR in the context of PARENT.")) + + (defmethod class-for-type ((parent null) type) + "If the PARENT is NIL, then TYPE must designate a subclass of SYSTEM." + (or (coerce-class type :package :asdf/interface :super 'system :error nil) + (sysdef-error "don't recognize component type ~S in the context of no parent" type))) + + (defmethod class-for-type ((parent parent-component) type) + (or (coerce-class type :package :asdf/interface :super 'component :error nil) + (and (eq type :file) + (coerce-class + (or (loop :for p = parent :then (component-parent p) :while p + :thereis (module-default-component-class p)) + *default-component-class*) + :package :asdf/interface :super 'component :error nil)) + (sysdef-error "don't recognize component type ~S" type)))) + + +;;; Check inputs +(with-upgradability () + (define-condition non-system-system (system-definition-error) + ((name :initarg :name :reader non-system-system-name) + (class-name :initarg :class-name :reader non-system-system-class-name)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (non-system-system-name c) (non-system-system-class-name c) 'system)))) + + (define-condition non-toplevel-system (system-definition-error) + ((parent :initarg :parent :reader non-toplevel-system-parent) + (name :initarg :name :reader non-toplevel-system-name)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (non-toplevel-system-parent c) (non-toplevel-system-name c))))) + + (define-condition bad-system-name (warning) + ((name :initarg :name :reader component-name) + (source-file :initarg :source-file :reader system-source-file)) + (:report (lambda (c s) + (let* ((file (system-source-file c)) + (name (component-name c)) + (asd (pathname-name file))) + (format s (compatfmt "~@") + file name asd (strcat asd "/") (strcat asd "/test")))))) + + (defun sysdef-error-component (msg type name value) + (sysdef-error (strcat msg (compatfmt "~&~@")) + type name value)) + + (defun check-component-input (type name weakly-depends-on + depends-on components) + "A partial test of the values of a component." + (unless (listp depends-on) + (sysdef-error-component ":depends-on must be a list." + type name depends-on)) + (unless (listp weakly-depends-on) + (sysdef-error-component ":weakly-depends-on must be a list." + type name weakly-depends-on)) + (unless (listp components) + (sysdef-error-component ":components must be NIL or a list of components." + type name components))) + + + (defun record-additional-system-input-file (pathname component parent) + (let* ((record-on (if parent + (loop :with retval + :for par = parent :then (component-parent par) + :while par + :do (setf retval par) + :finally (return retval)) + component)) + (comp (if (typep record-on 'component) + record-on + ;; at this point there will be no parent for RECORD-ON + (find-component record-on nil))) + (op (make-operation 'define-op)) + (cell (or (assoc op (%additional-input-files comp)) + (let ((new-cell (list op))) + (push new-cell (%additional-input-files comp)) + new-cell)))) + (pushnew pathname (cdr cell) :test 'pathname-equal) + (values))) + + ;; Given a form used as :version specification, in the context of a system definition + ;; in a file at PATHNAME, for given COMPONENT with given PARENT, normalize the form + ;; to an acceptable ASDF-format version. + (fmakunbound 'normalize-version) ;; signature changed between 2.27 and 2.31 + (defun normalize-version (form &key pathname component parent) + (labels ((invalid (&optional (continuation "using NIL instead")) + (warn (compatfmt "~@") + form component parent pathname continuation)) + (invalid-parse (control &rest args) + (unless (if-let (target (find-component parent component)) (builtin-system-p target)) + (apply 'warn control args) + (invalid)))) + (if-let (v (typecase form + ((or string null) form) + (real + (invalid "Substituting a string") + (format nil "~D" form)) ;; 1.0 becomes "1.0" + (cons + (case (first form) + ((:read-file-form) + (destructuring-bind (subpath &key (at 0)) (rest form) + (let ((path (subpathname pathname subpath))) + (record-additional-system-input-file path component parent) + (safe-read-file-form path + :at at :package :asdf-user)))) + ((:read-file-line) + (destructuring-bind (subpath &key (at 0)) (rest form) + (let ((path (subpathname pathname subpath))) + (record-additional-system-input-file path component parent) + (safe-read-file-line (subpathname pathname subpath) + :at at)))) + (otherwise + (invalid)))) + (t + (invalid)))) + (if-let (pv (parse-version v #'invalid-parse)) + (unparse-version pv) + (invalid)))))) + + +;;; "inline methods" +(with-upgradability () + (defparameter* +asdf-methods+ + '(perform-with-restarts perform explain output-files operation-done-p)) + + (defun %remove-component-inline-methods (component) + (dolist (name +asdf-methods+) + (map () + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf + ;; But this is hardly performance-critical + #'(lambda (m) + (remove-method (symbol-function name) m)) + (component-inline-methods component))) + (component-inline-methods component) nil) + + (defparameter *standard-method-combination-qualifiers* + '(:around :before :after)) + +;;; Find inline method definitions of the form +;;; +;;; :perform (test-op :before (operation component) ...) +;;; +;;; in REST (which is the plist of all DEFSYSTEM initargs) and define the specified methods. + (defun %define-component-inline-methods (ret rest) + ;; find key-value pairs that look like inline method definitions in REST. For each identified + ;; definition, parse it and, if it is well-formed, define the method. + (loop :for (key value) :on rest :by #'cddr + :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=)) + :when name :do + ;; parse VALUE as an inline method definition of the form + ;; + ;; (OPERATION-NAME [QUALIFIER] (OPERATION-PARAMETER COMPONENT-PARAMETER) &rest BODY) + (destructuring-bind (operation-name &rest rest) value + (let ((qualifiers '())) + ;; ensure that OPERATION-NAME is a symbol. + (unless (and (symbolp operation-name) (not (null operation-name))) + (sysdef-error "Ill-formed inline method: ~S. The first element is not a symbol ~ + designating an operation but ~S." + value operation-name)) + ;; ensure that REST starts with either a cons (potential lambda list, further checked + ;; below) or a qualifier accepted by the standard method combination. Everything else + ;; is ill-formed. In case of a valid qualifier, pop it from REST so REST now definitely + ;; has to start with the lambda list. + (cond + ((consp (car rest))) + ((not (member (car rest) + *standard-method-combination-qualifiers*)) + (sysdef-error "Ill-formed inline method: ~S. Only a single of the standard ~ + qualifiers ~{~S~^ ~} is allowed, not ~S." + value *standard-method-combination-qualifiers* (car rest))) + (t + (setf qualifiers (list (pop rest))))) + ;; REST must start with a two-element lambda list. + (unless (and (listp (car rest)) + (length=n-p (car rest) 2) + (null (cddar rest))) + (sysdef-error "Ill-formed inline method: ~S. The operation name ~S is not followed by ~ + a lambda-list of the form (OPERATION COMPONENT) and a method body." + value operation-name)) + ;; define the method. + (destructuring-bind ((o c) &rest body) rest + (pushnew + (eval `(defmethod ,name ,@qualifiers ((,o ,operation-name) (,c (eql ,ret))) ,@body)) + (component-inline-methods ret))))))) + + (defun %refresh-component-inline-methods (component rest) + ;; clear methods, then add the new ones + (%remove-component-inline-methods component) + (%define-component-inline-methods component rest))) + + +;;; Main parsing function +(with-upgradability () + (defun parse-dependency-def (dd) + (if (listp dd) + (case (first dd) + (:feature + (unless (= (length dd) 3) + (sysdef-error "Ill-formed feature dependency: ~s" dd)) + (let ((embedded (parse-dependency-def (third dd)))) + `(:feature ,(second dd) ,embedded))) + (feature + (sysdef-error "`feature' has been removed from the dependency spec language of ASDF. Use :feature instead in ~s." dd)) + (:require + (unless (= (length dd) 2) + (sysdef-error "Ill-formed require dependency: ~s" dd)) + dd) + (:version + (unless (= (length dd) 3) + (sysdef-error "Ill-formed version dependency: ~s" dd)) + `(:version ,(coerce-name (second dd)) ,(third dd))) + (otherwise (sysdef-error "Ill-formed dependency: ~s" dd))) + (coerce-name dd))) + + (defun parse-dependency-defs (dd-list) + "Parse the dependency defs in DD-LIST into canonical form by translating all +system names contained using COERCE-NAME. Return the result." + (mapcar 'parse-dependency-def dd-list)) + + (defgeneric compute-component-children (component components serial-p) + (:documentation + "Return a list of children for COMPONENT. + +COMPONENTS is a list of the explicitly defined children descriptions. + +SERIAL-P is non-NIL if each child in COMPONENTS should depend on the previous +children.")) + + (defun stable-union (s1 s2 &key (test #'eql) (key 'identity)) + (append s1 + (remove-if #'(lambda (e2) (member (funcall key e2) (funcall key s1) :test test)) s2))) + + (defun parse-component-form (parent options &key previous-serial-components) + (destructuring-bind + (type name &rest rest &key + (builtin-system-p () bspp) + ;; the following list of keywords is reproduced below in the + ;; remove-plist-keys form. important to keep them in sync + components pathname perform explain output-files operation-done-p + weakly-depends-on depends-on serial + do-first if-component-dep-fails version + ;; list ends + &allow-other-keys) options + (declare (ignore perform explain output-files operation-done-p builtin-system-p)) + (check-component-input type name weakly-depends-on depends-on components) + (when (and parent + (find-component parent name) + (not ;; ignore the same object when rereading the defsystem + (typep (find-component parent name) + (class-for-type parent type)))) + (error 'duplicate-names :name name)) + (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3")) + (let* ((name (coerce-name name)) + (args `(:name ,name + :pathname ,pathname + ,@(when parent `(:parent ,parent)) + ,@(remove-plist-keys + '(:components :pathname :if-component-dep-fails :version + :perform :explain :output-files :operation-done-p + :weakly-depends-on :depends-on :serial) + rest))) + (component (find-component parent name)) + (class (class-for-type parent type))) + (when (and parent (subtypep class 'system)) + (error 'non-toplevel-system :parent parent :name name)) + (if component ; preserve identity + (apply 'reinitialize-instance component args) + (setf component (apply 'make-instance class args))) + (component-pathname component) ; eagerly compute the absolute pathname + (when (typep component 'system) + ;; cache information for introspection + (setf (slot-value component 'depends-on) + (parse-dependency-defs depends-on) + (slot-value component 'weakly-depends-on) + ;; these must be a list of systems, cannot be features or versioned systems + (mapcar 'coerce-name weakly-depends-on))) + (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous + (when (and (typep component 'system) (not bspp)) + (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile))) + (setf version (normalize-version version :component name :parent parent :pathname sysfile))) + ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8. + ;; A better fix is required. + (setf (slot-value component 'version) version) + (when (typep component 'parent-component) + (setf (component-children component) (compute-component-children component components serial)) + (compute-children-by-name component)) + (when previous-serial-components + (setf depends-on (stable-union depends-on previous-serial-components :test #'equal))) + (when weakly-depends-on + ;; ASDF4: deprecate this feature and remove it. + (appendf depends-on + (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) + ;; Used by POIU. ASDF4: rename to component-depends-on? + (setf (component-sideway-dependencies component) depends-on) + (%refresh-component-inline-methods component rest) + (when if-component-dep-fails + (error "The system definition for ~S uses deprecated ~ + ASDF option :IF-COMPONENT-DEP-FAILS. ~ + Starting with ASDF 3, please use :IF-FEATURE instead" + (coerce-name (component-system component)))) + component))) + + (defmethod compute-component-children ((component parent-component) components serial-p) + (loop + :with previous-components = nil ; list of strings + :for c-form :in components + :for c = (parse-component-form component c-form + :previous-serial-components previous-components) + :for name :of-type string = (component-name c) + :when serial-p + ;; if this is an if-feature component, we need to make a serial link + ;; from previous components to following components -- otherwise should + ;; the IF-FEATURE component drop out, the chain of serial dependencies will be + ;; broken. + :unless (component-if-feature c) + :do (setf previous-components nil) + :end + :and + :do (push name previous-components) + :end + :collect c)) + + ;; the following are all systems that Stas Boukarev maintains and refuses to fix, + ;; hoping instead to make my life miserable. Instead, I just make ASDF ignore them. + (defparameter* *known-systems-with-bad-secondary-system-names* + (list-to-hash-set '("cl-ppcre" "cl-interpol"))) + (defun known-system-with-bad-secondary-system-names-p (asd-name) + ;; Does .asd file with name ASD-NAME contain known exceptions + ;; that should be screened out of checking for BAD-SYSTEM-NAME? + (gethash asd-name *known-systems-with-bad-secondary-system-names*)) + + (defun register-system-definition + (name &rest options &key pathname (class 'system) (source-file () sfp) + defsystem-depends-on &allow-other-keys) + ;; The system must be registered before we parse the body, + ;; otherwise we recur when trying to find an existing system + ;; of the same name to reuse options (e.g. pathname) from. + ;; To avoid infinite recursion in cases where you defsystem a system + ;; that is registered to a different location to find-system, + ;; we also need to remember it in the asdf-cache. + (nest + (with-asdf-session ()) + (let* ((name (coerce-name name)) + (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))))) + (flet ((fix-case (x) (if (logical-pathname-p source-file) (string-downcase x) x)))) + (let* ((asd-name (and source-file + (equal "asd" (fix-case (pathname-type source-file))) + (fix-case (pathname-name source-file)))) + ;; note that PRIMARY-NAME is a *syntactically* primary name + (primary-name (primary-system-name name))) + (when (and asd-name + (not (equal asd-name primary-name)) + (not (known-system-with-bad-secondary-system-names-p asd-name))) + (warn (make-condition 'bad-system-name :source-file source-file :name name)))) + (let* (;; NB: handle defsystem-depends-on BEFORE to create the system object, + ;; so that in case it fails, there is no incomplete object polluting the build. + (checked-defsystem-depends-on + (let* ((dep-forms (parse-dependency-defs defsystem-depends-on)) + (deps (loop :for spec :in dep-forms + :when (resolve-dependency-spec nil spec) + :collect :it))) + (load-systems* deps) + dep-forms)) + (system (or (find-system-if-being-defined name) + (if-let (registered (registered-system name)) + (reset-system-class registered 'undefined-system + :name name :source-file source-file) + (register-system (make-instance 'undefined-system + :name name :source-file source-file))))) + (component-options + (append + (remove-plist-keys '(:defsystem-depends-on :class) options) + ;; cache defsystem-depends-on in canonical form + (when checked-defsystem-depends-on + `(:defsystem-depends-on ,checked-defsystem-depends-on)))) + (directory (determine-system-directory pathname))) + ;; This works hand in hand with asdf/find-system:find-system-if-being-defined: + (set-asdf-cache-entry `(find-system ,name) (list system))) + ;; We change-class AFTER we loaded the defsystem-depends-on + ;; since the class might be defined as part of those. + (let ((class (class-for-type nil class))) + (unless (subtypep class 'system) + (error 'non-system-system :name name :class-name (class-name class))) + (unless (eq (type-of system) class) + (reset-system-class system class))) + (parse-component-form nil (list* :system name :pathname directory component-options)))) + + (defmacro defsystem (name &body options) + `(apply 'register-system-definition ',name ',options))) +;;;; ------------------------------------------------------------------------- +;;;; ASDF-Bundle + +(uiop/package:define-package :asdf/bundle + (:recycle :asdf/bundle :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade + :asdf/component :asdf/system :asdf/operation + :asdf/find-component ;; used by ECL + :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/parse-defsystem) + (:export + #:bundle-op #:bundle-type #:program-system + #:bundle-system #:bundle-pathname-type #:direct-dependency-files + #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p + #:basic-compile-bundle-op #:prepare-bundle-op + #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op + #:lib-op #:monolithic-lib-op + #:dll-op #:monolithic-dll-op + #:deliver-asd-op #:monolithic-deliver-asd-op + #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system + #:user-system-p #:user-system #:trivial-system-p + #:prologue-code #:epilogue-code #:static-library)) +(in-package :asdf/bundle) + +(with-upgradability () + (defclass bundle-op (operation) () + (:documentation "base class for operations that bundle outputs from multiple components")) + (defgeneric bundle-type (bundle-op)) + + (defclass monolithic-op (operation) () + (:documentation "A MONOLITHIC operation operates on a system *and all of its +dependencies*. So, for example, a monolithic concatenate operation will +concatenate together a system's components and all of its dependencies, but a +simple concatenate operation will concatenate only the components of the system +itself.")) + + (defclass monolithic-bundle-op (bundle-op monolithic-op) + ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation. + ;; DEPRECATED. Supported replacement: Define slots on program-system instead. + ((prologue-code :initform nil :accessor prologue-code) + (epilogue-code :initform nil :accessor epilogue-code)) + (:documentation "operations that are both monolithic-op and bundle-op")) + + (defclass program-system (system) + ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system + ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code) + (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code) + (no-uiop :initform nil :initarg :no-uiop :reader no-uiop) + (prefix-lisp-object-files :initarg :prefix-lisp-object-files + :initform nil :accessor prefix-lisp-object-files) + (postfix-lisp-object-files :initarg :postfix-lisp-object-files + :initform nil :accessor postfix-lisp-object-files) + (extra-object-files :initarg :extra-object-files + :initform nil :accessor extra-object-files) + (extra-build-args :initarg :extra-build-args + :initform nil :accessor extra-build-args))) + + (defmethod prologue-code ((x system)) nil) + (defmethod epilogue-code ((x system)) nil) + (defmethod no-uiop ((x system)) nil) + (defmethod prefix-lisp-object-files ((x system)) nil) + (defmethod postfix-lisp-object-files ((x system)) nil) + (defmethod extra-object-files ((x system)) nil) + (defmethod extra-build-args ((x system)) nil) + + (defclass link-op (bundle-op) () + (:documentation "Abstract operation for linking files together")) + + (defclass gather-operation (bundle-op) () + (:documentation "Abstract operation for gathering many input files from a system")) + (defgeneric gather-operation (gather-operation)) + (defmethod gather-operation ((o gather-operation)) nil) + (defgeneric gather-type (gather-operation)) + + (defun operation-monolithic-p (op) + (typep op 'monolithic-op)) + + ;; Dependencies of a gather-op are the actions of the dependent operation + ;; for all the (sorted) required components for loading the system. + ;; Monolithic operations typically use lib-op as the dependent operation, + ;; and all system-level dependencies as required components. + ;; Non-monolithic operations typically use compile-op as the dependent operation, + ;; and all transitive sub-components as required components (excluding other systems). + (defmethod component-depends-on ((o gather-operation) (s system)) + (let* ((mono (operation-monolithic-p o)) + (go (make-operation (or (gather-operation o) 'compile-op))) + (bundle-p (typep go 'bundle-op)) + ;; In a non-mono operation, don't recurse to other systems. + ;; In a mono operation gathering bundles, don't recurse inside systems. + (component-type (if mono (if bundle-p 'system t) '(not system))) + ;; In the end, only keep system bundles or non-system bundles, depending. + (keep-component (if bundle-p 'system '(not system))) + (deps + ;; Required-components only looks at the dependencies of an action, excluding the action + ;; itself, so it may be safely used by an action recursing on its dependencies (which + ;; may or may not be an overdesigned API, since in practice we never use it that way). + ;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks + ;; cleaner, we will miss the load-op on the requested system itself, which doesn't + ;; matter for a regular system, but matters, a lot, for a package-inferred-system. + ;; Using load-op as the goal operation and basic-compile-op as the keep-operation works + ;; for our needs of gathering all the files we want to include in a bundle. + ;; Note that we use basic-compile-op rather than compile-op so it will still work on + ;; systems that would somehow load dependencies with load-bundle-op. + (required-components + s :other-systems mono :component-type component-type :keep-component keep-component + :goal-operation 'load-op :keep-operation 'basic-compile-op))) + `((,go ,@deps) ,@(call-next-method)))) + + ;; Create a single fasl for the entire library + (defclass basic-compile-bundle-op (bundle-op basic-compile-op) () + (:documentation "Base class for compiling into a bundle")) + (defmethod bundle-type ((o basic-compile-bundle-op)) :fasb) + (defmethod gather-type ((o basic-compile-bundle-op)) + #-(or clasp ecl mkcl) :fasl + #+(or clasp ecl mkcl) :object) + + ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op + (defclass prepare-bundle-op (sideway-operation) + ((sideway-operation + :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op + :allocation :class)) + (:documentation "Operation class for loading the bundles of a system's dependencies")) + + (defclass lib-op (link-op gather-operation non-propagating-operation) () + (:documentation "Compile the system and produce a linkable static library (.a/.lib) +for all the linkable object files associated with the system. Compare with DLL-OP. + +On most implementations, these object files only include extensions to the runtime +written in C or another language with a compiler producing linkable object files. +On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files +themselves. In any case, this operation will produce what you need to further build +a static runtime for your system, or a dynamic library to load in an existing runtime.")) + (defmethod bundle-type ((o lib-op)) :lib) + (defmethod gather-type ((o lib-op)) :object) + + ;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so; + ;; on other implementations, we combine (usually concatenate) the .fasl files into one. + (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-operation + #+(or clasp ecl mkcl) link-op) + ((selfward-operation :initform '(prepare-bundle-op) :allocation :class)) + (:documentation "This operator is an alternative to COMPILE-OP. Build a system +and all of its dependencies, but build only a single (\"monolithic\") FASL, instead +of one per source file, which may be more resource efficient. That monolithic +FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP.")) + + (defclass load-bundle-op (basic-load-op selfward-operation) + ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class)) + (:documentation "This operator is an alternative to LOAD-OP. Build a system +and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with +respect to LOAD-OP is that it builds only a single FASL, which may be +faster and more resource efficient.")) + + ;; NB: since the monolithic-op's can't be sideway-operation's, + ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's, + ;; we'd have to have the monolithic-op not inherit from the main op, + ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above. + + (defclass dll-op (link-op gather-operation non-propagating-operation) () + (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) +for all the linkable object files associated with the system. Compare with LIB-OP.")) + (defmethod bundle-type ((o dll-op)) :dll) + (defmethod gather-type ((o dll-op)) :object) + + (defclass deliver-asd-op (basic-compile-op selfward-operation) + ((selfward-operation + ;; TODO: implement link-op on all implementations, and make that + ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op) + :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) + :allocation :class)) + (:documentation "produce an asd file for delivering the system as a single fasl")) + + + (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op) + ((selfward-operation + ;; TODO: implement link-op on all implementations, and make that + ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op) + :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op) + :allocation :class)) + (:documentation "produce fasl and asd files for combined system and dependencies.")) + + (defclass monolithic-compile-bundle-op + (basic-compile-bundle-op monolithic-bundle-op + #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation) + () + (:documentation "Create a single fasl for the system and its dependencies.")) + + (defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op) + ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class)) + (:documentation "Load a single fasl for the system and its dependencies.")) + + (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation) () + (:documentation "Compile the system and produce a linkable static library (.a/.lib) +for all the linkable object files associated with the system or its dependencies. See LIB-OP.")) + + (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation) () + (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll) +for all the linkable object files associated with the system or its dependencies. See LIB-OP")) + + (defclass image-op (monolithic-bundle-op selfward-operation + #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation) + ((selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class)) + (:documentation "create an image file from the system and its dependencies")) + (defmethod bundle-type ((o image-op)) :image) + #+(or clasp ecl mkcl) (defmethod gather-operation ((o image-op)) 'lib-op) + #+(or clasp ecl mkcl) (defmethod gather-type ((o image-op)) :static-library) + + (defclass program-op (image-op) () + (:documentation "create an executable file from the system and its dependencies")) + (defmethod bundle-type ((o program-op)) :program) + + ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type. + (defun bundle-pathname-type (bundle-type) + (etypecase bundle-type + ((or null string) ;; pass through nil or string literal + bundle-type) + ((eql :no-output-file) ;; marker for a bundle-type that has NO output file + (error "No output file, therefore no pathname type")) + ((eql :fasl) ;; the type of a fasl + (compile-file-type)) ; on image-based platforms, used as input and output + ((eql :fasb) ;; the type of a fasl + #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output + #+(or ecl mkcl) "fasb" + #+clasp "fasp") ; on C-linking platforms, only used as output for system bundles + ((member :image) + #+allegro "dxl" + #+(and clisp os-windows) "exe" + #-(or allegro (and clisp os-windows)) "image") + ;; NB: on CLASP and ECL these implementations, we better agree with + ;; (compile-file-type :type bundle-type)) + ((eql :object) ;; the type of a linkable object file + (os-cond ((os-unix-p) + #+clasp "fasp" ;(core:build-extension cmp:*default-object-type*) + #-clasp "o") + ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj")))) + ((member :lib :static-library) ;; the type of a linkable library + (os-cond ((os-unix-p) "a") + ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) + ((member :dll :shared-library) ;; the type of a shared library + (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) + ((eql :program) ;; the type of an executable program + (os-cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) + + ;; Compute the output-files for a given bundle action + (defun bundle-output-files (o c) + (let ((bundle-type (bundle-type o))) + (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type. + (and (null (input-files o c)) (not (member bundle-type '(:image :program))))) + (let ((name (or (component-build-pathname c) + (let ((suffix + (unless (typep o 'program-op) + ;; "." is no good separator for Logical Pathnames, so we use "--" + (if (operation-monolithic-p o) + "--all-systems" + ;; These use a different type .fasb or .a instead of .fasl + #-(or clasp ecl mkcl) "--system")))) + (format nil "~A~@[~A~]" (coerce-filename (component-name c)) suffix)))) + (type (bundle-pathname-type bundle-type))) + (values (list (subpathname (component-pathname c) name :type type)) + (eq (class-of o) (coerce-class (component-build-operation c) + :package :asdf/interface + :super 'operation + :error nil))))))) + + (defmethod output-files ((o bundle-op) (c system)) + (bundle-output-files o c)) + + #-(or clasp ecl mkcl) + (progn + (defmethod perform ((o image-op) (c system)) + (dump-image (output-file o c) :executable (typep o 'program-op))) + (defmethod perform :before ((o program-op) (c system)) + (setf *image-entry-point* (ensure-function (component-entry-point c))))) + + (defclass compiled-file (file-component) + ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")) + (:documentation "Class for a file that is already compiled, +e.g. as part of the implementation, of an outer build system that calls into ASDF, +or of opaque libraries shipped along the source code.")) + + (defclass precompiled-system (system) + ((build-pathname :initarg :fasb :initarg :fasl)) + (:documentation "Class For a system that is delivered as a precompiled fasl")) + + (defclass prebuilt-system (system) + ((build-pathname :initarg :static-library :initarg :lib + :accessor prebuilt-system-static-library)) + (:documentation "Class for a system delivered with a linkable static library (.a/.lib)"))) + + +;;; +;;; BUNDLE-OP +;;; +;;; This operation takes all components from one or more systems and +;;; creates a single output file, which may be +;;; a FASL, a statically linked library, a shared library, etc. +;;; The different targets are defined by specialization. +;;; +(when-upgrading (:version "3.2.0") + ;; Cancel any previously defined method + (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)))) + +(with-upgradability () + (defgeneric trivial-system-p (component)) + + (defun user-system-p (s) + (and (typep s 'system) + (not (builtin-system-p s)) + (not (trivial-system-p s))))) + +(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) + (deftype user-system () '(and system (satisfies user-system-p)))) + +;;; +;;; First we handle monolithic bundles. +;;; These are standalone systems which contain everything, +;;; including other ASDF systems required by the current one. +;;; A PROGRAM is always monolithic. +;;; +;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL +;;; +(with-upgradability () + (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) + ;; This function selects output files from direct dependencies; + ;; your component-depends-on method must gather the correct dependencies in the correct order. + (while-collecting (collect) + (map-direct-dependencies + o c #'(lambda (sub-o sub-c) + (loop :for f :in (funcall key sub-o sub-c) + :when (funcall test f) :do (collect f)))))) + + (defun pathname-type-equal-function (type) + #'(lambda (p) (equalp (pathname-type p) type))) + + (defmethod input-files ((o gather-operation) (c system)) + (unless (eq (bundle-type o) :no-output-file) + (direct-dependency-files + o c :key 'output-files + :test (pathname-type-equal-function (bundle-pathname-type (gather-type o)))))) + + ;; Find the operation that produces a given bundle-type + (defun select-bundle-operation (type &optional monolithic) + (ecase type + ((:dll :shared-library) + (if monolithic 'monolithic-dll-op 'dll-op)) + ((:lib :static-library) + (if monolithic 'monolithic-lib-op 'lib-op)) + ((:fasb) + (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op)) + ((:image) + 'image-op) + ((:program) + 'program-op)))) + +;;; +;;; LOAD-BUNDLE-OP +;;; +;;; This is like ASDF's LOAD-OP, but using bundle fasl files. +;;; +(with-upgradability () + (defmethod component-depends-on ((o load-bundle-op) (c system)) + `((,o ,@(component-sideway-dependencies c)) + (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c) + ,@(call-next-method))) + + (defmethod input-files ((o load-bundle-op) (c system)) + (when (user-system-p c) + (output-files (find-operation o 'compile-bundle-op) c))) + + (defmethod perform ((o load-bundle-op) (c system)) + (when (input-files o c) + (perform-lisp-load-fasl o c))) + + (defmethod mark-operation-done :after ((o load-bundle-op) (c system)) + (mark-operation-done (find-operation o 'load-op) c))) + +;;; +;;; PRECOMPILED FILES +;;; +;;; This component can be used to distribute ASDF systems in precompiled form. +;;; Only useful when the dependencies have also been precompiled. +;;; +(with-upgradability () + (defmethod trivial-system-p ((s system)) + (every #'(lambda (c) (typep c 'compiled-file)) (component-children s))) + + (defmethod input-files ((o operation) (c compiled-file)) + (list (component-pathname c))) + (defmethod perform ((o load-op) (c compiled-file)) + (perform-lisp-load-fasl o c)) + (defmethod perform ((o load-source-op) (c compiled-file)) + (perform (find-operation o 'load-op) c)) + (defmethod perform ((o operation) (c compiled-file)) + nil)) + +;;; +;;; Pre-built systems +;;; +(with-upgradability () + (defmethod trivial-system-p ((s prebuilt-system)) + t) + + (defmethod perform ((o link-op) (c prebuilt-system)) + nil) + + (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system)) + nil) + + (defmethod perform ((o lib-op) (c prebuilt-system)) + nil) + + (defmethod perform ((o dll-op) (c prebuilt-system)) + nil) + + (defmethod component-depends-on ((o gather-operation) (c prebuilt-system)) + nil) + + (defmethod output-files ((o lib-op) (c prebuilt-system)) + (values (list (prebuilt-system-static-library c)) t))) + + +;;; +;;; PREBUILT SYSTEM CREATOR +;;; +(with-upgradability () + (defmethod output-files ((o deliver-asd-op) (s system)) + (list (make-pathname :name (coerce-filename (component-name s)) :type "asd" + :defaults (component-pathname s)))) + + ;; because of name collisions between the output files of different + ;; subclasses of DELIVER-ASD-OP, we cannot trust the file system to + ;; tell us if the output file is up-to-date, so just treat the + ;; operation as never being done. + (defmethod operation-done-p ((o deliver-asd-op) (s system)) + (declare (ignorable o s)) + nil) + + (defun space-for-crlf (s) + (substitute-if #\space #'(lambda (x) (find x +crlf+)) s)) + + (defmethod perform ((o deliver-asd-op) (s system)) + "Write an ASDF system definition for loading S as a delivered system." + (let* ((inputs (input-files o s)) + (fasl (first inputs)) + (library (second inputs)) + (asd (output-file o s)) + (name (if (and fasl asd) (pathname-name asd) (return-from perform))) + (version (component-version s)) + (dependencies + (if (operation-monolithic-p o) + ;; We want only dependencies, and we use basic-load-op rather than load-op so that + ;; this will keep working on systems that load dependencies with load-bundle-op + (remove-if-not 'builtin-system-p + (required-components s :component-type 'system + :keep-operation 'basic-load-op)) + (while-collecting (x) ;; resolve the sideway-dependencies of s + (map-direct-dependencies + 'prepare-op s + #'(lambda (o c) + (when (and (typep o 'load-op) (typep c 'system)) + (x c))))))) + (depends-on (mapcar 'coerce-name dependencies))) + (when (pathname-equal asd (system-source-file s)) + (cerror "overwrite the asd file" + "~/asdf-action:format-action/ is going to overwrite the system definition file ~S ~ +which is probably not what you want; you probably need to tweak your output translations." + (cons o s) asd)) + (with-open-file (s asd :direction :output :if-exists :supersede + :if-does-not-exist :create) + (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%" + (operation-monolithic-p o) name) + ;; this can cause bugs in cases where one of the functions returns a multi-line + ;; string + (let ((description-string (format nil ";;; Built for ~A ~A on a ~A/~A ~A" + (lisp-implementation-type) + (lisp-implementation-version) + (software-type) + (machine-type) + (software-version)))) + ;; ensure the whole thing is on one line + (println (space-for-crlf description-string) s)) + (let ((*package* (find-package :asdf-user))) + (pprint `(defsystem ,name + :class prebuilt-system + :version ,version + :depends-on ,depends-on + :components ((:compiled-file ,(pathname-name fasl))) + ,@(when library `(:lib ,(file-namestring library)))) + s) + (terpri s))))) + + #-(or clasp ecl mkcl) + (defmethod perform ((o basic-compile-bundle-op) (c system)) + (let* ((input-files (input-files o c)) + (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) + (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp)) + (output-files (output-files o c)) ; can't use OUTPUT-FILE fn because possibility it's NIL + (output-file (first output-files))) + (assert (eq (not input-files) (not output-files))) + (when input-files + (when non-fasl-files + (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S" + (implementation-type) non-fasl-files)) + (when (or (prologue-code c) (epilogue-code c)) + (error "prologue-code and epilogue-code are not supported on ~A" + (implementation-type))) + (with-staging-pathname (output-file) + (combine-fasls fasl-files output-file))))) + + (defmethod input-files ((o load-op) (s precompiled-system)) + (bundle-output-files (find-operation o 'compile-bundle-op) s)) + + (defmethod perform ((o load-op) (s precompiled-system)) + (perform-lisp-load-fasl o s)) + + (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system)) + `((load-op ,s) ,@(call-next-method)))) + +#| ;; Example use: +(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl"))) +(asdf:load-system :precompiled-asdf-utils) +|# + +#+(or clasp ecl mkcl) +(with-upgradability () + (defun system-module-pathname (module) + (let ((name (coerce-name module))) + (some + 'file-exists-p + (list + #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object) + #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib) + #+ecl (compile-file-pathname (make-pathname :name (strcat "lib" name) :defaults "sys:") :type :lib) + #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object) + #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:") + #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;"))))) + + (defun make-prebuilt-system (name &optional (pathname (system-module-pathname name))) + "Creates a prebuilt-system if PATHNAME isn't NIL." + (when pathname + (make-instance 'prebuilt-system + :name (coerce-name name) + :static-library (resolve-symlinks* pathname)))) + + (defun linkable-system (x) + (or ;; If the system is available as source, use it. + (if-let (s (find-system x)) + (and (output-files 'lib-op s) s)) + ;; If an ASDF upgrade is available from source, but not a UIOP upgrade to that, + ;; then use the asdf/driver system instead of + ;; the UIOP that was disabled by check-not-old-asdf-system. + (if-let (s (and (equal (coerce-name x) "uiop") + (output-files 'lib-op "asdf") + (find-system "asdf/driver"))) + (and (output-files 'lib-op s) s)) + ;; If there was no source upgrade, look for modules provided by the implementation. + (if-let (p (system-module-pathname (coerce-name x))) + (make-prebuilt-system x p)))) + + (defmethod component-depends-on :around ((o image-op) (c system)) + (let* ((next (call-next-method)) + (deps (make-hash-table :test 'equal)) + (linkable (loop :for (do . dcs) :in next :collect + (cons do + (loop :for dc :in dcs + :for dep = (and dc (resolve-dependency-spec c dc)) + :when dep + :do (setf (gethash (coerce-name (component-system dep)) deps) t) + :collect (or (and (typep dep 'system) (linkable-system dep)) dep)))))) + `((lib-op + ,@(unless (no-uiop c) + (list (linkable-system "cmp") + (unless (or (and (gethash "uiop" deps) (linkable-system "uiop")) + (and (gethash "asdf" deps) (linkable-system "asdf"))) + (or (linkable-system "uiop") + (linkable-system "asdf") + "asdf"))))) + ,@linkable))) + + (defmethod perform ((o link-op) (c system)) + (let* ((object-files (input-files o c)) + (output (output-files o c)) + (bundle (first output)) + (programp (typep o 'program-op)) + (kind (bundle-type o))) + (when output + (apply 'create-image + bundle (append + (when programp (prefix-lisp-object-files c)) + object-files + (when programp (postfix-lisp-object-files c))) + :kind kind + :prologue-code (when programp (prologue-code c)) + :epilogue-code (when programp (epilogue-code c)) + :build-args (when programp (extra-build-args c)) + :extra-object-files (when programp (extra-object-files c)) + :no-uiop (no-uiop c) + (when programp `(:entry-point ,(component-entry-point c)))))))) +;;;; ------------------------------------------------------------------------- +;;;; Concatenate-source + +(uiop/package:define-package :asdf/concatenate-source + (:recycle :asdf/concatenate-source :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade + :asdf/component :asdf/operation + :asdf/system + :asdf/action :asdf/lisp-action :asdf/plan :asdf/bundle) + (:export + #:concatenate-source-op + #:load-concatenated-source-op + #:compile-concatenated-source-op + #:load-compiled-concatenated-source-op + #:monolithic-concatenate-source-op + #:monolithic-load-concatenated-source-op + #:monolithic-compile-concatenated-source-op + #:monolithic-load-compiled-concatenated-source-op)) +(in-package :asdf/concatenate-source) + +;;; +;;; Concatenate sources +;;; +(with-upgradability () + ;; Base classes for both regular and monolithic concatenate-source operations + (defclass basic-concatenate-source-op (bundle-op) ()) + (defmethod bundle-type ((o basic-concatenate-source-op)) "lisp") + (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ()) + (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ()) + (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ()) + + ;; Regular concatenate-source operations + (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) () + (:documentation "Operation to concatenate all sources in a system into a single file")) + (defclass load-concatenated-source-op (basic-load-concatenated-source-op) + ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)) + (:documentation "Operation to load the result of concatenate-source-op as source")) + (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op) + ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class)) + (:documentation "Operation to compile the result of concatenate-source-op")) + (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) + ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class)) + (:documentation "Operation to load the result of compile-concatenated-source-op")) + + (defclass monolithic-concatenate-source-op + (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) () + (:documentation "Operation to concatenate all sources in a system and its dependencies +into a single file")) + (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op) + ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)) + (:documentation "Operation to load the result of monolithic-concatenate-source-op as source")) + (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op) + ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class)) + (:documentation "Operation to compile the result of monolithic-concatenate-source-op")) + (defclass monolithic-load-compiled-concatenated-source-op + (basic-load-compiled-concatenated-source-op) + ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class)) + (:documentation "Operation to load the result of monolithic-compile-concatenated-source-op")) + + (defmethod input-files ((operation basic-concatenate-source-op) (s system)) + (loop :with encoding = (or (component-encoding s) *default-encoding*) + :with other-encodings = '() + :with around-compile = (around-compile-hook s) + :with other-around-compile = '() + :for c :in (required-components ;; see note about similar call to required-components + s :goal-operation 'load-op ;; in bundle.lisp + :keep-operation 'basic-compile-op + :other-systems (operation-monolithic-p operation)) + :append + (when (typep c 'cl-source-file) + (let ((e (component-encoding c))) + (unless (or (equal e encoding) + (and (equal e :ASCII) (equal encoding :UTF-8))) + (let ((a (assoc e other-encodings))) + (if a (push (component-find-path c) (cdr a)) + (push (list e (component-find-path c)) other-encodings))))) + (unless (equal around-compile (around-compile-hook c)) + (push (component-find-path c) other-around-compile)) + (input-files (make-operation 'compile-op) c)) :into inputs + :finally + (when other-encodings + (warn "~S uses encoding ~A but has sources that use these encodings:~{ ~A~}" + operation encoding + (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x))))) + other-encodings))) + (when other-around-compile + (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" + operation around-compile other-around-compile)) + (return inputs))) + (defmethod output-files ((o basic-compile-concatenated-source-op) (s system)) + (lisp-compilation-output-files o s)) + + (defmethod perform ((o basic-concatenate-source-op) (s system)) + (let* ((ins (input-files o s)) + (out (output-file o s)) + (tmp (tmpize-pathname out))) + (concatenate-files ins tmp) + (rename-file-overwriting-target tmp out))) + (defmethod perform ((o basic-load-concatenated-source-op) (s system)) + (perform-lisp-load-source o s)) + (defmethod perform ((o basic-compile-concatenated-source-op) (s system)) + (perform-lisp-compilation o s)) + (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system)) + (perform-lisp-load-fasl o s))) + +;;;; ------------------------------------------------------------------------- +;;;; Package systems in the style of quick-build or faslpath + +(uiop:define-package :asdf/package-inferred-system + (:recycle :asdf/package-inferred-system :asdf/package-system :asdf) + (:use :uiop/common-lisp :uiop + :asdf/upgrade :asdf/session + :asdf/component :asdf/system :asdf/system-registry :asdf/lisp-action + :asdf/parse-defsystem) + (:export + #:package-inferred-system #:sysdef-package-inferred-system-search + #:package-system ;; backward compatibility only. To be removed. + #:register-system-packages + #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error)) +(in-package :asdf/package-inferred-system) + +(with-upgradability () + ;; The names of the recognized defpackage forms. + (defparameter *defpackage-forms* '(defpackage define-package)) + + (defun initial-package-inferred-systems-table () + ;; Mark all existing packages are preloaded. + (let ((h (make-hash-table :test 'equal))) + (dolist (p (list-all-packages)) + (dolist (n (package-names p)) + (setf (gethash n h) t))) + h)) + + ;; Mapping from package names to systems that provide them. + (defvar *package-inferred-systems* (initial-package-inferred-systems-table)) + + (defclass package-inferred-system (system) + () + (:documentation "Class for primary systems for which secondary systems are automatically +in the one-file, one-file, one-system style: system names are mapped to files under the primary +system's system-source-directory, dependencies are inferred from the first defpackage form in +every such file")) + + ;; DEPRECATED. For backward compatibility only. To be removed in an upcoming release: + (defclass package-system (package-inferred-system) ()) + + ;; Is a given form recognizable as a defpackage form? + (defun defpackage-form-p (form) + (and (consp form) + (member (car form) *defpackage-forms*))) + + ;; Find the first defpackage form in a stream, if any + (defun stream-defpackage-form (stream) + (loop :for form = (read stream nil nil) :while form + :when (defpackage-form-p form) :return form)) + + (defun file-defpackage-form (file) + "Return the first DEFPACKAGE form in FILE." + (with-input-file (f file) + (stream-defpackage-form f))) + + (define-condition package-inferred-system-missing-package-error (system-definition-error) + ((system :initarg :system :reader error-system) + (pathname :initarg :pathname :reader error-pathname)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (error-system c) (error-pathname c))))) + + (defun package-dependencies (defpackage-form) + "Return a list of packages depended on by the package +defined in DEFPACKAGE-FORM. A package is depended upon if +the DEFPACKAGE-FORM uses it or imports a symbol from it." + (assert (defpackage-form-p defpackage-form)) + (remove-duplicates + (while-collecting (dep) + (loop :for (option . arguments) :in (cddr defpackage-form) :do + (ecase option + ((:use :mix :reexport :use-reexport :mix-reexport) + (dolist (p arguments) (dep (string p)))) + ((:import-from :shadowing-import-from) + (dep (string (first arguments)))) + #+package-local-nicknames + ((:local-nicknames) + (loop :for (nil actual-package-name) :in arguments :do + (dep (string actual-package-name)))) + ((:nicknames :documentation :shadow :export :intern :unintern :recycle))))) + :from-end t :test 'equal)) + + (defun package-designator-name (package) + "Normalize a package designator to a string" + (etypecase package + (package (package-name package)) + (string package) + (symbol (string package)))) + + (defun register-system-packages (system packages) + "Register SYSTEM as providing PACKAGES." + (let ((name (or (eq system t) (coerce-name system)))) + (dolist (p (ensure-list packages)) + (setf (gethash (package-designator-name p) *package-inferred-systems*) name)))) + + (defun package-name-system (package-name) + "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists, +otherwise return a default system name computed from PACKAGE-NAME." + (check-type package-name string) + (or (gethash package-name *package-inferred-systems*) + (string-downcase package-name))) + + ;; Given a file in package-inferred-system style, find its dependencies + (defun package-inferred-system-file-dependencies (file &optional system) + (if-let (defpackage-form (file-defpackage-form file)) + (remove t (mapcar 'package-name-system (package-dependencies defpackage-form))) + (error 'package-inferred-system-missing-package-error :system system :pathname file))) + + ;; Given package-inferred-system object, check whether its specification matches + ;; the provided parameters + (defun same-package-inferred-system-p (system name directory subpath around-compile dependencies) + (and (eq (type-of system) 'package-inferred-system) + (equal (component-name system) name) + (pathname-equal directory (component-pathname system)) + (equal dependencies (component-sideway-dependencies system)) + (equal around-compile (around-compile-hook system)) + (let ((children (component-children system))) + (and (length=n-p children 1) + (let ((child (first children))) + (and (eq (type-of child) 'cl-source-file) + (equal (component-name child) "lisp") + (and (slot-boundp child 'relative-pathname) + (equal (slot-value child 'relative-pathname) subpath)))))))) + + ;; sysdef search function to push into *system-definition-search-functions* + (defun sysdef-package-inferred-system-search (system-name) + "Takes SYSTEM-NAME and returns an initialized SYSTEM object, or NIL. Made to be added to +*SYSTEM-DEFINITION-SEARCH-FUNCTIONS*." + (let ((primary (primary-system-name system-name))) + ;; this function ONLY does something if the primary system name is NOT the same as + ;; SYSTEM-NAME. It is used to find the systems with names that are relative to + ;; the primary system's name, and that are not explicitly specified in the system + ;; definition + (unless (equal primary system-name) + (let ((top (find-system primary nil))) + (when (typep top 'package-inferred-system) + (if-let (dir (component-pathname top)) + (let* ((sub (subseq system-name (1+ (length primary)))) + (component-type (class-for-type top :file)) + (file-type (file-type (make-instance component-type))) + (f (probe-file* (subpathname dir sub :type file-type) + :truename *resolve-symlinks*))) + (when (file-pathname-p f) + (let ((dependencies (package-inferred-system-file-dependencies f system-name)) + (previous (registered-system system-name)) + (around-compile (around-compile-hook top))) + (if (same-package-inferred-system-p previous system-name dir sub around-compile dependencies) + previous + (eval `(defsystem ,system-name + :class package-inferred-system + :default-component-class ,component-type + :source-file ,(system-source-file top) + :pathname ,dir + :depends-on ,dependencies + :around-compile ,around-compile + :components ((,component-type file-type :pathname ,sub))))))))))))))) + +(with-upgradability () + (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*) + (setf *system-definition-search-functions* + (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil) + *system-definition-search-functions*))) +;;;; --------------------------------------------------------------------------- +;;;; asdf-output-translations + +(uiop/package:define-package :asdf/output-translations + (:recycle :asdf/output-translations :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade) + (:export + #:*output-translations* #:*output-translations-parameter* + #:invalid-output-translation + #:output-translations #:output-translations-initialized-p + #:initialize-output-translations #:clear-output-translations + #:disable-output-translations #:ensure-output-translations + #:apply-output-translations + #:validate-output-translations-directive #:validate-output-translations-form + #:validate-output-translations-file #:validate-output-translations-directory + #:parse-output-translations-string #:wrapping-output-translations + #:user-output-translations-pathname #:system-output-translations-pathname + #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname + #:environment-output-translations #:process-output-translations + #:compute-output-translations + #+abcl #:translate-jar-pathname + )) +(in-package :asdf/output-translations) + +;; (setf output-translations) between 2.27 and 3.0.3 was using a defsetf macro +;; for the sake of obsolete versions of GCL 2.6. Make sure it doesn't come to haunt us. +(when-upgrading (:version "3.1.2") (fmakunbound '(setf output-translations))) + +(with-upgradability () + (define-condition invalid-output-translation (invalid-configuration warning) + ((format :initform (compatfmt "~@")))) + + (defvar *output-translations* () + "Either NIL (for uninitialized), or a list of one element, +said element itself being a sorted list of mappings. +Each mapping is a pair of a source pathname and destination pathname, +and the order is by decreasing length of namestring of the source pathname.") + + (defun output-translations () + "Return the configured output-translations, if any" + (car *output-translations*)) + + ;; Set the output-translations, by sorting the provided new-value. + (defun set-output-translations (new-value) + (setf *output-translations* + (list + (stable-sort (copy-list new-value) #'> + :key #'(lambda (x) + (etypecase (car x) + ((eql t) -1) + (pathname + (let ((directory + (normalize-pathname-directory-component + (pathname-directory (car x))))) + (if (listp directory) (length directory) 0)))))))) + new-value) + (defun (setf output-translations) (new-value) (set-output-translations new-value)) + + (defun output-translations-initialized-p () + "Have the output-translations been initialized yet?" + (and *output-translations* t)) + + (defun clear-output-translations () + "Undoes any initialization of the output translations." + (setf *output-translations* '()) + (values)) + (register-clear-configuration-hook 'clear-output-translations) + + + ;;; Validation of the configuration directives... + + (defun validate-output-translations-directive (directive) + (or (member directive '(:enable-user-cache :disable-cache nil)) + (and (consp directive) + (or (and (length=n-p directive 2) + (or (and (eq (first directive) :include) + (typep (second directive) '(or string pathname null))) + (and (location-designator-p (first directive)) + (or (location-designator-p (second directive)) + (location-function-p (second directive)))))) + (and (length=n-p directive 1) + (location-designator-p (first directive))))))) + + (defun validate-output-translations-form (form &key location) + (validate-configuration-form + form + :output-translations + 'validate-output-translations-directive + :location location :invalid-form-reporter 'invalid-output-translation)) + + (defun validate-output-translations-file (file) + (validate-configuration-file + file 'validate-output-translations-form :description "output translations")) + + (defun validate-output-translations-directory (directory) + (validate-configuration-directory + directory :output-translations 'validate-output-translations-directive + :invalid-form-reporter 'invalid-output-translation)) + + + ;;; Parse the ASDF_OUTPUT_TRANSLATIONS environment variable and/or some file contents + (defun parse-output-translations-string (string &key location) + (cond + ((or (null string) (equal string "")) + '(:output-translations :inherit-configuration)) + ((not (stringp string)) + (error (compatfmt "~@") string)) + ((eql (char string 0) #\") + (parse-output-translations-string (read-from-string string) :location location)) + ((eql (char string 0) #\() + (validate-output-translations-form (read-from-string string) :location location)) + (t + (loop + :with inherit = nil + :with directives = () + :with start = 0 + :with end = (length string) + :with source = nil + :with separator = (inter-directory-separator) + :for i = (or (position separator string :start start) end) :do + (let ((s (subseq string start i))) + (cond + (source + (push (list source (if (equal "" s) nil s)) directives) + (setf source nil)) + ((equal "" s) + (when inherit + (error (compatfmt "~@") + string)) + (setf inherit t) + (push :inherit-configuration directives)) + (t + (setf source s))) + (setf start (1+ i)) + (when (> start end) + (when source + (error (compatfmt "~@") + string)) + (unless inherit + (push :ignore-inherited-configuration directives)) + (return `(:output-translations ,@(nreverse directives))))))))) + + + ;; The default sources of configuration for output-translations + (defparameter* *default-output-translations* + '(environment-output-translations + user-output-translations-pathname + user-output-translations-directory-pathname + system-output-translations-pathname + system-output-translations-directory-pathname)) + + ;; Compulsory implementation-dependent wrapping for the translations: + ;; handle implementation-provided systems. + (defun wrapping-output-translations () + `(:output-translations + ;; Some implementations have precompiled ASDF systems, + ;; so we must disable translations for implementation paths. + #+(or clasp #|clozure|# ecl mkcl sbcl) + ,@(let ((h (resolve-symlinks* (lisp-implementation-directory)))) + (when h `(((,h ,*wild-path*) ())))) + #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) + ;; All-import, here is where we want user stuff to be: + :inherit-configuration + ;; These are for convenience, and can be overridden by the user: + #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) + ;; We enable the user cache by default, and here is the place we do: + :enable-user-cache)) + + ;; Relative pathnames of output-translations configuration to XDG configuration directory + (defparameter *output-translations-file* (parse-unix-namestring "common-lisp/asdf-output-translations.conf")) + (defparameter *output-translations-directory* (parse-unix-namestring "common-lisp/asdf-output-translations.conf.d/")) + + ;; Locating various configuration pathnames, depending on input or output intent. + (defun user-output-translations-pathname (&key (direction :input)) + (xdg-config-pathname *output-translations-file* direction)) + (defun system-output-translations-pathname (&key (direction :input)) + (find-preferred-file (system-config-pathnames *output-translations-file*) + :direction direction)) + (defun user-output-translations-directory-pathname (&key (direction :input)) + (xdg-config-pathname *output-translations-directory* direction)) + (defun system-output-translations-directory-pathname (&key (direction :input)) + (find-preferred-file (system-config-pathnames *output-translations-directory*) + :direction direction)) + (defun environment-output-translations () + (getenv "ASDF_OUTPUT_TRANSLATIONS")) + + + ;;; Processing the configuration. + + (defgeneric process-output-translations (spec &key inherit collect)) + + (defun inherit-output-translations (inherit &key collect) + (when inherit + (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) + + (defun process-output-translations-directive (directive &key inherit collect) + (if (atom directive) + (ecase directive + ((:enable-user-cache) + (process-output-translations-directive '(t :user-cache) :collect collect)) + ((:disable-cache) + (process-output-translations-directive '(t t) :collect collect)) + ((:inherit-configuration) + (inherit-output-translations inherit :collect collect)) + ((:ignore-inherited-configuration :ignore-invalid-entries nil) + nil)) + (let ((src (first directive)) + (dst (second directive))) + (if (eq src :include) + (when dst + (process-output-translations (pathname dst) :inherit nil :collect collect)) + (when src + (let ((trusrc (or (eql src t) + (let ((loc (resolve-location src :ensure-directory t :wilden t))) + (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc))))) + (cond + ((location-function-p dst) + (funcall collect + (list trusrc (ensure-function (second dst))))) + ((typep dst 'boolean) + (funcall collect (list trusrc t))) + (t + (let* ((trudst (resolve-location dst :ensure-directory t :wilden t))) + (funcall collect (list trudst t)) + (funcall collect (list trusrc trudst))))))))))) + + (defmethod process-output-translations ((x symbol) &key + (inherit *default-output-translations*) + collect) + (process-output-translations (funcall x) :inherit inherit :collect collect)) + (defmethod process-output-translations ((pathname pathname) &key inherit collect) + (cond + ((directory-pathname-p pathname) + (process-output-translations (validate-output-translations-directory pathname) + :inherit inherit :collect collect)) + ((probe-file* pathname :truename *resolve-symlinks*) + (process-output-translations (validate-output-translations-file pathname) + :inherit inherit :collect collect)) + (t + (inherit-output-translations inherit :collect collect)))) + (defmethod process-output-translations ((string string) &key inherit collect) + (process-output-translations (parse-output-translations-string string) + :inherit inherit :collect collect)) + (defmethod process-output-translations ((x null) &key inherit collect) + (inherit-output-translations inherit :collect collect)) + (defmethod process-output-translations ((form cons) &key inherit collect) + (dolist (directive (cdr (validate-output-translations-form form))) + (process-output-translations-directive directive :inherit inherit :collect collect))) + + + ;;; Top-level entry-points to configure output-translations + + (defun compute-output-translations (&optional parameter) + "read the configuration, return it" + (remove-duplicates + (while-collecting (c) + (inherit-output-translations + `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) + :test 'equal :from-end t)) + + ;; Saving the user-provided parameter to output-translations, if any, + ;; so we can recompute the translations after code upgrade. + (defvar *output-translations-parameter* nil) + + ;; Main entry-point for users. + (defun initialize-output-translations (&optional (parameter *output-translations-parameter*)) + "read the configuration, initialize the internal configuration variable, +return the configuration" + (setf *output-translations-parameter* parameter + (output-translations) (compute-output-translations parameter))) + + (defun disable-output-translations () + "Initialize output translations in a way that maps every file to itself, +effectively disabling the output translation facility." + (initialize-output-translations + '(:output-translations :disable-cache :ignore-inherited-configuration))) + + ;; checks an initial variable to see whether the state is initialized + ;; or cleared. In the former case, return current configuration; in + ;; the latter, initialize. ASDF will call this function at the start + ;; of (asdf:find-system). + (defun ensure-output-translations () + (if (output-translations-initialized-p) + (output-translations) + (initialize-output-translations))) + + + ;; Top-level entry-point to _use_ output-translations + (defun apply-output-translations (path) + (etypecase path + (logical-pathname + path) + ((or pathname string) + (ensure-output-translations) + (loop :with p = (resolve-symlinks* path) + :for (source destination) :in (car *output-translations*) + :for root = (when (or (eq source t) + (and (pathnamep source) + (not (absolute-pathname-p source)))) + (pathname-root p)) + :for absolute-source = (cond + ((eq source t) (wilden root)) + (root (merge-pathnames* source root)) + (t source)) + :when (or (eq source t) (pathname-match-p p absolute-source)) + :return (translate-pathname* p absolute-source destination root source) + :finally (return p))))) + + + ;; Hook into uiop's output-translation mechanism + #-cormanlisp + (setf *output-translation-function* 'apply-output-translations) + + + ;;; Implementation-dependent hacks + #+abcl ;; ABCL: make it possible to use systems provided in the ABCL jar. + (defun translate-jar-pathname (source wildcard) + (declare (ignore wildcard)) + (flet ((normalize-device (pathname) + (if (find :windows *features*) + pathname + (make-pathname :defaults pathname :device :unspecific)))) + (let* ((jar + (pathname (first (pathname-device source)))) + (target-root-directory-namestring + (format nil "/___jar___file___root___/~@[~A/~]" + (and (find :windows *features*) + (pathname-device jar)))) + (relative-source + (relativize-pathname-directory source)) + (relative-jar + (relativize-pathname-directory (ensure-directory-pathname jar))) + (target-root-directory + (normalize-device + (pathname-directory-pathname + (parse-namestring target-root-directory-namestring)))) + (target-root + (merge-pathnames* relative-jar target-root-directory)) + (target + (merge-pathnames* relative-source target-root))) + (normalize-device (apply-output-translations target)))))) + +;;;; ----------------------------------------------------------------- +;;;; Source Registry Configuration, by Francois-Rene Rideau +;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 + +(uiop/package:define-package :asdf/source-registry + ;; NB: asdf/find-system allows upgrade from <=3.2.1 that have initialize-source-registry there + (:recycle :asdf/source-registry :asdf/find-system :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/system :asdf/system-registry) + (:export + #:*source-registry-parameter* #:*default-source-registries* + #:invalid-source-registry + #:source-registry-initialized-p + #:initialize-source-registry #:clear-source-registry #:*source-registry* + #:ensure-source-registry #:*source-registry-parameter* + #:*default-source-registry-exclusions* #:*source-registry-exclusions* + #:*wild-asd* #:directory-asd-files #:register-asd-directory + #:*recurse-beyond-asds* #:collect-asds-in-directory #:collect-sub*directories-asd-files + #:validate-source-registry-directive #:validate-source-registry-form + #:validate-source-registry-file #:validate-source-registry-directory + #:parse-source-registry-string #:wrapping-source-registry + #:default-user-source-registry #:default-system-source-registry + #:user-source-registry #:system-source-registry + #:user-source-registry-directory #:system-source-registry-directory + #:environment-source-registry #:process-source-registry #:inherit-source-registry + #:compute-source-registry #:flatten-source-registry + #:sysdef-source-registry-search)) +(in-package :asdf/source-registry) + +(with-upgradability () + (define-condition invalid-source-registry (invalid-configuration warning) + ((format :initform (compatfmt "~@")))) + + ;; Default list of directories under which the source-registry tree search won't recurse + (defvar *default-source-registry-exclusions* + '(;;-- Using ack 1.2 exclusions + ".bzr" ".cdv" + ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards + ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" + "_sgbak" "autom4te.cache" "cover_db" "_build" + ;;-- debian often builds stuff under the debian directory... BAD. + "debian")) + + ;; Actual list of directories under which the source-registry tree search won't recurse + (defvar *source-registry-exclusions* *default-source-registry-exclusions*) + + ;; The state of the source-registry after search in configured locations + (defvar *source-registry* nil + "Either NIL (for uninitialized), or an equal hash-table, mapping +system names to pathnames of .asd files") + + ;; Saving the user-provided parameter to the source-registry, if any, + ;; so we can recompute the source-registry after code upgrade. + (defvar *source-registry-parameter* nil) + + (defun source-registry-initialized-p () + (typep *source-registry* 'hash-table)) + + (defun clear-source-registry () + "Undoes any initialization of the source registry." + (setf *source-registry* nil) + (values)) + (register-clear-configuration-hook 'clear-source-registry) + + (defparameter *wild-asd* + (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) + + (defun directory-asd-files (directory) + (directory-files directory *wild-asd*)) + + (defun collect-asds-in-directory (directory collect) + (let ((asds (directory-asd-files directory))) + (map () collect asds) + asds)) + + (defvar *recurse-beyond-asds* t + "Should :tree entries of the source-registry recurse in subdirectories +after having found a .asd file? True by default.") + + ;; When walking down a filesystem tree, if in a directory there is a .cl-source-registry.cache, + ;; read its contents instead of further recursively querying the filesystem. + (defun process-source-registry-cache (directory collect) + (let ((cache (ignore-errors + (safe-read-file-form (subpathname directory ".cl-source-registry.cache"))))) + (when (and (listp cache) (eq :source-registry-cache (first cache))) + (loop :for s :in (rest cache) :do (funcall collect (subpathname directory s))) + t))) + + (defun collect-sub*directories-asd-files + (directory &key (exclude *default-source-registry-exclusions*) collect + (recurse-beyond-asds *recurse-beyond-asds*) ignore-cache) + (let ((visited (make-hash-table :test 'equalp))) + (flet ((collectp (dir) + (unless (and (not ignore-cache) (process-source-registry-cache dir collect)) + (let ((asds (collect-asds-in-directory dir collect))) + (or recurse-beyond-asds (not asds))))) + (recursep (x) ; x will be a directory pathname + (and + (not (member (car (last (pathname-directory x))) exclude :test #'equal)) + (flet ((pathname-key (x) + (namestring (truename* x)))) + (let ((visitedp (gethash (pathname-key x) visited))) + (if visitedp nil + (setf (gethash (pathname-key x) visited) t))))))) + (collect-sub*directories directory #'collectp #'recursep (constantly nil))))) + + + ;;; Validate the configuration forms + + (defun validate-source-registry-directive (directive) + (or (member directive '(:default-registry)) + (and (consp directive) + (let ((rest (rest directive))) + (case (first directive) + ((:include :directory :tree) + (and (length=n-p rest 1) + (location-designator-p (first rest)))) + ((:exclude :also-exclude) + (every #'stringp rest)) + ((:default-registry) + (null rest))))))) + + (defun validate-source-registry-form (form &key location) + (validate-configuration-form + form :source-registry 'validate-source-registry-directive + :location location :invalid-form-reporter 'invalid-source-registry)) + + (defun validate-source-registry-file (file) + (validate-configuration-file + file 'validate-source-registry-form :description "a source registry")) + + (defun validate-source-registry-directory (directory) + (validate-configuration-directory + directory :source-registry 'validate-source-registry-directive + :invalid-form-reporter 'invalid-source-registry)) + + + ;;; Parse the configuration string + + (defun parse-source-registry-string (string &key location) + (cond + ((or (null string) (equal string "")) + '(:source-registry :inherit-configuration)) + ((not (stringp string)) + (error (compatfmt "~@") string)) + ((find (char string 0) "\"(") + (validate-source-registry-form (read-from-string string) :location location)) + (t + (loop + :with inherit = nil + :with directives = () + :with start = 0 + :with end = (length string) + :with separator = (inter-directory-separator) + :for pos = (position separator string :start start) :do + (let ((s (subseq string start (or pos end)))) + (flet ((check (dir) + (unless (absolute-pathname-p dir) + (error (compatfmt "~@") string)) + dir)) + (cond + ((equal "" s) ; empty element: inherit + (when inherit + (error (compatfmt "~@") + string)) + (setf inherit t) + (push ':inherit-configuration directives)) + ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix? + (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) + (t + (push `(:directory ,(check s)) directives)))) + (cond + (pos + (setf start (1+ pos))) + (t + (unless inherit + (push '(:ignore-inherited-configuration) directives)) + (return `(:source-registry ,@(nreverse directives)))))))))) + + (defun register-asd-directory (directory &key recurse exclude collect) + (if (not recurse) + (collect-asds-in-directory directory collect) + (collect-sub*directories-asd-files + directory :exclude exclude :collect collect))) + + (defparameter* *default-source-registries* + '(environment-source-registry + user-source-registry + user-source-registry-directory + default-user-source-registry + system-source-registry + system-source-registry-directory + default-system-source-registry) + "List of default source registries" "3.1.0.102") + + (defparameter *source-registry-file* (parse-unix-namestring "common-lisp/source-registry.conf")) + (defparameter *source-registry-directory* (parse-unix-namestring "common-lisp/source-registry.conf.d/")) + + (defun wrapping-source-registry () + `(:source-registry + #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) + :inherit-configuration + #+mkcl (:tree ,(translate-logical-pathname "SYS:")) + #+cmucl (:tree #p"modules:") + #+scl (:tree #p"file://modules/"))) + (defun default-user-source-registry () + `(:source-registry + (:tree (:home "common-lisp/")) + #+sbcl (:directory (:home ".sbcl/systems/")) + (:directory ,(xdg-data-home "common-lisp/systems/")) + (:tree ,(xdg-data-home "common-lisp/source/")) + :inherit-configuration)) + (defun default-system-source-registry () + `(:source-registry + ,@(loop :for dir :in (xdg-data-dirs "common-lisp/") + :collect `(:directory (,dir "systems/")) + :collect `(:tree (,dir "source/"))) + :inherit-configuration)) + (defun user-source-registry (&key (direction :input)) + (xdg-config-pathname *source-registry-file* direction)) + (defun system-source-registry (&key (direction :input)) + (find-preferred-file (system-config-pathnames *source-registry-file*) + :direction direction)) + (defun user-source-registry-directory (&key (direction :input)) + (xdg-config-pathname *source-registry-directory* direction)) + (defun system-source-registry-directory (&key (direction :input)) + (find-preferred-file (system-config-pathnames *source-registry-directory*) + :direction direction)) + (defun environment-source-registry () + (getenv "CL_SOURCE_REGISTRY")) + + + ;;; Process the source-registry configuration + + (defgeneric process-source-registry (spec &key inherit register)) + + (defun inherit-source-registry (inherit &key register) + (when inherit + (process-source-registry (first inherit) :register register :inherit (rest inherit)))) + + (defun process-source-registry-directive (directive &key inherit register) + (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) + (ecase kw + ((:include) + (destructuring-bind (pathname) rest + (process-source-registry (resolve-location pathname) :inherit nil :register register))) + ((:directory) + (destructuring-bind (pathname) rest + (when pathname + (funcall register (resolve-location pathname :ensure-directory t))))) + ((:tree) + (destructuring-bind (pathname) rest + (when pathname + (funcall register (resolve-location pathname :ensure-directory t) + :recurse t :exclude *source-registry-exclusions*)))) + ((:exclude) + (setf *source-registry-exclusions* rest)) + ((:also-exclude) + (appendf *source-registry-exclusions* rest)) + ((:default-registry) + (inherit-source-registry + '(default-user-source-registry default-system-source-registry) :register register)) + ((:inherit-configuration) + (inherit-source-registry inherit :register register)) + ((:ignore-inherited-configuration) + nil))) + nil) + + (defmethod process-source-registry ((x symbol) &key inherit register) + (process-source-registry (funcall x) :inherit inherit :register register)) + (defmethod process-source-registry ((pathname pathname) &key inherit register) + (cond + ((directory-pathname-p pathname) + (let ((*here-directory* (resolve-symlinks* pathname))) + (process-source-registry (validate-source-registry-directory pathname) + :inherit inherit :register register))) + ((probe-file* pathname :truename *resolve-symlinks*) + (let ((*here-directory* (pathname-directory-pathname pathname))) + (process-source-registry (validate-source-registry-file pathname) + :inherit inherit :register register))) + (t + (inherit-source-registry inherit :register register)))) + (defmethod process-source-registry ((string string) &key inherit register) + (process-source-registry (parse-source-registry-string string) + :inherit inherit :register register)) + (defmethod process-source-registry ((x null) &key inherit register) + (inherit-source-registry inherit :register register)) + (defmethod process-source-registry ((form cons) &key inherit register) + (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) + (dolist (directive (cdr (validate-source-registry-form form))) + (process-source-registry-directive directive :inherit inherit :register register)))) + + + ;; Flatten the user-provided configuration into an ordered list of directories and trees + (defun flatten-source-registry (&optional (parameter *source-registry-parameter*)) + (remove-duplicates + (while-collecting (collect) + (with-pathname-defaults () ;; be location-independent + (inherit-source-registry + `(wrapping-source-registry + ,parameter + ,@*default-source-registries*) + :register #'(lambda (directory &key recurse exclude) + (collect (list directory :recurse recurse :exclude exclude)))))) + :test 'equal :from-end t)) + + ;; MAYBE: move this utility function to uiop/pathname and export it? + (defun pathname-directory-depth (p) + (length (normalize-pathname-directory-component (pathname-directory p)))) + + (defun preferred-source-path-p (x y) + "Return T iff X is to be preferred over Y as a source path" + (let ((lx (pathname-directory-depth x)) + (ly (pathname-directory-depth y))) + (or (< lx ly) + (and (= lx ly) + (string< (namestring x) + (namestring y)))))) + + ;; Will read the configuration and initialize all internal variables. + (defun compute-source-registry (&optional (parameter *source-registry-parameter*) + (registry *source-registry*)) + (dolist (entry (flatten-source-registry parameter)) + (destructuring-bind (directory &key recurse exclude) entry + (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates + (register-asd-directory + directory :recurse recurse :exclude exclude :collect + #'(lambda (asd) + (let* ((name (pathname-name asd)) + (name (if (typep asd 'logical-pathname) + ;; logical pathnames are upper-case, + ;; at least in the CLHS and on SBCL, + ;; yet (coerce-name :foo) is lower-case. + ;; won't work well with (load-system "Foo") + ;; instead of (load-system 'foo) + (string-downcase name) + name))) + (unless (gethash name registry) ; already shadowed by something else + (if-let (old (gethash name h)) + ;; If the name appears multiple times, + ;; prefer the one with the shallowest directory, + ;; or if they have same depth, compare unix-namestring with string< + (multiple-value-bind (better worse) + (if (preferred-source-path-p asd old) + (progn (setf (gethash name h) asd) (values asd old)) + (values old asd)) + (when *verbose-out* + (warn (compatfmt "~@") + directory recurse name better worse))) + (setf (gethash name h) asd)))))) + (maphash #'(lambda (k v) (setf (gethash k registry) v)) h)))) + (values)) + + (defun initialize-source-registry (&optional (parameter *source-registry-parameter*)) + ;; Record the parameter used to configure the registry + (setf *source-registry-parameter* parameter) + ;; Clear the previous registry database: + (setf *source-registry* (make-hash-table :test 'equal)) + ;; Do it! + (compute-source-registry parameter)) + + ;; Checks an initial variable to see whether the state is initialized + ;; or cleared. In the former case, return current configuration; in + ;; the latter, initialize. ASDF will call this function at the start + ;; of (asdf:find-system) to make sure the source registry is initialized. + ;; However, it will do so *without* a parameter, at which point it + ;; will be too late to provide a parameter to this function, though + ;; you may override the configuration explicitly by calling + ;; initialize-source-registry directly with your parameter. + (defun ensure-source-registry (&optional parameter) + (unless (source-registry-initialized-p) + (initialize-source-registry parameter)) + (values)) + + (defun sysdef-source-registry-search (system) + (ensure-source-registry) + (values (gethash (primary-system-name system) *source-registry*)))) + + +;;;; ------------------------------------------------------------------------- +;;; Internal hacks for backward-compatibility + +(uiop/package:define-package :asdf/backward-internals + (:recycle :asdf/backward-internals :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) + (:export #:load-sysdef)) +(in-package :asdf/backward-internals) + +(with-asdf-deprecation (:style-warning "3.2" :warning "3.4") + (defun load-sysdef (name pathname) + (declare (ignore name pathname)) + ;; Needed for backward compatibility with swank-asdf from SLIME 2015-12-01 or older. + (error "Use asdf:load-asd instead of asdf::load-sysdef"))) +;;;; ------------------------------------------------------------------------- +;;; Backward-compatible interfaces + +(uiop/package:define-package :asdf/backward-interface + (:recycle :asdf/backward-interface :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/system :asdf/system-registry :asdf/operation :asdf/action + :asdf/lisp-action :asdf/plan :asdf/operate + :asdf/find-system :asdf/parse-defsystem :asdf/output-translations :asdf/bundle) + (:export + #:*asdf-verbose* + #:operation-error #:compile-error #:compile-failed #:compile-warned + #:error-component #:error-operation #:traverse + #:component-load-dependencies + #:enable-asdf-binary-locations-compatibility + #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings + #:component-property + #:run-shell-command + #:system-definition-pathname #:system-registered-p #:require-system + #:explain + #+ecl #:make-build)) +(in-package :asdf/backward-interface) + +;; NB: the warning status of these functions may have to be distinguished later, +;; as some get removed faster than the others in client code. +(with-asdf-deprecation (:style-warning "3.2" :warning "3.4") + + ;; These conditions from ASDF 1 and 2 are used by many packages in Quicklisp; + ;; but ASDF3 replaced them with somewhat different variants of uiop:compile-condition + ;; that do not involve ASDF actions. + ;; TODO: find the offenders and stop them. + (progn + (define-condition operation-error (error) ;; Bad, backward-compatible name + ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel + ((component :reader error-component :initarg :component) + (operation :reader error-operation :initarg :operation)) + (:report (lambda (c s) + (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") + (type-of c) (error-operation c) (error-component c))))) + (define-condition compile-error (operation-error) ()) + (define-condition compile-failed (compile-error) ()) + (define-condition compile-warned (compile-error) ())) + + ;; In Quicklisp 2015-05, still used by lisp-executable, staple, repl-utilities, cffi + (defun component-load-dependencies (component) ;; from ASDF 2.000 to 2.26 + "DEPRECATED. Please use COMPONENT-SIDEWAY-DEPENDENCIES instead; or better, +define your operations with proper use of SIDEWAY-OPERATION, SELFWARD-OPERATION, +or define methods on PREPARE-OP, etc." + ;; Old deprecated name for the same thing. Please update your software. + (component-sideway-dependencies component)) + + ;; These old interfaces from ASDF1 have never been very meaningful + ;; but are still used in obscure places. + ;; In Quicklisp 2015-05, still used by cl-protobufs and clx. + (defgeneric operation-on-warnings (operation) + (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead.")) + (defgeneric operation-on-failure (operation) + (:documentation "DEPRECATED. Please use UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead.")) + (defgeneric (setf operation-on-warnings) (x operation) + (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-WARNINGS-BEHAVIOUR* instead.")) + (defgeneric (setf operation-on-failure) (x operation) + (:documentation "DEPRECATED. Please SETF UIOP:*COMPILE-FILE-FAILURE-BEHAVIOUR* instead.")) + (progn + (defmethod operation-on-warnings ((o operation)) + *compile-file-warnings-behaviour*) + (defmethod operation-on-failure ((o operation)) + *compile-file-failure-behaviour*) + (defmethod (setf operation-on-warnings) (x (o operation)) + (setf *compile-file-warnings-behaviour* x)) + (defmethod (setf operation-on-failure) (x (o operation)) + (setf *compile-file-failure-behaviour* x))) + + ;; Quicklisp 2015-05: Still used by SLIME's swank-asdf (!), common-lisp-stat, + ;; js-parser, osicat, babel, staple, weblocks, cl-png, plain-odbc, autoproject, + ;; cl-blapack, com.informatimago, cells-gtk3, asdf-dependency-grovel, + ;; cl-glfw, cffi, jwacs, montezuma + (defun system-definition-pathname (x) + ;; As of 2.014.8, we mean to make this function obsolete, + ;; but that won't happen until all clients have been updated. + "DEPRECATED. This function used to expose ASDF internals with subtle +differences with respect to user expectations, that have been refactored +away since. We recommend you use ASDF:SYSTEM-SOURCE-FILE instead for a +mostly compatible replacement that we're supporting, or even +ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME +if that's whay you mean." ;;) + (system-source-file x)) + + ;; TRAVERSE is the function used to compute a plan in ASDF 1 and 2. + ;; It was never officially exposed but some people still used it. + (defgeneric traverse (operation component &key &allow-other-keys) + (:documentation + "DEPRECATED. Use MAKE-PLAN and PLAN-ACTIONS, or REQUIRED-COMPONENTS, +or some other supported interface instead. + +Generate and return a plan for performing OPERATION on COMPONENT. + +The plan returned is a list of dotted-pairs. Each pair is the CONS +of ASDF operation object and a COMPONENT object. The pairs will be +processed in order by OPERATE.")) + (progn + (define-convenience-action-methods traverse (operation component &key))) + (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys) + (plan-actions (apply 'make-plan plan-class o c keys))) + + + ;; ASDF-Binary-Locations compatibility + ;; This remains supported for legacy user, but not recommended for new users. + ;; We suspect there are no more legacy users in 2016. + (defun enable-asdf-binary-locations-compatibility + (&key + (centralize-lisp-binaries nil) + (default-toplevel-directory + ;; Use ".cache/common-lisp/" instead ??? + (subpathname (user-homedir-pathname) ".fasls/")) + (include-per-user-information nil) + (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil)) + (source-to-target-mappings nil) + (file-types `(,(compile-file-type) + "build-report" + #+clasp (compile-file-type :output-type :object) + #+ecl (compile-file-type :type :object) + #+mkcl (compile-file-type :fasl-p nil) + #+clisp "lib" #+sbcl "cfasl" + #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) + "DEPRECATED. Use asdf-output-translations instead." + #+(or clasp clisp ecl mkcl) + (when (null map-all-source-files) + (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) + (let* ((patterns (if map-all-source-files (list *wild-file*) + (loop :for type :in file-types + :collect (make-pathname :type type :defaults *wild-file*)))) + (destination-directory + (if centralize-lisp-binaries + `(,default-toplevel-directory + ,@(when include-per-user-information + (cdr (pathname-directory (user-homedir-pathname)))) + :implementation ,*wild-inferiors*) + `(:root ,*wild-inferiors* :implementation)))) + (initialize-output-translations + `(:output-translations + ,@source-to-target-mappings + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) + #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory)) + ,@(loop :for pattern :in patterns + :collect `((:root ,*wild-inferiors* ,pattern) + (,@destination-directory ,pattern))) + (t t) + :ignore-inherited-configuration)))) + (progn + (defmethod operate :before (operation-class system &rest args &key &allow-other-keys) + (declare (ignore operation-class system args)) + (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil) + (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. +ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, +which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, +and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. +In case you insist on preserving your previous A-B-L configuration, but +do not know how to achieve the same effect with A-O-T, you may use function +ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; +call that function where you would otherwise have loaded and configured A-B-L.")))) + + + ;; run-shell-command from ASDF 2, lightly fixed from ASDF 1, copied from MK-DEFSYSTEM. Die! + (defun run-shell-command (control-string &rest args) + "PLEASE DO NOT USE. This function is not just DEPRECATED, but also dysfunctional. +Please use UIOP:RUN-PROGRAM instead." + #-(and ecl os-windows) + (let ((command (apply 'format nil control-string args))) + (asdf-message "; $ ~A~%" command) + (let ((exit-code + (ignore-errors + (nth-value 2 (run-program command :force-shell t :ignore-error-status t + :output *verbose-out*))))) + (typecase exit-code + ((integer 0 255) exit-code) + (t 255)))) + #+(and ecl os-windows) + (not-implemented-error "run-shell-command" "for ECL on Windows.")) + + ;; HOW do we get rid of variables??? With a symbol-macro that issues a warning? + ;; In Quicklisp 2015-05, cl-protobufs still uses it, but that should be fixed in next version. + (progn + (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. + + ;; Do NOT use in new code. NOT SUPPORTED. + ;; NB: When this goes away, remove the slot PROPERTY in COMPONENT. + ;; In Quicklisp 2014-05, it's still used by yaclml, amazon-ecs, blackthorn-engine, cl-tidy. + ;; See TODO for further cleanups required before to get rid of it. + (defgeneric component-property (component property)) + (defgeneric (setf component-property) (new-value component property)) + + (defmethod component-property ((c component) property) + (cdr (assoc property (slot-value c 'properties) :test #'equal))) + + (defmethod (setf component-property) (new-value (c component) property) + (let ((a (assoc property (slot-value c 'properties) :test #'equal))) + (if a + (setf (cdr a) new-value) + (setf (slot-value c 'properties) + (acons property new-value (slot-value c 'properties))))) + new-value) + + + ;; This method survives from ASDF 1, but really it is superseded by action-description. + (defgeneric explain (operation component) + (:documentation "Display a message describing an action. + +DEPRECATED. Use ASDF:ACTION-DESCRIPTION and/or ASDF::FORMAT-ACTION instead.")) + (progn + (define-convenience-action-methods explain (operation component))) + (defmethod explain ((o operation) (c component)) + (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%") (action-description o c)))) + +(with-asdf-deprecation (:style-warning "3.3") + (defun system-registered-p (name) + "DEPRECATED. Return a generalized boolean that is true if a system of given NAME was registered already. +NAME is a system designator, to be normalized by COERCE-NAME. +The value returned if true is a pair of a timestamp and a system object." + (if-let (system (registered-system name)) + (cons (if-let (primary-system (registered-system (primary-system-name name))) + (component-operation-time 'define-op primary-system)) + system))) + + (defun require-system (system &rest keys &key &allow-other-keys) + "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the +system or its dependencies if it has already been loaded." + (declare (ignore keys)) + (unless (component-loaded-p system) + (load-system system)))) + +;;; This function is for backward compatibility with ECL only. +#+ecl +(with-asdf-deprecation (:style-warning "3.2" :warning "9999") + (defun make-build (system &rest args + &key (monolithic nil) (type :fasl) (move-here nil move-here-p) + prologue-code epilogue-code no-uiop + prefix-lisp-object-files postfix-lisp-object-files extra-object-files + &allow-other-keys) + (let* ((operation (asdf/bundle::select-bundle-operation type monolithic)) + (move-here-path (if (and move-here + (typep move-here '(or pathname string))) + (ensure-pathname move-here :namestring :lisp :ensure-directory t) + (system-relative-pathname system "asdf-output/"))) + (extra-build-args (remove-plist-keys + '(:monolithic :type :move-here + :prologue-code :epilogue-code :no-uiop + :prefix-lisp-object-files :postfix-lisp-object-files + :extra-object-files) + args)) + (build-system (if (subtypep operation 'image-op) + (eval `(defsystem "asdf.make-build" + :class program-system + :source-file nil + :pathname ,(system-source-directory system) + :build-operation ,operation + :build-pathname ,(subpathname move-here-path + (file-namestring (first (output-files operation system)))) + :depends-on (,(coerce-name system)) + :prologue-code ,prologue-code + :epilogue-code ,epilogue-code + :no-uiop ,no-uiop + :prefix-lisp-object-files ,prefix-lisp-object-files + :postfix-lisp-object-files ,postfix-lisp-object-files + :extra-object-files ,extra-object-files + :extra-build-args ,extra-build-args)) + system)) + (files (output-files operation build-system))) + (operate operation build-system) + (if (or move-here + (and (null move-here-p) (member operation '(program-op image-op)))) + (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path)) + :for f :in files + :for new-f = (make-pathname :name (pathname-name f) + :type (pathname-type f) + :defaults dest-path) + :do (rename-file-overwriting-target f new-f) + :collect new-f) + files)))) +;;;; --------------------------------------------------------------------------- +;;;; Handle ASDF package upgrade, including implementation-dependent magic. + +(uiop/package:define-package :asdf/interface + (:nicknames :asdf :asdf-utilities) + (:recycle :asdf/interface :asdf) + (:unintern + #:loaded-systems ; makes for annoying SLIME completion + #:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session + :asdf/component :asdf/system :asdf/system-registry :asdf/find-component + :asdf/operation :asdf/action :asdf/lisp-action + :asdf/output-translations :asdf/source-registry + :asdf/forcing :asdf/plan :asdf/operate :asdf/find-system :asdf/parse-defsystem + :asdf/bundle :asdf/concatenate-source + :asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system) + ;; Note: (1) we are NOT automatically reexporting everything from previous packages. + ;; (2) we only reexport UIOP functionality when backward-compatibility requires it. + (:export + #:defsystem #:find-system #:load-asd #:locate-system #:coerce-name + #:primary-system-name #:primary-system-p + #:oos #:operate #:make-plan #:perform-plan #:sequential-plan + #:system-definition-pathname + #:search-for-system-definition #:find-component #:component-find-path + #:compile-system #:load-system #:load-systems #:load-systems* + #:require-system #:test-system #:clear-system + #:operation #:make-operation #:find-operation + #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation + #:non-propagating-operation + #:build-op #:make + #:load-op #:prepare-op #:compile-op + #:prepare-source-op #:load-source-op #:test-op #:define-op + #:feature #:version #:version-satisfies #:upgrade-asdf + #:implementation-identifier #:implementation-type #:hostname + #:component-depends-on ; backward-compatible name rather than action-depends-on + #:input-files #:additional-input-files + #:output-files #:output-file #:perform #:perform-with-restarts + #:operation-done-p #:explain #:action-description #:component-sideway-dependencies + #:needed-in-image-p + #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system + #:program-system + #:basic-compile-bundle-op #:prepare-bundle-op + #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op + #:lib-op #:dll-op #:deliver-asd-op #:program-op #:image-op + #:monolithic-lib-op #:monolithic-dll-op #:monolithic-deliver-asd-op + #:concatenate-source-op + #:load-concatenated-source-op + #:compile-concatenated-source-op + #:load-compiled-concatenated-source-op + #:monolithic-concatenate-source-op + #:monolithic-load-concatenated-source-op + #:monolithic-compile-concatenated-source-op + #:monolithic-load-compiled-concatenated-source-op + #:operation-monolithic-p + #:required-components + #:component-loaded-p + #:component #:parent-component #:child-component #:system #:module + #:file-component #:source-file #:c-source-file #:java-source-file + #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp + #:static-file #:doc-file #:html-file + #:file-type #:source-file-type + #:register-preloaded-system #:sysdef-preloaded-system-search + #:register-immutable-system #:sysdef-immutable-system-search + #:package-inferred-system #:register-system-packages + #:component-children + #:component-children-by-name + #:component-pathname + #:component-relative-pathname + #:component-name + #:component-version + #:component-parent + #:component-system + #:component-encoding + #:component-external-format + #:system-description + #:system-long-description + #:system-author + #:system-maintainer + #:system-license + #:system-licence + #:system-version + #:system-source-file + #:system-source-directory + #:system-relative-pathname + #:system-homepage + #:system-mailto + #:system-bug-tracker + #:system-long-name + #:system-source-control + #:map-systems + #:system-defsystem-depends-on + #:system-depends-on + #:system-weakly-depends-on + #:*system-definition-search-functions* ; variables + #:*central-registry* + #:*compile-file-warnings-behaviour* + #:*compile-file-failure-behaviour* + #:*resolve-symlinks* + #:*verbose-out* + #:asdf-version + #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error + #:compile-warned-warning #:compile-failed-warning + #:error-name + #:error-pathname + #:load-system-definition-error + #:error-component #:error-operation + #:system-definition-error + #:missing-component + #:missing-component-of-version + #:missing-dependency + #:missing-dependency-of-version + #:circular-dependency ; errors + #:duplicate-names #:non-toplevel-system #:non-system-system #:bad-system-name #:system-out-of-date + #:package-inferred-system-missing-package-error + #:operation-definition-warning #:operation-definition-error + #:try-recompiling ; restarts + #:retry + #:accept + #:coerce-entry-to-directory + #:remove-entry-from-registry + #:clear-configuration-and-retry + #:*encoding-detection-hook* + #:*encoding-external-format-hook* + #:*default-encoding* + #:*utf-8-external-format* + #:clear-configuration + #:*output-translations-parameter* + #:initialize-output-translations + #:disable-output-translations + #:clear-output-translations + #:ensure-output-translations + #:apply-output-translations + #:compile-file* + #:compile-file-pathname* + #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check + #:enable-asdf-binary-locations-compatibility + #:*default-source-registries* + #:*source-registry-parameter* + #:initialize-source-registry + #:compute-source-registry + #:clear-source-registry + #:ensure-source-registry + #:process-source-registry + #:registered-system #:registered-systems #:already-loaded-systems + #:resolve-location + #:asdf-message + #:*user-cache* + #:user-output-translations-pathname + #:system-output-translations-pathname + #:user-output-translations-directory-pathname + #:system-output-translations-directory-pathname + #:user-source-registry + #:system-source-registry + #:user-source-registry-directory + #:system-source-registry-directory + + ;; The symbols below are all DEPRECATED, do not use. To be removed in a further release. + #:*asdf-verbose* #:run-shell-command + #:component-load-dependencies #:system-registered-p #:package-system + #+ecl #:make-build + #:operation-on-warnings #:operation-on-failure #:operation-error + #:compile-failed #:compile-warned #:compile-error + #:module-components #:component-property #:traverse)) +;;;; --------------------------------------------------------------------------- +;;;; ASDF-USER, where the action happens. + +(uiop/package:define-package :asdf/user + (:nicknames :asdf-user) + ;; NB: releases before 3.1.2 this :use'd only uiop/package instead of uiop below. + ;; They also :use'd uiop/common-lisp, that reexports common-lisp and is not included in uiop. + ;; ASDF3 releases from 2.27 to 2.31 called uiop asdf-driver and asdf/foo uiop/foo. + ;; ASDF1 and ASDF2 releases (2.26 and earlier) create a temporary package + ;; that only :use's :cl and :asdf + (:use :uiop/common-lisp :uiop :asdf/interface)) +;;;; ----------------------------------------------------------------------- +;;;; ASDF Footer: last words and cleanup + +(uiop/package:define-package :asdf/footer + (:recycle :asdf/footer :asdf) + (:use :uiop/common-lisp :uiop + :asdf/system ;; used by ECL + :asdf/upgrade :asdf/system-registry :asdf/operate :asdf/bundle) + ;; Happily, all those implementations all have the same module-provider hook interface. + #+(or abcl clasp cmucl clozure ecl mezzano mkcl sbcl) + (:import-from #+abcl :sys #+(or clasp cmucl ecl) :ext #+clozure :ccl #+mkcl :mk-ext #+sbcl sb-ext #+mezzano :sys.int + #:*module-provider-functions* + #+ecl #:*load-hooks*) + #+(or clasp mkcl) (:import-from :si #:*load-hooks*)) + +(in-package :asdf/footer) + +;;;; Register ASDF itself and all its subsystems as preloaded. +(with-upgradability () + (dolist (s '("asdf" "uiop" "asdf-package-system")) + ;; Don't bother with these system names, no one relies on them anymore: + ;; "asdf-utils" "asdf-bundle" "asdf-driver" "asdf-defsystem" + (register-preloaded-system s :version *asdf-version*))) + + +;;;; Hook ASDF into the implementation's REQUIRE and other entry points. +#+(or abcl clasp clisp clozure cmucl ecl mezzano mkcl sbcl) +(with-upgradability () + ;; Hook into CL:REQUIRE. + #-clisp (pushnew 'module-provide-asdf *module-provider-functions*) + #+clisp (if-let (x (find-symbol* '#:*module-provider-functions* :custom nil)) + (eval `(pushnew 'module-provide-asdf ,x))) + + #+(or clasp ecl mkcl) + (progn + (pushnew '("fasb" . si::load-binary) *load-hooks* :test 'equal :key 'car) + + #+os-windows + (unless (assoc "asd" *load-hooks* :test 'equal) + (appendf *load-hooks* '(("asd" . si::load-source)))) + + ;; Wrap module provider functions in an idempotent, upgrade friendly way + (defvar *wrapped-module-provider* (make-hash-table)) + (setf (gethash 'module-provide-asdf *wrapped-module-provider*) 'module-provide-asdf) + (defun wrap-module-provider (provider name) + (let ((results (multiple-value-list (funcall provider name)))) + (when (first results) (register-preloaded-system (coerce-name name))) + (values-list results))) + (defun wrap-module-provider-function (provider) + (ensure-gethash provider *wrapped-module-provider* + (constantly + #'(lambda (module-name) + (wrap-module-provider provider module-name))))) + (setf *module-provider-functions* + (mapcar #'wrap-module-provider-function *module-provider-functions*)))) + +#+cmucl ;; Hook into the CMUCL herald. +(with-upgradability () + (defun herald-asdf (stream) + (format stream " ASDF ~A" (asdf-version))) + (setf (getf ext:*herald-items* :asdf) '(herald-asdf))) + + +;;;; Done! +(with-upgradability () + #+allegro ;; restore *w-o-n-r-c* setting as saved in uiop/common-lisp + (when (boundp 'excl:*warn-on-nested-reader-conditionals*) + (setf excl:*warn-on-nested-reader-conditionals* uiop/common-lisp::*acl-warn-save*)) + + ;; Advertise the features we provide. + (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf3.2 :asdf3.3)) (pushnew f *features*)) + + ;; Provide both lowercase and uppercase, to satisfy more people, especially LispWorks users. + (provide "asdf") (provide "ASDF") + + ;; Finally, call a function that will cleanup in case this is an upgrade of an older ASDF. + (cleanup-upgraded-asdf)) + +(when *load-verbose* + (asdf-message ";; ASDF, version ~a~%" (asdf-version))) diff --git a/swh/loader/core/tests/test_loader.py b/swh/loader/core/tests/test_loader.py --- a/swh/loader/core/tests/test_loader.py +++ b/swh/loader/core/tests/test_loader.py @@ -1,4 +1,4 @@ -# Copyright (C) 2018-2021 The Software Heritage developers +# Copyright (C) 2018-2022 The Software Heritage developers # See the AUTHORS file at the top-level directory of this distribution # License: GNU General Public License version 3, or any later version # See top-level LICENSE file for more information @@ -15,6 +15,7 @@ SENTRY_ORIGIN_URL_TAG_NAME, SENTRY_VISIT_TYPE_TAG_NAME, BaseLoader, + ContentLoader, DVCSLoader, ) from swh.loader.core.metadata_fetchers import MetadataFetcherProtocol @@ -306,10 +307,12 @@ assert save_path == expected_save_path -def _check_load_failure(caplog, loader, exc_class, exc_text, status="partial"): +def _check_load_failure( + caplog, loader, exc_class, exc_text, status="partial", origin=ORIGIN +): """Check whether a failed load properly logged its exception, and that the snapshot didn't get referenced in storage""" - assert isinstance(loader, DVCSLoader) # was implicit so far + assert isinstance(loader, (DVCSLoader, ContentLoader)) # was implicit so far for record in caplog.records: if record.levelname != "ERROR": continue @@ -319,11 +322,12 @@ assert isinstance(exc, exc_class) assert exc_text in exc.args[0] - # Check that the get_snapshot operation would have succeeded - assert loader.get_snapshot() is not None + if isinstance(loader, DVCSLoader): + # Check that the get_snapshot operation would have succeeded + assert loader.get_snapshot() is not None # And confirm that the visit doesn't reference a snapshot - visit = assert_last_visit_matches(loader.storage, ORIGIN.url, status) + visit = assert_last_visit_matches(loader.storage, origin.url, status) if status != "partial": assert visit.snapshot is None # But that the snapshot didn't get loaded @@ -503,3 +507,92 @@ sentry_tags = sentry_events[0]["tags"] assert sentry_tags.get(SENTRY_ORIGIN_URL_TAG_NAME) == ORIGIN.url assert sentry_tags.get(SENTRY_VISIT_TYPE_TAG_NAME) == DummyLoader.visit_type + + +CONTENT_MIRROR = "https://common-lisp.net" +CONTENT_URL = f"{CONTENT_MIRROR}/project/asdf/archives/asdf-3.3.5.lisp" + + +def test_content_loader_missing_field(swh_storage): + origin = Origin(CONTENT_URL) + with pytest.raises(ValueError, match="Mandatory field"): + ContentLoader(swh_storage, origin.url) + + +def test_content_loader_404(caplog, swh_storage, requests_mock_datadir): + unknown_origin = Origin(f"{CONTENT_MIRROR}/project/asdf/archives/unknown.lisp") + loader = ContentLoader( + swh_storage, unknown_origin.url, integrity="sha256-unusedfornow" + ) + result = loader.load() + + assert result == {"status": "uneventful"} + + _check_load_failure( + caplog, + loader, + NotFound, + "Unknown origin", + status="not_found", + origin=unknown_origin, + ) + + +def test_content_loader_404_with_fallback(caplog, swh_storage, requests_mock_datadir): + unknown_origin = Origin(f"{CONTENT_MIRROR}/project/asdf/archives/unknown.lisp") + fallback_url_ko = f"{CONTENT_MIRROR}/project/asdf/archives/unknown2.lisp" + loader = ContentLoader( + swh_storage, + unknown_origin.url, + fallback_urls=[fallback_url_ko], + integrity="sha256-unusedfornow", + ) + result = loader.load() + + assert result == {"status": "uneventful"} + + _check_load_failure( + caplog, + loader, + NotFound, + "Unknown origin", + status="not_found", + origin=unknown_origin, + ) + + +def test_content_loader_ok_with_fallback(caplog, swh_storage, requests_mock_datadir): + dead_origin = Origin(f"{CONTENT_MIRROR}/dead-origin-url") + fallback_url_ok = CONTENT_URL + fallback_url_ko = f"{CONTENT_MIRROR}/project/asdf/archives/unknown2.lisp" + + loader = ContentLoader( + swh_storage, + dead_origin.url, + fallback_urls=[fallback_url_ok, fallback_url_ko], + integrity="sha256-0HwaD0oDEfgwRDj0ooiVOxXnoZG1qYLDiwq4EWP2zdc=", + ) + result = loader.load() + + assert result == {"status": "eventful"} + + +def test_content_loader_ok_simple(swh_storage, requests_mock_datadir): + origin = Origin(CONTENT_URL) + loader = ContentLoader( + swh_storage, + origin.url, + integrity="sha256-0HwaD0oDEfgwRDj0ooiVOxXnoZG1qYLDiwq4EWP2zdc=", + ) + result = loader.load() + + assert result == {"status": "eventful"} + + visit_status = assert_last_visit_matches( + swh_storage, origin.url, status="full", type="content" + ) + assert visit_status.snapshot is not None + + result2 = loader.load() + + assert result2 == {"status": "uneventful"}