114 lines
3.3 KiB
Common Lisp
114 lines
3.3 KiB
Common Lisp
;;;; cl-scopes/util - common utilities for the scopes project
|
|
|
|
(defpackage :scopes/util
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:b64 :qbase64))
|
|
#+sbcl (:import-from :sb-ext #:add-package-local-nickname)
|
|
(:export #:lg #:lgd #:lgi
|
|
#:create-secret
|
|
#:rfill #:rtrim #:loop-plist #:filter-plist #:plist-pairs #:plist-equal
|
|
#:flatten-str #:to-keyword #:keyword-to-string #:to-integer #:to-string
|
|
#:absolute-dir #:check-dir #:ensure-dir #:home-path #:path-from-string
|
|
#:relative-path #:runtime-path #:system-path
|
|
#:add-package-local-nickname))
|
|
|
|
(in-package :scopes/util)
|
|
|
|
;;;; logging shortcuts
|
|
|
|
(defmacro lg (level &rest vars)
|
|
(let ((lm (find-symbol (string level) :log))
|
|
(fm (format nil "~{~(~a~): ~~S ~}" vars)))
|
|
`(,lm ,fm ,@vars)))
|
|
|
|
(defmacro lgd (&rest vars) `(lg :debug ,@vars))
|
|
(defmacro lgi (&rest vars) `(lg :info ,@vars))
|
|
|
|
;;;; secrets, digests, and other crypto stuff
|
|
|
|
(defun create-secret ()
|
|
(b64:encode-bytes (ironclad:random-data 16)))
|
|
|
|
;;;; lists and loops
|
|
|
|
(defun rfill (ll ls)
|
|
(mapcar #'(lambda (x) (pop ls)) ll))
|
|
|
|
(defun rtrim (lst)
|
|
(nreverse (member-if #'identity (reverse lst))))
|
|
|
|
(defmacro loop-plist (plist kvar vvar &body body)
|
|
`(loop for (,kvar ,vvar . nil) on ,plist by #'cddr ,@body))
|
|
|
|
(defun filter-plist (pl keys)
|
|
(loop-plist pl k v when (find k keys) append (list k v)))
|
|
|
|
(defun plist-pairs (pl)
|
|
(loop-plist pl k v collect (list k v)))
|
|
|
|
(defun plist-equal (l1 l2)
|
|
(unless (= (length l1) (length l2))
|
|
(return-from plist-equal nil))
|
|
(loop-plist l1 k v do
|
|
(unless (equal (getf l2 k) v)
|
|
(return-from plist-equal nil)))
|
|
t)
|
|
;;;; strings, symbols, keywords, ...
|
|
|
|
(defun flatten-str (s &key (sep " "))
|
|
(str:join sep
|
|
(mapcar (lambda (x) (str:trim x))
|
|
(str:lines s))))
|
|
|
|
(defun keyword-to-string (k)
|
|
(if k (string-downcase k) ""))
|
|
|
|
(defun to-string (k &key (sep " ") lower-case)
|
|
(let ((pattern (if lower-case "~(~a~)" "~a")))
|
|
(if (atom k)
|
|
(format nil pattern k)
|
|
(str:join sep (mapcar #'(lambda (s) (format nil pattern s)) k)))))
|
|
|
|
(defun to-integer (k)
|
|
(parse-integer (string k)))
|
|
|
|
(defun to-keyword (s)
|
|
(if (string= s "")
|
|
nil
|
|
(intern (string-upcase s) :keyword)))
|
|
|
|
;;;; directory and pathname utilities
|
|
|
|
(defun split-filename (name)
|
|
(let* ((parts (str:rsplit "." name :limit 2))
|
|
(n (car parts))
|
|
(type (cadr parts)))
|
|
(when (string= n "") ; leading dot, e.g. ".env"
|
|
(setf n name)
|
|
(setf type nil))
|
|
(values n type)))
|
|
|
|
(defun absolute-dir (path)
|
|
(make-pathname :directory (list :absolute path)))
|
|
|
|
(defun relative-path (name &rest dirs)
|
|
(multiple-value-bind (n type) (split-filename name)
|
|
(make-pathname :name n :type type :directory (cons :relative dirs))))
|
|
|
|
(defun runtime-path (name &rest dirs)
|
|
(merge-pathnames (apply #'relative-path name dirs)))
|
|
|
|
(defun home-path (name &rest dirs)
|
|
(merge-pathnames (apply #'relative-path name dirs) (user-homedir-pathname)))
|
|
|
|
(defun system-path (sys name &rest dirs)
|
|
(asdf:system-relative-pathname sys (apply #'relative-path name dirs)))
|
|
|
|
(defun path-from-string (s)
|
|
(uiop:parse-native-namestring (uiop:native-namestring s)))
|
|
|
|
(defun check-dir (p)
|
|
(probe-file (directory-namestring p)))
|
|
|
|
(defun ensure-dir (p)
|
|
(ensure-directories-exist (directory-namestring p)))
|