125 lines
4 KiB
Common Lisp
125 lines
4 KiB
Common Lisp
|
;;;; utils.lisp
|
||
|
|
|
||
|
|
(in-package #:ql-util)
|
||
|
|
|
||
|
|
(defun write-line-to-file (string file)
|
||
|
|
(with-open-file (stream file
|
||
|
|
:direction :output
|
||
|
|
:if-exists :supersede)
|
||
|
|
(write-line string stream)))
|
||
|
|
|
||
|
|
(defvar *do-not-prompt* nil
|
||
|
|
"When *DO-NOT-PROMPT* is true, PRESS-ENTER-TO-CONTINUE returns true
|
||
|
|
without user interaction.")
|
||
|
|
|
||
|
|
(defmacro without-prompting (&body body)
|
||
|
|
"Evaluate BODY in an environment where PRESS-ENTER-TO-CONTINUE
|
||
|
|
always returns true without prompting for the user to press enter."
|
||
|
|
`(let ((*do-not-prompt* t))
|
||
|
|
,@body))
|
||
|
|
|
||
|
|
(defun press-enter-to-continue ()
|
||
|
|
(when *do-not-prompt*
|
||
|
|
(return-from press-enter-to-continue t))
|
||
|
|
(format *query-io* "~&Press Enter to continue.~%")
|
||
|
|
(let ((result (read-line *query-io*)))
|
||
|
|
(zerop (length result))))
|
||
|
|
|
||
|
|
(defun replace-file (from to)
|
||
|
|
"Like RENAME-FILE, but deletes TO if it exists, first."
|
||
|
|
(when (probe-file to)
|
||
|
|
(delete-file to))
|
||
|
|
(rename-file from to))
|
||
|
|
|
||
|
|
(defun copy-file (from to &key (if-exists :rename-and-delete))
|
||
|
|
"Copy the file FROM to TO."
|
||
|
|
(let* ((buffer-size 8192)
|
||
|
|
(buffer (make-array buffer-size :element-type '(unsigned-byte 8))))
|
||
|
|
(with-open-file (from-stream from :element-type '(unsigned-byte 8))
|
||
|
|
(with-open-file (to-stream to :element-type '(unsigned-byte 8)
|
||
|
|
:direction :output
|
||
|
|
:if-exists if-exists)
|
||
|
|
(let ((length (file-length from-stream)))
|
||
|
|
(multiple-value-bind (full leftover)
|
||
|
|
(floor length buffer-size)
|
||
|
|
(dotimes (i full)
|
||
|
|
(read-sequence buffer from-stream)
|
||
|
|
(write-sequence buffer to-stream))
|
||
|
|
(read-sequence buffer from-stream)
|
||
|
|
(write-sequence buffer to-stream :end leftover)))))
|
||
|
|
(probe-file to)))
|
||
|
|
|
||
|
|
(defun ensure-file-exists (pathname)
|
||
|
|
(open pathname :direction :probe :if-does-not-exist :create))
|
||
|
|
|
||
|
|
(defun delete-file-if-exists (pathname)
|
||
|
|
(when (probe-file pathname)
|
||
|
|
(delete-file pathname)))
|
||
|
|
|
||
|
|
(defun split-spaces (line)
|
||
|
|
(let ((words '())
|
||
|
|
(mark 0)
|
||
|
|
(pos 0))
|
||
|
|
(labels ((finish ()
|
||
|
|
(setf pos (length line))
|
||
|
|
(save)
|
||
|
|
(return-from split-spaces (nreverse words)))
|
||
|
|
(save ()
|
||
|
|
(when (< mark pos)
|
||
|
|
(push (subseq line mark pos) words)))
|
||
|
|
(mark ()
|
||
|
|
(setf mark pos))
|
||
|
|
(in-word (char)
|
||
|
|
(case char
|
||
|
|
(#\Space
|
||
|
|
(save)
|
||
|
|
#'in-space)
|
||
|
|
(t
|
||
|
|
#'in-word)))
|
||
|
|
(in-space (char)
|
||
|
|
(case char
|
||
|
|
(#\Space
|
||
|
|
#'in-space)
|
||
|
|
(t
|
||
|
|
(mark)
|
||
|
|
#'in-word))))
|
||
|
|
(let ((state #'in-word))
|
||
|
|
(dotimes (i (length line) (finish))
|
||
|
|
(setf pos i)
|
||
|
|
(setf state (funcall state (char line i))))))))
|
||
|
|
|
||
|
|
(defun first-line (file)
|
||
|
|
(with-open-file (stream file)
|
||
|
|
(values (read-line stream))))
|
||
|
|
|
||
|
|
(defun (setf first-line) (line file)
|
||
|
|
(with-open-file (stream file :direction :output
|
||
|
|
:if-exists :rename-and-delete)
|
||
|
|
(write-line line stream)))
|
||
|
|
|
||
|
|
(defun file-size (file)
|
||
|
|
(with-open-file (stream file :element-type '(unsigned-byte 8))
|
||
|
|
(file-length stream)))
|
||
|
|
|
||
|
|
(defun safely-read (stream)
|
||
|
|
"Read one form from STREAM with *READ-EVAL* bound to NIL."
|
||
|
|
(let ((*read-eval* nil))
|
||
|
|
(read stream)))
|
||
|
|
|
||
|
|
(defun safely-read-file (file)
|
||
|
|
"Read the first form from FILE with SAFELY-READ."
|
||
|
|
(with-open-file (stream file)
|
||
|
|
(safely-read stream)))
|
||
|
|
|
||
|
|
(defun make-versions-url (url)
|
||
|
|
"Given an URL that looks like http://foo/bar.ext, return
|
||
|
|
http://foo/bar-versions.txt."
|
||
|
|
(let ((suffix-pos (position #\. url :from-end t)))
|
||
|
|
(unless suffix-pos
|
||
|
|
(error "Can't make a versions URL from ~A" url))
|
||
|
|
(let ((extension (subseq url suffix-pos)))
|
||
|
|
(concatenate 'string
|
||
|
|
(subseq url 0 suffix-pos)
|
||
|
|
"-versions"
|
||
|
|
extension))))
|