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

Last change on this file was 47, checked in by Magnus Henoch, 16 years ago

Add compress-file function

File size: 10.1 KB
Line 
1;;; Copyright (C) 2006 Magnus Henoch
2;;;
3;;; This program is free software; you can redistribute it and/or
4;;; modify it under the terms of the GNU General Public License as
5;;; published by the Free Software Foundation; either version 2 of the
6;;; License, or (at your option) any later version.
7;;;
8;;; This program is distributed in the hope that it will be useful,
9;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11;;; General Public License for more details.
12;;;
13;;; You should have received a copy of the GNU General Public License
14;;; along with this program; if not, write to the Free Software
15;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
16
17(in-package :darcs)
18
19(eval-when (:compile-toplevel :load-toplevel :execute)
20  (defparameter +debugged-modules+ '(get #|read-patch patchinfo|# apply-patch #|init upath|# util)
21    "Modules emitting debug output."))
22
23(defvar *http-proxy* nil
24  "HTTP proxy to use.
25This should be either NIL or \"proxy.example.com:3128\".")
26
27(defmacro dformat (&rest format-args)
28  "Print FORMAT-ARGS to standard output if debugging applies."
29  (let ((pathname (or (and (boundp '*load-pathname*) *load-pathname*)
30                      (and (boundp '*compile-file-pathname*) *compile-file-pathname*)
31                      t)))              ;loaded in repl
32    (when (or (eql pathname t)
33              (member (string-upcase (pathname-name pathname))
34                      +debugged-modules+ :test #'string=))
35      `(format t ,@format-args))))
36
37(defun isspace (c)
38  (ctypecase c
39    (character
40     (member c '(#\Space #\Tab #\Newline #\Linefeed)))
41    (number
42     (member c '(32 9 10 13)))))
43
44(defun hex-to-number (c)
45  "Turn C, the octet value of a hex digit, into the corresponding number."
46  (cond
47    ((<= (char-code #\0) c (char-code #\9))
48     (- c (char-code #\0)))
49    ((<= (char-code #\A) c (char-code #\F))
50     (- c (char-code #\A)))
51    ((<= (char-code #\a) c (char-code #\f))
52     (- c (char-code #\a)))
53    (t
54     (error "Invalid hex digit ~A." c))))
55
56(defun make-matcher (delimiters)
57  "Return a predicate based on DELIMITERS.
58If DELIMITERS is an atom, checks for equality.
59If DELIMITERS is a list, checks for membership.
60If DELIMITERS is a function, returns it unchanged."
61  (ctypecase delimiters
62    (function delimiters)
63    (atom (lambda (c) (eql c delimiters)))
64    (list (lambda (c) (member c delimiters)))))
65
66;; These two functions should be eachother's inverses, and be defined
67;; for all possible 8-bit values.
68(defun bytes-to-string (sequence)
69  "Convert SEQUENCE, a sequence of binary values, to a string."
70  (map 'string #'code-char sequence))
71
72(defun string-to-bytes (string)
73  "Convert STRING to a vector of (unsigned-byte 8)."
74  (map '(vector (unsigned-byte 8)) #'char-code string))
75
76;; These functions read vaguely character-like data from binary
77;; streams.
78
79(defun read-until (delimiters stream &optional (eof-error-p t) eof-value)
80  "Read from STREAM until encountering DELIMITERS.
81DELIMITERS is an atom, or a list of atoms, or a predicate function.
82
83Returns two values:
84 - vector of elements read
85 - encountered delimiter, or EOF-VALUE"
86  (let ((predicate (make-matcher delimiters))
87        (bytes (make-array 80 :element-type '(unsigned-byte 8)
88                           :adjustable t :fill-pointer 0)))
89    (loop for char = (read-byte stream eof-error-p)
90       while (and char (not (funcall predicate char)))
91       do (vector-push-extend char bytes)
92       finally (return (values bytes (or char eof-value))))))
93
94(defmethod read-binary-line ((stream stream) &optional (eof-error-p t) eof-value)
95  "Read from STREAM until encountering a newline or end-of-file.
96Return a vector of binary values.  Return EOF-VALUE if EOF-ERROR-P
97is nil and end-of-file occurs before any data is read."
98  (multiple-value-bind (line delim)
99      (read-until 10 stream eof-error-p eof-value)
100    (if (or (not (zerop (length line))) (eql delim 10))
101        line
102        delim)))
103
104(defun read-token (stream)
105  "Read and return a whitespace-separated token from STREAM.
106The first value returned is a string containing the token,
107without the terminating whitespace.
108The second value is a list of bytes containing the token and
109the terminating whitespace.
110STREAM is assumed to be an UNREADABLE-STREAM."
111  (loop for i = (read-byte stream)
112     while (isspace i)
113     finally (unread-byte stream i))
114  (multiple-value-bind (token char)
115      (read-until #'isspace stream)
116    (values
117     (bytes-to-string token)
118     (progn
119       (vector-push-extend char token)
120       token))))
121
122(defun uncompress-file (infile outfile)
123  "Uncompress INFILE (a gzipped file) and write contents to OUTFILE."
124  (setf infile (make-upath infile))
125  (cond
126    #+clisp
127    ((pathnamep infile)
128     ;; C gunzip is magnitudes faster than the Lisp implementation, at
129     ;; least in CLISP.
130     (dformat "~&Uncompressing ~A through external program..." infile)
131     (ext:run-program "gunzip" :input (namestring infile) :output (namestring outfile)
132                      :if-output-exists :error)
133     (dformat "done"))
134    (t
135     (dformat "~&Uncompressing ~A through Lisp function..." infile)
136     (with-open-stream (in (open-upath infile :binary t))
137       (with-open-file (out outfile :direction :output :element-type '(unsigned-byte 8)
138                            :if-exists :error)
139         (util.zip:skip-gzip-header in)
140         (util.zip:inflate in out)
141         (dformat "done"))))))
142
143(defun compress-file (infile outfile)
144  "Compress INFILE and write contents to OUTFILE."
145  (setf infile (make-upath infile))
146  (cond
147    #+clisp
148    ((pathnamep infile)
149     (dformat "~&Compressing ~A through external program..." outfile)
150     (ext:run-program "gzip" :input (namestring infile) :output (namestring outfile)
151                      :if-output-exists :error)
152     (dformat "done"))
153    (t
154     (cerror "Assume compression performed."
155             "Don't know how to gzip ~A to ~A." infile outfile))))
156
157(defun make-temp-file-name ()
158  "Create a random name for a temporary file.
159This is hopefully random enough to avoid problems."
160  ;; this ought to be fine, though unix-specific...
161  (make-pathname :directory '(:absolute "tmp") 
162                 :name (format nil "~A" (random most-positive-fixnum))))
163
164(defun make-temp-file (&rest options)
165  "Open a temporary file with the given OPTIONS.
166If OPTIONS specifies no direction, :OUTPUT is assumed."
167  (let ((filename (make-temp-file-name))
168        (options (if (getf options :direction)
169                     options
170                     (cons :direction (cons :output options)))))
171    (apply 'open filename :direction :io options)))
172
173(defmacro with-temp-file-name (filename-variable &body body)
174  "Bind FILENAME-VARIABLE to a name generated by
175MAKE-TEMP-FILE-NAME.
176Delete that file after executing BODY."
177  `(let ((,filename-variable (make-temp-file-name)))
178     (unwind-protect
179          (progn
180            ,@body)
181       (delete-file ,filename-variable))))
182
183(defmacro with-temp-file ((stream &rest options) &body body)
184  "Open a temporary file and bind the stream to STREAM.
185Execute BODY, and remove the file."
186  `(let ((,stream (make-temp-file ,@options)))
187     (unwind-protect
188          (progn
189            ,@body)
190       (close ,stream)
191       (delete-file ,stream))))
192
193(defun sanitize-filename (filename &key (type :file))
194  "Convert FILENAME into a pathname.
195Signal an error if FILENAME doesn't denote a relative path going
196strictly down.
197If TYPE is :DIRECTORY, return pathname in directory form."
198  (let ((components (split-sequence:split-sequence #\/ filename)))
199    (setf components (delete "." components :test #'string=))
200    (when (member ".." components :test #'string=)
201      (error "Filename ~S tries to go up in directory tree." filename))
202    (ecase type
203      (:directory
204       (make-pathname :directory (cons :relative components)))
205      (:file
206       (let* ((directory (butlast components))
207              (filename (car (last components)))
208              (last-dot (position #\. filename :from-end t))
209              (filename-without-dot
210               (if (and last-dot (/= 0 last-dot))
211                   (subseq filename 0 last-dot) filename))
212              (type
213               (when (and last-dot (/= 0 last-dot))
214                 (subseq filename (1+ last-dot)))))
215         (make-pathname :directory (cons :relative directory)
216                        :name filename-without-dot :type type))))))
217
218(defun pathname-to-string (pathname)
219  "Convert PATHNAME to a string usable in darcs patch files.
220PATHNAME is assumed to be a relative pathname going strictly down,
221as returned by SANITIZE-FILENAME."
222  (apply #'concatenate 'string
223         "./"
224         (append
225          (mapcan (lambda (d)
226                    (list d "/"))
227                  (cdr (pathname-directory pathname)))
228          (when (pathname-name pathname)
229            (cons (pathname-name pathname)
230                  (when (pathname-type pathname)
231                    (list "." (pathname-type pathname))))))))
232
233(defun make-dir (pathname)
234  "Create directory PATHNAME."
235  (with-simple-restart (ignore-error "Ignore ~A directory creation error." pathname)
236    #+clisp (ext:make-dir pathname)
237    #+sbcl  (sb-posix:mkdir pathname #o777)
238    #-(or clisp sbcl)
239    (error "MAKE-DIR not implemented for ~A." (lisp-implementation-type))))
240
241(defun delete-dir (pathname)
242  "Delete directory PATHNAME."
243  #+clisp (ext:delete-dir pathname)
244  #+sbcl  (sb-posix:rmdir pathname)
245  #-(or clisp sbcl)
246  (error "DELETE-DIR not implemented for ~A." (lisp-implementation-type)))
247
248(defun copy-directory (source target &key excluding)
249  "Copy all files and directories in SOURCE to TARGET.
250SOURCE and TARGET are pathnames designating directories, both of
251which must exist.  EXCLUDING is a list of files and directories
252to exclude.
253
254Symlinks will confuse the function."
255  (let* ((wild (make-pathname :directory '(:relative :wild-inferiors)
256                              :name :wild
257                              :type :wild
258                              :version :wild))
259         (source-wild (merge-pathnames wild source))
260         (target-wild (merge-pathnames wild target))
261         (excluding-wild (mapcar
262                          (lambda (excluded) (merge-pathnames wild excluded))
263                          excluding))
264
265         (files (fad:list-directory (truename source))))
266    (dolist (source-file files)
267      (let ((target-file (translate-pathname source-file source-wild target-wild)))
268        (cond
269          ((some (lambda (excluded) (pathname-match-p source-file excluded)) excluding-wild)
270           ;; File excluded - do nothing.
271           )
272          ((fad:directory-pathname-p source-file)
273           (make-dir target-file)
274           (copy-directory source-file target-file :excluding excluding))
275          (t
276           (fad:copy-file source-file target-file)))))))
Note: See TracBrowser for help on using the repository browser.