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