From 39b7c4c574f62f24c22fbdc00134657ae37914c3 Mon Sep 17 00:00:00 2001 From: Stelian Ionescu Date: Thu, 6 Aug 2009 00:58:54 +0200 Subject: [PATCH] Make most FILE-PATH operators and accessors regular functions. --- src/pathnames/file-path-unix.lisp | 49 ++++++++++++++-------------- src/pathnames/file-path.lisp | 67 ++++++++------------------------------- 2 files changed, 39 insertions(+), 77 deletions(-) diff --git a/src/pathnames/file-path-unix.lisp b/src/pathnames/file-path-unix.lisp index ca584a2..a4d0714 100644 --- a/src/pathnames/file-path-unix.lisp +++ b/src/pathnames/file-path-unix.lisp @@ -38,25 +38,29 @@ ;;; Operations ;;;------------------------------------------------------------------------- -(defmethod enough-file-path ((path unix-path) &optional - (defaults *default-file-path-defaults*)) - (cond - ((or (relative-file-path-p path) - (relative-file-path-p defaults)) - path) - (t - (let* ((dir (cdr (slot-value path 'components))) - (mismatch - (mismatch dir (cdr (slot-value defaults 'components)) - :test #'ustring=))) - (if mismatch - (make-instance 'unix-path :components (subseq dir mismatch)) - (make-instance 'unix-path :components (list :root))))))) - -(defmethod %file-path-host-namestring ((path unix-path)) +(defun enough-file-path (pathspec &optional + (defaults *default-file-path-defaults*)) + (let ((path (file-path pathspec)) + (defaults (file-path defaults))) + (cond + ((or (relative-file-path-p path) + (relative-file-path-p defaults)) + path) + (t + (let* ((dir (cdr (slot-value path 'components))) + (mismatch + (mismatch dir (cdr (slot-value defaults 'components)) + :test #'ustring=))) + (if mismatch + (make-instance 'unix-path :components (subseq dir mismatch)) + (make-instance 'unix-path :components (list :root)))))))) + +(defun %file-path-host-namestring (path) + (declare (ignore path)) "") -(defmethod %file-path-device-namestring ((path unix-path)) +(defun %file-path-device-namestring (path) + (declare (ignore path)) "") (defun %components-namestring (components print-dot trailing-delimiter) @@ -73,19 +77,18 @@ (apply #'join/ustring +directory-delimiter+ dirs) (if (and dirs trailing-delimiter) delimstr nullstr))))) -(defmethod %file-path-components-namestring ((path unix-path) &key print-dot - trailing-delimiter) +(defun %file-path-components-namestring (path &key print-dot trailing-delimiter) (ustring-to-string* (%components-namestring (slot-value path 'components) print-dot trailing-delimiter))) -(defmethod %file-path-directory-namestring ((path unix-path)) +(defun %file-path-directory-namestring (path) (if-let (dir (%file-path-directory path)) (ustring-to-string* (%components-namestring dir t t)) "")) -(defmethod %file-path-file-namestring ((path unix-path)) +(defun %file-path-file-namestring (path) (if-let (file (%file-path-file path)) (ustring-to-string* file) "")) @@ -96,7 +99,7 @@ (ustring-to-string* (%components-namestring components t trailing-delimiter)))) -(defmethod file-path-namestring/ustring ((path unix-path)) +(defun file-path-namestring/ustring (path) (with-slots (components trailing-delimiter) path (%components-namestring components t trailing-delimiter))) @@ -112,7 +115,7 @@ (defun absolute-namestring-p (namestring) (uchar= +directory-delimiter+ (aref namestring 0))) -(defmethod parse-file-path (pathspec &key (start 0) end as-directory (expand-user t)) +(defun parse-file-path (pathspec &key (start 0) end as-directory (expand-user t)) (check-type pathspec (or string ustring)) (when (zerop (length pathspec)) (error 'invalid-file-path diff --git a/src/pathnames/file-path.lisp b/src/pathnames/file-path.lisp index a6a7112..b789d8d 100644 --- a/src/pathnames/file-path.lisp +++ b/src/pathnames/file-path.lisp @@ -64,69 +64,28 @@ ;;; Generic Functions ;;;------------------------------------------------------------------------- -;;; Accessors - -(defgeneric file-path-host (pathspec &key namestring)) - -(defgeneric file-path-device (pathspec &key namestring)) - -(defgeneric file-path-components (pathspec &key namestring)) - -(defgeneric file-path-directory (pathspec &key namestring)) - -(defgeneric file-path-file (pathspec &key namestring)) - -(defgeneric file-path-file-name (pathspec)) - -(defgeneric file-path-file-type (pathspec)) - -(defgeneric file-path-namestring (pathspec)) - -;;; Operations - -(defgeneric make-file-path (&key host device components defaults trailing-delimiter)) - -(defgeneric merge-file-paths (pathspec &optional defaults)) - -(defgeneric enough-file-path (pathspec &optional defaults)) - (defgeneric file-path (pathspec)) -(defgeneric parse-file-path (pathspec &key start end as-directory expand-user)) - -;;; Internal functions - -(defgeneric file-path-namestring/ustring (path)) - -(defgeneric %file-path-host-namestring (path)) - -(defgeneric %file-path-device-namestring (path)) - -(defgeneric %file-path-components-namestring - (path &key print-dot trailing-delimiter)) - -(defgeneric %file-path-directory-namestring (path)) - -(defgeneric %file-path-file-namestring (path)) +(defgeneric file-path-namestring (path)) ;;;------------------------------------------------------------------------- ;;; Accessors ;;;------------------------------------------------------------------------- -(defmethod file-path-host (pathspec &key namestring) +(defun file-path-host (pathspec &key namestring) (let ((path (file-path pathspec))) (if namestring (%file-path-host-namestring path) (slot-value path 'host)))) -(defmethod file-path-device (pathspec &key namestring) +(defun file-path-device (pathspec &key namestring) (let ((path (file-path pathspec))) (if namestring (%file-path-device-namestring path) (slot-value path 'device)))) -(defmethod file-path-components (pathspec &key namestring) +(defun file-path-components (pathspec &key namestring) (let ((path (file-path pathspec))) (if namestring (%file-path-components-namestring @@ -146,7 +105,7 @@ (split-root/nodes components) (cons root (butlast nodes))))) -(defmethod file-path-directory (pathspec &key namestring) +(defun file-path-directory (pathspec &key namestring) (let ((path (file-path pathspec))) (if namestring (%file-path-directory-namestring path) @@ -156,7 +115,7 @@ (let ((components (slot-value path 'components))) (lastcar (nth-value 1 (split-root/nodes components))))) -(defmethod file-path-file (pathspec &key namestring) +(defun file-path-file (pathspec &key namestring) (let ((path (file-path pathspec))) (if namestring (%file-path-file-namestring path) @@ -170,12 +129,12 @@ (values (subseq file 0 dotpos) (subseq file (1+ dotpos)))))) -(defmethod file-path-file-name (pathspec) +(defun file-path-file-name (pathspec) (let ((path (file-path pathspec))) (when-let (file (%file-path-file path)) (nth-value 0 (split-name/type file))))) -(defmethod file-path-file-type (pathspec) +(defun file-path-file-type (pathspec) (let ((path (file-path pathspec))) (when-let (file (%file-path-file path)) (nth-value 1 (split-name/type file))))) @@ -239,9 +198,9 @@ (defmethod file-path ((pathspec pathname)) (parse-file-path (namestring pathspec))) -(defmethod make-file-path (&key (host nil hostp) (device nil devicep) - (components nil componentsp) - (defaults nil defaultsp) trailing-delimiter) +(defun make-file-path (&key (host nil hostp) (device nil devicep) + (components nil componentsp) + (defaults nil defaultsp) trailing-delimiter) (let ((defaults (and defaultsp (file-path defaults)))) (make-instance '#.+file-path-host-type+ :host (cond (hostp host) @@ -254,8 +213,8 @@ (defaultsp (file-path-components defaults))) :trailing-delimiter trailing-delimiter))) -(defmethod merge-file-paths (pathspec &optional - (defaults *default-file-path-defaults*)) +(defun merge-file-paths (pathspec &optional + (defaults *default-file-path-defaults*)) (let ((path (file-path pathspec)) (defaults (file-path defaults))) (make-instance '#.+file-path-host-type+ -- 2.11.4.GIT