:)
--- post-sysdef-install.lisp-old 2009-06-18 22:08:59.000000000 -0600
+++ post-sysdef-install.lisp 2010-05-03 01:16:01.731375996 -0600
@@ -35,12 +35,13 @@
#+cmu (defun get-uid () (unix:unix-getuid))
#+ecl (defun get-uid () (ffi:c-inline () () :int "getuid()" :one-liner t))
#+allegro (defun get-uid () (excl.osi:getuid))
+#+ccl (defun get-uid () (ccl::getuid))
#+clisp (defun world-writable? (mode) (or (member :RWXO mode) (member :WOTH mode)))
#+clisp (defun group-writable? (mode) (or (member :RWXG mode) (member :WGRP mode)))
#-clisp (defun world-writable? (mode) (/= 0 (logand mode #o002)))
#-clisp (defun group-writable? (mode) (/= 0 (logand mode #o020)))
-#-(or cmu sbcl clisp allegro ecl)
+#-(or cmu sbcl clisp allegro ecl ccl)
(defun get-uid ()
(let ((uid-string
(with-output-to-string (asdf::*VERBOSE-OUT*)
@@ -80,6 +81,17 @@
(declare (ignore res dev ino nlink gid rdev size atime mtime))
(values uid mode))))
+#+ccl
+(defun get-owner-and-mode (directory)
+ (when (eq :directory
+ (ccl::%unix-file-kind (namestring directory)))
+ ;; check who owns it
+ (multiple-value-bind (success mode size mtime inode uid blksize)
+ (ccl::%stat (namestring directory))
+ (declare (ignore success size mtime inode blksize))
+ (values uid mode))))
+
+
#+allegro
(defun get-owner-and-mode (directory)
(when (excl:probe-directory directory)
@@ -89,6 +101,14 @@
(uid (excl.osi:stat-uid stat)))
(values uid mode uid))))
+#+ccl
+(defmacro with-secure-umask (&body forms)
+ (let ((old-umask (gensym)))
+ `(let ((,old-umask (#_umask #o0077)))
+ (unwind-protect (progn ,@forms)
+ (#_umask ,old-umask)))))
+
+
#+sbcl
(defmacro with-secure-umask (&body forms)
(let ((old-umask (gensym)))
@@ -117,7 +137,7 @@
(unwind-protect ,@forms
(excl.osi:umask ,old-umask)))))
-#+(or clisp sbcl cmu allegro)
+#+(or clisp sbcl cmu allegro ccl)
(defun check-spooldir-security (target)
;; does target exist?
(multiple-value-bind (uid mode)
@@ -138,7 +158,7 @@
(values))
;; sucks but is portable ;-(
-#-(or cmu sbcl clisp allegro)
+#-(or cmu sbcl clisp allegro ccl)
(defun check-spooldir-security (target)
#+(or)
(cerror "I have checked this"
@@ -211,7 +231,7 @@
(let* ((source-root (asdf::resolve-symlinks *source-root*))
(relative-source (enough-namestring source source-root)))
- #-(or clisp sbcl allergo cmu)
+ #-(or clisp sbcl allergo cmu ccl)
(when (equalp source
(pathname relative-source))
(unless *warned-for-broken-enough-namestring*
_______________________________________________
pkg-common-lisp-devel mailing list
[email protected]
http://lists.alioth.debian.org/mailman/listinfo/pkg-common-lisp-devel
