(in-package "KPML")

;;; File: cross-file-system-functions.lisp
;;; John:Oct97:Edinburgh.

;;; Contains single places for functions that are very sensitive
;;; to particular Lisps... mostly to do with access to the file
;;; system, etc. Note this file is always loaded and particular
;;; system dependencies should be correctly conditionalized.
;;; When moving to a new lisp, this is a good place to check
;;; for problems and necessary extensions. 
;;; 
;;; 4.0 Jan 05, updated to include GNU-CLISP under Unix/Linux/Windows
;;;     Mostly straightforward, although the standard function
;;;     cl-user::directory appears differs from the implementations
;;;     under Lispworks and Allegro. For Lispworks/Allegro, directory
;;;     applied to a pathname "file/" returns the files within that
;;;     directory; for CLISP we get just the name of the directory back
;;;     instead of the contents. For CLISP the idiom necessary appears
;;;     to be (directory "file/*/"), which is pretty wild. The
;;;     function kpml::kpml-directory is the x-platform function
;;;     that will always behave as is the case in Lispworks/Allegro
;;;     and so should be used instead of cl-user::directory.
;;;
;;;     This needs a bit more work because evidently file/*.systems.*
;;;     does work the same so things are not so clear exactly what
;;;     the differences in behaviour are.
;;;
;;; 4.0 heap from resource management added in and also updated
;;;     for ACL5 and 6 under Windows.
;;; 2.1 Conditionalized ranges added.
;;;     Stable ordering for the files in a directory.

;;; ----------------------------------------------------------------------

(defun CURRENT-DIRECTORY ()
  *default-pathname-defaults*
  #+acl3.0                             (allegro::current-directory)
  #+clisp                              (ext:default-directory)
  #+excl(:version-case (":ALLEGRO-V")
		 ((- "4.3")            *default-pathname-defaults*)
		 ((+ "4.2")            (excl::current-directory))))

;;; ----------------------------------------------------------------------
;;; For file names...
;;; ----------------------------------------------------------------------
;;  3.2.3  coerce-directory made a trifle more resilient...
;;  4.0    now guaranteed to return a STRING, never a pathname.
;;         nasty hack added to get round a GNU CLISP awkwardness.
;;

(defun COERCE-DIRECTORY (string)
  (let* ((s (namestring string))
    	 (result (if (string= s "")
;; #+ignore (pathname (string *directory-delimiter*))  ;; 4.0
		     (string *directory-delimiter*)
		   (if (char-equal (elt s (- (length s) 1)) *directory-delimiter*)
		       s
		     (concatenate 'string s (string *directory-delimiter*))))))
    ;;
    ;; result now has the same as 4.0- prior to CLISP, and now we
    ;; add the following split... Cannot find the truename/namestring
    ;; of something with a wildcard ... If it is not a wildcard we
    ;; pass it through truename in order to force it to be a full
    ;; path (Linux CLISP sometimes gives relative paths!)
    ;;
    #-clisp result

    #+clisp
    (if (find #\* result)
	result
      (ignore-errors (namestring                ;; this obviously needs
		      (truename result)))       ;; to be changed!
      )))


;;; ----------------------------------------------------------------------
;;; Stable directory...       
;;;
;;;  4.0 added a slight complication to handle different behaviour of
;;;      GNU CLISP under Linux/Windows.
;;
;; Explanation:
;; -----------
;; There are two uses of stable-directory which work fine
;; together in Allegro/Lispworks but do not coincide with
;; Windows CLISP. Unix CLISP behaves just fine.
;; For Windows, if we want the files within a directory matching
;; the given wildpath, then we can use path as given
;; with (directory path :full T); but if we want a wilddirectory
;; from that directory, we have to make sure that it has
;; an appropriate delimiter at the end of the wilddirectory
;; to tell CLISP that we are looking at directories. We
;; can tell this apart easily from the namestring of the
;; argument if it contains a dot in last element or not.
;; If it does not, we treat it as a directory and coerce
;; it; if it does, we leave it as it is. If we are not
;; in CLISP, we do what we always did. We also now improve
;; this by breaking out the two usages in the source
;; KPML code, particularly in kpml-resource-maintenance.lisp,
;; so that we can spare ourselves checking each time whether
;; there is a wildcard.
;;
;;; ----------------------------------------------------------------------

#-clisp
(defun STABLE-DIRECTORY (dir)
  (sort (directory dir) 
	#'(lambda (x y) (string-lessp (pathname-name x)(pathname-name y)))))

#+clisp
(defun STABLE-DIRECTORY (dir)
  (let ((matches
	 (if (find #\. (file-namestring dir))
	     ;;
	     ;; looking for a file in the directory
	     ;;
	     #-unix (mapcar #'car (directory dir :full T))
	     #+unix (directory dir)
	   ;; 
	   ;; looking for a subdirectory
	   ;;
	   (directory (coerce-directory dir))
	   )))
    (sort matches
	  #'(lambda (x y) (string-lessp (pathname-name x)(pathname-name y)))))
  )

(defun STABLE-DIRECTORY-WILD (dir)
  #-clisp
  (stable-directory dir)
  #+clisp
  (stable-directory dir)
  )

;;; ----------------------------------------------------------------------
   ;; --------------------------------------------------------------------
   ;; 3.2.3 missed the update for Lispworks! 
   ;; --------------------------------------------------------------------

(defun GETENV (string)
  #-clisp "Generalized GETENV across Lisps"
  ""
  #+acl3.0                                 
  (allegro::getenv string)
  #+clisp                      ;; 4.0
  (let ((envar (ext:getenv string)))
    (if envar envar ""))
  #+excl
  (:version-case 
   (":ALLEGRO-V")
   ((+ "4.2")  (let ((envar (sys:getenv string)))
		 (if envar envar ""))))
  #+lcl5.0
  (let ((envar (lispworks:environment-variable string)))
    (if envar envar ""))
  
  #+lispworks                 ;; 3.2.3
  (:version-case 
   (":LISPWORKS")
   ((+ "4")
    (let ((envar (lispworks:environment-variable string)))
      (if envar envar ""))))
  )

(defun ENV-VAR-SET-P (var)
  (not (string= (getenv var) "")))

;;; ----------------------------------------------------------------------

#+(and acl3.0 aclpc)
(defun DESTRUCTIVE-RECURSIVE-DIRECTORY-COPY (old-dir new-dir)
  (let* ((new-dir-string (coerce-directory new-dir))
	 (old-dir-string (coerce-directory old-dir))
	 (files (directory 
		       (concatenate 'string old-dir-string "*")))
	 (dirs (kpml-acl-directory 
		(concatenate 'string old-dir-string "*\\"))))
    (allegro:create-directory new-dir)
    (loop for file in files
	  do (rename-file file
			  (concatenate 'string new-dir-string
				       (file-namestring file))))
    (loop for dir in dirs
	  do 
	  (destructive-recursive-directory-copy 
	   dir 
	   (concatenate 'string new-dir-string 
			(acl-get-directory-name dir)))
	  (allegro:delete-directory dir))
    (allegro:delete-directory old-dir)))

#+(and acl3.0 aclpc)
(defun NONDESTRUCTIVE-RECURSIVE-DIRECTORY-COPY (old-dir new-dir)
  (let* ((new-dir-string (coerce-directory new-dir))
	 (old-dir-string (coerce-directory old-dir))
	 (files (directory 
		       (concatenate 'string old-dir-string "*")))
	 (dirs (kpml-acl-directory 
		(concatenate 'string old-dir-string "*\\"))))
    (allegro:create-directory new-dir)
    (loop for file in files
	  do (allegro:copy-file file
				(concatenate 'string new-dir-string
					     (file-namestring file))))
    (loop for dir in dirs
	  do 
	  (nondestructive-recursive-directory-copy 
	   dir 
	   (concatenate 'string new-dir-string 
			(acl-get-directory-name dir))))))

;;; ----------------------------------------------------------------------

#+(or (and acl3.0 aclpc) lispworks)
(defun ACL-GET-DIRECTORY-NAME (dir)
  (file-namestring
   (subseq (namestring dir) 
	   0 (1- (length (namestring dir))))))


;;; ----------------------------------------------------------------------
;;; Following hack stops us getting dots and doubledots.

#+(and acl3.0 aclpc)
(defun KPML-ACL-DIRECTORY (pathstring)
  (let ((dirs (directory pathstring)))
    (loop for dir in dirs
	  when (equal (pathname (namestring dir)) dir)
	  collect dir)))
	  
(defun KPML-DIRECTORY (pathstring)
  #+(and acl3.0 aclpc)(kpml-acl-directory pathstring)
  #-(and acl3.0 aclpc (not clisp))(directory pathstring)
  ;;
  ;; 4.0
  ;;     cl-user::directory appears differs from the implementations
  ;;     under Lispworks and Allegro. For Lispworks/Allegro, directory
  ;;     applied to a pathname "file/" returns the files within that
  ;;     directory; for CLISP we get just the name of the directory back
  ;;     instead of the contents. For CLISP the idiom necessary appears
  ;;     to be (directory "file/*/"), which is pretty wild. 
  ;;
  #+clisp 
  (directory 
   (concatenate 'string 
		(coerce-directory pathstring)    ;; guarantee delimiter
		"*"
		(string *directory-delimiter*)   ;; and again
		))
  )

;;; ----------------------------------------------------------------------

(defun DIR-EXISTS-P (directory)
  #+(and :unix (not :clisp))(open directory :direction :probe)
  #+clisp (directory (coerce-directory directory))
  ;; was: 
  ;; (ext:probe-directory (coerce-directory directory))
  #+acl3.0(allegro:directory-exists-p directory)
  #+lispworks(lispworks::file-directory-p directory)
  #+(and allegro mswindows)(open directory :direction :probe)
  )

;;; ----------------------------------------------------------------------
;;; 2.1

(defun DIRNAME-FROM-DIR-PATHNAME (directory)
  (first (last (pathname-directory directory))))

;;; ----------------------------------------------------------------------
;;; 4.0 removed from kpml-resource-management and updated here...

(defun BACK-UP-RESOURCE 
  (lg-name root-directory lg-root-directory &optional (mode :destructive))
  #+(and acl3.0 aclpc)
  (let ((backup-resource-directory 
	 (merge-pathnames
	  (make-backed-up-resource-directory-name lg-name)
	  root-directory
	  )))
    (case mode
	  (:destructive
	   (destructive-recursive-directory-copy 
	    (namestring lg-root-directory)
	    (namestring backup-resource-directory)))
	  (otherwise
	   (nondestructive-recursive-directory-copy 
	    (namestring lg-root-directory)
	    (namestring backup-resource-directory)))))

  ;; following is for ACL5 and 6, nothing before, and PC only!! Although it
  ;; should also work for Unix if it is worth doing a general overhaul of
  ;; of the above shell-based versions sometime.
  #+(and Allegro excl (not unix))
  (progn
    (excl:copy-directory 
     (namestring lg-root-directory)
     (namestring backup-resource-directory))
    (when (equal mode :destructive)
      (excl:delete-directory-and-files (namestring lg-root-directory))))

  #-(and acl3.0 aclpc)
  (let* ((backup-resource-directory 
	  (merge-pathnames
	   (make-backed-up-resource-directory-name lg-name)
	   root-directory
	   ))
	 (command-line
	  (concatenate 'string 
		       (case mode
			     (:destructive "mv ")
			     (otherwise *recursive-copy-command*))
		       (namestring lg-root-directory)
		       " "
		       (namestring backup-resource-directory))))
    #+Lucid              (lcl::shell command-line)
    #+(and Allegro unix) (excl:run-shell-command command-line)
    #+clisp              (ext:run-shell-command command-line)   ;; 4.0
    #-(or allegro lucid clisp)
    (progn
      (warning "Not able to create resource backup directory! Requires update for non-Lucid, non-Allegro or CLISP installation. Create by hand."))))

  ;; ..............................

#-unix
(defun CREATE-NEW-RESOURCE-DIRECTORY (lg-root-directory)
  (pc-make-directory (namestring lg-root-directory))
  (loop for dir 
	in '("Grammar" "Examples" "Lexicons" 
	     "Domains" "Inquiry-implementations")
	do (pc-make-directory 
	    (concatenate 'string (namestring lg-root-directory) dir))))

#+unix
(defun CREATE-NEW-RESOURCE-DIRECTORY (lg-root-directory)
  (let ((command-line 
	 (concatenate 'string "mkdir "
			(namestring lg-root-directory)
			"; mkdir "
			(namestring lg-root-directory)
			"Grammar"
			"; mkdir "
			(namestring lg-root-directory)
			"Examples"
			"; mkdir "
			(namestring lg-root-directory)
			"Lexicons"
			"; mkdir "
			(namestring lg-root-directory)
			"Domains"
			"; mkdir "
			(namestring lg-root-directory)
			"Inquiry-implementations")))
    #+Lucid (lcl::shell command-line)
    #+Allegro (excl:run-shell-command command-line)
    #+clisp (ext:run-shell-command command-line)
    #-(or allegro lucid clisp)(progn
			  (warning "Not able to create resource directory! Requires update for non-Lucid, non-Allegro or non-Clisp installation. Create directory structure by hand."))))


#-unix
(defun PC-MAKE-DIRECTORY (path) 
  #+lispworks              (system:make-directory path)
  #+(and aclpc acl3.0)     (allegro:create-directory path)
  #+(and allegro excl)     (excl:make-directory path)
  #+clisp                  (ext:make-dir (coerce-directory path))  ;; 4.0
  
  #-(or lispworks (and aclpc acl3.0) (and allegro excl))
  (warning "Unable to create directory: check Lisp version!"))


;;; ----------------------------------------------------------------------
;;; A general directory creation function...
;;; ----------------------------------------------------------------------

(defun CREATE-A-DIRECTORY (directory-name)
  #+unix
  (let ((command-line 
	 (concatenate 'string "mkdir " (namestring directory-name))))
    #+Lucid (lcl::shell command-line)
    #+Allegro (excl:run-shell-command command-line)
    #+clisp (ext:run-shell-command command-line)   ;; 4.0
    #-(or allegro lucid clisp)
               (warning "Not available for the current Unix Lisp."))
  #+(or lispworks (and aclpc acl3.0))
  (kpml::pc-make-directory directory-name)
  #+(and allegro excl (not unix))
  (pc-make-directory directory-name)
  #+(and clisp win32)
  (pc-make-directory directory-name)
  directory-name)

  ;; ......................................................................
  ;; 4.0 a create or warn function for directories...
  ;; ......................................................................

(defun CREATE-A-DIRECTORY-OR-WARN (directory-name)
  (if (dir-exists-p directory-name)
      (warning "Requested directory [" 
	       (string directory-name) 
	       "] exists: re-using")
    (create-a-directory directory-name)))
  

  ;; ......................................................................
  ;; probably now redundant:
  ;; ......................................................................
  ;;
(defun UNCOERCE-DIR-NAME (pathname)
  (let ((spath (namestring pathname)))
    (if (char= (char spath (1- (length spath))) 
	       *directory-delimiter*)
	(subseq spath 0 (1- (length spath)))
      spath)))
