source: cl-darcs/tags/0.1.0/util.lisp

;;; Copyright (C) 2006 Magnus Henoch
;;;
;;; This program 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 of the
;;; License, or (at your option) any later version.
;;;
;;; This program 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 program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

(in-package :darcs)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter +debugged-modules+ '(get #|read-patch patchinfo|# apply-patch #|init upath|# util)
    "Modules emitting debug output."))

(defvar *http-proxy* nil
  "HTTP proxy to use.
This should be either NIL or \"proxy.example.com:3128\".")

(defmacro dformat (&rest format-args)
  "Print FORMAT-ARGS to standard output if debugging applies."
  (let ((pathname (or (and (boundp '*load-pathname*) *load-pathname*)
                      (and (boundp '*compile-file-pathname*) *compile-file-pathname*)
                      t)))              ;loaded in repl
    (when (or (eql pathname t)
              (member (string-upcase (pathname-name pathname))
                      +debugged-modules+ :test #'string=))
      `(format t ,@format-args))))

(defun isspace (c)
  (ctypecase c
    (character
     (member c '(#\Space #\Tab #\Newline #\Linefeed)))
    (number
     (member c '(32 9 10 13)))))

(defun hex-to-number (c)
  "Turn C, the octet value of a hex digit, into the corresponding number."
  (cond
    ((<= (char-code #\0) c (char-code #\9))
     (- c (char-code #\0)))
    ((<= (char-code #\A) c (char-code #\F))
     (- c (char-code #\A)))
    ((<= (char-code #\a) c (char-code #\f))
     (- c (char-code #\a)))
    (t
     (error "Invalid hex digit ~A." c))))

(defun make-matcher (delimiters)
  "Return a predicate based on DELIMITERS.
If DELIMITERS is an atom, checks for equality.
If DELIMITERS is a list, checks for membership.
If DELIMITERS is a function, returns it unchanged."
  (ctypecase delimiters
    (function delimiters)
    (atom (lambda (c) (eql c delimiters)))
    (list (lambda (c) (member c delimiters)))))

;; These two functions should be eachother's inverses, and be defined
;; for all possible 8-bit values.
(defun bytes-to-string (sequence)
  "Convert SEQUENCE, a sequence of binary values, to a string."
  (map 'string #'code-char sequence))

(defun string-to-bytes (string)
  "Convert STRING to a vector of (unsigned-byte 8)."
  (map '(vector (unsigned-byte 8)) #'char-code string))

;; These functions read vaguely character-like data from binary
;; streams.

(defun read-until (delimiters stream &optional (eof-error-p t) eof-value)
  "Read from STREAM until encountering DELIMITERS.
DELIMITERS is an atom, or a list of atoms, or a predicate function.

Returns two values:
 - vector of elements read
 - encountered delimiter, or EOF-VALUE"
  (let ((predicate (make-matcher delimiters))
        (bytes (make-array 80 :element-type '(unsigned-byte 8)
                           :adjustable t :fill-pointer 0)))
    (loop for char = (read-byte stream eof-error-p)
       while (and char (not (funcall predicate char)))
       do (vector-push-extend char bytes)
       finally (return (values bytes (or char eof-value))))))

(defmethod read-binary-line ((stream stream) &optional (eof-error-p t) eof-value)
  "Read from STREAM until encountering a newline or end-of-file.
Return a vector of binary values.  Return EOF-VALUE if EOF-ERROR-P
is nil and end-of-file occurs before any data is read."
  (multiple-value-bind (line delim)
      (read-until 10 stream eof-error-p eof-value)
    (if (or (not (zerop (length line))) (eql delim 10))
        line
        delim)))

(defun read-token (stream)
  "Read and return a whitespace-separated token from STREAM.
The first value returned is a string containing the token,
without the terminating whitespace.
The second value is a list of bytes containing the token and
the terminating whitespace.
STREAM is assumed to be an UNREADABLE-STREAM."
  (loop for i = (read-byte stream)
     while (isspace i)
     finally (unread-byte stream i))
  (multiple-value-bind (token char)
      (read-until #'isspace stream)
    (values
     (bytes-to-string token)
     (progn
       (vector-push-extend char token)
       token))))

(defun uncompress-file (infile outfile)
  "Uncompress INFILE (a gzipped file) and write contents to OUTFILE."
  (setf infile (make-upath infile))
  (cond
    #+clisp
    ((pathnamep infile)
     ;; C gunzip is magnitudes faster than the Lisp implementation, at
     ;; least in CLISP.
     (dformat "~&Uncompressing ~A through external program..." infile)
     (ext:run-program "gunzip" :input (namestring infile) :output (namestring outfile)
                      :if-output-exists :error)
     (dformat "done"))
    (t
     (dformat "~&Uncompressing ~A through Lisp function..." infile)
     (with-open-stream (in (open-upath infile :binary t))
       (with-open-file (out outfile :direction :output :element-type '(unsigned-byte 8)
                            :if-exists :error)
         (util.zip:skip-gzip-header in)
         (util.zip:inflate in out)
         (dformat "done"))))))

(defun compress-file (infile outfile)
  "Compress INFILE and write contents to OUTFILE."
  (setf infile (make-upath infile))
  (cond
    #+clisp
    ((pathnamep infile)
     (dformat "~&Compressing ~A through external program..." outfile)
     (ext:run-program "gzip" :input (namestring infile) :output (namestring outfile)
                      :if-output-exists :error)
     (dformat "done"))
    (t
     (cerror "Assume compression performed."
             "Don't know how to gzip ~A to ~A." infile outfile))))

(defun make-temp-file-name ()
  "Create a random name for a temporary file.
This is hopefully random enough to avoid problems."
  ;; this ought to be fine, though unix-specific...
  (make-pathname :directory '(:absolute "tmp") 
                 :name (format nil "~A" (random most-positive-fixnum))))

(defun make-temp-file (&rest options)
  "Open a temporary file with the given OPTIONS.
If OPTIONS specifies no direction, :OUTPUT is assumed."
  (let ((filename (make-temp-file-name))
        (options (if (getf options :direction)
                     options
                     (cons :direction (cons :output options)))))
    (apply 'open filename :direction :io options)))

(defmacro with-temp-file-name (filename-variable &body body)
  "Bind FILENAME-VARIABLE to a name generated by
MAKE-TEMP-FILE-NAME.
Delete that file after executing BODY."
  `(let ((,filename-variable (make-temp-file-name)))
     (unwind-protect
          (progn
            ,@body)
       (delete-file ,filename-variable))))

(defmacro with-temp-file ((stream &rest options) &body body)
  "Open a temporary file and bind the stream to STREAM.
Execute BODY, and remove the file."
  `(let ((,stream (make-temp-file ,@options)))
     (unwind-protect
          (progn
            ,@body)
       (close ,stream)
       (delete-file ,stream))))

(defun sanitize-filename (filename &key (type :file))
  "Convert FILENAME into a pathname.
Signal an error if FILENAME doesn't denote a relative path going
strictly down.
If TYPE is :DIRECTORY, return pathname in directory form."
  (let ((components (split-sequence:split-sequence #\/ filename)))
    (setf components (delete "." components :test #'string=))
    (when (member ".." components :test #'string=)
      (error "Filename ~S tries to go up in directory tree." filename))
    (ecase type
      (:directory
       (make-pathname :directory (cons :relative components)))
      (:file
       (let* ((directory (butlast components))
              (filename (car (last components)))
              (last-dot (position #\. filename :from-end t))
              (filename-without-dot
               (if (and last-dot (/= 0 last-dot))
                   (subseq filename 0 last-dot) filename))
              (type
               (when (and last-dot (/= 0 last-dot))
                 (subseq filename (1+ last-dot)))))
         (make-pathname :directory (cons :relative directory)
                        :name filename-without-dot :type type))))))

(defun pathname-to-string (pathname)
  "Convert PATHNAME to a string usable in darcs patch files.
PATHNAME is assumed to be a relative pathname going strictly down,
as returned by SANITIZE-FILENAME."
  (apply #'concatenate 'string
         "./"
         (append
          (mapcan (lambda (d)
                    (list d "/"))
                  (cdr (pathname-directory pathname)))
          (when (pathname-name pathname)
            (cons (pathname-name pathname)
                  (when (pathname-type pathname)
                    (list "." (pathname-type pathname))))))))

(defun make-dir (pathname)
  "Create directory PATHNAME."
  (with-simple-restart (ignore-error "Ignore ~A directory creation error." pathname)
    #+clisp (ext:make-dir pathname)
    #+sbcl  (sb-posix:mkdir pathname #o777)
    #-(or clisp sbcl)
    (error "MAKE-DIR not implemented for ~A." (lisp-implementation-type))))

(defun delete-dir (pathname)
  "Delete directory PATHNAME."
  #+clisp (ext:delete-dir pathname)
  #+sbcl  (sb-posix:rmdir pathname)
  #-(or clisp sbcl)
  (error "DELETE-DIR not implemented for ~A." (lisp-implementation-type)))

(defun copy-directory (source target &key excluding)
  "Copy all files and directories in SOURCE to TARGET.
SOURCE and TARGET are pathnames designating directories, both of
which must exist.  EXCLUDING is a list of files and directories
to exclude.

Symlinks will confuse the function."
  (let* ((wild (make-pathname :directory '(:relative :wild-inferiors)
                              :name :wild
                              :type :wild
                              :version :wild))
         (source-wild (merge-pathnames wild source))
         (target-wild (merge-pathnames wild target))
         (excluding-wild (mapcar
                          (lambda (excluded) (merge-pathnames wild excluded))
                          excluding))

         (files (fad:list-directory (truename source))))
    (dolist (source-file files)
      (let ((target-file (translate-pathname source-file source-wild target-wild)))
        (cond
          ((some (lambda (excluded) (pathname-match-p source-file excluded)) excluding-wild)
           ;; File excluded - do nothing.
           )
          ((fad:directory-pathname-p source-file)
           (make-dir target-file)
           (copy-directory source-file target-file :excluding excluding))
          (t
           (fad:copy-file source-file target-file)))))))