mirror of https://codeberg.org/cage/tinmop/
- removed dependency on osicat.
This commit is contained in:
cage
parent
f2a8635b3e
commit
4d65bc200a
49
LICENSES.org
49
LICENSES.org
|
|
@ -1,3 +1,52 @@
|
|||
- src/os-utils.lisp
|
||||
uses code from osicat
|
||||
|
||||
Copyright © Nikodemus Siivola
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining
|
||||
a copy of this software and associated documentation files (the
|
||||
"Software"), to deal in the Software without restriction, including
|
||||
without limitation the rights to use, copy, modify, merge, publish,
|
||||
distribute, sublicense, and/or sell copies of the Software, and to
|
||||
permit persons to whom the Software is furnished to do so, subject to
|
||||
the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included
|
||||
in all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||||
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
|
||||
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||||
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
|
||||
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
|
||||
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
||||
|
||||
- src/fylesystem-utils
|
||||
|
||||
uses code from osicat
|
||||
|
||||
Copyright © Nikodemus Siivola
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining
|
||||
a copy of this software and associated documentation files (the
|
||||
"Software"), to deal in the Software without restriction, including
|
||||
without limitation the rights to use, copy, modify, merge, publish,
|
||||
distribute, sublicense, and/or sell copies of the Software, and to
|
||||
permit persons to whom the Software is furnished to do so, subject to
|
||||
the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included
|
||||
in all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||||
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
|
||||
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||||
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
|
||||
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
|
||||
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
||||
|
||||
- src/gemini/dummy-server.lisp
|
||||
|
||||
derived from:
|
||||
|
|
|
|||
|
|
@ -47,10 +47,10 @@ See: complete:directory-complete")
|
|||
(defun underlying-directory-p (pathname)
|
||||
"Find the actual directory of pathname (i.e. resolve file link"
|
||||
(ignore-errors
|
||||
(case (file-kind pathname)
|
||||
(case (fs:file-kind pathname)
|
||||
(:directory t)
|
||||
(:symbolic-link
|
||||
(file-kind (merge-pathnames (read-link pathname) pathname))))))
|
||||
(fs:file-kind (merge-pathnames (fs:read-link pathname) pathname))))))
|
||||
|
||||
;;; We can't easily do zsh-style tab-completion of ~us into ~user, but
|
||||
;;; at least we can expand ~ and ~user. The other bug here at the
|
||||
|
|
@ -67,7 +67,9 @@ to the appropriate home directory."
|
|||
return i))
|
||||
(suffix (and slash-index (subseq string slash-index)))
|
||||
(uname (subseq string 1 slash-index))
|
||||
(homedir (or (cdr (assoc :home (user-info uname)))
|
||||
(user-info (ignore-errors (os-utils:user-info uname)))
|
||||
(homedir (if user-info
|
||||
(os-utils:user-info-home user-info)
|
||||
(chop (namestring
|
||||
(or (probe-file (user-homedir-pathname))
|
||||
(return-from tilde-expand-string
|
||||
|
|
@ -80,29 +82,27 @@ to the appropriate home directory."
|
|||
completed) and the common prefix of the completion string."
|
||||
(when (text-utils:string-not-empty-p string)
|
||||
(let* ((namestring (tilde-expand-string string))
|
||||
(name-dir (if (file-exists-p namestring)
|
||||
(name-dir (if (fs:file-exists-p namestring)
|
||||
(fs:parent-dir-path namestring)
|
||||
namestring))
|
||||
(dir (pathname->directory-pathname namestring))
|
||||
(namefun (if (relative-pathname-p string)
|
||||
(namefun (if (fs:relative-pathname-p string)
|
||||
#'namestring
|
||||
(lambda (x) (namestring (merge-pathnames x))))))
|
||||
(unless (and (underlying-directory-p dir)
|
||||
(not (wild-pathname-p dir)))
|
||||
(return-from directory-complete (values nil 0)))
|
||||
(with-directory-iterator (next dir)
|
||||
(when-let* ((all (loop
|
||||
for entry = (next)
|
||||
while entry collect
|
||||
(funcall namefun entry)))
|
||||
(candidates (sort (remove-if-not (lambda (a)
|
||||
(text-utils:string-starts-with-p name-dir
|
||||
a))
|
||||
all)
|
||||
(lambda (a b) (< (length a)
|
||||
(length b))))))
|
||||
(values candidates
|
||||
(reduce-to-common-prefix candidates)))))))
|
||||
(format t "~a~%" dir)
|
||||
(let* ((all (mapcar (lambda (a) (funcall namefun a))
|
||||
(fs:collect-children dir)))
|
||||
(candidates (sort (remove-if-not (lambda (a)
|
||||
(text-utils:string-starts-with-p name-dir
|
||||
a))
|
||||
all)
|
||||
(lambda (a b) (< (length a)
|
||||
(length b))))))
|
||||
(values candidates
|
||||
(reduce-to-common-prefix candidates))))))
|
||||
|
||||
(defun starts-with-clsr (hint)
|
||||
(lambda (a)
|
||||
|
|
|
|||
|
|
@ -73,6 +73,61 @@
|
|||
:if-does-not-exist :create)
|
||||
(write-sequence seq stream)))
|
||||
|
||||
(defun absolute-pathname-p (pathname)
|
||||
(not (relative-pathname-p pathname)))
|
||||
|
||||
(defun relative-pathname-p (pathname)
|
||||
(uiop:relative-pathname-p pathname))
|
||||
|
||||
(defun file-kind (namestring &key (follow-p t))
|
||||
(let ((mode (nix:stat-mode (if follow-p
|
||||
(nix:stat namestring)
|
||||
(nix:lstat namestring)))))
|
||||
(cond
|
||||
((nix:s-isdir mode)
|
||||
:directory)
|
||||
((nix:s-ischr mode)
|
||||
:character-device)
|
||||
((nix:s-isblk mode)
|
||||
:block-device)
|
||||
((nix:s-isreg mode)
|
||||
:regular-file)
|
||||
((nix:s-islnk mode)
|
||||
:symbolic-link)
|
||||
((nix:s-issock mode)
|
||||
:socket)
|
||||
((nix:s-isfifo mode)
|
||||
:pipe)
|
||||
(t
|
||||
(error "uknown file type for ~a" namestring)))))
|
||||
|
||||
(defun current-directory ()
|
||||
(uiop:getcwd))
|
||||
|
||||
(defun absolute-pathname (pathspec
|
||||
&optional (default *default-pathname-defaults*))
|
||||
"Returns an absolute pathname corresponding to PATHSPEC by
|
||||
merging it with DEFAULT, and (CURRENT-DIRECTORY) if necessary."
|
||||
(if (relative-pathname-p pathspec)
|
||||
(let ((tmp (merge-pathnames
|
||||
pathspec
|
||||
(make-pathname :name nil :type nil :version nil
|
||||
:defaults default))))
|
||||
(if (relative-pathname-p tmp)
|
||||
(merge-pathnames tmp (current-directory))
|
||||
tmp))
|
||||
pathspec))
|
||||
|
||||
(defun read-link (pathspec)
|
||||
"Returns the pathname pointed to by the symbolic link
|
||||
designated by PATHSPEC. If the link is relative, then the
|
||||
returned pathname is relative to the link, not
|
||||
*DEFAULT-PATHNAME-DEFAULTS*.
|
||||
|
||||
Signals an error if PATHSPEC is wild, or does not designate a
|
||||
symbolic link."
|
||||
(pathname (nix:readlink (absolute-pathname pathspec))))
|
||||
|
||||
(defun create-file (file &key (skip-if-exists nil))
|
||||
"create file and parent dir, if necessary"
|
||||
(when (not (and skip-if-exists
|
||||
|
|
@ -144,15 +199,13 @@
|
|||
(unwind-protect
|
||||
(handler-case
|
||||
(flet ((read-dir ()
|
||||
(when-let* ((,dir-name (nix:readdir ,dir))
|
||||
(when-let* ((,dir-name (nix:dirent-name (nix:readdir ,dir)))
|
||||
(,new-path (cat-parent-dir ,root ,dir-name)))
|
||||
,new-path)))
|
||||
(do ((,var (read-dir) (read-dir)))
|
||||
((not ,var) ())
|
||||
,@body))
|
||||
(nix::enotdir () 0)
|
||||
(nix:eacces () 0)
|
||||
(nix:eloop () 0))
|
||||
(error () 0))
|
||||
(nix:closedir ,dir)))))
|
||||
|
||||
(defun collect-children (parent-dir)
|
||||
|
|
@ -247,8 +300,16 @@
|
|||
(match root-directory)
|
||||
matched)))
|
||||
|
||||
(cffi:defcfun (ffi-realpath "realpath")
|
||||
:string
|
||||
(path :pointer)
|
||||
(resolved-path :pointer))
|
||||
|
||||
(defun relative-file-path->absolute (path)
|
||||
(nix:realpath path))
|
||||
(cffi:with-foreign-string (ptr-path path)
|
||||
(let ((resolved ""))
|
||||
(cffi:with-foreign-string (ptr-resolved resolved)
|
||||
(ffi-realpath ptr-path ptr-resolved)))))
|
||||
|
||||
(defun regular-file-p (path)
|
||||
(nix:s-isreg (nix:stat-mode (nix:stat path))))
|
||||
|
|
@ -345,14 +406,15 @@
|
|||
(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))))
|
||||
(handler-case
|
||||
(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))))
|
||||
t))
|
||||
(nix:syscall-error (e)
|
||||
(declare (ignore e))
|
||||
nil)))
|
||||
|
||||
(defun file-exists-p (f)
|
||||
(uiop:file-exists-p f))
|
||||
|
|
@ -371,15 +433,22 @@
|
|||
(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)))
|
||||
(cffi:defcfun ("mkstemps" ffi-mkstemps) :int
|
||||
(template :pointer)
|
||||
(suffix-length :int))
|
||||
|
||||
(defun mkstemps (template suffix &optional (filler "XXXXXX"))
|
||||
(let ((actual-template (concatenate 'string
|
||||
template
|
||||
filler
|
||||
suffix)))
|
||||
(cffi:with-foreign-string (ptr-template actual-template)
|
||||
(values (ffi-mkstemps ptr-template (length suffix))
|
||||
(cffi:foreign-string-to-lisp ptr-template)))))
|
||||
|
||||
(defun %mkstemp (prefix suffix)
|
||||
(multiple-value-bind (fd path)
|
||||
(nix:mkstemps prefix suffix)
|
||||
(mkstemps prefix suffix)
|
||||
(nix:close fd)
|
||||
path))
|
||||
|
||||
|
|
@ -466,8 +535,40 @@
|
|||
(dolist (temporary-directory *temporary-directories-created*)
|
||||
(recursive-delete temporary-directory)))
|
||||
|
||||
(define-constant +file-permissions+
|
||||
'((:user-read . #.nix:s-irusr)
|
||||
(:user-write . #.nix:s-iwusr)
|
||||
(:user-exec . #.nix:s-ixusr)
|
||||
(:group-read . #.nix:s-irgrp)
|
||||
(:group-write . #.nix:s-iwgrp)
|
||||
(:group-exec . #.nix:s-ixgrp)
|
||||
(:other-read . #.nix:s-iroth)
|
||||
(:other-write . #.nix:s-iwoth)
|
||||
(:other-exec . #.nix:s-ixoth)
|
||||
(:set-user-id . #.nix:s-isuid)
|
||||
(:set-group-id . #.nix:s-isgid)
|
||||
(:sticky . #.nix:s-isvtx))
|
||||
:test #'equalp)
|
||||
|
||||
(defun file-permissions (file)
|
||||
(labels ((extract-permissions (mode permissions-mask &optional (accum '()))
|
||||
(if (> mode 0)
|
||||
(let* ((permission (first permissions-mask))
|
||||
(permission-name (car permission))
|
||||
(permission-mask (cdr permission))
|
||||
(mode-enabled (= (logand permission-mask mode)
|
||||
1))
|
||||
(modes (if mode-enabled
|
||||
(push permission-name accum))))
|
||||
(extract-permissions (logand permission-mask mode)
|
||||
permissions-mask
|
||||
modes))
|
||||
accum)))
|
||||
(let ((modes (nix:stat-mode (nix:stat file))))
|
||||
(extract-permissions modes +file-permissions+))))
|
||||
|
||||
(defun has-file-permission-p (file permission)
|
||||
(find permission (osicat:file-permissions file) :test #'eq))
|
||||
(find permission (file-permissions file) :test #'eq))
|
||||
|
||||
(defun file-can-write-p (file)
|
||||
(has-file-permission-p file :user-write))
|
||||
|
|
@ -480,8 +581,8 @@
|
|||
: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)
|
||||
nix:s-irusr nix:s-iwusr nix:s-ixusr nix:s-irgrp nix:s-iwgrp
|
||||
nix:s-ixgrp 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))
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@
|
|||
(uiop:launch-program cmd-line :output nil)))
|
||||
|
||||
(defun getenv (name &key (default nil))
|
||||
(or (nix:getenv name)
|
||||
(or (uiop:getenv name)
|
||||
default))
|
||||
|
||||
(defun default-temp-dir ()
|
||||
|
|
@ -59,6 +59,35 @@
|
|||
(defun pwd ()
|
||||
(getenv "PWD"))
|
||||
|
||||
(defun home-directory (&key (add-separator-ends nil))
|
||||
(let ((home (os-utils:getenv "HOME")))
|
||||
(if add-separator-ends
|
||||
(text-utils:strcat home fs:*directory-sep*)
|
||||
home)))
|
||||
|
||||
(defstruct user-info
|
||||
(name)
|
||||
(password)
|
||||
(user-id)
|
||||
(group-id)
|
||||
(gecos)
|
||||
(home)
|
||||
(shell))
|
||||
|
||||
(defun user-info (id)
|
||||
"USER-INFO returns the password entry for the given name or
|
||||
numerical user ID, as an assoc-list."
|
||||
(a:when-let ((password-struct (etypecase id
|
||||
(string (nix:getpwnam id))
|
||||
(integer (nix:getpwuid id)))))
|
||||
(make-user-info :name (nix:passwd-name password-struct)
|
||||
:password (nix:passwd-passwd password-struct)
|
||||
:user-id (nix:passwd-uid password-struct)
|
||||
:group-id (nix:passwd-gid password-struct)
|
||||
:gecos (nix:passwd-gecos password-struct)
|
||||
:home (nix:passwd-dir password-struct)
|
||||
:shell (nix:passwd-shell password-struct))))
|
||||
|
||||
(defun external-editor ()
|
||||
(let* ((editor (or (swconf:external-editor)
|
||||
(and (text-utils:string-not-empty-p (getenv "VISUAL"))
|
||||
|
|
|
|||
|
|
@ -297,17 +297,15 @@
|
|||
:cl
|
||||
:alexandria)
|
||||
(:nicknames :fs)
|
||||
(:local-nicknames (:nix :sb-posix))
|
||||
(:export
|
||||
:+file-path-regex+
|
||||
:+s-irwxu+
|
||||
:+s-irusr+
|
||||
:+s-iwusr+
|
||||
:+s-ixusr+
|
||||
:+s-irwxg+
|
||||
:+s-irgrp+
|
||||
:+s-iwgrp+
|
||||
:+s-ixgrp+
|
||||
:+s-irwxo+
|
||||
:+s-iroth+
|
||||
:+s-iwoth+
|
||||
:+s-ixoth+
|
||||
|
|
@ -316,12 +314,18 @@
|
|||
:*directory-sep-regexp*
|
||||
:*directory-sep*
|
||||
:create-a-file
|
||||
:current-directory
|
||||
:absolute-pathname
|
||||
:read-link
|
||||
:copy-a-file
|
||||
:rename-a-file
|
||||
:file-size
|
||||
:slurp-file
|
||||
:dump-sequence-to-file
|
||||
:create-file
|
||||
:absolute-pathname-p
|
||||
:relative-pathname-p
|
||||
:file-kind
|
||||
:cat-parent-dir
|
||||
:has-extension
|
||||
:get-extension
|
||||
|
|
@ -358,7 +362,6 @@
|
|||
:file-length-if-exists
|
||||
:delete-file-if-exists
|
||||
:file-hash
|
||||
:home-dir
|
||||
:*temporary-files-created*
|
||||
:temporary-file
|
||||
:clean-temporary-files
|
||||
|
|
@ -393,6 +396,8 @@
|
|||
:cl
|
||||
:config
|
||||
:constants)
|
||||
(:local-nicknames (:nix :sb-posix)
|
||||
(:a :alexandria))
|
||||
(:export
|
||||
:+ssl-cert-name+
|
||||
:+ssl-key-name+
|
||||
|
|
@ -401,6 +406,8 @@
|
|||
:getenv
|
||||
:default-temp-dir
|
||||
:pwd
|
||||
:home-directory
|
||||
:user-info
|
||||
:run-external-program
|
||||
:process-exit-code
|
||||
:process-exit-success-p
|
||||
|
|
@ -421,7 +428,14 @@
|
|||
:file->mime-type
|
||||
:unzip-file
|
||||
:unzip-single-file
|
||||
:copy-to-clipboard))
|
||||
:copy-to-clipboard
|
||||
:user-info
|
||||
:user-info-name
|
||||
:user-info-user-id
|
||||
:user-info-group-id
|
||||
:user-info-gecos
|
||||
:user-info-home
|
||||
:user-info-shell))
|
||||
|
||||
(defpackage :text-utils
|
||||
(:use
|
||||
|
|
@ -1609,8 +1623,7 @@
|
|||
(defpackage :complete
|
||||
(:use
|
||||
:cl
|
||||
:alexandria
|
||||
:osicat)
|
||||
:alexandria)
|
||||
(:export
|
||||
:*complete-function*
|
||||
:shortest-candidate
|
||||
|
|
|
|||
|
|
@ -869,7 +869,8 @@
|
|||
(let* ((signature-file (or (access:accesses *software-configuration*
|
||||
+key-signature-file+)
|
||||
+default-signature-filename+))
|
||||
(signature-path (fs:cat-parent-dir (fs:home-dir) signature-file)))
|
||||
(signature-path (fs:cat-parent-dir (os-utils:home-directory)
|
||||
signature-file)))
|
||||
(if (fs:file-exists-p signature-path)
|
||||
signature-path
|
||||
nil)))
|
||||
|
|
|
|||
|
|
@ -31,7 +31,6 @@
|
|||
:tooter
|
||||
:croatoan
|
||||
:nodgui
|
||||
:osicat
|
||||
:flexi-streams
|
||||
:cl-spark
|
||||
:access
|
||||
|
|
|
|||
Loading…
Reference in New Issue