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. |
---|
25 | This 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. |
---|
58 | If DELIMITERS is an atom, checks for equality. |
---|
59 | If DELIMITERS is a list, checks for membership. |
---|
60 | If 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. |
---|
81 | DELIMITERS is an atom, or a list of atoms, or a predicate function. |
---|
82 | |
---|
83 | Returns 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. |
---|
96 | Return a vector of binary values. Return EOF-VALUE if EOF-ERROR-P |
---|
97 | is 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. |
---|
111 | The first value returned is a string containing the token, |
---|
112 | without the terminating whitespace. |
---|
113 | The second value is a list of bytes containing the token and |
---|
114 | the terminating whitespace. |
---|
115 | STREAM 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. |
---|
169 | This 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. |
---|
176 | If 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 |
---|
185 | MAKE-TEMP-FILE-NAME. |
---|
186 | Delete 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. |
---|
195 | Execute 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. |
---|
205 | Signal an error if FILENAME doesn't denote a relative path going |
---|
206 | strictly down. |
---|
207 | If 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. |
---|
239 | PATHNAME is assumed to be a relative pathname going strictly down, |
---|
240 | as 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. |
---|
271 | SOURCE and TARGET are pathnames designating directories, both of |
---|
272 | which must exist. EXCLUDING is a list of files and directories |
---|
273 | to exclude. |
---|
274 | |
---|
275 | Symlinks 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. |
---|
301 | Creating 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. |
---|
305 | Cache 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. |
---|
326 | Uses 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. |
---|
332 | Uses the regexps specified in REPO." |
---|
333 | (let ((binary-regexps (get-preflist repo "boring"))) |
---|
334 | (matches-one-of binary-regexps filename))) |
---|