Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

270 lines (220 sloc) 9.206 kb
;;;; utils.lisp
(in-package #:quicklisp-controller)
(defvar *random-alphanumeric*
(concatenate 'string
"abcdefghijklmnopqrstuvwxyz"
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"0123456789"))
(defun random-element (vector)
(aref vector (random (length vector))))
(defun random-char ()
(random-element *random-alphanumeric*))
(defun random-string (length)
(map-into (make-string length) 'random-char))
(defun native (pathname)
(native-namestring (merge-pathnames pathname)))
(defun prefix-timestamp (&optional (time (get-universal-time)))
(multiple-value-bind (second minute hour day month year)
(decode-universal-time time 0)
(declare (ignore second minute hour))
(format nil "~4,'0D~2,'0D~2,'0D" year month day)))
(defvar *in-temporary-directory*)
(setf (documentation '*in-temporary-directory* 'variable)
"Bound to the current temporary directory of
CALL-IN-TEMPORARY-DIRECTORY for the duration of the call. Used
for checking that a pathname is being generated within a
directory that will be cleaned up.")
(defun temporary-pathname (pathname)
(unless (boundp '*in-temporary-directory*)
(error "Not in a temporary directory scope"))
(values (ensure-directories-exist (merge-pathnames pathname))))
(defun rm-rf (path)
(run "rm" "-rf" (native path)))
(defun call-in-temporary-directory (template-pathname fun)
(flet ((random-temporary ()
(let* ((parts (pathname-directory template-pathname))
(last (first (last parts)))
(randomized (format nil "~A-~A" last (random-string 8))))
(make-pathname :directory (nconc (butlast parts) (list randomized))
:defaults template-pathname))))
(block nil
(tagbody
retry
(let* ((path (random-temporary))
(*in-temporary-directory* path))
(handler-case
(progn
(sb-posix:mkdir (native path) #o700)
(unwind-protect
(with-posix-cwd path
(return (funcall fun)))
(ignore-errors (rm-rf path))))
(sb-posix:syscall-error (condition)
(when (= (sb-posix:syscall-errno condition)
sb-posix:eexist)
(go retry))
(error condition))))))))
(defmacro in-temporary-directory (template-pathname &body body)
"Evaluate BODY with the POSIX working directory and
*default-pathname-defaults set to a temporary directory specified by
TEMPLATE-PATHNAME. The TEMPLATE-PATHNAME will be used to form a unique
name in the filesystem."
`(call-in-temporary-directory ,template-pathname (lambda () ,@body)))
(defmacro in-anonymous-directory (&body body)
"Like IN-TEMPORARY-DIRECTORY, but does not require specifying a
template pathname."
(let ((base (gensym)))
`(let ((,base #p "quicklisp-controller:tmp;anonymous;"))
(ensure-directories-exist ,base)
(with-posix-cwd ,base
(in-temporary-directory "anonymous/"
,@body)))))
(defmacro ensure-in-anonymous-directory (&body body)
`(if (boundp '*in-temporary-directory*)
(progn ,@body)
(in-anonymous-directory ,@body)))
(defun copy (from to)
(run "cp" (native (truename from)) (native to)))
(defun curl (url output)
(run "curl" "--location" url "--output" (native output)))
(defparameter *days* #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
(defvar *months* #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
(defun http-date-string (&optional (time (get-universal-time)))
"Return a HTTP-style date string."
(multiple-value-bind (second minute hour day month year day-of-week)
(decode-universal-time time 0)
(let ((*print-pretty* nil))
(format nil "~A, ~2,'0D ~A ~4,'0D ~2,'0D:~2,'0D:~2,'0D GMT"
(aref *days* day-of-week)
day
(aref *months* (1- month))
year
hour
minute
second))))
(defun string-digest (string)
(ironclad:byte-array-to-hex-string
(ironclad:digest-sequence :md5
(babel:string-to-octets string
:encoding :utf-8))))
(defun merge-logical (pathname logical)
(merge-pathnames pathname
(translate-logical-pathname logical)))
(defun parent-directory (pathname)
(make-pathname :directory (butlast (pathname-directory pathname))
:defaults pathname))
(defun split-spaces (line)
(ppcre:split " " line))
(defmacro destructure-line (lambda-list line &body body)
`(destructuring-bind ,lambda-list
(split-spaces ,line)
,@body))
(defun call-for-each-line (fun file)
(with-open-file (stream file)
(loop for line = (read-line stream nil)
while line do (funcall fun line))))
(defmacro for-each-line ((line file) &body body)
`(call-for-each-line (lambda (,line) ,@body) ,file))
(defun file-lines (file)
(let ((result '()))
(for-each-line (line file)
(push line result))
(nreverse result)))
(defun ignorable-line-p (line)
(or (zerop (length line))
(char= (char line 0) #\#)))
(defun config-file-lines (file)
(remove-if #'ignorable-line-p (file-lines file)))
(defun save-lines (lines file)
(with-open-file (*standard-output* file
:direction :output
:if-exists :supersede)
(map nil #'write-line lines))
(probe-file file))
(defun save-forms (forms file)
(with-open-file (*standard-output* file
:direction :output
:if-exists :supersede)
(map nil 'print forms))
(probe-file file))
(defun save-form (form file)
(save-forms (list form) file))
(defun tarball-contents (file)
(with-run-output (stream ("tar" "tzf" (native file)))
(loop for line = (read-line stream nil)
while line collect line)))
(defun tarball-prefix (file)
(let ((contents (tarball-contents file)))
(let ((prefix (subseq (first contents) 0
(1+ (position #\/ (first contents))))))
(dolist (entry contents prefix)
(unless (and (<= (length prefix) (length entry))
(string= prefix entry :end2 (length prefix)))
(error "Tarball ~A lacks consistent prefix output directory"
file))))))
(defun tarball-canonical-name (file)
(string-right-trim "/" (tarball-prefix file)))
(defun repack (input-file new-prefix output-file)
(in-temporary-directory "repack/"
(let ((old-prefix (tarball-prefix input-file)))
(run "tar" "xf" input-file)
(unless (equal old-prefix new-prefix)
(run "mv" old-prefix new-prefix))
(run "tar" :owner 0 :group 0 "-cf" "repack.tar" new-prefix)
(run "gzip" "-n9" "repack.tar")
(copy "repack.tar.gz" output-file)))
(probe-file output-file))
(defun package-exported-symbols (package)
(let ((symbols '()))
(do-external-symbols (symbol package (sort symbols #'string<))
(push symbol symbols))))
(defun dump-symbols (prefix)
"Display a list of all external symbols in the image prefixed by PREFIX."
(let ((packages (sort (list-all-packages) #'string< :key #'package-name))
(ignored-packages (mapcar #'find-package '(:keyword :cl))))
(dolist (package packages)
(unless (member package ignored-packages)
(dolist (symbol (package-exported-symbols package))
(format t "~A ~A ~S~%" prefix (package-name package) symbol))))))
(defun make-string-table (&key case-sensitive)
(make-hash-table :test (if case-sensitive
'equal
'equalp)))
(defun first-line-of (file)
(with-open-file (stream file)
(read-line stream)))
(defun first-form-of (file)
(with-open-file (stream file)
(read stream)))
(defun file-size (file)
(with-open-file (stream file)
(file-length stream)))
(defun file-md5 (file)
(ironclad:byte-array-to-hex-string
(ironclad:digest-file :md5 file)))
(defun dist-string (&optional (timestamp (get-universal-time)))
(multiple-value-bind (second minute hour day month year)
(decode-universal-time timestamp 0)
(declare (ignore second minute hour))
(format nil "~4,'0D-~2,'0D-~2,'0D" year month day)))
(defgeneric base-directory (object)
(:method ((object pathname))
(merge-pathnames object))
(:method ((object string))
(base-directory (pathname object))))
(defgeneric relative-to (object pathname)
(:documentation "Merge PATHNAME with the BASE-DIRECTORY of OBJECT.")
(:method (object pathname)
(merge-pathnames pathname (base-directory object))))
(defun relative-to-system (pathname)
(merge-pathnames pathname
quicklisp-controller-config:*base-directory*))
(defun skip (&optional condition)
(declare (ignore condition))
(let ((restart (find-restart 'skip)))
(when restart
(invoke-restart restart))))
(defmacro with-skipping (&body body)
`(handler-bind ((error #'skip))
,@body))
Jump to Line
Something went wrong with that request. Please try again.