From 43ece156979ffdff9f3edc1c48889416cb5ba9b5 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Tue, 11 May 2010 18:34:43 -0400 Subject: [PATCH] Remove desperately outdated files. Show a good example: use (require :asdf) instead or (require 'asdf). --- .gitignore | 1 + asdf-install.lisp | 299 --------------------------------------------- cclan-package.lisp | 5 - cclan.asd | 8 -- cclan.lisp | 99 --------------- wild-modules.lisp | 2 +- 6 files changed, 2 insertions(+), 412 deletions(-) delete mode 100644 asdf-install.lisp delete mode 100644 cclan-package.lisp delete mode 100644 cclan.asd delete mode 100644 cclan.lisp diff --git a/.gitignore b/.gitignore index e9fba8a7..4c372176 100644 --- a/.gitignore +++ b/.gitignore @@ -3,6 +3,7 @@ push resbcl reccl reecl +regcl # Temporary files from documentation build doc/asdf/ diff --git a/asdf-install.lisp b/asdf-install.lisp deleted file mode 100644 index 9813f29c..00000000 --- a/asdf-install.lisp +++ /dev/null @@ -1,299 +0,0 @@ -#|| sh asdf-install.lisp will compile this file to an exe called asdf-install -sbcl <<EOF -(require 'sb-executable) -(compile-file "asdf-install.lisp") -(sb-executable:make-executable "asdf-install" *) -EOF -exit 0 -||# - -;;; Install an ASDF system or anything else that looks convincingly -;;; like one, including updating symlink for all the toplevel .asd files it -;;; contains - -;;; If the file $HOME/.asdf-install exists, it is loaded. This can be -;;; used to override the default values of exported special variables -;;; (see the defpackage form for details) - however, most of them are -;;; sensible and/or taken from the environment anyway - -#|| -TODO: -a) gpg signature checking would be better if it actually checked against -a list of "trusted to write Lisp" keys, instead of just "trusted to be -who they say they are" - -d) in sbcl 0.8.1 we'll have a run-program that knows about $PATH and so -won't need to hardcode gpgpgpgp and tar locations. - -e) nice to have: resume half-done downloads instead of starting from scratch -every time. but right now we're dealing in fairly small packages, this is not -an immediate concern - -||# -(in-package :cl-user) -(eval-when (:compile-toplevel :load-toplevel :execute) - (require 'asdf) - (require 'sb-posix) - (require 'sb-executable) - (require 'sb-bsd-sockets)) - -(defpackage :asdf-install - (:use "CL" "SB-EXT" "SB-BSD-SOCKETS") - (:export #:*proxy* #:*cclan-mirror* #:*sbcl-home* - #:*verify-gpg-signatures* #:*locations*)) - -(defpackage :asdf-install-customize - (:use "CL" "SB-EXT" "SB-BSD-SOCKETS" "ASDF-INSTALL")) - -(in-package :asdf-install) - -(defvar *proxy* (posix-getenv "http_proxy")) -(defvar *cclan-mirror* - (or (posix-getenv "CCLAN_MIRROR") - "http://ftp.linux.org.uk/pub/lisp/cclan/")) - -(defun directorify (name) - ;; input name may or may not have a training #\/, but we know we - ;; want a directory - (let ((path (pathname name))) - (if (pathname-name path) - (merge-pathnames - (make-pathname :directory `(:relative ,(pathname-name path)) - :name "") - path) - path))) - -(defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME"))) -(defvar *dot-sbcl* - (merge-pathnames (make-pathname :directory '(:relative ".sbcl")) - (user-homedir-pathname))) - -(defvar *verify-gpg-signatures* t) - -(defvar *locations* - `((,(merge-pathnames "site/" *sbcl-home*) - ,(merge-pathnames "site-systems/" *sbcl-home*) - "System-wide install") - (,(merge-pathnames "site/" *dot-sbcl*) - ,(merge-pathnames "systems/" *dot-sbcl*) - "Personal installation"))) - -(let* ((*package* (find-package :asdf-install-customize)) - (file (probe-file (merge-pathnames - (make-pathname :name ".asdf-install") - (user-homedir-pathname))))) - (when file (load file))) - -(define-condition download-error (error) - ((url :initarg :url :reader download-url) - (response :initarg :response :reader download-response)) - (:report (lambda (c s) - (format s "Server responded ~A for GET ~A" - (download-response c) (download-url c))))) - -(define-condition signature-error (error) - ((cause :initarg :cause :reader signature-error-cause)) - (:report (lambda (c s) - (format s "Cannot verify package signature: ~A" - (signature-error-cause c))))) - -(defun url-host (url) - (assert (string-equal url "http://" :end1 7)) - (let* ((port-start (position #\: url :start 7)) - (host-end (min (or (position #\/ url :start 7) (length url)) - (or port-start (length url))))) - (subseq url 7 host-end))) - -(defun url-port (url) - (assert (string-equal url "http://" :end1 7)) - (let ((port-start (position #\: url :start 7))) - (if port-start (parse-integer url :start port-start :junk-allowed t) 80))) - -(defun url-connection (url) - (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) - (host (url-host url)) - (port (url-port url))) - (socket-connect - s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url))))) - (url-port (or *proxy* url))) - (let ((stream (socket-make-stream s :input t :output t :buffering :full))) - ;; we are exceedingly unportable about proper line-endings here. - ;; Anyone wishing to run this under non-SBCL should take especial care - (format stream "GET ~A HTTP/1.0~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%" - url host *cclan-mirror*) - (force-output stream) - (list - (let* ((l (read-line stream)) - (space (position #\Space l))) - (parse-integer l :start (1+ space) :junk-allowed t)) - (loop for line = (read-line stream nil nil) - until (or (null line) (eql (elt line 0) (code-char 13))) - collect - (let ((colon (position #\: line))) - (cons (intern (string-upcase (subseq line 0 colon)) :keyword) - (string-trim (list #\Space (code-char 13)) - (subseq line (1+ colon)))))) - stream)))) - -(defun download (package-name-or-url file-name) - (let ((url - (if (= (mismatch package-name-or-url "http://") 7) - package-name-or-url - (format nil "http://www.cliki.net/~A?download" - package-name-or-url)))) - (destructuring-bind (response headers stream) - (block got - (loop - (destructuring-bind (response headers stream) (url-connection url) - (unless (member response '(301 302)) - (return-from got (list response headers stream))) - (close stream) - (setf url (cdr (assoc :location headers)))))) - (if (>= response 400) - (error 'download-error :url url :response response)) - (let ((length (parse-integer - (or (cdr (assoc :content-length headers)) "") - :junk-allowed t))) - (format t "Downloading ~A bytes from ~A ..." - (if length length "some unknown number of") url) - (force-output) - (with-open-file (o file-name :direction :output) - (if length - (let ((buf (make-array length - :element-type - (stream-element-type stream) ))) - (read-sequence buf stream) - (write-sequence buf o)) - (sb-executable:copy-stream stream o)))) - (close stream) - (terpri) - ;; seems to have worked. let's try for a detached gpg signature too - (when *verify-gpg-signatures* - (verify-gpg-signature url file-name))))) - -(defun verify-gpg-signature (url file-name) - (destructuring-bind (response headers stream) - (url-connection (concatenate 'string url ".asc")) - (declare (ignore headers)) - (unwind-protect - (if (= response 200) - ;; sadly, we can't pass the stream directly to run-program, - ;; because (at least in sbcl 0.8) that ignores existing buffered - ;; data and only reads new fresh data direct from the file - ;; descriptor - (let ((data (make-string (parse-integer - (cdr (assoc :content-length headers)) - :junk-allowed t)))) - (read-sequence data stream) - (let ((ret - (process-exit-code - (sb-ext:run-program "/usr/bin/gpg" - (list "--verify" "-" - (namestring file-name)) - :output t - :input (make-string-input-stream data) - :wait t)))) - (unless (zerop ret) - (error 'signature-error - :cause (make-condition - 'simple-error - :format-control "GPG returned exit status ~A" - :format-arguments (list ret)))))) - (error 'signature-error - :cause - (make-condition - 'download-error :url (concatenate 'string url ".asc") - :response response))) - (close stream)))) - - - - -(defun where () - (format t "Install where?~%") - (loop for (source system name) in *locations* - for i from 1 - do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%" - i name system source)) - (format t " --> ") (force-output) - (let ((response (read))) - (when (> response 0) - (elt *locations* (1- response))))) - -(defun install (source system packagename) - "Returns a list of asdf system names for installed asdf systems" - (ensure-directories-exist source ) - (ensure-directories-exist system ) - (let* ((tar - (with-output-to-string (o) - (or - (sb-ext:run-program "/bin/tar" - (list "-C" (namestring source) - "-xzvf" (namestring packagename)) - :output o - :wait t) - (error "can't untar")))) - (dummy (princ tar)) - (pos-slash (position #\/ tar)) - (*default-pathname-defaults* - (merge-pathnames - (make-pathname :directory - `(:relative ,(subseq tar 0 pos-slash))) - source))) - (loop for asd in (directory - (make-pathname :name :wild :type "asd")) - do (let ((target (merge-pathnames - (make-pathname :name (pathname-name asd) - :type (pathname-type asd)) - system))) - (when (probe-file target) - (sb-posix:unlink target)) - (sb-posix:symlink asd target)) - collect (pathname-name asd)))) - -(defvar *temporary-files*) -(defun temp-file-name (p) - (let* ((pos-slash (position #\/ p :from-end t)) - (pos-dot (position #\. p :start (or pos-slash 0)))) - (merge-pathnames - (make-pathname - :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot) - :type "asdf-install-tmp")))) - - - -(defun run (&optional (packages (cdr *posix-argv*))) - (destructuring-bind (source system name) (where) - (labels ((one-iter (packages) - (dolist (asd - (loop for p in packages - unless (probe-file p) - do (let ((tmp (temp-file-name p))) - (pushnew tmp *temporary-files*) - (download p tmp) - (setf p tmp)) - end - do (format t "Installing ~A in ~A,~A~%" p source system) - append (install source system p))) - (handler-case - (asdf:operate 'asdf:load-op asd) - (asdf:missing-dependency (c) - (format t "Downloading package ~A, required by ~A~%" - (asdf::missing-requires c) - (asdf:component-name (asdf::missing-required-by c))) - (one-iter (list - (symbol-name (asdf::missing-requires c))))))))) - (one-iter packages)))) - -(handler-case - (let ((*temporary-files* nil)) - (unwind-protect - (run) - (dolist (l *temporary-files*) - (when (probe-file l) (delete-file l))))) - (error (c) - (princ "Install failed due to error:") (terpri) - (princ c) (terpri) - (quit :unix-status 1))) - -;(quit) \ No newline at end of file diff --git a/cclan-package.lisp b/cclan-package.lisp deleted file mode 100644 index a00d6040..00000000 --- a/cclan-package.lisp +++ /dev/null @@ -1,5 +0,0 @@ -(in-package :cl-user) - -(defpackage :cclan (:use #:cl #:asdf) - (:export #:all-components #:write-package)) - diff --git a/cclan.asd b/cclan.asd deleted file mode 100644 index 7f0c3b0f..00000000 --- a/cclan.asd +++ /dev/null @@ -1,8 +0,0 @@ -;;; -*- Lisp -*- -(defpackage :cclan-system (:use #:cl #:asdf)) -(in-package :cclan-system) - -(defsystem cclan - :version "0.1" - :components ((:file "cclan-package") - (:file "cclan" :depends-on ("cclan-package")))) diff --git a/cclan.lisp b/cclan.lisp deleted file mode 100644 index 9b31fb45..00000000 --- a/cclan.lisp +++ /dev/null @@ -1,99 +0,0 @@ -(in-package :cclan) - -;;;; This file contains functions, classes etc that are not part of -;;;; asdf itself, but extend it in various ways useful for maintainers -;;;; of new-style cCLan packages - -;;;; The public interface consists of the functions whose symbols are -;;;; exported from the package - -;;;; This file does not contain references to asdf internals - or -;;;; shouldn't, anyway. Send bug reports - - -(defun mapappend (function list) - (let ((f (coerce function 'function))) - (loop for i in list append (funcall f i)))) - -(defgeneric all-components (component)) -(defmethod all-components ((source-file source-file)) - (list source-file)) - -(defmethod all-components ((module module)) - (cons module (mapappend #'all-components (module-components module)))) - -(defmethod all-components ((module symbol)) - (all-components (find-system module))) - -(defun cvs-tag-name (system) - (let* ((system (find-system system)) - (version (component-version system))) - (format nil "release_~A" (substitute #\_ #\. version)))) - -(defun cvs-tag (system) - (let* ((system (find-system system)) - (directory (component-pathname system))) - (run-shell-command "cd ~A && cvs tag -F ~A" - (namestring directory) (cvs-tag-name system)))) - - -(defun write-readme-file (stream suggested-registry system-name) - "Write a README.install file detailing a possible sequence of commands to use the newly-untarred system." - (format stream "~ -1. Make a symlink in ~W[*] pointing to the .asd file -2. Start your asdf-enabled lisp -2a. Ensure that ~W[*] is in asdf:*central-registry* -3. At the lisp prompt, type '(asdf:operate 'asdf:load-op ~W)'. This - will compile and load the system into your running lisp. - -[*] This path (~W) is only a suggestion; the important -thing is that asdf know where to find the .asd file. asdf uses the -contents of the variable ASDF:*CENTRAL-REGISTRY* to find its system -definitions. - -These instructions were automatically generated by cCLan software. Use -at your own peril.~%" suggested-registry suggested-registry system-name suggested-registry)) - -(defun write-package (system) - (let* ((parent-dir - (parse-namestring - (format nil "/tmp/~A.~A/" - #+sbcl (sb-unix:unix-getpid) - #-sbcl (random 1000000) - (get-internal-run-time)))) - (system (find-system system)) - (sub-dir-name - (format nil "~A_~A" - (component-name system) (component-version system))) - (cvsroot-file - (merge-pathnames "CVS/Root" (component-pathname system))) - (old-pwd *default-pathname-defaults*) - (*default-pathname-defaults* parent-dir)) - (ensure-directories-exist parent-dir) - (cvs-tag system) - (and - (zerop (asdf:run-shell-command - "cd ~A && cvs -d `cat ~A` checkout -d ~A -r ~A -kv ~A" - (namestring parent-dir) - (namestring cvsroot-file) - sub-dir-name - (cvs-tag-name system) - (component-name system))) - (with-open-file (o (format nil "~A/INSTALL.asdf" sub-dir-name) - :direction :output) - (write-readme-file o "$HOME/lisp/systems/" (component-name system)) - t) - (zerop (asdf:run-shell-command "cd ~A && tar cf ~A~A.tar ~A" - (namestring parent-dir) - (namestring old-pwd) sub-dir-name - sub-dir-name)) - (zerop (asdf:run-shell-command - "gzip -f9 ~A~A.tar" - (namestring old-pwd) sub-dir-name)) - (format t "Now run~% gpg -b -a ~A~A.tar.gz~%in a shell with a tty" - (namestring old-pwd) sub-dir-name)))) - -(defun class-name-of (x) - (class-name (class-of x))) - - diff --git a/wild-modules.lisp b/wild-modules.lisp index 2649d7ef..7a8267d0 100644 --- a/wild-modules.lisp +++ b/wild-modules.lisp @@ -33,6 +33,6 @@ use a wild pathname instead." module))) files))))) ;; Don't export wild-module or else will get a full warning -;; when (require 'asdf) if asdf is already loaded +;; when (require :asdf) if asdf is already loaded ;;(export '(wild-module)) -- GitLab