RELAY.ARPA> Subject: Explorer Pathnames on Symbolics To: info-explorer@sumex-aim.arpa CC: Davies@sumex-aim.arpa, acuff@sumex-aim.arpa, statz@ausome I haven't had time to completely test this, but the following seems to do well in providing Explorer pathname support on Symbolics machines running Release 6.0 software. Let me know if you have any problems (or, even better, if you have any enhancements to this). Dan Cerys [Cerys%TI-CSL@CSNet-Relay] ------------------------------------------------- ;;; -*- Mode: LISP; Package: FILE-SYSTEM; Base: 10; Patch-File: Yes;-*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1984,1985, Texas Instruments Incorporated. All rights reserved. ;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;;;This file provides support for Explorer (and LMI) pathnames on Symbolics machines. ;;;In dealing with Explorer hosts, use Explorer syntax (eg Host:D1.D2;Filename.Type#Version) ;;; ;;;How do you specify which syntax to use for which host? ;;;This is really up to you. ;;;Alternatives: - A table of the MIT (or LMFS) hosts ;;; - Use the host name for differentiation (kludge method below) ;;; - Assign a user property to each host of a given syntax (preferred method) ;;; ;;;Note that this code is not a supported TI product. ;;; ;;; To install this patch, just do two things: ;;; 1) Edit your Symbolics namespace as indicated in the :PATHNAME-FLAVOR below. ;;; 2) Compile and load this file. ;;; ;;; To get this file onto your Symbolics, even though your Symbolics can't talk to ;;; an Explorer, you can copy files from an Explorer to a Symbolics if the copy is ;;; done on an Explorer that knows the correct address of the Symbolics machine. ;;; ****************************************** ;;; This first method is the non-trivial part. ;;; Using the Symbolics namespace editor, you must place a property either on ;;; all of your Symbolics, or on all of your Explorers. ;;; Using the following method, you must add a USER PROPERTY called LMFS-SYNTAX ;;; (no colon) on every Symbolics in your namespace that will be installing this ;;; patch. ;;; ****************************************** (DEFMETHOD (lispm-host :pathname-flavor) () "The important thing here is that this method return the correct flavor name, based on what SELF is." (IF (SEND self :user-get :lmfs-syntax) 'lmfs-pathname 'explorer-pathname)) ;; Old method (kludge to use if you call your Symbolics by names like Sym1, Sym2...) ;(DEFMETHOD (lispm-host :pathname-flavor) () ; (COND ((CHAR-EQUAL #/s (AREF (STRING (SEND SELF ':name)) 0.)) 'lmfs-pathname) ; (t 'explorer-pathname))) (SETQ fs:*use-full-parser* t) (DEFFLAVOR explorer-pathname () (lmfs-pathname)) ;Inherit it all (DEFMETHOD (explorer-pathname :valid-directory-p) (dirname) (TYPECASE dirname (:string t) (:symbol (MEMQ dirname '(nil :wild :root))) (:list (AND (OR (NEQ (CAR dirname) :wild-inferiors) (NOT (SEND self :root-always-explicit-p))) (SEND self ':valid-subdirectory-p dirname 0))))) (DEFUN-METHOD explorer-type-string explorer-pathname () (string-or-wild type)) (DEFUN-METHOD explorer-version-string explorer-pathname () (SELECTQ version (nil nil) (:newest ">") (:oldest "<") (:wild "*") (otherwise version))) (DEFUN-METHOD explorer-directory-string explorer-pathname () "Allows the use of multi-level directories." (COND ((LISTP directory) (LET ((temp-directory (REMQ ':relative directory))) ;Remove relative components. (not used) (FORMAT nil "~a~{.~a~}" (FIRST temp-directory) (CDR temp-directory)))) (t (string-or-wild directory)))) (DEFMETHOD (explorer-pathname :character-needs-quoting-p) (ch) ch nil) (DEFMETHOD (explorer-pathname :string-for-directory) () (LET ((default-cons-area pathname-area)) (FORMAT nil "~A;" (explorer-directory-string)))) (DEFMETHOD (explorer-pathname :string-for-dired) () (LET ((nam (string-or-wild name)) (typ (explorer-type-string)) (ver (explorer-version-string)) (default-cons-area pathname-area)) (FORMAT nil "~:[~A~;~*~]~:[.~A~;~*~]~:[#~D~;~*~]" (NULL nam) nam (NULL typ) typ (NULL ver) ver))) (DEFMETHOD (explorer-pathname :string-for-editor) () (LET ((dir (explorer-directory-string)) (nam (string-or-wild name)) (typ (explorer-type-string)) (ver (explorer-version-string)) (default-cons-area pathname-area)) (FORMAT nil "~:[~A~;~*~]~:[.~A~;~*~]~:[#~D~;~*~] ~:[~A;~;~*~] ~a:" (NULL nam) nam (NULL typ) typ (NULL ver) ver (NULL directory) dir (FUNCALL host ':name-as-file-computer)))) (DEFMETHOD (explorer-pathname :string-for-host) () (LET ((dir (IF (MEMQ directory '(:wild :root)) "~" (explorer-directory-string))) (nam (string-or-wild name)) (typ (explorer-type-string)) (ver (explorer-version-string)) (default-cons-area pathname-area)) (FORMAT nil "~A:~:[~A;~;~*~]~:[~A~;~*~]~:[.~A~;~*~]~:[/#~D~;~*~]" (FUNCALL host ':name-as-file-computer) (NULL directory) dir (NULL nam) nam (NULL typ) typ (NULL ver) ver))) (DEFMETHOD (explorer-pathname :string-for-printing) () (LET ((dir (explorer-directory-string)) (nam (string-or-wild name)) (typ (explorer-type-string)) (ver (explorer-version-string)) (default-cons-area pathname-area)) (FORMAT nil "~A:~:[~A;~;~*~]~:[~A~;~*~]~:[.~A~;~*~]~:[/#~D~;~*~]" (FUNCALL host ':name-as-file-computer) (NULL directory) dir (NULL nam) nam (NULL typ) typ (NULL ver) ver))) (DEFMETHOD (explorer-pathname :parse-namestring) (IGNORE namestring &optional (start 0) end) "Provides smarter parsing than the old version." (explorer-parse-namestring namestring start end)) (DEFWHOPPER (explorer-pathname :new-pathname) (&rest args) (LET* ((new-pathname (LEXPR-CONTINUE-WHOPPER args)) (directory-list (SEND new-pathname :directory))) (WHEN (AND (LISTP directory-list) (MEMQ :relative directory-list)) (SETQ new-pathname (SEND new-pathname :new-pathname :directory (REMQ :relative directory-list)))) new-pathname)) (COMPILE-FLAVOR-METHODS explorer-pathname) (DEFUN explorer-parse-namestring (STRING &optional (start 0) end &aux char state tem tem1 field-start (device "dsk") directory name type version) ;; STATE can be T, DOTTED, VERSION, DIRECTORY or NIL. ;; NIL is the initial state, and means anything is allowed and nothing is in progress. ;; T means that we are in the middle of a name, but nothing else special. ;; DOTTED means we have encountered a single period. TEM is what preceded it. ;; DOUBLE-DOTTED means we have encountered "name.name." ;; TEM is the first name and TEM1 is the second. ;; DIRECTORY means we have encountered "name . name . name" ;; which can only be the beginning of a directory name, ;; or else that we have encountered a "<". ;; VERSION means reading a version number (following a #). (OR end (SETQ end (ARRAY-ACTIVE-LENGTH string))) (DO ((index start (1+ index))) (nil) (IF (>= index end) (SETQ char 'done) (SETQ char (AREF string index))) (COND ((AND (NOT (MEMQ char '(#\sp #\tab #/. #/: #/; #/# done))) (OR (NOT (MEMQ char '(#/< #/>))) (MEMQ state '(version double-dotted)))) (AND (%STORE-CONDITIONAL (LOCF state) nil t) (SETQ field-start index)) (COND ((OR (EQ char #//) (EQ char #\circle-plus)) (SETQ index (1+ index)) (OR (< index end) (explorer-char-error string 'done)) (SETQ char (AREF string index)) (AND (>= char #o200) (NOT (= char #\tab)) (explorer-char-error string char))))) ((EQ char #\<) (COND ((NULL state)) ;Extraneous whitespace. ((EQ state t) (SETQ name (explorer-field string field-start index))) ((EQ state 'dotted) (AND tem (SETQ name tem)) (SETQ type (explorer-field string field-start index))) ((EQ state 'double-dotted) (AND tem (SETQ name tem)) (AND tem1 (SETQ type tem1)) (SETQ version (explorer-field string field-start index t))) (t (explorer-char-error string char))) (SETQ state 'DIRECTORY directory nil) (GO new-field)) ((MEMQ char '(#\sp #\tab done)) (COND ((NULL state)) ;Extraneous whitespace. ((EQ state t) (SETQ name (explorer-field string field-start index) state nil)) ((EQ state 'dotted) (AND tem (SETQ name tem)) (SETQ type (explorer-field string field-start index) state nil)) ((EQ state 'double-dotted) (AND tem (SETQ name tem)) (AND tem1 (SETQ type tem1)) (SETQ version (explorer-field string field-start index t) state nil) (COND ((EQ version 0) (SETQ version ':newest)) ((EQ version -2) (SETQ version ':oldest)))) ((EQ state 'version) (SETQ version (explorer-field string field-start index t) state nil)) (t (explorer-char-error string char)))) ((EQ char #/.) (COND ((NULL state) ;Could only be :UNSPECIFIC name (SETQ tem nil state 'dotted)) ((EQ state t) ;Could either be directory or name (SETQ state 'dotted tem (explorer-field string field-start index))) ((EQ state 'dotted) (OR tem (explorer-char-error string #/.)) (SETQ tem1 (explorer-field string field-start index) state 'double-dotted)) ((EQ state 'double-dotted) (OR tem (explorer-char-error string #/.)) (SETQ state 'DIRECTORY directory (LIST* tem tem1 (explorer-field string field-start index) nil))) ((EQ state 'DIRECTORY) (SETQ directory (NCONC directory (NCONS (explorer-field string field-start index))))) ((EQ state 'version) (SETQ version (explorer-field string field-start index t) state 'dotted)) (t (explorer-char-error string char))) (GO new-field)) ((EQ char #/#) (COND ((NULL state) (SETQ state 'version)) ((EQ state t) (SETQ name (explorer-field string field-start index) state 'version)) ((EQ state 'dotted) (AND tem (SETQ name tem)) (SETQ type (explorer-field string field-start index) state 'version)) (t (explorer-char-error string char))) (GO new-field)) ((OR (EQ char #/;) (EQ char #/>)) (COND ((EQ state t) (SETQ directory (explorer-field string field-start index)) (IF (STRING-EQUAL directory "~") (SETQ directory ':root))) ((EQ state 'dotted) (OR tem (explorer-char-error string char)) (SETQ directory (LIST tem (explorer-field string field-start index)))) ((EQ state 'double-dotted) (OR (AND tem tem1) (explorer-char-error string char)) (SETQ directory (LIST tem tem1 (explorer-field string field-start index)))) ((EQ state 'DIRECTORY) (LET ((field (explorer-field string field-start index))) (IF (AND (NULL directory) (EQ field ':unspecific)) (SETQ directory ':root) (SETQ directory (NCONC directory (LIST field)))))) (t (explorer-char-error string char))) (SETQ state nil)) ((EQ state t) (SETQ device ;(FUNCALL-SELF ':PARSE-DEVICE-SPEC ; (EXPLORER-FIELD STRING FIELD-START INDEX)) ':unspecific state nil)) (t (explorer-char-error string char))) (GO skip) new-field (SETQ field-start (1+ index)) skip (AND (EQ char 'done) (RETURN (VALUES device directory name type version))))) (DEFPROP explorer-char-error t :error-reporter) (DEFUN explorer-char-error (STRING char) (IF (EQ char 'done) (FERROR ':pathname-parse-error "Unexpected end of string while parsing ~s." string) (FERROR ':pathname-parse-error "Unexpected character (~:C) while parsing ~s." char string))) (DEFUN explorer-field (STRING &optional (start 0) end version-p device-p &aux size arr char) device-p (OR end (SETQ end (ARRAY-ACTIVE-LENGTH string))) (SETQ size (- end start)) (IF (ZEROP size) ':unspecific (SETQ arr (MAKE-ARRAY size ':type 'art-string)) (DO ((i start (1+ i)) (si 0)) ((>= i end) (OR (= si size) (SETQ arr (ADJUST-ARRAY-SIZE arr si)))) (COND ((NOT (MEMQ (SETQ char (AREF string i)) '(#// #\circle-plus))) (AND (>= char #o200) (NOT (= char #\tab)) (explorer-char-error string char)) (ASET (CHAR-UPCASE char) arr si) (SETQ si (1+ si))))) (COND ((STRING-EQUAL arr "*") ':wild) ((NOT version-p) arr) ((numeric-p arr nil t)) ((CDR (ASSOC arr '((">" . :newest) ("<" . :oldest))))) (t (FERROR ':pathname-parse-error "Invalid version spec ~S in ~s" arr string))))) -------