;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*-
;;; Patch file for NFS version 5.12
;;; Reason: Restored the determination in NFS-DIRECTORY-LIST of whether it is safe
;;; to use the LX- and MX-specific 'long directory' procedure on the host.
;;; Previously, it was using this illegal NFS procedure on remote NFS hosts.
;;; Written 12/02/88 11:33:48 by CORNISH,
;;; while running on MX7 from band NA27
;;; With SYSTEM 5.19, GC 5.3, VIRTUAL-MEMORY 5.5, MICRONET 5.5, MICRONET-COMM 5.13,
;;;  DISK-IO 5.9, BASIC-PATHNAME 5.2, MAC-PATHNAME 5.0, NETWORK-SUPPORT-COLD 5.1,
;;;  BASIC-NAMESPACE 5.6, BASIC-FILE 5.3, RPC 5.4, NFS 5.10, EH 5.3, MAKE-SYSTEM 5.2,
;;;  MEMORY-AUX 5.1, MACTOOLBOX 1.25, COMPILER 5.1, TV 5.21, NVRAM 5.1, UCL 5.0, INPUT-EDITOR 5.0,
;;;  METER 5.0, ZWEI 5.9, DEBUG-TOOLS 5.1, WINDOW-MX 5.28, PRINTER 5.11, MAC-PRINTER-TYPES 5.4,
;;;  NETWORK-PATHNAME 5.0, NETWORK-NAMESPACE 5.0, DATALINK 5.7, CHAOSNET 5.6, NETWORK-SUPPORT 5.0,
;;;  NETWORK-SERVICE 5.0, DATALINK-DISPLAYS 5.0, NAMESPACE-EDITOR 5.1, IP 3.33, NFS-SERVER 5.3,
;;;  PRINTER-TYPES 5.2, IMAGEN 5.1, MAIL-DAEMON 5.1, MAIL-READER 5.3, TELNET 5.1,
;;;  VT100 5.0, STREAMER-TAPE 5.6, DECNET 1.45, VISIDOC 5.4, PROFILE 5.1, DISK-LABEL 5.1,
;;;   microcode 96, Band Name: microExplorer Network (10/27)

#!C
; From file SERVICE_FUNCTIONS.LISP#> NFS; SYS:
#10R NETWORK-FILE-SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "NETWORK-FILE-SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: NFS; SERVICE_FUNCTIONS.É#É"


(DEFUN NFS-DIRECTORY-LIST (nfs-client pathname options &optional credentials)
   (declare (values directory-list))
   (when (null (pathname-name pathname))
     (setf pathname (send pathname :new-pathname :name :wild)))
   (when (OR (eq (pathname-type pathname) :UNSPECIFIC)
	     (NULL (pathname-type pathname)))
     (setf pathname (send pathname :new-pathname :type :wild)))

   ;; copy-file -> wildcard-map -> directory-list. if coping a single file, we do not need
   ;; to go through all the directory-list operations for that file, properties are cached
   ;; anyway. -- Tung (6/27/88)
   (WHEN (AND (NOT (SEND pathname :wild-p))	;; dir or single file copy -- Tung
	      (MEMBER :short options))
       (let ((attr (file-attributes nfs-client pathname credentials)))
	       ;(file-attributes-p pathname)))
	 (and attr
	      (setq attr (fattr-plist pathname attr nil nil)))
	 ;; no file system info ?!!
	 (RETURN-FROM nfs-directory-list (LIST NIL (cons pathname attr) ))) ) ; or

   (when (member :DIRECTORIES-ONLY options)
     (setf options (remove :DIRECTORIES-ONLY options))	   ; avoid infinite loop with :ALL-DIRECTORIES
     (return-from nfs-directory-list (nfs-all-directories nfs-client pathname options credentials)))
     
   (let* ((rpc:*call-who-state* (or rpc:*call-who-state* *read-directory-who-state*))
	  (superior-path        (superior-pathname pathname))
	  (client-buffer-limit  (array-total-size (send nfs-client :memory-buffer))))
     (with-credentials (cred superior-path credentials)
       (when (= S-IFLNK (ifmt-mode (file-attributes nfs-client superior-path cred)))	;; Tung for performance, it was get-file-attributes
	 (setf (file-handle nfs-client superior-path cred) nil))
       (with-mounted-dir (superior-fhandle superior-path cred)
         (let* ((dir-list       () )
	       (entry-pathname nil)
	       (fast-p         (member :fast options))
	       (long-dir       (and (null fast-p)
				    (or (and (boundp 'si:local-lx-host)
					     (eq (send nfs-client :host) si:local-lx-host))
					(net:connection-possible-p :micronet (send nfs-client :host)))))
	       (readdir-arg    (make-readdir-arg superior-fhandle
						 0 ; updated each iteration
						 (rpc:round-to-block
						   (- (min client-buffer-limit
							   (rpc:protocol-max-msg-size
							     (send nfs-client :protocol-keyword)))
						      RPC:MAX-REPLY-HEADER
						      READDIR-REPLY-HEADER))))  
	       (readdir-reply  () ))

	   (loop
	       ;; read the next block of directory contents and check reply
	     (if long-dir
		 (send (send nfs-client :new-xid) :call-with-retry NFSPROC-LONGDIR
		       #'xdr-readdir-arg   readdir-arg
		       #'xdr-longdir-reply-fast-decode (locf readdir-reply) cred)
		 (send (send nfs-client :new-xid) :call-with-retry NFSPROC-READDIR
		       #'xdr-readdir-arg   readdir-arg
		       #'xdr-readdir-reply-fast-decode (locf readdir-reply) cred))
	     (when (integerp readdir-reply)
	       (signal-nfserr readdir-reply superior-path :DIRECTORY-LIST :pathname-type :DIRECTORY
			      :proceed-types '(:retry-file-operation :new-pathname)))
	     ;(SETQ user:pathnam pathname)
	     ;; create the basic directory list
	     (let ((rpc:*call-who-state* nil)
		   (entry-string nil))
	       (dolist (entry (rest readdir-reply))
		 (setf entry-string (if long-dir (car entry) entry))
		 ;(PRINT entry-string)
		 ;;Do not call merge-pathnames unconditionally
		 (if (or (eq (send pathname :name) :WILD)
			 (eq (send pathname :type) :WILD)
			 (string-equal entry-string  ;; TUNG + DAVID B.(5/2/88)
				       (SUBSEQ (file-namestring pathname)
					       0 
					       (STRING-SEARCH-SET
						 '(#\SPACE #\#) 
						 (file-namestring pathname)))
							 
				       ))
		     (let ((fs:*merge-mac-types* nil))	   ;10.8.87 MBC
		       (declare (special fs:*merge-mac-types*))
		       (setf entry-pathname
			     (send (send
				     (if (typep pathname 'fs:mac-pathname)	;3.08.88
					 superior-path pathname)
				     :new-name-and-type entry-string)
				   :new-version :newest))) ;11.05.87 HMC
		     (setf entry-pathname nil))

		 (when (and (send pathname :pathname-match entry-pathname)
			    (string/= "."          entry-string)
			    (string/= ".."         entry-string)
			    (string/= "`node_data" entry-string))

		    ;; then this is one of the pathnames implied by the original (possibly wildcarded) pathname
		   (push (if fast-p
			     (list entry-pathname)   ; just the name, don't bother with properties
			     (if long-dir
				 (nfs-properties nfs-client entry-pathname cred (cdr entry))
				 (condition-case ()
				     (nfs-properties nfs-client entry-pathname cred)
				   ((fs:file-not-found fs:directory-not-found nfserr-acces)
				      ;; don't complain if we can't get the properties of some files...it happens
				    (list entry-pathname)))))
			 dir-list)
		    );when
		  );dolist
	       );let

	     (when (null (first readdir-reply))
	       (return))
	     
	       ;; first entry was really the last one sent, so remember its COOKIE for the next iteration
	     (setf (readdir-arg-cookie readdir-arg) (first readdir-reply))
	       );loop
	 
	    ;; sort directory list, if necessary
	   (when (member :sorted options)
	     (setf dir-list (sort dir-list #'fs:pathname-lessp :key #'first)))
	 
	   ;; prepend directory info and return
	   (cons (if (or fast-p (member :DIRECTORIES-ONLY options))
		     nil
		     (let* ((rpc:*call-who-state* nil)
			    (statfs-reply (get-filesystem-attributes nfs-client superior-path cred)))
		       (list nil
			     :DISK-SPACE-DESCRIPTION
			     (format nil "Total=~D., Free=~D., Available to Users=~D. (~D. bytes/block)"
				     (statfs-reply-blocks statfs-reply)
				     (statfs-reply-bfree  statfs-reply)
				     (statfs-reply-bavail statfs-reply)
				     (statfs-reply-bsize  statfs-reply))
			     :SETTABLE-PROPERTIES SETTABLE-PROPERTIES
			     :PATHNAME (condition-bind    ; don't die chasing circular or non-existent links 
					 (((nfserr-noent fs:circular-link rpc:proc-unavail
							 relative-pathnames-not-allowed)
					    #'(lambda (c) ; return last known link instead
					        (declare (ignore c))
						:return-last-link)))
					 (nfs-truename nfs-client superior-path cred))
			     :NFS-FILESYSTEM-ATTRIBUTES statfs-reply))
		       );if
		 dir-list)
	    );let
	  );with-mounted-dir
         );witn-credentials
       );let
   )
))
