Commit f8ef0d2c authored by Didier Verna's avatar Didier Verna
Browse files

Restore qlmapper's copyright, prettify.

parent 4ad51af5
;; Shamelessly copied and adapted from:
;; https://github.com/xach/qlmapper
;;; qrmapper.lisp --- Lisp code mapper over every Quicklisp system/release
;; Copyright (C) 2012 Zachary Beane
;; Copyright (C) 2018 EPITA Research and Development Laboratory
;; Author: Zachary Beane
;; Maintainer: Antoine Martin <antoine4.martin@epita.fr>
;; This file is part of Quickref.
;; 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.
;;; Comment:
;; Adapted from https://github.com/xach/qlmapper.
;;; Code:
(in-package quickref)
(defvar *sbcl-program* sb-ext:*runtime-pathname*)
(defvar *init-file* (merge-pathnames "qrmapper-init.lisp"
......@@ -13,15 +47,15 @@
(defun eval-defvar-forms (environment-pairs)
(loop for (name value) on environment-pairs by #'cddr
for sym = (format nil "cl-user::~A" name)
collect "--eval"
collect (format nil "(defvar ~A (sb-posix:getenv ~S))" sym name)
collect "--eval"
collect (format nil "(export '~A '#:cl-user)" sym)))
for sym = (format nil "cl-user::~A" name)
collect "--eval"
collect (format nil "(defvar ~A (sb-posix:getenv ~S))" sym name)
collect "--eval"
collect (format nil "(export '~A '#:cl-user)" sym)))
(defun environment-list (environment-pairs)
(loop for (name value) on environment-pairs by #'cddr
collect (format nil "~A=~A" name value)))
collect (format nil "~A=~A" name value)))
(defun flatlist (&rest args)
(alexandria:flatten args))
......@@ -38,18 +72,18 @@
(eval-defvar-forms environment-pairs)
"--eval"
(format nil "(setf cl:*default-pathname-defaults* ~
#p~S)"
(native-truename *default-pathname-defaults*))
#p~S)"
(native-truename *default-pathname-defaults*))
"--load"
(native-truename *init-file*)
(when pre-file
(list "--load" (native-truename pre-file)))
(mapcar (lambda (eval)
(list "--eval" eval))
evals)
evals)
"--eval"
(format nil "(defparameter *remove-cache* ~S)"
*remove-cache*)
*remove-cache*)
"--load" (native-truename file))
:environment (append (environment-list environment-pairs)
(sb-ext:posix-environ))
......@@ -80,7 +114,7 @@
(base-directory (ql-dist:release system))))
(defun map-objects (file
&key dist-name function (filter 'identity) evals pre-file)
&key dist-name function (filter 'identity) evals pre-file)
(unless (probe-file file)
(error "~S does not exist" file))
(let ((dist (ql-dist:find-dist dist-name)))
......@@ -88,11 +122,11 @@
(error "~S does not name any known dist" dist-name))
(let ((objects (funcall function dist)))
(dolist (object objects)
(let ((name (ql-dist:name object)))
(when (funcall filter name)
(ql-dist:ensure-installed object)
(let ((*default-pathname-defaults*
(base-directory object)))
(let ((name (ql-dist:name object)))
(when (funcall filter name)
(ql-dist:ensure-installed object)
(let ((*default-pathname-defaults*
(base-directory object)))
(log-sbcl name
:file file
:pre-file pre-file
......@@ -102,15 +136,15 @@
:evals evals))))))))
(defun map-releases (file &key (dist-name "quicklisp") (filter 'identity)
pre-file)
pre-file)
"For each release in a dist (defaults to the \"quicklisp\" dist),
start an independent SBCL process and load FILE with the variable
CL-USER:*QRMAPPER-OBJECT-NAME* bound to the release's name."
(map-objects file
:pre-file pre-file
:dist-name dist-name
:function #'ql-dist:provided-releases
:filter filter))
:pre-file pre-file
:dist-name dist-name
:function #'ql-dist:provided-releases
:filter filter))
(defun map-objects-thread (file mutex waitqueue
&key dist-name function (filter 'identity) evals pre-file)
......@@ -121,11 +155,11 @@
(error "~S does not name any known dist" dist-name))
(let ((objects (funcall function dist)))
(dolist (object objects)
(let ((name (ql-dist:name object)))
(when (funcall filter name)
(ql-dist:ensure-installed object)
(let ((*default-pathname-defaults*
(base-directory object)))
(let ((name (ql-dist:name object)))
(when (funcall filter name)
(ql-dist:ensure-installed object)
(let ((*default-pathname-defaults*
(base-directory object)))
(log-sbcl name
:file file
:pre-file pre-file
......@@ -139,7 +173,7 @@
(defun map-releases-thread (file mutex waitqueue
&key (dist-name "quicklisp") (filter 'identity)
pre-file)
pre-file)
"For each release in a dist (defaults to the \"quicklisp\" dist),
start an independent SBCL process and load FILE with the variable
CL-USER:*QRMAPPER-OBJECT-NAME* bound to the release's name.
......@@ -153,3 +187,5 @@
:dist-name dist-name
:function #'ql-dist:provided-releases
:filter filter))
;;; qrmapper.lisp ends here
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment