source: cl-darcs/trunk/util.lisp

Last change on this file was 158, checked in by Magnus Henoch, 14 years ago

Use more elaborate options framework for command line tool

File size: 12.2 KB
Line 
1;;; Copyright (C) 2006, 2007, 2008 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 diff)
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     (+ 10 (- c (char-code #\A))))
51    ((<= (char-code #\a) c (char-code #\f))
52     (+ 10 (- 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 nil :eof)
100    (cond
101      ;; nothing read, and we've reached the end
102      ((and (zerop (length line)) (eq delim :eof))
103       (if eof-error-p
104           (error 'end-of-file :stream stream)
105           eof-value))
106      (t
107       line))))
108
109(defun read-token (stream)
110  "Read and return a whitespace-separated token from STREAM.
111The first value returned is a string containing the token,
112without the terminating whitespace.
113The second value is a list of bytes containing the token and
114the terminating whitespace.
115STREAM is assumed to be an UNREADABLE-STREAM."
116  (loop for i = (read-byte stream)
117     while (isspace i)
118     finally (unread-byte stream i))
119  (multiple-value-bind (token char)
120      (read-until #'isspace stream)
121    (values
122     (bytes-to-string token)
123     (progn
124       (vector-push-extend char token)
125       token))))
126
127(defun uncompress-file (infile outfile)
128  "Uncompress INFILE (a gzipped file) and write contents to OUTFILE."
129  (setf infile (make-upath infile))
130  (cond
131    #+clisp
132    ((pathnamep infile)
133     ;; C gunzip is magnitudes faster than the Lisp implementation, at
134     ;; least in CLISP.
135     (dformat "~&Uncompressing ~A through external program..." infile)
136     (ext:run-program "gunzip" :input (namestring infile) :output (namestring outfile)
137                      :if-output-exists :error)
138     (dformat "done"))
139    (t
140     (dformat "~&Uncompressing ~A through Lisp function..." infile)
141     (with-open-stream (in (open-upath infile :binary t))
142       (with-open-file (out outfile :direction :output :element-type '(unsigned-byte 8)
143                            :if-exists :error)
144         (util.zip:skip-gzip-header in)
145         (util.zip:inflate in out)
146         (dformat "done"))))))
147
148(defun compress-file (infile outfile)
149  "Compress INFILE and write contents to OUTFILE."
150  (setf infile (make-upath infile))
151  (cond
152    #+clisp
153    ((pathnamep infile)
154     (dformat "~&Compressing ~A through external program..." outfile)
155     (ext:run-program "gzip" :input (namestring infile) :output (namestring outfile)
156                      :if-output-exists :error)
157     (dformat "done"))
158    #+sbcl
159    ((pathnamep infile)
160     (dformat "~&Compressing ~A through external program..." outfile)
161     (sb-ext:run-program "/usr/bin/gzip" nil :input infile :output outfile
162                         :if-output-exists :error))
163    (t
164     (cerror "Assume compression performed."
165             "Don't know how to gzip ~A to ~A." infile outfile))))
166
167(defun make-temp-file-name ()
168  "Create a random name for a temporary file.
169This is hopefully random enough to avoid problems."
170  ;; this ought to be fine, though unix-specific...
171  (make-pathname :directory '(:absolute "tmp") 
172                 :name (format nil "~A" (random most-positive-fixnum))))
173
174(defun make-temp-file (&rest options)
175  "Open a temporary file with the given OPTIONS.
176If OPTIONS specifies no direction, :OUTPUT is assumed."
177  (let ((filename (make-temp-file-name))
178        (options (if (getf options :direction)
179                     options
180                     (cons :direction (cons :output options)))))
181    (apply 'open filename :direction :io options)))
182
183(defmacro with-temp-file-name (filename-variable &body body)
184  "Bind FILENAME-VARIABLE to a name generated by
185MAKE-TEMP-FILE-NAME.
186Delete that file after executing BODY."
187  `(let ((,filename-variable (make-temp-file-name)))
188     (unwind-protect
189          (progn
190            ,@body)
191       (delete-file ,filename-variable))))
192
193(defmacro with-temp-file ((stream &rest options) &body body)
194  "Open a temporary file and bind the stream to STREAM.
195Execute BODY, and remove the file."
196  `(let ((,stream (make-temp-file ,@options)))
197     (unwind-protect
198          (progn
199            ,@body)
200       (close ,stream)
201       (delete-file ,stream))))
202
203(defun sanitize-filename (filename &key (type :file))
204  "Convert FILENAME into a pathname.
205Signal an error if FILENAME doesn't denote a relative path going
206strictly down.
207If TYPE is :DIRECTORY, return pathname in directory form."
208  (declare (type (member :file :directory) type))
209  (let ((components (split-sequence:split-sequence #\/ filename :remove-empty-subseqs t)))
210    (setf components (delete "." components :test #'string=))
211    (when (member ".." components :test #'string=)
212      (error "Filename ~S tries to go up in directory tree." filename))
213    (ecase type
214      (:directory
215       (make-pathname :directory (cons :relative components)))
216      (:file
217       (let* ((directory (butlast components))
218              (filename (car (last components)))
219              (last-dot (position #\. filename :from-end t))
220              (filename-without-dot
221               (if (and last-dot (/= 0 last-dot))
222                   (subseq filename 0 last-dot) filename))
223              (type
224               (when (and last-dot (/= 0 last-dot))
225                 (subseq filename (1+ last-dot)))))
226         (make-pathname :directory (cons :relative directory)
227                        :name filename-without-dot :type type))))))
228
229(defun pathname-sane-p (pathname)
230  "Return true if PATHNAME is a relative path going strictly down."
231  (let ((directory (pathname-directory pathname)))
232    (or (null directory)
233        (and (listp directory)
234             (eql (car directory) :relative)
235             (every #'stringp (cdr directory))))))
236
237(defun pathname-to-string (pathname)
238  "Convert PATHNAME to a string usable in darcs patch files.
239PATHNAME is assumed to be a relative pathname going strictly down,
240as returned by SANITIZE-FILENAME."
241  (assert (pathname-sane-p pathname))
242  (apply #'concatenate 'string
243         "./"
244         (append
245          (mapcan (lambda (d)
246                    (list d "/"))
247                  (cdr (pathname-directory pathname)))
248          (when (pathname-name pathname)
249            (cons (pathname-name pathname)
250                  (when (pathname-type pathname)
251                    (list "." (pathname-type pathname))))))))
252
253(defun make-dir (pathname)
254  "Create directory PATHNAME."
255  (with-simple-restart (ignore-error "Ignore ~A directory creation error." pathname)
256    (multiple-value-bind (path created) (ensure-directories-exist pathname)
257      (declare (ignore path))
258      (unless created
259        (error "Directory ~A already exists." pathname)))))
260
261(defun delete-dir (pathname)
262  "Delete directory PATHNAME."
263  #+clisp (ext:delete-dir pathname)
264  #+sbcl  (sb-posix:rmdir pathname)
265  #+lispworks (lw:delete-directory pathname)
266  #-(or clisp sbcl lispworks)
267  (error "DELETE-DIR not implemented for ~A." (lisp-implementation-type)))
268
269(defun copy-directory (source target &key excluding)
270  "Copy all files and directories in SOURCE to TARGET.
271SOURCE and TARGET are pathnames designating directories, both of
272which must exist.  EXCLUDING is a list of files and directories
273to exclude.
274
275Symlinks will confuse the function."
276  (let* ((wild (make-pathname :directory '(:relative :wild-inferiors)
277                              :name :wild
278                              :type :wild
279                              :version :wild))
280         (source-wild (merge-pathnames wild source))
281         (target-wild (merge-pathnames wild target))
282         (excluding-wild (mapcar
283                          (lambda (excluded) (merge-pathnames wild excluded))
284                          excluding))
285
286         (files (fad:list-directory (truename source))))
287    (dolist (source-file files)
288      (let ((target-file (translate-pathname source-file source-wild target-wild)))
289        (cond
290          ((some (lambda (excluded) (pathname-match-p source-file excluded)) excluding-wild)
291           ;; File excluded - do nothing.
292           )
293          ((fad:directory-pathname-p source-file)
294           (make-dir target-file)
295           (copy-directory source-file target-file :excluding excluding))
296          (t
297           (fad:copy-file source-file target-file)))))))
298
299(defvar *scanner-cache* (make-hash-table :test 'equal)
300  "Hash table for scanners created for filename regexp tests.
301Creating a scanner is slow, but using it is fast.")
302
303(defun matches-one-of (regexps string)
304  "Return true if some of REGEXPS match STRING.
305Cache scanners for faster execution beyond first time."
306  ;; These scanners use _a lot_ of memory, so we build just one, and
307  ;; hope that the exact combination of regexps will be used often
308  ;; enough.
309  (setq regexps (sort (copy-seq regexps) #'string>))
310  (let* ((combined-regexp
311          (apply
312           #'concatenate 'string
313           (loop for regexp in regexps
314              for n upfrom 0
315              unless (zerop n) collect "|"
316              collect regexp)))
317         (scanner (or
318                   (gethash combined-regexp *scanner-cache*)
319                   (setf (gethash combined-regexp *scanner-cache*)
320                         (cl-ppcre:create-scanner combined-regexp)))))
321    (when (cl-ppcre:scan scanner string)
322      t)))
323
324(defun file-binary-p (repo filename)
325  "Return true if FILENAME names a binary file.
326Uses the regexps specified in REPO."
327  (let ((binary-regexps (get-preflist repo "binaries")))
328    (matches-one-of binary-regexps filename)))
329
330(defun file-boring-p (repo filename)
331  "Return true if FILENAME names a boring file.
332Uses the regexps specified in REPO."
333  (let ((binary-regexps (get-preflist repo "boring")))
334    (matches-one-of binary-regexps filename)))
Note: See TracBrowser for help on using the repository browser.