328 lines
12 KiB
Common Lisp
328 lines
12 KiB
Common Lisp
(uiop:define-package ambrevar/file
|
|
(:documentation "File class.")
|
|
(:use #:common-lisp)
|
|
(:use #:trivia)
|
|
(:import-from #:hu.dwim.defclass-star #:defclass*)
|
|
(:import-from #:serapeum #:export-always)
|
|
(:import-from #:ambrevar/ffprobe))
|
|
(in-package ambrevar/file)
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(trivial-package-local-nicknames:add-package-local-nickname :alex :alexandria)
|
|
(trivial-package-local-nicknames:add-package-local-nickname :sera :serapeum))
|
|
|
|
;; TODO: Allow some slots to modify file on disk. Transaction?
|
|
;; Could we edit files virtually nonetheless? Does that even make sense?
|
|
|
|
;; TODO: Only expose readers for slots that cannot be modified, such as `path'.
|
|
|
|
(sera:eval-always
|
|
(defun name-identity (name definition)
|
|
(declare (ignore definition))
|
|
name))
|
|
|
|
(defclass* file ()
|
|
((path (error "Path required")
|
|
:type string)
|
|
(inode 0)
|
|
(link-count 0)
|
|
(kind :regular-file ; "kind" because `type' is reserved by CL.
|
|
:type (member :directory
|
|
:character-device
|
|
:block-device
|
|
:regular-file
|
|
:symbolic-link
|
|
:socket
|
|
:pipe))
|
|
(size 0)
|
|
(user-id 0)
|
|
(group-id 0)
|
|
;; TODO: Include blocks?
|
|
(creation-date (local-time:unix-to-timestamp 0))
|
|
(modification-date (local-time:unix-to-timestamp 0))
|
|
(access-date (local-time:unix-to-timestamp 0))
|
|
(permissions '()
|
|
:type (or null
|
|
(cons #.(cons 'member (mapcar #'first osicat::+permissions+))))))
|
|
(:accessor-name-transformer #'name-identity)
|
|
(:export-accessor-names-p t)
|
|
(:export-class-name-p t))
|
|
|
|
(defmethod path ((s string))
|
|
s)
|
|
|
|
(defmethod path ((p pathname))
|
|
(namestring p))
|
|
|
|
(export-always 'extension)
|
|
(defmethod extension ((file file))
|
|
"Return the file extension.
|
|
If none, return the empty string unlike `pathname-type'."
|
|
(or (pathname-type (path file))
|
|
""))
|
|
|
|
(defmethod directory? ((file file))
|
|
(eq (kind file) :directory))
|
|
|
|
(defmethod file? ((file file))
|
|
(eq (kind file) :regular-file))
|
|
|
|
(defun file= (file1 file2)
|
|
"Return true if FILE1 and FILE2 point to the same file.
|
|
They might not be the same objects."
|
|
(and (file? file1) (file? file2)
|
|
(string= (path file1)
|
|
(path file2))))
|
|
|
|
(defun separator (&optional char?)
|
|
(if char?
|
|
(uiop:directory-separator-for-host)
|
|
(string (uiop:directory-separator-for-host))))
|
|
|
|
(export-always 'basename)
|
|
(defmethod basename ((file file))
|
|
"Return the file basename (including the extension).
|
|
This returns the directory name for directories."
|
|
(let* ((path (path file))
|
|
(path (if (str:ends-with? (separator) path)
|
|
(subseq path 0 (1- (length path)))
|
|
path))
|
|
(last-separator (position (separator :char)
|
|
path :from-end t)))
|
|
(subseq path
|
|
(1+ last-separator))))
|
|
|
|
(export-always 'relative-path)
|
|
(defmethod relative-path ((file file) &optional (parent-directory *default-pathname-defaults*))
|
|
"Return PATH relative to PARENT-DIRECTORY.
|
|
If PARENT-DIRECTORY is not a parent of PATH, return PATH."
|
|
(setf parent-directory (path (uiop:ensure-directory-pathname parent-directory)))
|
|
(if (str:starts-with? parent-directory
|
|
(path file))
|
|
(subseq (path file) (length parent-directory))
|
|
(path file)))
|
|
|
|
;; TODO: Support `*print-pretty*'?
|
|
;; TODO: `*print-readably*'?
|
|
(defmethod print-object ((file file) stream)
|
|
(print-unreadable-object (file stream :type t :identity t)
|
|
(write-string (str:concat (basename file)
|
|
(when (directory? file) "/"))
|
|
stream)))
|
|
|
|
(export-always 'file)
|
|
(defmethod initialize-instance :after ((file file) &key)
|
|
(let* ((path (path file))
|
|
(native-path (uiop:truename* (if (pathnamep path)
|
|
path
|
|
(uiop:parse-native-namestring path)))))
|
|
(assert (or (uiop:file-exists-p native-path)
|
|
(uiop:directory-exists-p native-path)))
|
|
;; TODO: What do we do with non-existent files (e.g. unsaved emacs buffers)? Just return nil?
|
|
(let ((stat (ignore-errors (osicat-posix:stat native-path))))
|
|
(when stat
|
|
;; From Osicat's `file-permissions':
|
|
(flet ((stat-permissions (stat)
|
|
(let ((mode (osicat-posix:stat-mode stat)))
|
|
(loop for (name . value) in osicat::+permissions+
|
|
when (plusp (logand mode value))
|
|
collect name))))
|
|
(setf
|
|
(path file) (uiop:unix-namestring native-path)
|
|
(inode file) (osicat-posix:stat-ino stat)
|
|
(link-count file) (osicat-posix:stat-nlink stat)
|
|
(kind file) (osicat:file-kind native-path) ; TODO: Don't recall `stat'.
|
|
(size file) (osicat-posix:stat-size stat)
|
|
(user-id file) (osicat-posix:stat-uid stat)
|
|
(group-id file) (osicat-posix:stat-gid stat)
|
|
(creation-date file) (local-time:unix-to-timestamp (osicat-posix:stat-ctime stat))
|
|
(modification-date file) (local-time:unix-to-timestamp (osicat-posix:stat-mtime stat))
|
|
(access-date file) (local-time:unix-to-timestamp (osicat-posix:stat-atime stat))
|
|
(permissions file) (stat-permissions stat)))))))
|
|
|
|
(defun file (path)
|
|
(make-instance 'file :path path))
|
|
|
|
(export-always 'list-directory)
|
|
(defun list-directory (&optional (path *default-pathname-defaults*) sort)
|
|
"Return entries in PATH.
|
|
By default, directories come first.
|
|
If SORT is non nil, sort them alphabetically.
|
|
Second value is the list of directories, third value is the non-directories."
|
|
;; TODO: Use locale to sort?
|
|
(let* ((subdirs (mapcar #'file (uiop:subdirectories path)))
|
|
(subfiles (mapcar #'file (uiop:directory-files path)))
|
|
(result (append subdirs subfiles)))
|
|
(values
|
|
(if sort
|
|
(sort result #'string< :key #'path)
|
|
result)
|
|
subdirs
|
|
subfiles)))
|
|
|
|
(export-always '*finder-include-directories*)
|
|
(defvar *finder-include-directories* t
|
|
"When non-nil `walk' include directories.")
|
|
|
|
(export-always '*finder-constructor*)
|
|
(defvar *finder-constructor* #'file
|
|
"Function that takes a path and returns a `file'-like object.")
|
|
|
|
(export-always 'walk)
|
|
(defun walk (root &rest predicates)
|
|
"List FILES (including directories) that satisfy all PREDICATES.
|
|
Without PREDICATES, list all files."
|
|
(let ((result '()))
|
|
(uiop:collect-sub*directories
|
|
(uiop:ensure-directory-pathname root)
|
|
(constantly t) (constantly t)
|
|
(lambda (subdirectory)
|
|
(setf result (nconc result
|
|
(let ((subfiles (mapcar *finder-constructor*
|
|
(append (if *finder-include-directories* (list subdirectory) nil)
|
|
(uiop:directory-files subdirectory)))))
|
|
(if predicates
|
|
(delete-if (lambda (file)
|
|
(notany (lambda (pred) (funcall pred file))
|
|
predicates))
|
|
subfiles)
|
|
subfiles))))))
|
|
result))
|
|
|
|
(export-always 'finder)
|
|
(defun finder (root &rest predicates)
|
|
"List files in ROOT that satisfy all PREDICATES.
|
|
Without PREDICATES, list all files."
|
|
(let ((*finder-include-directories* nil))
|
|
(apply #'walk root predicates)))
|
|
|
|
(defun match-date< (timestamp)
|
|
"Return a file predicate that matches on modification time #'< than timestamp."
|
|
(lambda (file)
|
|
(local-time:timestamp< (modification-date file) timestamp)))
|
|
|
|
(defun match-date> (timestamp)
|
|
"Return a file predicate that matches on modification time #'> than timestamp."
|
|
(lambda (file)
|
|
(local-time:timestamp> (modification-date file) timestamp)))
|
|
|
|
(export-always 'match-extension)
|
|
(defun match-extension (extension &rest more-extensions)
|
|
"Return a predicate for files that match on of the provided extensions.
|
|
Useful for `finder'."
|
|
(lambda (file)
|
|
(some (lambda (ext)
|
|
(string= ext (extension file)))
|
|
(cons extension more-extensions))))
|
|
|
|
(export-always 'match-name)
|
|
(defun match-name (name &rest more-names)
|
|
"Return a predicate that matches when one of the names is contained in the
|
|
file basename.
|
|
Basename includes the extension. Useful for `finder'."
|
|
(lambda (file)
|
|
(some (lambda (name)
|
|
(str:contains? name (basename file)))
|
|
(cons name more-names))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(defparameter %magic-cookie-mime nil
|
|
"Internal storage for `magic-cookie-mime'.")
|
|
(defun magic-cookie-mime ()
|
|
"Return internal, persistent MIME cookie for `magicffi' calls.
|
|
Benchmark on thousands of files shows that
|
|
keeping the same cookie saves about 15% of time. "
|
|
(when (or (not %magic-cookie-mime)
|
|
(not (magicffi:open-magic-p %magic-cookie-mime)))
|
|
(setf %magic-cookie-mime (magicffi:magic-open '(:symlink :mime)))
|
|
(magicffi:magic-load %magic-cookie-mime))
|
|
%magic-cookie-mime)
|
|
|
|
(defparameter %magic-cookie-description nil
|
|
"Internal storage for `magic-cookie-description'.")
|
|
(defun magic-cookie-description ()
|
|
"Same as `magic-cooke-mime' but for `file' descriptions.
|
|
See `%description'."
|
|
(when (or (not %magic-cookie-description)
|
|
(not (magicffi:open-magic-p %magic-cookie-description)))
|
|
(setf %magic-cookie-description (magicffi:magic-open '(:symlink)))
|
|
(magicffi:magic-load %magic-cookie-description))
|
|
%magic-cookie-description)
|
|
|
|
(defun %mime-type+encoding (path)
|
|
"Return a pair of MIME type and MIME encoding for PATH."
|
|
(str:split "; "
|
|
(magicffi:magic-file (magic-cookie-mime) path)))
|
|
|
|
(defun %description (path)
|
|
"Return the PATH description as per the `file' UNIX command."
|
|
(magicffi:magic-file (magic-cookie-description) path))
|
|
|
|
;; TODO: Include the description or do it in another class? Could be slower. Benchmark.
|
|
(defclass* file+mime (file)
|
|
((mime-type "")
|
|
(mime-encoding "")
|
|
(description ""))
|
|
(:accessor-name-transformer #'name-identity)
|
|
(:export-accessor-names-p t)
|
|
(:export-class-name-p t))
|
|
|
|
(defmethod initialize-instance :after ((file file+mime) &key)
|
|
(let ((mime-type+encoding (%mime-type+encoding (path file))))
|
|
(setf (mime-type file) (first mime-type+encoding)
|
|
(mime-encoding file) (second mime-type+encoding)
|
|
(description file) (%description (path file)))))
|
|
|
|
(defun file+mime (path)
|
|
(make-instance 'file+mime :path path))
|
|
|
|
(defun walk+mime (root &rest predicates)
|
|
(let ((*finder-constructor* #'file+mime))
|
|
(apply #'walk root predicates)))
|
|
|
|
(defun finder+mime (root &rest predicates)
|
|
(let ((*finder-constructor* #'file+mime))
|
|
(apply #'finder root predicates)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defclass* mediafile (file+mime) ; REVIEW: Include MIME?
|
|
((media-format nil
|
|
:type (or null ambrevar/ffprobe:media-format))
|
|
(media-streams '()
|
|
:type (or null
|
|
(cons ambrevar/ffprobe:media-stream))))
|
|
(:accessor-name-transformer #'name-identity)
|
|
(:export-accessor-names-p t)
|
|
(:export-class-name-p t))
|
|
|
|
(defmethod initialize-instance :after ((file mediafile) &key)
|
|
(let ((probe (ambrevar/ffprobe:ffprobe (path file))))
|
|
(setf (media-format file) (first probe)
|
|
(media-streams file) (rest probe))))
|
|
|
|
(export-always 'mediafile)
|
|
(defun mediafile (path)
|
|
(make-instance 'mediafile :path path))
|
|
|
|
(export-always 'mediawalk)
|
|
(defun mediawalk (root &rest predicates)
|
|
(let ((*finder-constructor* #'mediafile))
|
|
(apply #'walk root predicates)))
|
|
|
|
(export-always 'mediafinder)
|
|
(defun mediafinder (root &rest predicates)
|
|
(let ((*finder-constructor* #'mediafile))
|
|
(apply #'finder root predicates)))
|
|
|
|
(export-always 'width)
|
|
(defmethod width ((file mediafile))
|
|
(ambrevar/ffprobe:width
|
|
(find-if #'plusp (media-streams file)
|
|
:key #'ambrevar/ffprobe:width)))
|
|
|
|
(export-always 'height)
|
|
(defmethod height ((file mediafile))
|
|
(ambrevar/ffprobe:height
|
|
(find-if #'plusp (media-streams file)
|
|
:key #'ambrevar/ffprobe:height)))
|