;-*- Mode:LISP; Package:FS; Readtable:ZL; Base:8; Lowercase:T; Patch-File:T -*- ;; this fix lets symbolics systems send symbolics-style pathnames to ;; an lmi machine. Those symbolics machines then see only symbolics ;; style pathnames in directory lists, probes, etc. ;; 21-Nov-86 11:16:37 -gjc (defun lmfs-parse-for-server (string) (condition-case (result) (let ((fhost (and (boundp 'conn) conn (si:get-host-from-address (chaos:foreign-address conn) :chaos)))) (cond ((and fhost (eq :lmfs (send-if-handles fhost :file-system-type)) (or (get fhost 'wants-lmfs-pathnames-only) (string-search ">" string))) (putprop fhost t 'wants-lmfs-pathnames-only) (send (fs:merge-pathname-defaults string (fs:default-pathname nil fhost nil nil t) ':unspecific ':newest) :new-pathname :host si:local-host)) ('else (fs:merge-pathname-defaults string local-host-pathname ':unspecific ':newest)))) (pathname-error result))) (defun wants-lmfs-pathnames-only () (let ((fhost (and (boundp 'conn) conn (si:get-host-from-address (chaos:foreign-address conn) :chaos)))) (when (and fhost (get fhost 'wants-lmfs-pathnames-only)) fhost))) (defun other-guy-pathname (pathname fhost) (let ((p (make-pathname :host fhost :device nil :directory (send pathname :directory) :name (send pathname :name) :type (send pathname :type) :version (send pathname :version)))) (cond ((eq (send pathname :directory) :root) ;; kludge fix. bug work around (parse-pathname (string-append fhost ":>" (send pathname :name) "." (send pathname :type) "." (format nil "~D" (send pathname :Version))) fhost)) ('else p)))) (defun server-print-pathname (pathname) (let ((fhost (wants-lmfs-pathnames-only))) (cond ((not fhost) (if (eq (send pathname ':host) si:local-host) (send pathname ':string-for-host) (send pathname ':string-for-printing))) ('else (send (other-guy-pathname pathname fhost) :string-for-host))))) (defun server-dirlist-single (props pn conn-stream &aux (*print-base* 10.) (*nopoint t)) (format conn-stream "~%") (if pn (let ((fhost (wants-lmfs-pathnames-only))) (cond ((not fhost) (format conn-stream "~A~%" (send pn ':string-for-host))) ('else (format conn-stream "~A~%" (send (other-guy-pathname pn fhost) :string-for-host)))))) (tv:doplist (props prop ind) (format conn-stream "~A " ind) (if (eq ind ':settable-properties) (loop for x on prop do (princ (car x) conn-stream) (if (cdr x) (tyo #/SP conn-stream))) (or (dolist (spec fs:*known-directory-properties*) (if (memq ind (cdr spec)) (progn (funcall (or (cadar spec) #'princ) prop conn-stream) (return t)))) (princ prop conn-stream))) (format conn-stream "~%"))) (defun file-server-close-connection (fh) (let ((data (get fh server-instance))) (if (null data) (format conn-stream "~A ~A ERROR UFH F Unknown file handle: ~A" tid fh fh) (let ((direction (server-dataproc-comm-iotype data)) (opening (server-dataproc-comm-opening data)) (cell (server-dataproc-comm-cell data))) (cond ((null opening) (format conn-stream "~A ~A ERROR UFH F No opening on handle ~A" tid fh fh)) (t (if (eq direction 'input) (rplaca cell 'wsync)) (%store-conditional (locf (car cell)) 'async-mark 'async-abort) (cond ((eq opening 'directory) (format conn-stream "~A ~A CLOSE" tid fh)) (t (selectq server-protocol-version (0 (format conn-stream "~A ~A CLOSE ~D ~A ~D~%~A~%" tid fh (send (send opening ':truename) ':version) (cv-time (send opening ':creation-date)) (send opening ':length) (server-print-pathname (send opening ':truename)))) (1 (format conn-stream "~A ~A CLOSE ~A ~D~%~A~%" tid fh (cv-time (send opening ':creation-date)) (send opening ':length) (server-print-pathname (send opening ':truename))))))) (send conn-stream ':force-output) (if (eq direction 'input) (process-wait "Read Finish" #'null-car cell) (process-wait "Write Finish" #'null-car cell)) ;!! (setf (server-dataproc-comm-opening data) nil) (cond ((not (eq opening 'directory)) (send opening ':close) (setq server-openings (delq opening server-openings)))))))))) (DEFVAR *KNOWN-DIRECTORY-PROPERTIES* '(((PARSE-DIRECTORY-BOOLEAN-PROPERTY PRIN1 :BOOLEAN) . (:DELETED :DONT-DELETE :DONT-DUMP :DONT-REAP :DELETE-PROTECT :SUPERSEDE-PROTECT :NOT-BACKED-UP :OFFLINE :TEMPORARY :CHARACTERS :DUMPED :DIRECTORY ;; Supported by LM :QFASLP :PDP10 :MAY-BE-REAPED)) ((SUBSTRING PRINC :STRING) . (:ACCOUNT :AUTHOR :LINK-TO :PHYSICAL-VOLUME :PROTECTION :VOLUME-NAME :PACK-NUMBER :READER :DISK-SPACE-DESCRIPTION :INCREMENTAL-DUMP-TAPE :COMPLETE-DUMP-TAPE)) ((ZWEI:PARSE-NUMBER PRINT-DECIMAL-PROPERTY :NUMBER) . (:BLOCK-SIZE :BYTE-SIZE :GENERATION-RETENTION-COUNT :LENGTH-IN-BLOCKS :LENGTH-IN-BYTES :DEFAULT-GENERATION-RETENTION-COUNT)) ((PARSE-DIRECTORY-DATE-PROPERTY PRINT-DIRECTORY-DATE-PROPERTY :DATE) . (:CREATION-DATE :MODIFICATION-DATE)) ((PARSE-DIRECTORY-DATE-PROPERTY PRINT-UNIVERSAL-TIME-OR-NEVER-FOR-DIRLIST :DATE-OR-NEVER) . ( :REFERENCE-DATE :INCREMENTAL-DUMP-DATE :COMPLETE-DUMP-DATE :DATE-LAST-EXPUNGED :EXPIRATION-DATE)) ((PARSE-SETTABLE-PROPERTIES PRINT-SETTABLE-PROPERTIES) . (:SETTABLE-PROPERTIES :LINK-TRANSPARENCIES :DEFAULT-LINK-TRANSPARENCIES)) ((PARSE-DIRECTORY-FREE-SPACE PRINT-DIRECTORY-FREE-SPACE) . (:PHYSICAL-VOLUME-FREE-BLOCKS)) ((TIME:PARSE-INTERVAL-OR-NEVER TIME:PRINT-INTERVAL-OR-NEVER :TIME-INTERVAL-OR-NEVER) . (:AUTO-EXPUNGE-INTERVAL)) )) (DEFUN PRINT-UNIVERSAL-TIME-OR-NEVER-FOR-DIRLIST (TIME STREAM) (IF (NULL TIME) (PRINC "never" STREAM) (TIME:PRINT-UNIVERSAL-TIME TIME STREAM NIL ':mm//dd//yy))) ;; this is a needed bug fix. ;; strict time protocol says that the year must be given as two digits. ;; What happens 16 years from now? (DEFUN PRINT-DIRECTORY-DATE-PROPERTY (UT STREAM) (if (numberp ut) ;"defensive" (MULTIPLE-VALUE-BIND (SEC MIN HR DAY MON YR) (TIME:DECODE-UNIVERSAL-TIME UT) (FORMAT STREAM "~2,'0D//~2,'0D//~2,'0D ~2,'0D:~2,'0D:~2,'0D" MON DAY (MOD YR 100.) HR MIN SEC))))