system-extensions.lisp

;; Copyright (C) 2010-2011 Alexander aka CosmonauT Vynnyk
;;
;;  This file is part of dswm.
;;
;; dswm is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; dswm is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA

;; Commentary:
;;
;; Many useful extensions for using with
;; filesystem, system environments etc
;; Some code given from cl-fad
;;
;; Code:

(in-package :dswm)

#+:sbcl (require :sb-executable)
#+:sbcl (require :sb-posix)

(export '(get-env
 	  where-is
	  directory-pathname-p
	  file-exists-p
	  directory-exists-p
	  delete-directory-and-files
 	  ))

(defun getenv (var)
  "Get values of UNIX system environment variables"
  (or #+:clisp (ext:getenv (string var))
      #+:sbcl (sb-unix::posix-getenv (string var))))

;;;; Pathname operations
(defun pathname-is-executable-p (pathname)
  "Return T if the pathname describes an executable file."
  (declare (ignorable pathname))
  #+sbcl
  (let ((filename (coerce (sb-ext:native-namestring pathname) 'string)))
    (and (or (pathname-name pathname)
             (pathname-type pathname))
         (sb-unix:unix-access filename sb-unix:x_ok)))
  ;; FIXME: this is not exactly perfect
  #+clisp
  (logand (posix:convert-mode (posix:file-stat-mode (posix:file-stat pathname)))
          (posix:convert-mode '(:xusr :xgrp :xoth)))
  #-(or sbcl clisp) t)

(defun probe-path (path)
  "Return the truename of a supplied path, or nil if it does not exist."
  (handler-case
      (truename
       (let ((pathname (pathname path)))
         ;; If there is neither a type nor a name, we have a directory
         ;; pathname already. Otherwise make a valid one.
         (if (and (not (pathname-name pathname))
                  (not (pathname-type pathname)))
             pathname
             (make-pathname
              :directory (append (or (pathname-directory pathname)
                                     (list :relative))
                                 (list (file-namestring pathname)))
              :name nil :type nil :defaults pathname))))
    (file-error () nil)))

(defun basename (pathname)
  "Returns basename of given path"
  (make-pathname :name
		 (pathname-name
		  (pathname pathname))
		 :type
		 (pathname-type
		  (pathname pathname))))

(defun dirname (pathname)
  "Returns dirname of path"
  (make-pathname :directory
		 (pathname-directory
		  (pathname pathname))))

;; (defun whereis (name &optional type) ;; Types :binary :source :manual
;;   "Files for where-is
;;        /{bin,sbin,etc}

;;        /usr/{lib,bin,old,new,local,games,include,etc,src,man,sbin,
;;                            X386,TeX,g++-include}

;;        /usr/local/{X386,TeX,X11,include,lib,man,etc,bin,games,emacs}
;; "
;;   (let ((path (cl-ppcre:split ":" (dswm::unix-getenv "PATH"))))
;;     (dolist (j path)
;;       (if (probe-file (concat j "/" name))
;; 	  (concat j "/" name)))

;;     ))

(defun cat (file)
  "Like UNIX command 'cat'" ;; FIXME: It's working not completely correct
  (let ((a nil))
    (with-open-file (in file)
      (loop for line = (read-line in nil nil)
	 while line
	 do
	   (setf a (append a (list line)))))
    (car (format nil "~a~%" a))))

;;;; Code from cl-fad

(defun component-present-p (value)
  "Helper function for DIRECTORY-PATHNAME-P which checks whether VALUE
is neither NIL nor the keyword :UNSPECIFIC."
  (and value (not (eql value :unspecific))))

(defun directory-pathname-p (pathspec)
  "Returns NIL if PATHSPEC \(a pathname designator) does not designate
a directory, PATHSPEC otherwise.  It is irrelevant whether file or
directory designated by PATHSPEC does actually exist."
  (and 
    (not (component-present-p (pathname-name pathspec)))
    (not (component-present-p (pathname-type pathspec)))
    pathspec))

(defun pathname-as-directory (pathspec)
  "Converts the non-wild pathname designator PATHSPEC to directory
form."
  (let ((pathname (pathname pathspec)))
    (when (wild-pathname-p pathname)
      (error "Can't reliably convert wild pathnames."))
    (cond ((not (directory-pathname-p pathspec))
           (make-pathname :directory (append (or (pathname-directory pathname)
                                                 (list :relative))
                                             (list (file-namestring pathname)))
                          :name nil
                          :type nil
                          :defaults pathname))
          (t pathname))))

;; ;; (defun directory-wildcard (dirname)
;; ;;   "Returns a wild pathname designator that designates all files within
;; ;; the directory named by the non-wild pathname designator DIRNAME."
;; ;;   (when (wild-pathname-p dirname)
;; ;;     (error "Can only make wildcard directories from non-wildcard directories."))
;; ;;   (make-pathname :name #-:cormanlisp :wild #+:cormanlisp "*"
;; ;;                  :type #-(or :clisp :cormanlisp) :wild
;; ;;                        #+:clisp nil
;; ;;                        #+:cormanlisp "*"
;; ;;                  :defaults (pathname-as-directory dirname)))

;; ;; #+:clisp
;; ;; (defun clisp-subdirectories-wildcard (wildcard)
;; ;;   "Creates a wild pathname specifically for CLISP such that
;; ;; sub-directories are returned by DIRECTORY."
;; ;;   (make-pathname :directory (append (pathname-directory wildcard)
;; ;;                                     (list :wild))
;; ;;                  :name nil
;; ;;                  :type nil
;; ;;                  :defaults wildcard))

;; ;; (defun list-directory (dirname)
;; ;;   "Returns a fresh list of pathnames corresponding to the truenames of
;; ;; all files within the directory named by the non-wild pathname
;; ;; designator DIRNAME.  The pathnames of sub-directories are returned in
;; ;; directory form - see PATHNAME-AS-DIRECTORY."
;; ;;   (when (wild-pathname-p dirname)
;; ;;     (error "Can only list concrete directory names."))
;; ;;   #+:ecl 
;; ;;   (let ((dir (pathname-as-directory dirname)))
;; ;;     (concatenate 'list
;; ;;                  (directory (merge-pathnames (pathname "*/") dir))
;; ;;                  (directory (merge-pathnames (pathname "*.*") dir))))
;; ;;   #-:ecl 
;; ;;   (let ((wildcard (directory-wildcard dirname)))
;; ;;     #+:abcl (system::list-directory dirname)
;; ;;     #+(or :sbcl :cmu :scl :lispworks) (directory wildcard)
;; ;;     #+(or :openmcl :digitool) (directory wildcard :directories t)
;; ;;     #+:allegro (directory wildcard :directories-are-files nil)
;; ;;     #+:clisp (nconc (directory wildcard :if-does-not-exist :keep)
;; ;;                     (directory (clisp-subdirectories-wildcard wildcard)))
;; ;;     #+:cormanlisp (nconc (directory wildcard)
;; ;;                          (cl::directory-subdirs dirname)))
;; ;;   #-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool)
;; ;;   (error "LIST-DIRECTORY not implemented"))

;; ;; (defun pathname-as-file (pathspec)
;; ;;   "Converts the non-wild pathname designator PATHSPEC to file form."
;; ;;   (let ((pathname (pathname pathspec)))
;; ;;     (when (wild-pathname-p pathname)
;; ;;       (error "Can't reliably convert wild pathnames."))
;; ;;     (cond ((directory-pathname-p pathspec)
;; ;;            (let* ((directory (pathname-directory pathname))
;; ;;                   (name-and-type (pathname (first (last directory)))))
;; ;;              (make-pathname :directory (butlast directory)
;; ;;                             :name (pathname-name name-and-type)
;; ;;                             :type (pathname-type name-and-type)
;; ;;                             :defaults pathname)))
;; ;;           (t pathname))))

(defun file-exists-p (pathspec)
  "Checks whether the file named by the pathname designator PATHSPEC
exists and returns its truename if this is the case, NIL otherwise.
The truename is returned in `canonical' form, i.e. the truename of a
directory is returned as if by PATHNAME-AS-DIRECTORY."
  #+:sbcl (probe-file pathspec)
  #+:clisp (or (ignore-errors
                 (let ((directory-form (pathname-as-directory pathspec)))
                   (when (ext:probe-directory directory-form)
                     directory-form)))
               (ignore-errors
                 (probe-file (pathname-as-file pathspec)))))

(defun directory-exists-p (pathspec)
  "Checks whether the file named by the pathname designator PATHSPEC
exists and if it is a directory.  Returns its truename if this is the
case, NIL otherwise.  The truename is returned in directory form as if
by PATHNAME-AS-DIRECTORY."
  (let ((result (file-exists-p pathspec)))
    (and result
         (directory-pathname-p result)
         result)))

(defun walk-directory (dirname fn &key directories
                                       (if-does-not-exist :error)
                                       (test (constantly t)))
  "Recursively applies the function FN to all files within the
directory named by the non-wild pathname designator DIRNAME and all of
its sub-directories.  FN will only be applied to files for which the
function TEST returns a true value.  If DIRECTORIES is not NIL, FN and
TEST are applied to directories as well.  If DIRECTORIES is :DEPTH-FIRST,
FN will be applied to the directory's contents first.  If
DIRECTORIES is :BREADTH-FIRST and TEST returns NIL, the
directory's content will be skipped. IF-DOES-NOT-EXIST must be
one of :ERROR or :IGNORE where :ERROR means that an error will be
signaled if the directory DIRNAME does not exist."
  (labels ((walk (name)
             (cond
               ((directory-pathname-p name)
                ;; the code is written in a slightly awkward way for
                ;; backward compatibility
                (cond ((not directories)
                       (dolist (file (list-directory name))
                         (walk file)))
                      ((eql directories :breadth-first)
                       (when (funcall test name)
                         (funcall fn name)
                         (dolist (file (list-directory name))
                           (walk file))))
                      ;; :DEPTH-FIRST is implicit
                      (t (dolist (file (list-directory name))
                           (walk file))
                         (when (funcall test name)
                           (funcall fn name)))))
               ((funcall test name)
                (funcall fn name)))))
    (let ((pathname-as-directory (pathname-as-directory dirname)))
      (case if-does-not-exist
        ((:error)
         (cond ((not (file-exists-p pathname-as-directory))
                (error "File ~S does not exist."
                       pathname-as-directory))
               (t (walk pathname-as-directory))))
        ((:ignore)
         (when (file-exists-p pathname-as-directory)
           (walk pathname-as-directory)))
        (otherwise
         (error "IF-DOES-NOT-EXIST must be one of :ERROR or :IGNORE."))))
    (values)))

(defvar *stream-buffer-size* 8192)

(defun copy-stream (from to &optional (checkp t))
  "Copies into TO \(a stream) from FROM \(also a stream) until the end
of FROM is reached, in blocks of *stream-buffer-size*.  The streams
should have the same element type.  If CHECKP is true, the streams are
checked for compatibility of their types."
  (when checkp
    (unless (subtypep (stream-element-type to) (stream-element-type from))
      (error "Incompatible streams ~A and ~A." from to)))
  (let ((buf (make-array *stream-buffer-size*
                         :element-type (stream-element-type from))))
    (loop
       (let ((pos #-(or :clisp :cmu) (read-sequence buf from)
                  #+:clisp (ext:read-byte-sequence buf from :no-hang nil)
                  #+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil)))
         (when (zerop pos) (return))
         (write-sequence buf to :end pos))))
  (values))

(defun copy-file (from to &key overwrite)
  "Copies the file designated by the non-wild pathname designator FROM
to the file designated by the non-wild pathname designator TO.  If
OVERWRITE is true overwrites the file designtated by TO if it exists."
  #+:allegro (excl.osi:copy-file from to :overwrite overwrite)
  #-:allegro
  (let ((element-type #-:cormanlisp '(unsigned-byte 8)
                      #+:cormanlisp 'unsigned-byte))
    (with-open-file (in from :element-type element-type)
      (with-open-file (out to :element-type element-type
                              :direction :output
                              :if-exists (if overwrite
                                           :supersede
                                           #-:cormanlisp :error
                                           #+:cormanlisp nil))
        #+:cormanlisp
        (unless out
          (error (make-condition 'file-error
                                 :pathname to
                                 :format-control "File already exists.")))
        (copy-stream in out))))
  (values))

(defun delete-directory-and-files (dirname &key (if-does-not-exist :error))
  "Recursively deletes all files and directories within the directory
designated by the non-wild pathname designator DIRNAME including
DIRNAME itself.  IF-DOES-NOT-EXIST must be one of :ERROR or :IGNORE
where :ERROR means that an error will be signaled if the directory
DIRNAME does not exist."
  (walk-directory dirname
		  (lambda (file)
		    (cond ((directory-pathname-p file)
			   #+:sbcl (sb-posix:rmdir file)
			   #+:clisp (ext:delete-dir file))
			  (t (delete-file file))))
		  :directories t
		  :if-does-not-exist if-does-not-exist)
  (values))