osicat-cvs

osicat-cvs@common-lisp.net

53 discussions

[osicat-cvs] CVS update: src/osicat.lisp src/test-osicat.lisp
by Nikodemus Siivola 29 Feb '04

29 Feb '04

Update of /project/osicat/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv7831 Modified Files: osicat.lisp test-osicat.lisp Log Message: * Fixed return value from MAKUNBOUND-ENVIRONMENT-VARIABLE * More tests Date: Sun Feb 29 15:52:37 2004 Author: nsiivola Index: src/osicat.lisp diff -u src/osicat.lisp:1.13 src/osicat.lisp:1.14 --- src/osicat.lisp:1.13 Sun Feb 29 15:29:35 2004 +++ src/osicat.lisp Sun Feb 29 15:52:37 2004 @@ -234,7 +234,7 @@ string designated by name. Signals an error on failure." (with-c-name (cname name) (if (zerop (unsetenv cname)) - nil + (string name) (error "Could not remove environment variable ~S." name)))) (defun environment () Index: src/test-osicat.lisp diff -u src/test-osicat.lisp:1.2 src/test-osicat.lisp:1.3 --- src/test-osicat.lisp:1.2 Sun Feb 29 15:29:35 2004 +++ src/test-osicat.lisp Sun Feb 29 15:52:37 2004 @@ -21,6 +21,21 @@ (in-package :osicat-test) +(deftest current-directory.1 + (equal (current-directory) + #.(make-pathname :name nil :type nil :version nil + :defaults *compile-file-truename*)) + t) + +(deftest current-directory.2 + (let ((old (current-directory))) + (unwind-protect + (progn + (setf (current-directory) "/tmp/") + (equal (current-directory) (truename "/tmp/"))) + (setf (current-directory) old))) + t) + (deftest delete-directory.1 (let ((dir (merge-pathnames "delete-directory/" *test-dir*))) (ensure-directories-exist dir) @@ -41,6 +56,10 @@ t) (deftest environment.1 + (cdr (assoc "HOME" (environment) :test #'equal)) + #.(namestring (user-homedir-pathname))) + +(deftest environment.2 (unwind-protect (progn (setf (environment-variable 'test-variable) "TEST-VALUE") @@ -100,6 +119,21 @@ (delete-file file))) :regular-file) +(deftest file-permissions.1 + (and (member :other-read (file-permissions "/tmp/")) + t) + t) + +(deftest file-permissions.2 + (let ((file (ensure-file "tmp-exec"))) + (unwind-protect + (and (not (member :user-exec (file-permissions file))) + (push :user-exec (file-permissions file)) + (member :user-exec (file-permissions file)) + t) + (delete-file file))) + t) + (deftest make-link.1 (let ((link (merge-pathnames "make-link-test-link" *test-dir*)) (file (ensure-file "tmp-file"))) @@ -121,4 +155,13 @@ (delete-file file) (delete-file link))) :symbolic-link) - \ No newline at end of file + +(deftest maunbound-environment-variable.1 + (let ((old (environment-variable :path))) + (unwind-protect + (and old + (makunbound-environment-variable :path) + (null (environment-variable :path)) + t) + (setf (environment-variable :path) old))) + t)

1 0

[osicat-cvs] CVS update: src/test-tools.lisp src/osicat.asd src/osicat.lisp src/test-osicat.lisp src/test-setup.lisp
by Nikodemus Siivola 29 Feb '04

29 Feb '04

Update of /project/osicat/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv5965 Modified Files: osicat.asd osicat.lisp test-osicat.lisp Added Files: test-tools.lisp Removed Files: test-setup.lisp Log Message: * Turn ENVIRONMENT into a function. * Fix tests, nicer test-suite. Date: Sun Feb 29 15:29:35 2004 Author: nsiivola Index: src/osicat.asd diff -u src/osicat.asd:1.5 src/osicat.asd:1.6 --- src/osicat.asd:1.5 Sun Feb 29 13:10:41 2004 +++ src/osicat.asd Sun Feb 29 15:29:35 2004 @@ -83,12 +83,15 @@ (defsystem :osicat-test :depends-on (:osicat :rt) - :components ((:file "test-setup") - (:file "test-osicat" :depends-on ("test-setup")))) + :components ((:file "test-tools") + (:file "test-osicat" :depends-on ("test-tools")))) (defmethod perform ((o test-op) (c (eql (find-system :osicat)))) (operate 'load-op :osicat-test) - (operate 'test-op :osicat-test :force t)) + (funcall (intern "SETUP" :osicat-test)) + (unwind-protect + (operate 'test-op :osicat-test :force t) + (funcall (intern "TEARDOWN" :osicat-test)))) (defmethod perform ((o test-op) (c (eql (find-system :osicat-test)))) (or (funcall (intern "DO-TESTS" :rt)) Index: src/osicat.lisp diff -u src/osicat.lisp:1.12 src/osicat.lisp:1.13 --- src/osicat.lisp:1.12 Sun Feb 29 13:36:42 2004 +++ src/osicat.lisp Sun Feb 29 15:29:35 2004 @@ -237,7 +237,16 @@ nil (error "Could not remove environment variable ~S." name)))) -(defun get-environ () +(defun environment () + "function ENVIRONMENT => alist +function (SETF ENVIRONMENT) alist => alist + +ENVIRONMENT return the current environment as an assoc-list. +SETF ENVIRONMENT modifies the environment its argument. + +Often it is preferable to use SETF ENVIRONMENT-VARIABLE and +MAKUNBOUND-ENVIRONMENT-VARIABLE to modify the environment instead +of SETF ENVIRONMENT." (handler-case (loop for i from 0 by 1 for string = (convert-from-cstring @@ -249,7 +258,7 @@ (error (e) (error "Could not access environment (~S)." e)))) -(defun (setf get-environ) (alist) +(defun (setf environment) (alist) (let ((oldenv (get-environ))) (loop for (var . val) in alist do (setf (environment-variable var) (string val) @@ -260,15 +269,6 @@ do (makunbound-environment-variable var))) alist) -(define-symbol-macro environment (get-environ)) - -(setf (documentation 'environment 'variable) - "symbol-macro ENVIRONMENT - -The current environment as a read-only assoc-list. To modify -the environment use (SETF ENVIRONMENT-VARIABLE) and -MAKUNBOUND-ENVIRONMENT-VARIABLE.") - (defun read-link (pathspec) "function READ-LINK pathspec => pathname Index: src/test-osicat.lisp diff -u src/test-osicat.lisp:1.1 src/test-osicat.lisp:1.2 --- src/test-osicat.lisp:1.1 Tue Nov 18 03:18:58 2003 +++ src/test-osicat.lisp Sun Feb 29 15:29:35 2004 @@ -85,29 +85,40 @@ nil) (deftest file-kind.3 - (file-kind *test-symlink*) + (let* ((file (ensure-file "tmp-file")) + (link (ensure-link "tmp-link" :target file))) + (unwind-protect + (file-kind link) + (delete-file link) + (delete-file file))) :symbolic-link) (deftest file-kind.4 - (file-kind *test-file*) + (let ((file (ensure-file "tmp-file"))) + (unwind-protect + (file-kind file) + (delete-file file))) :regular-file) (deftest make-link.1 - (let ((link (merge-pathnames "make-link-test-link" *test-dir*))) + (let ((link (merge-pathnames "make-link-test-link" *test-dir*)) + (file (ensure-file "tmp-file"))) (unwind-protect (progn - (make-link *test-file* link) + (make-link link :target file) (namestring (read-link link))) - (delete-file link))) - #.(namestring *test-file*)) + (delete-file link) + (delete-file file))) + #.(namestring (merge-pathnames "tmp-file" *test-dir*))) (deftest make-link.2 - (let ((link (merge-pathnames "make-link-test-link" *test-dir*))) + (let ((link (merge-pathnames "make-link-test-link" *test-dir*)) + (file (ensure-file "tmp-file"))) (unwind-protect (progn - (make-link *test-file* link) + (make-link link :target file) (file-kind link)) + (delete-file file) (delete-file link))) :symbolic-link) -

1 0

[osicat-cvs] CVS update: src/osicat.lisp
by Nikodemus Siivola 29 Feb '04

29 Feb '04

Update of /project/osicat/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv22337 Modified Files: osicat.lisp Log Message: * Better interface for MAKE-LINK * Smaller code for WITH-DIRECTORY-ITERATOR Date: Sun Feb 29 13:36:42 2004 Author: nsiivola Index: src/osicat.lisp diff -u src/osicat.lisp:1.11 src/osicat.lisp:1.12 --- src/osicat.lisp:1.11 Sun Feb 29 13:10:41 2004 +++ src/osicat.lisp Sun Feb 29 13:36:42 2004 @@ -150,30 +150,29 @@ The value returned is the value of the last form evaluated in body. Signals an error if pathspec is wild or does not designate a directory." - (with-unique-names (dp dir cdir) + (with-unique-names (dp dir cdir one-iter) `(let ((,dir (normpath ,pathspec t))) (with-c-file (,cdir ,dir :directory t) (let (,dp) (unwind-protect - (macrolet ((,iterator () - `(block nil - (tagbody :retry - (let ((entry (readdir ,',dp))) - (if (null-pointer-p entry) - nil - (let ((name - (convert-from-cstring - (osicat-dirent-name - entry)))) - (if (member name '("." "..") - :test #'string=) - (go :retry) - (return (normpath name)))))))))) - (setf ,dp (opendir ,cdir)) - (when (null-pointer-p ,dp) - (error "Error opening directory ~S." ,dir)) - (let ((*default-pathname-defaults* ,dir)) - ,@body)) + (labels ((,one-iter () + (let ((entry (readdir ,dp))) + (if (null-pointer-p entry) + nil + (let ((name + (convert-from-cstring + (osicat-dirent-name entry)))) + (if (member name '("." "..") + :test #'string=) + (,one-iter) + (normpath name))))))) + (macrolet ((,iterator () + `(,',one-iter))) + (setf ,dp (opendir ,cdir)) + (when (null-pointer-p ,dp) + (error "Error opening directory ~S." ,dir)) + (let ((*default-pathname-defaults* ,dir)) + ,@body))) (when ,dp (if (zerop (closedir ,dp)) nil @@ -291,25 +290,33 @@ (pathname str))) (free-foreign-object buffer))))) -(defun make-link (target link &key hard) - "function MAKE-LINK target link &key hard => pathname +(defun make-link (link &key target hard) + "function MAKE-LINK link &key target hard => pathname Creates link that points to target. Defaults to a symbolic link, but giving a non-NIL value to the keyword argument :HARD creates a hard link. Returns the pathname of the link. +Relative targets are resolved against the link. Relative links are +resolved against *default-pathname-defaults*. + Signals an error if either target or link is wild, target does not exist, or link exists already." + (unless target + (error "No target given to MAKE-LINK.")) (let ((old (current-directory))) (unwind-protect - (with-c-file (old target) + ;; KLUDGE: We merge against link for hard links only, + ;; since symlink does the right thing once we are in + ;; the correct directory. + (with-c-file (old (if hard (merge-pathnames target link) target)) (with-c-file (new link) (setf (current-directory) (normpath *default-pathname-defaults* t)) (if (zerop (funcall (if hard #'link #'symlink) old new)) (pathname link) - (error "Could not create ~A link ~S -> ~S." - (if hard "hard" "symbolic") link target)))) + (error "MAKE-LINK: Could not create ~A link ~S -> ~S." + (if hard "hard" "symbolic") new old)))) (setf (current-directory) old)))) (define-symbol-macro +permissions+

1 0

[osicat-cvs] CVS update: src/early-util.lisp src/ffi.lisp src/osicat-glue.c src/osicat.asd src/osicat.lisp src/packages.lisp
by Nikodemus Siivola 29 Feb '04

29 Feb '04

Update of /project/osicat/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv10914 Modified Files: early-util.lisp ffi.lisp osicat-glue.c osicat.asd osicat.lisp packages.lisp Log Message: More work on consolidating *default-pathname-defaults* and current directory. Date: Sun Feb 29 13:10:41 2004 Author: nsiivola Index: src/early-util.lisp diff -u src/early-util.lisp:1.1 src/early-util.lisp:1.2 --- src/early-util.lisp:1.1 Sun Feb 29 06:25:27 2004 +++ src/early-util.lisp Sun Feb 29 13:10:41 2004 @@ -35,3 +35,11 @@ (format stream "~A. This seems to be a bug in Osicat.~ Please report on osicat-devel(a)common-lisp.net." (message condition))))) + +(defmacro with-c-name ((cname name) &body forms) + (with-unique-names (n-name) + `(let ((,n-name ,name)) + (with-cstring (,cname (etypecase ,n-name + (string ,n-name) + (symbol (symbol-name ,n-name)))) + ,@forms)))) Index: src/ffi.lisp diff -u src/ffi.lisp:1.1 src/ffi.lisp:1.2 --- src/ffi.lisp:1.1 Sun Feb 29 06:27:11 2004 +++ src/ffi.lisp Sun Feb 29 13:10:41 2004 @@ -21,14 +21,28 @@ (in-package :osicat) -;;; FIXME: These should be groveled as well. +;;;; TYPES + +;; FIXME: These should be groveled as well. (def-foreign-type :size-t :unsigned-int) (def-foreign-type :mode-t :unsigned-int) +;;;; FOREIGN GLUE + (def-function ("osicat_mode" c-file-mode) ((name :cstring) (follow-p :int)) :module "osicat" :returning :int) +(def-function ("osicat_getcwd" c-getcwd) () + :module "osicat" + :returning (* :unsigned-char)) + +(def-function "osicat_dirent_name" ((entry :pointer-void)) + :module "osicat" + :returning :cstring) + +;;;; PLAIN POSIX + (def-function "opendir" ((name :cstring)) :module "osicat" :returning :pointer-void) @@ -41,10 +55,6 @@ :module "osicat" :returning :pointer-void) -(def-function "osicat_dirent_name" ((entry :pointer-void)) - :module "osicat" - :returning :cstring) - (def-function "rmdir" ((name :cstring)) :module "osicat" :returning :int) @@ -81,3 +91,6 @@ :module "osicat" :returning :int) +(def-function "chdir" ((name :cstring)) + :module "osicat" + :returning :int) Index: src/osicat-glue.c diff -u src/osicat-glue.c:1.6 src/osicat-glue.c:1.7 --- src/osicat-glue.c:1.6 Sat Nov 8 09:19:25 2003 +++ src/osicat-glue.c Sun Feb 29 13:10:41 2004 @@ -24,6 +24,7 @@ #include <dirent.h> #include <sys/stat.h> #include <pwd.h> +#include <errno.h> extern int osicat_mode (char * name, int follow_p) @@ -51,6 +52,24 @@ return entry->d_name; } - - - +extern char * +osicat_getcwd (void) +{ + size_t size = 128; + while (1) + { + char *buffer = (char *) malloc (size); + if (!buffer) { + return 0; + } + else if (getcwd (buffer, size) == buffer) { + return buffer; + } + else { + free (buffer); + if (errno != ERANGE) + return 0; + size += 128; + } + } +} Index: src/osicat.asd diff -u src/osicat.asd:1.4 src/osicat.asd:1.5 --- src/osicat.asd:1.4 Sun Feb 29 06:29:14 2004 +++ src/osicat.asd Sun Feb 29 13:10:41 2004 @@ -39,7 +39,7 @@ (defmethod perform ((o load-op) (c c-source-file)) (let ((loader (intern "LOAD-FOREIGN-LIBRARY" :uffi))) (dolist (file (asdf::input-files o c)) - (funcall loader file :module "osicat")))) + (funcall loader file :module "osicat" :force-load t)))) (defmethod perform ((o compile-op) (c c-source-file)) (unless (zerop (run-shell-command "~A ~A ~{~A ~}-o ~A" Index: src/osicat.lisp diff -u src/osicat.lisp:1.10 src/osicat.lisp:1.11 --- src/osicat.lisp:1.10 Sun Feb 29 07:44:47 2004 +++ src/osicat.lisp Sun Feb 29 13:10:41 2004 @@ -26,6 +26,9 @@ *compile-file-truename*)) (symbol-name (read f)))) +;;;; COMMON SUBROUTINES + +(declaim (inline c-file-kind)) (macrolet ((def () `(defun c-file-kind (c-file follow-p) (let ((mode (c-file-mode c-file (if follow-p 1 0)))) @@ -47,28 +50,69 @@ (defmacro with-c-file ((c-file pathname &optional required-kind follow-p) &body forms) (with-unique-names (path kind) - ;; We merge the pathname to consolidate *default-pathname-defaults* - ;; and C-sides idea of current directory: relative *d-p-d* gives - ;; way to the C-side, whereas absolute ones take precedence. - `(let ((,path (merge-pathnames ,pathname))) - (print (list :c-file-kind (pathname-directory ,path))) + `(let ((,path ,pathname)) (when (wild-pathname-p ,path) (error "Pathname is wild: ~S." ,path)) (with-cstring (,c-file (namestring ,path)) ,@(if required-kind `((let ((,kind (c-file-kind ,c-file ,follow-p))) ,(etypecase required-kind - (keyword `(unless (eq ,required-kind ,kind) - (if ,kind - (error "~A is ~A, not ~A." - ,path ,kind ,required-kind) - (error "~A ~S does not exist." - ,required-kind ,path)))) - ((eql t) `(unless ,kind - (error "~A does not exist." ,path)))) + (keyword `(unless (eq ,required-kind ,kind) + (if ,kind + (error "~A is ~A, not ~A." + ,path ,kind ,required-kind) + (error "~A ~S does not exist." + ,required-kind ,path)))) + ((eql t) `(unless ,kind + (error "~A does not exist." ,path)))) ,@forms)) forms))))) +(defun relative-pathname-p (pathspec) + (not (eq :absolute (car (pathname-directory pathspec))))) + +(defun merge-directories + (pathspec &optional (other *default-pathname-defaults*)) + (let ((tmp (merge-pathnames pathspec + (make-pathname :name nil :type nil :version nil + :defaults other)))) + (if (relative-pathname-p tmp) + (merge-pathnames tmp (current-directory)) + tmp))) + +(defun normpath (pathspec &optional merge) + (flet ((fixedname (path) + (let ((name (pathname-name path))) + (cond ((equal ".." name) :up) + ((equal "." name) nil) + ((stringp name) name)))) + (fixedtype (path) + (let ((type (pathname-type path))) + (and (stringp type) type))) + (fixeddir (path) + (let ((dir (pathname-directory path))) + (if (member (car dir) '(:absolute :relative)) + dir + (cons :relative dir))))) + (let ((path (if (and merge (relative-pathname-p pathspec)) + (merge-directories pathspec) + pathspec))) + (when (wild-pathname-p path) + (error "Pathname is wild: ~S." path)) + (with-cstring (cfile (namestring path)) + (if (eq :directory (c-file-kind cfile t)) + (make-pathname :name nil :type nil + :directory + (append (fixeddir path) + (remove-if + #'null + (list (fixedname path) + (fixedtype path)))) + :defaults path) + path))))) + +;;;; FILE-KIND + (defun file-kind (pathspec) "function FILE-KIND pathspec => file-kind @@ -80,63 +124,56 @@ :block-device. Signals an error if pathspec is wild." - ;; KLUDGE: OAOOM: We scurry to avoid an extra lstat here. - (let ((path (pathname pathspec))) + (let ((path (merge-pathnames pathspec))) (when (wild-pathname-p path) (error "Pathname is wild: ~S." path)) (with-cstring (cfile (namestring path)) (c-file-kind cfile nil)))) +;;;; DIRECTORY ACCESS + (defmacro with-directory-iterator ((iterator pathspec) &body body) "macro WITH-DIRECTORY-ITERATOR (iterator pathspec) &body forms => value -Within the lexical scope of the body, iterator is defined via flet +If pathspec is relative, it is resolved against *default-pathname-defaults*. +If the resulting pathname is still relative, it is further resolved against +current directory. The resulting pathname is then bound to +*default-pathname-defaults* for the dynamic scope of the body. + +Within the lexical scope of the body, iterator is defined via macrolet such that successive invocations of (iterator) return the directory entries, one by one. Both files and directories are returned, except -'.' and '..'. The order of entries is not guaranteed. - -Once all entries have been returned, further invocations of (iterator) -will all return NIL. +'.' and '..'. The order of entries is not guaranteed. The entries are +returned as relative pathnames against the directory. Entries that are +symbolic links are not resolved. Once all entries have been returned, +further invocations of (iterator) will all return NIL. The value returned is the value of the last form evaluated in -body. - -If pathspec designates a symbolic link, it is implicitly resolved. - -Signal an error if pathspec is wild or does not designate a directory." - (with-unique-names (dp dir cdir err default) - `(let ((,dir (merge-pathnames ,pathspec))) +body. Signals an error if pathspec is wild or does not designate a directory." + (with-unique-names (dp dir cdir) + `(let ((,dir (normpath ,pathspec t))) (with-c-file (,cdir ,dir :directory t) - (let ((,dp nil) - (,default - (make-pathname :name nil :type nil - :directory - (append ;KLUDGE: deal with missing /'s - (pathname-directory ,dir) - (remove-if (lambda (o) - (or (null o) - (keywordp o) - (equal "." o))) - (list (pathname-name ,dir) - (pathname-type ,dir)))) - :defaults ,dir))) + (let (,dp) (unwind-protect - (labels ((,iterator () - (let ((entry (readdir ,dp))) - (if (null-pointer-p entry) - nil - (let ((namestring - (convert-from-cstring - (osicat-dirent-name entry)))) - (if (member namestring '("." "..") - :test #'equal) - (,iterator) - (merge-pathnames namestring - ,default))))))) + (macrolet ((,iterator () + `(block nil + (tagbody :retry + (let ((entry (readdir ,',dp))) + (if (null-pointer-p entry) + nil + (let ((name + (convert-from-cstring + (osicat-dirent-name + entry)))) + (if (member name '("." "..") + :test #'string=) + (go :retry) + (return (normpath name)))))))))) (setf ,dp (opendir ,cdir)) (when (null-pointer-p ,dp) (error "Error opening directory ~S." ,dir)) - ,@body) + (let ((*default-pathname-defaults* ,dir)) + ,@body)) (when ,dp (if (zerop (closedir ,dp)) nil @@ -164,19 +201,11 @@ Signals an error if pathspec is wild, doesn't designate a directory, or if the directory could not be deleted." - (with-c-file (path pathspec :directory) + (with-c-file (path (normpath pathspec t) :directory) (if (zerop (rmdir path)) pathspec (error "Could not delete directory ~S." pathspec)))) -(defmacro with-c-name ((cname name) &body forms) - (with-unique-names (n-name) - `(let ((,n-name ,name)) - (with-cstring (,cname (etypecase ,n-name - (string ,n-name) - (symbol (symbol-name ,n-name)))) - ,@forms)))) - (defun environment-variable (name) "function ENVIRONMENT-VARIABLE name => string function (SETF (ENVIRONMENT-VARIABLE name) value) => value @@ -210,12 +239,27 @@ (error "Could not remove environment variable ~S." name)))) (defun get-environ () - (loop for i from 0 by 1 - for string = (convert-from-cstring - (deref-array environ cstring-array i)) - for split = (position #\= string) - while string - collecting (cons (subseq string 0 split) (subseq string (1+ split))))) + (handler-case + (loop for i from 0 by 1 + for string = (convert-from-cstring + (deref-array environ cstring-array i)) + for split = (position #\= string) + while string + collecting (cons (subseq string 0 split) + (subseq string (1+ split)))) + (error (e) + (error "Could not access environment (~S)." e)))) + +(defun (setf get-environ) (alist) + (let ((oldenv (get-environ))) + (loop for (var . val) in alist + do (setf (environment-variable var) (string val) + oldenv (delete var oldenv + :key (lambda (x) (string (car x))) + :test #'string=))) + (loop for (var . val) in oldenv + do (makunbound-environment-variable var))) + alist) (define-symbol-macro environment (get-environ)) @@ -235,18 +279,17 @@ Signals an error if pathspec is wild, or does not designate a symbolic link." - ;; KLUDGE: Silence a compiler-note (handler-bind (#+sbcl (sb-ext:compiler-note #'muffle-warning)) - (with-c-file (path pathspec :symbolic-link) - (do* ((size 64 (* size 2)) - (buffer #1=(allocate-foreign-string size) #1#) - (got (readlink path buffer size))) - ((< got size) - (let ((str (convert-from-foreign-string buffer :length got))) - (free-foreign-object buffer) - (pathname str))) - (free-foreign-object buffer))))) + (with-c-file (path (normpath pathspec t) :symbolic-link) + (do* ((size 64 (* size 2)) + (buffer #1=(allocate-foreign-string size) #1#) + (got (readlink path buffer size))) + ((< got size) + (let ((str (convert-from-foreign-string buffer :length got))) + (free-foreign-object buffer) + (pathname str))) + (free-foreign-object buffer))))) (defun make-link (target link &key hard) "function MAKE-LINK target link &key hard => pathname @@ -257,12 +300,17 @@ Signals an error if either target or link is wild, target does not exist, or link exists already." - (with-c-file (old target) - (with-c-file (new link) - (if (zerop (funcall (if hard #'link #'symlink) old new)) - (pathname link) - (error "Could not create ~A link ~S -> ~S." - (if hard "hard" "symbolic") link target))))) + (let ((old (current-directory))) + (unwind-protect + (with-c-file (old target) + (with-c-file (new link) + (setf (current-directory) + (normpath *default-pathname-defaults* t)) + (if (zerop (funcall (if hard #'link #'symlink) old new)) + (pathname link) + (error "Could not create ~A link ~S -> ~S." + (if hard "hard" "symbolic") link target)))) + (setf (current-directory) old)))) (define-symbol-macro +permissions+ (load-time-value (mapcar (lambda (x) @@ -307,3 +355,27 @@ :initial-value 0))) perms (error "Could not set file permissions of ~S to ~S." pathspec perms)))) + +(defun current-directory () + "function CURRENT-DIRECTORY => pathname +function (SETF CURRENT-DIRECTORY) pathspec => pathspec + +CURRENT-DIRECTORY returns the operating system's current directory, which +may or may not correspond to *DEFAULT-PATHNAME-DEFAULTS*. + +SETF CURRENT-DIRECTORY changes the operating system's current directory to +the pathspec. An error is signalled if the pathspec is wild or does not +designate a directory." + (let* ((cwd (c-getcwd)) + (str (convert-from-foreign-string cwd :null-terminated-p t))) + (if str + (prog1 + (pathname (concatenate 'string str "/")) + (free-foreign-object cwd)) + (error "Could not get current directory.")))) + +(defun (setf current-directory) (pathspec) + (with-c-file (dir pathspec :directory) + (if (minusp (chdir dir)) + (error "Could not change current directory.") + pathspec))) Index: src/packages.lisp diff -u src/packages.lisp:1.3 src/packages.lisp:1.4 --- src/packages.lisp:1.3 Sun Feb 29 07:44:47 2004 +++ src/packages.lisp Sun Feb 29 13:10:41 2004 @@ -36,6 +36,7 @@ #:with-directory-iterator #:mapdir #:delete-directory + #:current-directory ;; Files #:file-kind ;; Symlinks

1 0

[osicat-cvs] CVS update: src/make-readme.lisp src/osicat.lisp src/packages.lisp src/version.txt
by Nikodemus Siivola 29 Feb '04

29 Feb '04

Update of /project/osicat/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv16491 Modified Files: osicat.lisp packages.lisp version.txt Added Files: make-readme.lisp Log Message: * Handle relative pathnames correctly in WITH-DIRECTORY-ITERATOR. * README generator (make-readme.lisp) Date: Sun Feb 29 07:44:47 2004 Author: nsiivola Index: src/osicat.lisp diff -u src/osicat.lisp:1.9 src/osicat.lisp:1.10 --- src/osicat.lisp:1.9 Sun Feb 29 06:29:14 2004 +++ src/osicat.lisp Sun Feb 29 07:44:47 2004 @@ -21,6 +21,11 @@ (in-package :osicat) +(defparameter *osicat-version* + #.(with-open-file (f (merge-pathnames "version.txt" + *compile-file-truename*)) + (symbol-name (read f)))) + (macrolet ((def () `(defun c-file-kind (c-file follow-p) (let ((mode (c-file-mode c-file (if follow-p 1 0)))) @@ -46,6 +51,7 @@ ;; and C-sides idea of current directory: relative *d-p-d* gives ;; way to the C-side, whereas absolute ones take precedence. `(let ((,path (merge-pathnames ,pathname))) + (print (list :c-file-kind (pathname-directory ,path))) (when (wild-pathname-p ,path) (error "Pathname is wild: ~S." ,path)) (with-cstring (,c-file (namestring ,path)) @@ -99,7 +105,7 @@ Signal an error if pathspec is wild or does not designate a directory." (with-unique-names (dp dir cdir err default) - `(let ((,dir ,pathspec)) + `(let ((,dir (merge-pathnames ,pathspec))) (with-c-file (,cdir ,dir :directory t) (let ((,dp nil) (,default @@ -109,7 +115,8 @@ (pathname-directory ,dir) (remove-if (lambda (o) (or (null o) - (keywordp o))) + (keywordp o) + (equal "." o))) (list (pathname-name ,dir) (pathname-type ,dir)))) :defaults ,dir))) @@ -152,11 +159,11 @@ (defun delete-directory (pathspec) "function DELETE-DIRECTORY pathspec => T -Deletes the direcotry designated by pathspec. Returns T. The +Deletes the directory designated by pathspec. Returns T. The directory must be empty. Symbolic links are not followed. Signals an error if pathspec is wild, doesn't designate a directory, -or if the direcotry could not be deleted." +or if the directory could not be deleted." (with-c-file (path pathspec :directory) (if (zerop (rmdir path)) pathspec Index: src/packages.lisp diff -u src/packages.lisp:1.2 src/packages.lisp:1.3 --- src/packages.lisp:1.2 Sun Oct 26 09:19:32 2003 +++ src/packages.lisp Sun Feb 29 07:44:47 2004 @@ -1,4 +1,4 @@ -;; Copyright (c) 2003 Nikodemus Siivola <nikodemus(a)random-state.net> +;; Copyright (c) 2003, 2004 Nikodemus Siivola <nikodemus(a)random-state.net> ;; ;; Permission is hereby granted, free of charge, to any person obtaining ;; a copy of this software and associated documentation files (the @@ -21,9 +21,12 @@ (defpackage :osicat (:use :cl :uffi) - (:documentation "Osicat is a lightweight operating system interface -for Common Lisp on Unix-platforms. It is not a POSIX-style API, but -rather a simple lispy accompaniment to the standard ANSI facilities.") + (:documentation + "Osicat is a lightweight operating system interface for Common Lisp +on Unix-platforms. It is not a POSIX-style API, but rather a simple +lispy accompaniment to the standard ANSI facilities. + +Osicat homepage: http://www.common-lisp.net/project/osicat") (:export ;;; Evironment #:environment @@ -40,4 +43,7 @@ #:make-link ;; Permissions #:file-permissions + ;; Version info + #:*osicat-version* )) + Index: src/version.txt diff -u src/version.txt:1.6 src/version.txt:1.7 --- src/version.txt:1.6 Sat Nov 8 09:22:34 2003 +++ src/version.txt Sun Feb 29 07:44:47 2004 @@ -1 +1 @@ -0.3.3 +0.3.4

1 0

[osicat-cvs] CVS update: src/grovel-constants.lisp src/osicat.asd src/osicat.lisp src/release.txt
by Nikodemus Siivola 29 Feb '04

29 Feb '04

Update of /project/osicat/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv32116 Modified Files: grovel-constants.lisp osicat.asd osicat.lisp release.txt Log Message: Moved ffi code away from osicat.lisp, with-c-file now consolidates *default-pathname-defaults* and the os current directory. Date: Sun Feb 29 06:29:14 2004 Author: nsiivola Index: src/grovel-constants.lisp diff -u src/grovel-constants.lisp:1.2 src/grovel-constants.lisp:1.3 --- src/grovel-constants.lisp:1.2 Thu Oct 23 19:48:05 2003 +++ src/grovel-constants.lisp Sun Feb 29 06:29:14 2004 @@ -1,3 +1,30 @@ +;; Copyright (c) 2003 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. + +;;;; A simple groveler loosely based on various SBCL grovelers. +;;;; +;;;; Jargon note: A groveler is a lisp program that writes a C-program +;;;; that writes a lisp program. The purpose of this excercise is to +;;;; extract C-side definitions in a portable manner. + (in-package :osicat-system) (defun write-groveler (file constants) @@ -33,7 +60,9 @@ (setf *grovel* (lambda (c obj lisp) (write-groveler c - '( ;; File types + '(;; File types + ;; OAOOM Warning: these are explicitly listed + ;; in osicat.lisp as well. (mode-mask . S_IFMT) (directory . S_IFDIR) (character-device . S_IFCHR) Index: src/osicat.asd diff -u src/osicat.asd:1.3 src/osicat.asd:1.4 --- src/osicat.asd:1.3 Tue Nov 18 03:18:58 2003 +++ src/osicat.asd Sun Feb 29 06:29:14 2004 @@ -1,4 +1,4 @@ -;; Copyright (c) 2003 Nikodemus Siivola <nikodemus(a)random-state.net> +;; Copyright (c) 2003, 2004 Nikodemus Siivola <nikodemus(a)random-state.net> ;; ;; Permission is hereby granted, free of charge, to any person obtaining ;; a copy of this software and associated documentation files (the @@ -24,6 +24,8 @@ (in-package :osicat-system) +;;;; C-SOURCE FILE HANDLING + (defvar *gcc* "/usr/bin/gcc") (defvar *gcc-options* '(#-darwin "-shared" #+darwin "-bundle" @@ -47,6 +49,8 @@ (namestring (car (output-files o c))))) (error 'operation-error :component c :operation o))) +;;;; GROVELING + (defclass grovel-file (cl-source-file) ()) (defmethod perform ((o compile-op) (c grovel-file)) @@ -57,21 +61,25 @@ (constants (merge-pathnames "grovel.lisp-temp" output-file)) (*grovel*)) (declare (special *grovel*)) - (load filename) + ;; Loading the groveler will bind the *govel* hook. + (load filename) (and (funcall (the function *grovel*) c-source a-dot-out constants) (compile-file constants :output-file output-file)))) -;;; The actual system +;;;; SYSTEM + (defsystem :osicat :depends-on (:uffi) :components ((:c-source-file "osicat-glue") (:file "packages") - (:file "macros" :depends-on ("packages")) (:grovel-file "grovel-constants" :depends-on ("packages")) - (:file "foreign-types" :depends-on ("packages")) + (:file "early-util" :depends-on ("packages")) + (:file "ffi" :depends-on ("early-util")) (:file "osicat" :depends-on - ("osicat-glue" "foreign-types" "macros" "grovel-constants")))) + ("osicat-glue" "ffi" "grovel-constants")))) + +;;;; TESTING (defsystem :osicat-test :depends-on (:osicat :rt) Index: src/osicat.lisp diff -u src/osicat.lisp:1.8 src/osicat.lisp:1.9 --- src/osicat.lisp:1.8 Sun Oct 26 11:10:33 2003 +++ src/osicat.lisp Sun Feb 29 06:29:14 2004 @@ -1,4 +1,4 @@ -;; Copyright (c) 2003 Nikodemus Siivola +;; Copyright (c) 2003, 2004 Nikodemus Siivola ;; ;; Permission is hereby granted, free of charge, to any person obtaining ;; a copy of this software and associated documentation files (the @@ -21,53 +21,47 @@ (in-package :osicat) -(def-function ("osicat_mode" c-file-mode) ((name :cstring) (follow-p :int)) - :module "osicat" - :returning :int) - -(define-condition bug (error) - ((message :reader message :initarg :message)) - (:report (lambda (condition stream) - (format stream "~A. This seems to be a bug in Osicat.~ - Please report on osicat-devel(a)common-lisp.net." - (message condition))))) - -;;; KLUDGE: Would macrolet frob be preferable here? I can't see why... -(eval - `(defun c-file-kind (c-file follow-p) - (let ((mode (c-file-mode c-file (if follow-p 1 0)))) - (unless (minusp mode) - (case (logand mode-mask mode) - ,@(mapcar - (lambda (sym) - (list (eval sym) - (intern (symbol-name sym) :keyword))) - ;; OAOOM: These are in grovel-constants.lisp as well. - '(directory character-device block-device - regular-file symbolic-link pipe socket)) - (t (error - 'bug :message - (format nil "Unknown file mode: ~H." mode)))))))) +(macrolet ((def () + `(defun c-file-kind (c-file follow-p) + (let ((mode (c-file-mode c-file (if follow-p 1 0)))) + (unless (minusp mode) + (case (logand mode-mask mode) + ,@(mapcar + (lambda (sym) + (list (eval sym) + (intern (symbol-name sym) :keyword))) + ;; OAOOM Warning: + ;; These are in grovel-constants.lisp as well. + '(directory character-device block-device + regular-file symbolic-link pipe socket)) + (t (error + 'bug :message + (format nil "Unknown file mode: ~H." mode))))))))) + (def)) -(defmacro with-c-file ((c-file pathname &optional required-kind follow-p) &body forms) - ;; FIXME: This assumes that OS has the same idea of current dir as Lisp +(defmacro with-c-file + ((c-file pathname &optional required-kind follow-p) &body forms) (with-unique-names (path kind) - `(let ((,path ,pathname)) + ;; We merge the pathname to consolidate *default-pathname-defaults* + ;; and C-sides idea of current directory: relative *d-p-d* gives + ;; way to the C-side, whereas absolute ones take precedence. + `(let ((,path (merge-pathnames ,pathname))) (when (wild-pathname-p ,path) (error "Pathname is wild: ~S." ,path)) (with-cstring (,c-file (namestring ,path)) - (let ((,kind (c-file-kind ,c-file ,follow-p))) - ,(etypecase required-kind - (keyword `(unless (eq ,required-kind ,kind) - (if ,kind - (error "~A is ~A, not ~A." - ,path ,kind ,required-kind) - (error "~A ~S does not exist." - ,required-kind ,path)))) - ((eql t) `(unless ,kind - (error "~A does not exist." ,path))) - (null nil)) - ,@forms))))) + ,@(if required-kind + `((let ((,kind (c-file-kind ,c-file ,follow-p))) + ,(etypecase required-kind + (keyword `(unless (eq ,required-kind ,kind) + (if ,kind + (error "~A is ~A, not ~A." + ,path ,kind ,required-kind) + (error "~A ~S does not exist." + ,required-kind ,path)))) + ((eql t) `(unless ,kind + (error "~A does not exist." ,path)))) + ,@forms)) + forms))))) (defun file-kind (pathspec) "function FILE-KIND pathspec => file-kind @@ -87,22 +81,6 @@ (with-cstring (cfile (namestring path)) (c-file-kind cfile nil)))) -(def-function "opendir" ((name :cstring)) - :module "osicat" - :returning :pointer-void) - -(def-function "closedir" ((dir :pointer-void)) - :module "osicat" - :returning :int) - -(def-function "readdir" ((dir :pointer-void)) - :module "osicat" - :returning :pointer-void) - -(def-function "osicat_dirent_name" ((entry :pointer-void)) - :module "osicat" - :returning :cstring) - (defmacro with-directory-iterator ((iterator pathspec) &body body) "macro WITH-DIRECTORY-ITERATOR (iterator pathspec) &body forms => value @@ -124,26 +102,30 @@ `(let ((,dir ,pathspec)) (with-c-file (,cdir ,dir :directory t) (let ((,dp nil) - (,default (make-pathname :name nil - :type nil - :directory (append ;KLUDGE: deal with missing /'s - (pathname-directory ,dir) - (remove-if (lambda (o) - (or (null o) - (keywordp o))) - (list (pathname-name ,dir) - (pathname-type ,dir)))) - :defaults ,dir))) + (,default + (make-pathname :name nil :type nil + :directory + (append ;KLUDGE: deal with missing /'s + (pathname-directory ,dir) + (remove-if (lambda (o) + (or (null o) + (keywordp o))) + (list (pathname-name ,dir) + (pathname-type ,dir)))) + :defaults ,dir))) (unwind-protect (labels ((,iterator () (let ((entry (readdir ,dp))) (if (null-pointer-p entry) nil - (let ((namestring (convert-from-cstring - (osicat-dirent-name entry)))) - (if (member namestring '("." "..") :test #'equal) + (let ((namestring + (convert-from-cstring + (osicat-dirent-name entry)))) + (if (member namestring '("." "..") + :test #'equal) (,iterator) - (merge-pathnames namestring ,default))))))) + (merge-pathnames namestring + ,default))))))) (setf ,dp (opendir ,cdir)) (when (null-pointer-p ,dp) (error "Error opening directory ~S." ,dir)) @@ -167,10 +149,6 @@ while entry collect (funcall function entry)))) -(def-function "rmdir" ((name :cstring)) - :module "osicat" - :returning :int) - (defun delete-directory (pathspec) "function DELETE-DIRECTORY pathspec => T @@ -184,21 +162,6 @@ pathspec (error "Could not delete directory ~S." pathspec)))) -(def-function "getenv" ((name :cstring)) - :module "osicat" - :returning :cstring) - -(def-function "setenv" ((name :cstring) (value :cstring) (replace :int)) - :module "osicat" - :returning :int) - -(def-function "unsetenv" ((name :cstring)) - :module "osicat" - :returning :int) - -(def-array-pointer cstring-array :cstring) -(def-foreign-var "environ" 'cstring-array "osicat") - (defmacro with-c-name ((cname name) &body forms) (with-unique-names (n-name) `(let ((,n-name ,name)) @@ -256,11 +219,6 @@ the environment use (SETF ENVIRONMENT-VARIABLE) and MAKUNBOUND-ENVIRONMENT-VARIABLE.") -(def-function "readlink" - ((name :cstring) (buffer (* :unsigned-char)) (size :size-t)) - :module "osicat" - :returning :int) - (defun read-link (pathspec) "function READ-LINK pathspec => pathname @@ -283,14 +241,6 @@ (pathname str))) (free-foreign-object buffer))))) -(def-function "symlink" ((old :cstring) (new :cstring)) - :module "osicat" - :returning :int) - -(def-function "link" ((old :cstring) (new :cstring)) - :module "osicat" - :returning :int) - (defun make-link (target link &key hard) "function MAKE-LINK target link &key hard => pathname @@ -306,10 +256,6 @@ (pathname link) (error "Could not create ~A link ~S -> ~S." (if hard "hard" "symbolic") link target))))) - -(def-function "chmod" ((name :cstring) (mode :mode-t)) - :module "osicat" - :returning :int) (define-symbol-macro +permissions+ (load-time-value (mapcar (lambda (x) Index: src/release.txt diff -u src/release.txt:1.3 src/release.txt:1.4 --- src/release.txt:1.3 Sun Oct 26 09:19:32 2003 +++ src/release.txt Sun Feb 29 06:29:14 2004 @@ -1,6 +1,6 @@ osicat.asd -foreign-types.lisp -macros.lisp +ffi.lisp +early-util.lisp grovel-constants.lisp packages.lisp osicat.lisp

1 0

[osicat-cvs] CVS update: src/ffi.lisp src/foreign-types.lisp
by Nikodemus Siivola 29 Feb '04

29 Feb '04

Update of /project/osicat/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv15600 Added Files: ffi.lisp Removed Files: foreign-types.lisp Log Message: Collected all ffi code to a single place Date: Sun Feb 29 06:27:12 2004 Author: nsiivola

1 0

[osicat-cvs] CVS update: src/early-util.lisp src/macros.lisp
by Nikodemus Siivola 29 Feb '04

29 Feb '04

Update of /project/osicat/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv9280 Added Files: early-util.lisp Removed Files: macros.lisp Log Message: Renamed macros.lisp to early-util.lisp Date: Sun Feb 29 06:25:27 2004 Author: nsiivola

1 0

[osicat-cvs] CVS update: src/.cvsignore src/test-osicat.lisp src/test-setup.lisp src/osicat.asd src/osicat-test.lisp
by Nikodemus Siivola 18 Nov '03

18 Nov '03

Update of /project/osicat/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv4896 Modified Files: osicat.asd Added Files: .cvsignore test-osicat.lisp test-setup.lisp Removed Files: osicat-test.lisp Log Message: More tests. Date: Tue Nov 18 03:18:58 2003 Author: nsiivola Index: src/osicat.asd diff -u src/osicat.asd:1.2 src/osicat.asd:1.3 --- src/osicat.asd:1.2 Sat Nov 8 09:21:59 2003 +++ src/osicat.asd Tue Nov 18 03:18:58 2003 @@ -75,11 +75,12 @@ (defsystem :osicat-test :depends-on (:osicat :rt) - :components ((:file "osicat-test"))) + :components ((:file "test-setup") + (:file "test-osicat" :depends-on ("test-setup")))) (defmethod perform ((o test-op) (c (eql (find-system :osicat)))) (operate 'load-op :osicat-test) - (operate 'test-op :osicat-test)) + (operate 'test-op :osicat-test :force t)) (defmethod perform ((o test-op) (c (eql (find-system :osicat-test)))) (or (funcall (intern "DO-TESTS" :rt))

1 0

[osicat-cvs] CVS update: src/version.txt
by Nikodemus Siivola 08 Nov '03

08 Nov '03

Update of /project/osicat/cvsroot/src In directory common-lisp.net:/tmp/cvs-serv16499 Modified Files: version.txt Log Message: 0.3.3 Date: Sat Nov 8 09:22:34 2003 Author: nsiivola Index: src/version.txt diff -u src/version.txt:1.5 src/version.txt:1.6 --- src/version.txt:1.5 Sun Oct 26 11:10:33 2003 +++ src/version.txt Sat Nov 8 09:22:34 2003 @@ -1 +1 @@ -0.3.2 +0.3.3

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

2003

osicat-cvs