157 lines
4.6 KiB
Common Lisp
157 lines
4.6 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 #:make-vars-format #:lg #:lgd #:lgi #:lgw
|
|
#:from-unix-time #:to-unix-time
|
|
#:ptr
|
|
#:rfill #:rtrim
|
|
#:loop-plist #:filter-plist #:plist-pairs #:plist-equal #:plist-add
|
|
#:flatten-str #:from-keyword #:to-keyword #:to-integer #:to-string
|
|
#:from-bytes #:to-bytes #:b64-decode #:b64-encode #:from-b64 #:to-b64
|
|
#: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)
|
|
|
|
;;;; formatting and logging shortcuts
|
|
|
|
(defun make-vars-format (vars &optional info)
|
|
(let ((prefix (if info (format nil "~a: " info) "")))
|
|
(format nil "~a~{~(~a~): ~~S ~}" prefix vars)))
|
|
|
|
(defmacro lg (level info &rest vars)
|
|
(let ((lm (find-symbol (string level) :log))
|
|
(fm (make-vars-format vars info)))
|
|
`(,lm ,fm ,@vars)))
|
|
|
|
(defmacro lgd (&rest vars) `(lg :debug nil ,@vars))
|
|
(defmacro lgi (&rest vars) `(lg :info nil ,@vars))
|
|
(defmacro lgw (info &rest vars) `(lg :warn ,info ,@vars))
|
|
|
|
;;;; date and time manipulations
|
|
|
|
(defconstant +unix-time-base+ (encode-universal-time 0 0 0 1 1 1970 0))
|
|
|
|
(defun from-unix-time (time)
|
|
(when time (+ time +unix-time-base+)))
|
|
|
|
(defun to-unix-time (time)
|
|
(when time (- time +unix-time-base+)))
|
|
|
|
;;;; pointers, lists, loops
|
|
|
|
(defun ptr (&optional x)
|
|
(make-array nil :initial-element x))
|
|
|
|
(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)
|
|
|
|
(defmacro plist-add (pl k v)
|
|
`(setf ,pl (cons ,k (cons ,v ,pl))))
|
|
|
|
;;;; strings, symbols, keywords, ...
|
|
|
|
(defun flatten-str (s &key (sep " "))
|
|
(str:join sep
|
|
(mapcar (lambda (x) (str:trim x))
|
|
(str:lines s))))
|
|
|
|
(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 from-keyword (k)
|
|
(if k (string-downcase k) ""))
|
|
|
|
(defun to-keyword (s)
|
|
(if (string= s "")
|
|
nil
|
|
(intern (string-upcase s) :keyword)))
|
|
|
|
(defun from-bytes (b)
|
|
(flexi-streams:octets-to-string b :external-format :utf8))
|
|
|
|
(defun to-bytes (s)
|
|
(flexi-streams:string-to-octets s :external-format :utf8))
|
|
|
|
(defun b64-decode (s &key (scheme :uri))
|
|
(let ((padding
|
|
(case (mod (length s) 4)
|
|
(3 "=")
|
|
(2 "==")
|
|
(t ""))))
|
|
(b64:decode-string (str:concat s padding) :scheme scheme)))
|
|
|
|
(defun b64-encode (b &key (scheme :uri))
|
|
(str:trim-right (b64:encode-bytes b :scheme scheme) :char-bag "="))
|
|
|
|
(defun from-b64 (s &key (scheme :uri))
|
|
(from-bytes (b64-decode s :scheme scheme)))
|
|
|
|
(defun to-b64 (s &key (scheme :uri))
|
|
(b64-encode (to-bytes s) :scheme scheme))
|
|
|
|
;;;; 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)))
|