1
0
Fork 0
tinmop/src/filesystem-utils.lisp

395 lines
14 KiB
Common Lisp
Raw Normal View History

2020-09-06 11:32:08 +02:00
;; tinmop: an humble gemini and pleroma client
2020-05-08 15:45:43 +02:00
;; Copyright (C) 2020 cage
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(in-package :filesystem-utils)
(define-constant +preprocess-include+ "^%include" :test #'string=)
(define-constant +file-path-regex+ "[\\p{L},\\/,\\\\,\\.]+" :test 'string=)
(defparameter *directory-sep-regexp*
#+windows "\\"
#-windows "\\/")
(defparameter *directory-sep*
#+windows "\\"
#-windows "/")
(defun copy-a-file (in out &key (overwrite nil))
(if (and in
(file-exists-p in)
out
(or (not (file-exists-p out))
overwrite))
(progn
(uiop:copy-file in out)
out)
nil))
(defun file-size (filename)
(with-open-file (stream filename :direction :input :element-type '(unsigned-byte 8)
:if-does-not-exist nil)
(if (null stream)
0
(file-length stream))))
(defun slurp-file (filename &key (convert-to-string t))
"A simple way to slurp a file."
(with-open-file (stream filename :direction :input :element-type '(unsigned-byte 8))
(let ((seq (make-array (file-length stream) :element-type '(unsigned-byte 8))))
(read-sequence seq stream)
(if convert-to-string
(babel:octets-to-string seq)
seq))))
(defun dump-sequence-to-file (seq file)
(with-open-file (stream file
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(write-sequence seq stream)))
(defun create-file (file &key (skip-if-exists nil))
"create file and parent dir, if necessary"
(when (not (and skip-if-exists
(file-exists-p file)))
(let ((path-splitted (fs:split-path-elements file)))
(when (and path-splitted
(> (length path-splitted) 1))
(do* ((path-rest (subseq path-splitted 0
(1- (length path-splitted)))
(rest path-rest))
(path-so-far "" (if (and path-rest
(not (string= "" (first-elt path-rest))))
(concatenate 'string
path-so-far
*directory-sep*
(first-elt path-rest)
*directory-sep*)
path-so-far)))
((null path-rest))
(when (not (directory-exists-p path-so-far))
(make-directory path-so-far)))
(with-open-file (stream file
:direction :output
:if-exists :supersede
:if-does-not-exist :create))))))
(defun has-extension (path ext)
(let ((re (concatenate 'string ext "$")))
(cl-ppcre:scan re path)))
(defun strip-extension (file &key (strip-all nil))
(let ((new (cl-ppcre:regex-replace "(?i)[a-z0-9]\\.[^.]+$" file "")))
(if (string= file new)
new
(if strip-all
(strip-extension new :strip-all t)
new))))
(defun get-extension (file)
(multiple-value-bind (matchedp res)
(cl-ppcre:scan-to-strings "(?i)[a-z0-9]\(\\.[^.]+$\)" file)
(when matchedp
(first-elt res))))
(defun add-extension (file extension)
(text-utils:strcat file "." extension))
(defun cat-parent-dir (parent direntry)
(format nil "~a~a~a" parent *directory-sep* direntry))
(defmacro do-directory ((var) root &body body)
(with-gensyms (dir)
`(let ((,dir (nix:opendir ,root)))
(unwind-protect
(handler-case
(do ((,var (cat-parent-dir ,root (nix:readdir ,dir))
(cat-parent-dir ,root (nix:readdir ,dir))))
((cl-ppcre:scan "NIL$" ,var))
,@body)
(nix::enotdir () 0)
(nix:eacces () 0)
(nix:eloop () 0))
(nix:closedir ,dir)))))
(defun collect-children (parent-dir)
(let ((all-paths ()))
(fs:do-directory (path) parent-dir
(push path all-paths))
(setf all-paths (sort all-paths #'string<))
all-paths))
(defgeneric prepend-pwd (object))
(defmethod prepend-pwd ((object string))
(if (cl-ppcre:scan "^\\." object)
(text-utils:strcat (os-utils:pwd) (subseq object 1))
object))
(defmethod prepend-pwd ((object sequence))
(map 'list #'prepend-pwd object))
2020-05-08 15:45:43 +02:00
(defun search-matching-file (root-directory &key (name ".*"))
"Scan a filesystem saving files that match the provided criteria,
does not follow symlinks."
(let ((matched '())
(scanner (cl-ppcre:create-scanner name)))
(labels ((match (dir)
(do-directory (path) dir
(let ((filename (path-last-element path)))
(cond
((regular-file-p path)
(when (cl-ppcre:scan scanner filename)
(push path matched)))
((and (not (cl-ppcre:scan "^\\.\\." filename))
(not (cl-ppcre:scan "^\\." filename))
(dirp path))
(match path)))))))
(match root-directory)
matched)))
(defun regular-file-p (path)
(nix:s-isreg (nix:stat-mode (nix:stat path))))
(defun dirp (path)
(nix:s-isdir (nix:stat-mode (nix:stat path))))
(defun split-path-elements (path)
(cl-ppcre:split *directory-sep-regexp* path))
(defun path-last-element (path)
(let ((elements (cl-ppcre:split *directory-sep-regexp* path)))
(and elements
(last-elt elements))))
(defun path-first-element (path)
(let ((elements (cl-ppcre:split *directory-sep-regexp* path)))
(and elements
(first-elt elements))))
(defun path-to-hidden-file-p (path)
"unix-like only"
(let ((last-element (path-last-element path)))
(and path (cl-ppcre:scan "^\\." last-element))))
(defun strip-dirs-from-path (p)
(multiple-value-bind (all registers)
(cl-ppcre:scan-to-strings (concatenate 'string
*directory-sep*
"([^"
*directory-sep*
"]+)$")
p)
(declare (ignore all))
(and (> (length registers) 0)
(elt registers 0))))
(defun parent-dir-path (path)
(let ((splitted (remove-if #'(lambda (a) (string= "" a))
(split-path-elements path))))
(cond
((> (length splitted) 1)
(let ((res (if (string= (string (elt path 0)) *directory-sep*)
(concatenate 'string *directory-sep* (first splitted))
(first splitted))))
(loop for i in (subseq splitted 1 (1- (length splitted))) do
(setf res (concatenate 'string res *directory-sep* i)))
(setf res (concatenate 'string res *directory-sep*))
res))
((or (= (length splitted) 1)
(null splitted))
2020-05-08 15:45:43 +02:00
*directory-sep*)
(t
path))))
(defmacro define-stat-time (slot-name)
(with-gensyms (stat)
`(defun ,(format-symbol t "~:@(get-stat-~a~)" slot-name) (file)
(restart-case
(let ((,stat (nix:stat file)))
(when ,stat
(misc:time-unix->universal (,(format-symbol :nix "~:@(stat-~a~)" slot-name)
,stat))))
(use-value (value) value)))))
(define-stat-time mtime)
(define-stat-time ctime)
(define-stat-time atime)
(defun file-hash (file)
(num:fnv-hash-32 (slurp-file file :convert-to-string nil)))
(defun file-outdated-p (file &rest dependencies)
(handler-bind ((nix:enoent #'(lambda (c)
(declare (ignore c))
(invoke-restart 'use-value nil))))
(let ((mtime-file (get-stat-mtime file))
(mtimes-deps (remove-if #'null (mapcar #'get-stat-mtime dependencies))))
(if mtime-file
(remove-if #'(lambda (mtime) (<= mtime mtime-file)) mtimes-deps)
t))))
(defun file-exists-p (f)
(uiop:file-exists-p f))
(defun directory-exists-p (d)
(uiop:directory-exists-p d))
(defun delete-file-if-exists (f)
(uiop:delete-file-if-exists f))
(defun file-length-if-exists (f)
(when (file-exists-p f)
(with-open-file (stream f :element-type '(unsigned-byte 8))
(file-length stream))))
(defun home-dir (&key (add-separator-ends nil))
(let ((home (os-utils:getenv "HOME")))
(if add-separator-ends
(text-utils:strcat home *directory-sep*)
home)))
(defparameter *temporary-files-created* ())
(defun temporary-file (&optional (temp-directory nil))
2020-05-08 15:45:43 +02:00
(let ((tmpdir (or temp-directory
(os-utils:default-temp-dir))))
(multiple-value-bind (x filename)
(if tmpdir
(nix:mkstemp (format nil "~a~a~a" tmpdir *directory-sep*
config:+program-name+))
(nix:mkstemp (format nil "~atmp~a~a" *directory-sep* *directory-sep*
config:+program-name+)))
(declare (ignore x))
(push filename *temporary-files-created*)
2020-05-08 15:45:43 +02:00
filename)))
(defun clean-temporary-files ()
(dolist (temporary-file *temporary-files-created*)
(delete-file-if-exists temporary-file)))
2020-05-08 15:45:43 +02:00
(defmacro with-anaphoric-temp-file ((stream &key (prefix nil) (unlink nil)) &body body)
`(let ((temp-file (temporary-file ,prefix))) ; anaphora
2020-05-08 15:45:43 +02:00
(unwind-protect
(with-open-file (,stream temp-file
:element-type '(unsigned-byte 8)
2020-05-08 15:45:43 +02:00
:direction :output
:if-exists :supersede
2020-05-08 15:45:43 +02:00
:if-does-not-exist :create)
,@body)
,(if unlink
`(delete-file-if-exists temp-file)
nil))))
(defun has-file-permission-p (file permission)
(find permission (osicat:file-permissions file) :test #'eq))
(defun file-can-write-p (file)
(has-file-permission-p file :user-write))
(defmacro gen-permission-files (&rest modes)
`(progn
,@(loop for mode in modes collect
`(define-constant ,(misc:format-fn-symbol t "+~a+" mode)
,mode
:test #'eql))))
(gen-permission-files
nix:s-irwxu nix:s-irusr nix:s-iwusr nix:s-ixusr nix:s-irwxg nix:s-irgrp nix:s-iwgrp
nix:s-ixgrp nix:s-irwxo nix:s-iroth nix:s-iwoth nix:s-ixoth nix:s-isuid nix:s-isgid)
(defun set-file-permissions (file mode)
(nix:chmod file mode))
(misc:defcached cached-directory-files ((path) :test equal)
(declare (optimize (speed 0) (safety 3) (debug 3)))
(if (gethash path cache)
(gethash path cache)
(progn
(setf (gethash path cache) (uiop:directory-files path))
(cached-directory-files path))))
(defun directory-files (path)
(and path
(uiop:directory-files path)))
(defun make-directory (path)
(if (not (cl-ppcre:scan (concatenate 'string *directory-sep* "$") path))
(make-directory (concatenate 'string path *directory-sep*))
(ensure-directories-exist path)))
(defun package-path ()
(uiop:pathname-parent-directory-pathname
(asdf:component-pathname
(asdf:find-component (symbolicate (string-upcase config:+program-name+))
nil))))
(defun file-in-package (name)
(concatenate 'string (namestring (package-path)) name))
(defparameter *file-link-to* nil)
(define-constant +rel-link+ :rel)
(define-constant +abs-link+ :abs)
(defmacro see-file (&body forms)
(if (> (length forms) 1)
(warn "see-file: too many elements in forms, must be exactly 2"))
(let ((path (first-elt forms)))
(when (not (stringp path))
(error (format nil "see-file: the path ~a is not a string" path)))
(when (= (length path) 0)
(error (format nil "see-file: the path ~a is to short" path)))
(if (string= *directory-sep* (string (first-elt path)))
`(setf *file-link-to* (cons ,path +abs-link+))
`(setf *file-link-to* (cons ,path +rel-link+)))))
(defun link-file-path (file)
(misc:with-load-forms-in-var (*file-link-to* link-file file)
(if link-file
(destructuring-bind (path . type)
link-file
(if (eq type +rel-link+)
(cat-parent-dir (parent-dir-path file) path)
path))
nil)))
(defmacro file-is-link-if-else ((file link-file-pointed) is-link-forms is-not-link-forms)
`(let ((,link-file-pointed (link-file-path ,file)))
(if ,link-file-pointed
,is-link-forms
,is-not-link-forms)))
(defun pathname->namestring (p)
(uiop:native-namestring p))
(defun namestring->pathname (p)
(uiop:parse-native-namestring p))
(defun read-single-form (file)
(with-open-file (stream file :direction :input :if-does-not-exist nil)
(when stream
(read stream))))
(defun eq-filename (a b)
(flet ((strip (a) (strip-dirs-from-path (pathname->namestring a))))
(string= (strip a)
(strip b))))