Restore Distribution

[RWK@fuji.ila.com (Robert W. Kerns)]

    Date: Mon, 22 Oct 90 11:50 EDT
    From: barmar@think.com (Barry Margolin)

	Date: Sat, 20 Oct 90 13:02:50 EDT
	From: rwtucker@starbase.MITRE.ORG (Richard W. Tucker)

	    Date: Tue, 16 Oct 90 17:38:37 EDT
	    From: orgren@RTC.Reston.Unisys.COM (Paul Orgren)

	    Just having gone through loading Genera 8.0, I would argue that the
	    "Restore Distribution" ...
				       To de-select .IBIN files and ...

	I suppose you could define the logical pathname Sys: **; *.ibin to
	translate to a null device...  but I don't know how to create a
	Symbolics pathname that works as a null device.  I've wanted one on
	occasion.

    There is no null file system in Genera, although there's a null stream
    (#'SYS:NULL-STREAM).  If you have a Unix file server and you're using
    FTP to access it you could translate sys:**;*.ibin to unix:/dev/null
    (this won't work if you're using NFS, as it doesn't support remote
    access to device files).

						    barmar
It's not hard to add.  I once had a implementation of things like access to
buffers, windows, etc., but this was never installed because of some feeling
that "you shouldn't do things like this via pathnames, you should have a user
interface".  Thus we have weird bits of ui like the :Output Destination CP
command.

;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: FILE-SYSTEM; Lowercase: T -*-


(defflavor null-pathname () (no-device-mixin case-pathname-mixin pathname))

(defvar *null-pathname*)

(defmethod (:fully-merged-p null-pathname) ()
  t)

(defmethod (pathname-file-access-path null-pathname) (operation)
  (declare (ignore operation))
  self)

;; Circular dependency; have to define this method before we can initialize
;; this variable.

(defmethod (:parse-namestring null-pathname) (&rest ignore)
  *null-pathname*)

(defmethod (:string-for-printing null-pathname) ()
  "NULL:")

(macrolet ((pathname-methods (&rest methods)
	     (let ((defs ()))
	       (dolist (m methods)
		 (push `(defmethod (,m null-pathname) (&rest ignore)
			  *null-pathname*)
		       defs))
	       `(progn ,@(reverse defs))))
	   (null-methods (&rest methods)
	     (let ((defs ()))
	       (dolist (m methods)
		 (push `(defmethod (,m null-pathname) (&rest ignore)
			  nil)
		       defs))
	       `(progn ,@(reverse defs))))
	   (error-methods (&rest methods)
	     (let ((defs ()))
	       (dolist (m methods)
		 (push `(defmethod (,m null-pathname) (&rest ignore)
			  (error "You can't do ~S on a null host." ',m))
		       defs))
	       `(progn ,@(reverse defs)))))
  (pathname-methods :homedir :quiet-homedir)
  (null-methods :all-directories :delete :directory-list :expunge
		:multiple-file-plists :properties)
  (error-methods :change-properties :rename :undelete))

(defmethod (:complete-string null-pathname) (default-pathname string options)
  (declare (ignore default-pathname string options))
  "NULL:")

;;; This seems to not be used.
(defmethod (:open null-pathname) (pathname &key &allow-other-keys)
  (declare (ignore pathname))
  'si:null-stream)

(defmethod (file-access-path-open null-pathname) (&key &allow-other-keys)
  'si:null-stream)

(defflavor null-host () (host-null-mixin active-pathname-host net:basic-host))

(defflavor host-null-mixin () (net:pathname-host-mixin)
  (:required-flavors net:basic-host))

(defmethod (:get-pathname host-null-mixin) (dev dir nam typ vrs others)
  (declare (ignore dev dir nam typ vrs others))
  *null-pathname*)

(defmethod (:pathname-flavor null-host) ()
  'null-pathname)

(defmethod (:name null-host) ()
  "NULL")

(defmethod (:system-type null-host) ()
  :null)

(defmethod (neti:pathname-host-get-pathname null-host) (dev dir nam type vrs other vc-brunch vc-diversion)
  (declare (ignore dev dir nam type vrs other vc-brunch vc-diversion))
  *null-pathname*)

(defvar *null-host* (make-instance 'null-host))

(unless (boundp '*null-pathname*)
  (setq *null-pathname* (make-instance 'null-pathname
				       :host *null-host*
				       :device :unspecific
				       :directory nil
				       :name ""
				       :type :unspecific
				       :version :unspecific)))


(unless (member *null-host* *pathname-host-list*)
  (push *null-host* *pathname-host-list*))

(unless (assoc *null-host* *default-pathname-defaults*)
  (let ((default (default-pathname)))
    (set-default-pathname *null-pathname*)
    (set-default-pathname default)))