;;; -*- Mode: LISP; Mode: paredit; Package: :USER; BASE: 10; Syntax: ANSI-Common-Lisp; ;-*- ;;; ;;; Personal CMUCL configuration file ;;; (C) 2004-2007 Madhu . All Rights Reserved. ;;; Status: Experimental. DO NOT REDISTRIBUTE ;;; ;;; Time-stamp: <2008-09-29 10:17:18 madhu> ;;; Touched: Wed Dec 19 11:22:21 2001 ;;; (in-package "CL-USER") #+cmu (eval-when (:compile-toplevel) (setq c::top-level-lambda-max 0)) #+cmu (case (c:backend-fasl-file-version c:*target-backend*) (#x19a) (#x19c) (#x19d) (#x19e) (#x20a) (t (cerror "Continue." "Which version of CMUCL?"))) #+scl (case (c:backend-fasl-file-version c:*target-backend*) (16910848 ) ; 1.2.10 (16910592 ) ; 1.2.9.1 (16911104 ) ; 1.2.11 (t (cerror "Continue." "Which version of SCL?"))) #+(and nil cmu) (let* ((foo (with-output-to-string (str) (funcall (sixth (GETF *HERALD-ITEMS* :COMMON-LISP)) str))) (core (subseq foo 11 (position #\Newline foo))) (core-path (truename LISP::*CMUCL-CORE-PATH*)) (lisp-path (truename LISP::*COMMAND-LINE-UTILITY-NAME*))) (assert (equal core-path (truename core))) (warn "(core core-path lisp-path) = ~S" (list core core-path lisp-path))) ;;; ---------------------------------------------------------------------- ;;; ;;; PATHNAME UTILS - PORTABLE ;;; ;;; (defun pathname-to-list (pathname) "PATHNAME is an absolute pathname. Return a new list of string components. If PATHNAME is a file, the last element will be the file-namestring of PATHNAME. Otherwise it will be last directory component" (declare (type pathname pathname)) (let ((components (pathname-directory pathname)) (name (file-namestring pathname))) (assert (eq (pop components) :absolute)) (append components (if name (if (string/= name "") (list name)))))) (defun within-directory-p (target directory) "Return NON-NIL if TARGET is contained within DIRECTORY. TARGET and DIRECTORY are absolute pathnames." (let* ((dir (pathname-to-list target)) (dlen (length dir)) (parent (pathname-to-list directory)) (plen (length parent))) (unless (> plen dlen) ;;madhu: XXX case (not (mismatch parent (butlast dir (- dlen plen)) :test #'string-equal))))) #+nil (progn (within-directory-p #p"/foo/bar" #p"/foo") (within-directory-p #p"/foo/bar/" #p"/foo") (within-directory-p #p"/foo/" #p"/foo")) (defun wildify (root &rest components) "COMPONENTS are directory components. Returns a WILD PATHNAME" (merge-pathnames (make-pathname :name :wild :type :wild :version :wild :directory (append '(:relative) components) :host nil) root nil)) #+nil (directory (wildify (user-homedir-pathname))) (defun directory-pathname (p) "Return a directory pathname with NULL name version and type components." (let ((n (file-namestring p))) (cond (n (make-pathname :name nil :type nil :version nil :directory (append (pathname-directory p) (list n)) :defaults p)) (T (pathname p))))) (defun define-default-logical-pathname-translations (host directory) (let ((translations (list (list "*.*.*" (wildify directory)) (list "**;*.*.*" (wildify directory :wild-inferiors)))) (original-translations (ignore-errors (logical-pathname-translations host)))) (if original-translations (if (equalp original-translations translations) (return-from define-default-logical-pathname-translations nil) (cerror "Change." "Translations defined for host ~A:~&~S New Translations: ~A~&" host original-translations translations))) (format t "~&Setting up translation for ~S: ~S.~%" host translations) (setf (logical-pathname-translations host) translations))) (export '(pathname-to-list within-directory-p wildify directory-pathname define-default-logical-pathname-translations)) ;;; ---------------------------------------------------------------------- ;;; ;;; SEARCHLIST SHENNANIGANS (CMUCL) ;;; ;;; #+cmu (progn (defun setup-search-lists-unpacked (cmudir) "Set up search lists for library: modules: and target: when running a cmucl distribution from an unpacked location at CMUDIR. The lisp binary is usually at CMUDIR/bin/lisp." (setf (ext:search-list "trunk:") (list (truename cmudir)) (ext:search-list "library:") '(#P"trunk:lib/cmucl/lib/" #P"trunk:lib/") (ext:search-list "modules:") '(#P"library:subsystems/") (ext:search-list "target:") '(#P"trunk:/src/")) T) (defun setup-search-lists-compiled (cmudir targetname) " TARGETNAME is a string denoting the directory component of the target. Set up search lists for library: modules:: when running a cmucl distribution from an compiled location based on the target: search path. The lisp binary is usually at target:/lisp/lisp." (setf (ext:search-list "trunk:") (list (truename cmudir)) (ext:search-list "target:") (mapcar (lambda (x) (pathname (concatenate 'string "trunk:" x "/"))) (list "src" targetname)) (ext:search-list "modules:") (list "target:pcl/" "target:clx/" "target:hemlock/" "target:interface/") (ext:search-list "library:") (list "target:/motif/server/" "target:hemlock/") (ext:search-list "ext-formats:") (list "target:pcl/simple-streams/external-formats/")) T) (defun show-search-lists () (loop for path being each hash-key in LISP::*SEARCH-LISTS* using (hash-value sl) for x = (concatenate 'string path ":") when (LISP::SEARCH-LIST-DEFINED sl) ;; NOTE: cannot use (ext:search-list-defined-p x) here because ;; it errors out when x names a logical pathname do (format t "~T~A~T~T~T~S~&" x (ext:search-list x)) and collect (cons path (mapcar #'(lambda (directory) (make-pathname :host (pathname-host "") :directory (cons :absolute directory))) (lisp::search-list-expansions sl))) else collect path into undefined initially (format t "~&Defined *SEARCH-LISTS*:~%") finally (format t "~%Undefined *SEARCH-LISTS*:~%~T ~S." undefined))) #+nil (setup-search-lists-unpacked "/usr/local/") #-rhea (setup-search-lists-compiled "home:cmu/" "glibc22") #+rhea (setup-search-lists-unpacked "home:scratch/cmucl/") ;;; ;;; (unless (ext:search-list-defined-p "fasl:") (setf (ext:search-list "fasl:") (list #-rhea #p"/var/local/fasl/" #+rhea #p"/scratch/madhu/fasl/" ))) ;;; ;;; ;;; (defmacro nconcf (list lists) "NCONCS LISTS to the place denoted by the form LIST." `(setf ,list (nconc ,list ,lists))) (defun add-to-search-list (search-host &rest paths) (dolist (dir paths) (unless (find dir (ext:search-list search-host) :test #'equal) (nconcf (ext:search-list search-host) (list dir))))) (defmacro with-added-paths ((&rest paths) &body body) "Execute BODY in an environment where the paths: search list is modified temporarily to include given PATHS." `(let ((list (ext:search-list "path:"))) (unwind-protect (progn (setf (ext:search-list "path:") (append ',paths list)) ,@body) (setf (ext:search-list "path:") list)))) (export '(with-added-paths add-to-search-list))) ;;; ---------------------------------------------------------------------- ;;; ;;; (defvar *log-ignored-errors* t) (defun maybe-log-ignored-errors (c) (case *log-ignored-errors* ((t) (format t "~&IGNORING-ERROR:") (etypecase c (simple-condition (apply 'format t (simple-condition-format-control c) (simple-condition-format-arguments c))) (error (format t "~S" c))) (format t "~&")) ((:break) (with-simple-restart (continue "IGNORING-ERRORS: Continue from BREAK.") (signal c))))) (defmacro ignoring-errors (&body form) `(handler-case (progn ,@form) (error (c) (maybe-log-ignored-errors c)))) (defmacro continuing-from-errors ((&rest condition-types) &body body) "CONDITION-TYPES is a list of CONDITION-MATCHERs which specify the conditions which we handle by invoking the CONTINUE restart automatically. If CONDITION-TYPES is NIL, include ERROR. To disable handling any conditions, use CONDITION-TYPE (:NONE). condition-types = (condition-matcher*); condition-matcher = condition-type | (condition-type fmt*); A CONDITION-TYPE is a symbol denoting a condition. FMT is a string which is tested against the SIMPLE-CONDITION-FORMAT-CONTROL of the condition being handled: we continue from the error only if there is a prefix match. If multiple FMT strings are supplied, we continue from the error if any one of them match." (cond ((endp condition-types) (setq condition-types '(error))) (t (setq condition-types (remove :none condition-types)))) (let ((handlers (loop for elem in condition-types for (x test) = (cond ((consp elem) (check-type (car elem) symbol "Expect a symbol denoting a conditon.") (list (car elem) (if (endp (cdr elem)) t `(or ,@(loop for x in (cdr elem) do (check-type x string "Expect a format control string.") collect `(prefixp ,x (simple-condition-format-control x))))))) (t (list elem t))) collect `(,x (lambda (x &aux r) (when ,test (when (setq r (find-restart 'continue x)) (maybe-log-ignored-errors x) (format t "Invoking restart ~S~&" r) (invoke-restart r)))))))) `(handler-bind ,handlers ,@body))) #+nil (continuing-from-errors ((error "Redefining class ~S incompatibly with the current")) (defstruct foo a b c) (defstruct foo a b c d)) ;;; ---------------------------------------------------------------------- ;;; ;;; BINARY-DIRECTORY. (LC-LITE) (progn (defvar *binary-directory-fasl-root* "fasl:" "Root Directory of fasl files.") ;XXX (defvar *binary-directory-pattern* (or #+scl (list "binary-scl") #+cmu (list "binary-cmucl") #+lispworks (list "binary-lispworks") #+allegro (list "binary-allegro") #+clisp (list "binary-clisp") #+sbcl (list "binary-sbcl") (cerror "Continue" "Unknown implementation.")) "List of strings denoting directory components under fasl root.") (defvar *binary-directory-version* (or #+scl (list (let* ((backend (c:backend-name c:*target-backend*)) (version (c:backend-fasl-file-version c:*target-backend*))) (format nil "scl-~A-~D.~D.~D.~D" backend (ldb (byte 8 24) version) (ldb (byte 8 16) version) (ldb (byte 8 8) version) (ldb (byte 8 0) version)))) #+(and nil cmu) (list (format nil "~(~x~)" (c:backend-fasl-file-version c:*target-backend*))) (list (lisp-implementation-version))) "List of strings denoting directory components under implementation's fasl root.") (defun binary-directory (pathname &rest dirnames) (when (or #+allegro (excl::logical-pathname-p (pathname pathname)) #+(or clisp lispworks) (system::logical-pathname-p (pathname pathname)) #+cmu (LISP::LOGICAL-PATHNAME-P (pathname pathname))) (setq pathname (translate-logical-pathname pathname))) (let* ((pathname-directory (pathname-directory pathname)) (last (if (endp (cdr pathname-directory)) nil (last pathname-directory)))) #+cmu (when (lisp::search-list-p (car last)) ;handle "host:/skt.lisp" (assert (lisp::search-list-defined (cadr pathname-directory))) (setq last nil)) (let ((p (make-pathname :name nil :type nil :version nil :directory (append (pathname-directory *binary-directory-fasl-root*) last *binary-directory-pattern* dirnames *binary-directory-version*)))) p))) (defvar *binary-directory-ensure-directories-exist* t) (defvar *binary-directory-source-file-types* '("lisp" "l" "cl" "lsp")) (defun lc (pathname &key library-p force (source-directory *default-pathname-defaults*) (source-file-types *binary-directory-source-file-types*) (create-directories *binary-directory-ensure-directories-exist*) binary-directory dry-run) "Compile and load pathnanme. CREATE-DIRECTORIES has no effect during DRY-RUN." (prog* ((*default-pathname-defaults* source-directory) (source-truename (or (probe-file pathname) (when (null (pathname-type pathname)) (some (lambda (source-file-type) (probe-file (make-pathname :type source-file-type :defaults pathname))) source-file-types)))) (binary-directory (or binary-directory (and source-truename (binary-directory source-truename)) (binary-directory pathname))) (fasl (let ((purported-fasl (compile-file-pathname (or source-truename pathname)))) (make-pathname :name (if library-p (concatenate 'string (pathname-name purported-fasl) "-library") (pathname-name purported-fasl)) :version (pathname-version purported-fasl) :type (pathname-type purported-fasl) :defaults binary-directory)))) (if dry-run (return (values fasl source-truename))) retry (unless source-truename (error "Could not find source file: ~A" pathname)) (if create-directories (ensure-directories-exist fasl)) (when (or force (< (or (handler-case (file-write-date fasl) (error (e) (format "Error: file-write-date: ~A: ~A." fasl e) 0)) 0) (file-write-date source-truename))) (print (list 'compile-file source-truename :output-file fasl)) (multiple-value-bind (output-truename warnings-p failure-p) (compile-file source-truename :output-file fasl) (assert (equal (truename fasl) (truename output-truename))) (when failure-p ;XXX (format t "lc: compile-file returned: ~A." (list output-truename warnings-p failure-p))))) (print (list 'load fasl)) load-fasl (restart-case (load fasl) (delete-fasl-and-retry () :report (lambda (stream) (format stream "Delete ~A and retry compilation." fasl)) :test (lambda (condition) (declare (ignore condition)) (probe-file fasl)) (delete-file fasl) (go retry))))) (setf (symbol-function 'lc-lite) #'lc) (export '(binary-directory lc))) #+cmu (defun crumple (source-pathname &key (source-file-type "c") (object-file-type "so") (cc "/usr/local/bin/gcc") (cflags (list "-g" "-shared")) (force nil) &aux (path (truename source-pathname))) "[Compile and] load C file." (assert (string= source-file-type (pathname-type path))) (let ((obj (let ((cfp (compile-file-pathname path))) ; hack! (make-pathname :name (pathname-name cfp) :type object-file-type :defaults cfp))) p) (when (or force (< (or (file-write-date obj) 0) (or (file-write-date path) (file-write-date (setq p (make-pathname :type source-file-type :defaults path))) (error "couldn't find given ~S or ~S." path p)))) (ext:run-program cc (append cflags (list "-o" (namestring obj)) (list (namestring path))))) (ext:load-foreign obj))) ;;; ---------------------------------------------------------------------- ;;; ;;; #+cmu (progn (assert (eq 'unix-namestring 'unix::unix-namestring)) (export '(unix-namestring))) #+allegro (progn (defun unix-namestring (pathname) (excl::unix-namestring pathname)) (export '(unix-namestring))) #+lispworks (progn (defun unix-namestring (pathname) (system::os-namestring pathname)) (export '(unix-namestring))) ;; FIXME: CONFORM ON RETURN VALUE OF UNIX-TRUNCATE ;madhu 080829 #+cmu (progn (defun unix-truncate (name length) (unix:unix-truncate name length)) (export '(unix-truncate))) #+allegro (progn (defun unix-truncate (name length) (excl.osi:os-truncate name length)) (export '(unix-truncate))) #+(and lispworks unix) (progn (fli:define-foreign-function (unix-truncate "truncate" :source) ((path (:reference-pass :ef-mb-string)) (offset :int)) :result-type :int) (export '(unix-truncate))) #+(and lispworks unix) (defun perror (fmt &rest args) (let ((errno (lw::errno-value))) (funcall 'error "~?: ~A(~D).~&" fmt args (lw:get-unix-error errno) errno))) ;;; ---------------------------------------------------------------------- ;;; ;;; CLI ;;; #+allegro (defun quit (excl:exit)) #+(or scl cmu clisp) (defun pwd () (ext:default-directory)) #+lispworks (defun pwd nil (system::current-directory)) #+allegro (defun pwd () (excl::current-directory)) #+allegro (defun cd (&optional directory) (excl::chdir (or directory (user-homedir-pathname)))) #+(or cmu scl) (defun cd (&optional (gross-dir (unix-namestring (car (ext:search-list "home:"))))) (and (pathnamep gross-dir) (setq gross-dir (unix-namestring gross-dir))) (when (/= (length gross-dir) 0) (if (char= (char gross-dir 0) #\~) (let ((p (position #\/ gross-dir))) (unless (or (null p) (= p 1)) (warn "~~unimplemented/")) (when p (cd) (cd (subseq gross-dir (1+ p))))) (unix:unix-chdir gross-dir))) (pwd)) #+cmu (defun ps () (mp::show-processes)) #+(or cmu scl) (defun delete-directory (path) (unix:unix-rmdir (unix::unix-namestring path))) (let ((dirstack nil)) (defun pushd (&optional dir n) ; TODO (push (pwd) dirstack) (if dir (cd dir) (cd))) (defun popd (&optional n) (cd (pop dirstack)))) #+nil ;TODO (export '(pwd cd ps delete-directory pushd popd)) ;;; ;;; ;;; (defmacro in-directory (directory &body forms) (let ((cwd (gensym))) `(let ((,cwd (pwd)) #+allegro (*default-pathname-defaults* #p"")) (unwind-protect (progn (cd ,directory) ,@forms) (cd ,cwd))))) (export '(in-directory)) ;;; ---------------------------------------------------------------------- ;;; ;;; ENVIRONMENT VARIABLES: (GETENV SETENV) ;;; #+cmu (progn (alien:def-alien-routine ("getenv" unix-getenv) c-call:c-string (name c-call:c-string)) (alien:def-alien-routine ("setenv" unix-setenv) c-call:int (name c-call:c-string) (value c-call:c-string) (overwrite c-call:int)) (alien:def-alien-routine ("unsetenv" unix-unsetenv) c-call:void (name c-call:c-string)) (defun getenv (var) (cdr (assoc (intern var "KEYWORD") ext:*environment-list*))) (defun setenv (var value) (let* ((item (intern var "KEYWORD")) (cons (assoc item ext:*environment-list*))) (cond (cons (setf (cdr cons) value)) (t (setq cons (cons item value)) (push cons ext:*environment-list*) value)))) (export '(unix-getenv unix-setenv unix-unsetenv))) #+lispworks (eval-when (load eval compile) (shadow '(getenv setenv))) #+lispworks (progn (defun getenv (x) (environment-variable x)) (defun setenv (x v) (setf (environment-variable x) v))) #+clisp (eval-when (load eval compile) ;FIXME: CLISP gets it right (mapcar 'unintern '(cl-user::getenv cl-user::setenv)) (shadow '(getenv setenv))) #+clisp (progn (defun getenv (x) (ext:getenv x)) (defun setenv (x v) (setf (ext:getenv x) v))) #+allegro (progn (defun getenv (x) (sys:getenv x)) (defun setenv (x v) (if v (setf (sys:getenv x) v) (excl.osi:unsetenv x)))) (defsetf getenv (var) (value) `(setenv ,var ,value)) (export '(getenv setenv)) ;;; ---------------------------------------------------------------------- ;;; ;;; ENVIRONMENT VAR UTILS - PORTABLE ;;; (defmacro with-env-vars ((&rest bindings) &body body) (loop for (var env-val) in bindings for x = (gensym) for env-var = (etypecase var (keyword (symbol-name var)) (string var)) collect `(,x (getenv ,env-var)) into old-bindings collect `(setenv ,env-var ,env-val) into do-forms collect `(setenv ,env-var ,x) into undo-forms finally (return `(let ,old-bindings (unwind-protect (progn ,@do-forms ,@body) ,@undo-forms))))) (defun add-to-env (env item &optional (separator (or #+unix ":" #+mswindows ";" ":")) at-beginning-p &key (test #'string-equal) force) "ENV is a string environment variable. Appends string ITEM to the expansion of ENV seperated by SEPARATOR. If AT-BEGINNING-P is non-NIL prepend it. NOTE ITEM is not added if it is already present. Use FORCE in addition to AT-BEGINNING-P to prepend a string even if it is present in the expansion, but not at the beginning." (let ((old (getenv env))) (assert (stringp old) nil "Env variable ~S isnt defined: ~S." env old) (let ((pos (search item old :test test))) (cond (at-beginning-p (when (or (null pos) (and force (not (zerop pos)))) (setenv env (concatenate 'string item separator old)))) (t (unless pos (setenv env (concatenate 'string old separator item)))))))) (export '(add-to-env with-env-vars)) #|| (user:getenv "SHELL") (user:getenv "PATH") (user:add-to-env "PATH" "c:/msys/1.0/bin") (user:getenv "FOO") (progn (user:setenv "FOO" "BAR;CAR") (assert (string= (user:getenv "FOO") "BAR;CAR")) (user:add-to-env "FOO" "VAR" ";") (assert (string= (user:getenv "FOO") "BAR;CAR;VAR")) (user:add-to-env "FOO" "VAR" ";" t) (assert (string= (user:getenv "FOO") "BAR;CAR;VAR")) (user:add-to-env "FOO" "TAR" ";" t) (assert (string= (user:getenv "FOO") "TAR;BAR;CAR;VAR")) (user:setenv "FOO" nil)) (with-env-vars ((:GIT_COMMITTER_DATE "TIMESTAMP") (:GIT_AUTHOR_DATE "timestamp")) '*environment-list*) ||# ;;; ---------------------------------------------------------------------- ;;; ;;; DATE TIME UTILITIES - PORTABLE ;;; (defun convert-zone-string (zone) "Internal. Convert ZONE of the form +/- NNNN to a common lisp time zone." (let ((num (parse-integer zone))) (multiple-value-bind (hours minutes) (truncate num 100) (let ((lisp-zone (- (+ hours (/ minutes 60))))) (assert (rationalp lisp-zone)) lisp-zone)))) (defun date (&key (stream *standard-output*) (utime (get-universal-time)) tz) (multiple-value-bind (second minute hour date month year day daylight-p zone) (if tz (decode-universal-time utime tz) (decode-universal-time utime)) (when daylight-p (decf zone)) ; check (format stream "~a ~a ~2,' d ~2,'0d:~2,'0d:~2,'0d ~4d ~?" (ecase day (0 "Mon") (1 "Tue") (2 "Wed") (3 "Thu") (4 "Fri") (5 "Sat") (6 "Sun")) (ecase month (1 "Jan") (2 "Feb") (3 "Mar") (4 "Apr") (5 "May") (6 "Jun") (7 "Jul") (8 "Aug") (9 "Sep") (10 "Oct") (11 "Nov") (12 "Dec")) date hour minute second year "~:[+~;-~]~2,'0d~2,'0d" (multiple-value-bind (hour min) (truncate zone 1) (list (plusp zone) (abs hour) (* 60 (abs min))))))) (defun iso-8601-date (&key (stream nil) (utime (get-universal-time)) (tz nil) (suppress-time-p nil) (suppress-tz-p t)) "Format current datetime (for Common Lisp time-zone TZ) on STREAM." (multiple-value-bind (second minute hour date month year day daylight-p zone) (if tz (decode-universal-time utime tz) (decode-universal-time utime)) (declare (ignore day)) (if daylight-p (decf zone)) ; check (format stream "~4,'0D-~2,'0D-~2,'0D~:[ ~2,'0D:~2,'0D:~2,'0D~:[ ~C~2,'0D~2,'0D~;~]~;~]" ; year month date suppress-time-p hour minute second suppress-tz-p (if (plusp zone) #\- #\+) (abs (truncate zone)) (truncate (* 60 (mod zone 1)))))) (defun yymmddhhmm (&key (stream nil) (utime (get-universal-time)) tz) "[[CC]YY]MMDDhhmm[.ss] for touch(1)." (multiple-value-bind (second minute hour date month year day daylight-p zone) (if tz (decode-universal-time utime tz) (decode-universal-time utime)) (declare (ignorable daylight-p day zone)) (format stream "~4d~2,'0d~2,'0d~2,'0d~2,'0d.~2,'0d" year month date hour minute second))) (defun yymmdd (&key stream (utime (get-universal-time)) tz) (multiple-value-bind (second minute hour date month year day daylight-p zone) (if tz (decode-universal-time utime tz) (decode-universal-time utime)) (declare (ignorable daylight-p zone second minute hour day)) (format stream "~d~2,'0d~2,'0d" year month date))) ;; Eg. World Times fluff ;; Mon Dec 4 09:46:07 2000 ;; (defvar TimeZoneMap2000.gif-codes '(("Z" 0) ("A" 1) ("B" 2) ("C" 3) ("C*" 7/2) ("D" 4) ("D*" 9/2) ("E" 5) ("E*" 11/2) ("F" 6) ("F*" 13/2) ("G" 7) ("H" 8) ("I" 9) ("I*" 19/2) ("J" 10) ("K" 11) ("K*" 21/2) ("L" 12) ("L*" 23/2) ("M" 13) ("M*" 14) ("N" -1) ("O" -2) ("P" -3) ("P*" -7/2) ("Q" -4) ("R" -5) ("S" -6) ("T" -7) ("U" -8) ("U*" -17/2) ("V" -9) ("V*" -19/2) ("W" -10) ("X" -11) ("Y" -12))) (defvar TimeZoneMap2000.gif-cities '((("Honolulu" "Hawaii") "W") (("Anchorage" "Alaska") "V") (("Los Angeles" "California") "U") (("Denver" "Colorado") "T") (("Chicago" "Illinois") "S") (("New York" "America") "R") (("Caracas" "Venezuela") "Q") (("London" "United Kingdom") "Z") (("Paris" "France") "A") (("Buenos Aires" "Argentina") "P") (("Hong Kong" "China") "H") (("Tokyo" "Japan") "I") (("Brisbane" "Australia") "K") (("Sydney" "Australia") "K") (("Bangkok" "Thailand") "G") (("Moscow" "Russia") "G") (("Karachi" "Pakistan") "E") (("Calcutta" "Asia") "E*"))) (defun world-times (&key (utime (get-universal-time)) (stream t)) (loop for ((place city) code) in TimeZoneMap2000.gif-cities for cons = (assoc code TimeZoneMap2000.gif-codes :test #'string=) do (format stream "~&~30:<~a/~a~>~t" place city) (date :stream stream :utime utime :tz (- (cadr cons))))) (export '(date iso-8601-date date touchdate yymmdd world-times convert-zone-string)) (defconstant +unix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0)) (defun universal-time (unix-time) "Return the Common Lisp universal time in seconds of the given unix time." (+ unix-time +unix-epoch+)) (export '(+unix-epoch+ universal-time)) #+nil (assert (= user:+unix-epoch+ 2208988800)) ;;; ---------------------------------------------------------------------- ;;; ;;; RUN2 SUB-PROCESS INTERFACE ;;; ;;; Madhu [Sat Mar 12 08:26:25 2005 +0530] ;;; #+cmu (progn (defvar *process* nil) (define-symbol-macro $stdin (ext::process-input *process*)) (define-symbol-macro $stdout (ext::process-output *process*)) (define-symbol-macro $stderr (ext::process-error *process*)) (define-symbol-macro $pty (ext::process-pty *process*)) (defvar *last-command* nil) (defvar *last-command-error-stream* (make-string-output-stream)) (defvar *last-command-error-string* nil) (defun last-command-status (&optional (stream *standard-output*)) (format stream "Last command: `~{~A~^ ~}'~%" *last-command*) (format stream "Last command output: `~A'~%" ;TODO *last-command-error-string*) (cond ((EXT:process-p *process*) (format stream "Process: ~A. Status: ~A. Exit Code: ~A.~%" *process* (EXT:process-status *process*) (EXT:process-exit-code *process*))) (t (format stream "Invalid process: ~A~%" *process*)))) (defvar *default-settings** (list :wait t :input nil :output (load-time-value cl:*standard-output*) :pty nil :error :output)) ;; XXX :error is hokey (defmacro with-defaults ((&rest plist &key (wait t) (input nil) (error :output) (output 'cl:*standard-output*) (pty nil)) &body body) "Binds *DEFAULT-SETTINGS**. See EXT:RUN-PROGRAM" (declare (ignorable wait input output pty error)) `(let ((*default-settings** (nconc (list ,@plist) *default-settings**))) ,@body)) (defun run2 (command &rest args) "Get defaults from *DEFAULT-SETTINGS**. See EXT::RUN-PROGRAM" (macrolet ((default (x) `(getf *default-settings** ,x))) (if *process* (ext:process-kill *process* 9)) (get-output-stream-string *last-command-error-stream*) (let* ((output (default :output)) (error (default :error)) (error-stream (case error (:output (cond ((null output) *last-command-error-stream*) ;XXX ((streamp output) (make-broadcast-stream *last-command-error-stream* output)) (t (warn "RUN2: Ignoring :ERROR :OUTPUT") *last-command-error-stream*))) ((nil) nil) ((streamp error) (make-broadcast-stream *last-command-error-stream* error)) (t (warn "RUN2: Ignoring :ERROR ~S" error) *last-command-error-stream*)))) (setq *last-command* (cons command args) *process* (EXT:run-program command args :wait (default :wait) :error error-stream :input (default :input) :output output :pty (default :pty)) *last-command-error-string* (get-output-stream-string *last-command-error-stream*)))) (case (ext:process-status *process*) (:exited (if (zerop (ext:process-exit-code *process*)) t (cerror "Continue" "`~{~A~^ ~}' aborted with an error~@[:~%~A~]~%" *last-command* (unless (string= "" *last-command-error-string*) *last-command-error-string*)))) (:signaled (cerror "Continue" "`~{~A~^ ~}' killed with signal ~A~@[ (core dumped)].~%" *last-command* (ext:process-exit-code *process*) (ext:process-core-dumped *process*))))) (export '(with-defaults run2 $stdin $stdout $stderr last-command-status))) #+lispworks (progn (defvar *last-command* nil) (defvar *default-settings** (list :wait t :output (load-time-value cl:*standard-output*))) (defmacro with-defaults ((&rest plist &key (output 'cl:*standard-output*) (wait t)) &body body) (declare (ignorable output wait)) `(let ((*default-settings** (nconc (list ,@plist) *default-settings**))) ,@body)) ;; (prefix system::*call-system-showing-output-prefix*) ;; XXX Make sure sh.exe is in PATH (defun run2 (command &rest args) (macrolet ((default (x) `(getf *default-settings** ,x))) (system::call-system-showing-output (setq *last-command* (or ;FIXME #+mswindows (cons command args) #-mswindows (list "/bin/sh" "-c" (format nil "~A ~{~S~^ ~}" command args)) (reduce (lambda (a b) (concatenate 'string a " " b)) args :initial-value command))) :current-directory nil :prefix nil :show-cmd nil :output-stream (default :output) :wait (default :wait) :shell-type #+mswindows "sh.exe" #-mswindows "/bin/sh" :kill-process-on-abort nil :extra-environ nil))) (export '(with-defaults run2))) #+clisp (progn ;; madhu 050611 clisp wont let you pass in a stream. create new streams each ;; time. no :pty. To support pass-in streams bind *terminal-io* before ;; calling. Not worth fighting design (defvar *process* nil) (defvar $stdin nil) (defvar $stdout nil) (defvar $pty nil) (defvar *default-settings** `(:wait t :input nil :output :terminal)) (defmacro with-defaults (alist &body body) `(let ((*default-settings** (nconc (list ,@alist) *default-settings**))) ,@body)) (defun run2 (command &rest args) (macrolet ((default (x) `(getf *default-settings** ,x))) (if $stdin (close $stdin) (setf $stdin nil)) (if $stdout (close $stdout) (setf $stdout nil)) (if $pty (close $pty) (setf $pty nil)) (let ((input (default :input)) (output (default :output))) (etypecase output (symbol (ecase output ((:terminal :stream nil)))) (string) (stream (error "Not supported."))) (etypecase input (symbol (ecase input ((:terminal :stream nil)))) (string) (stream (error "Not supported."))) ;; check the fucking clisp contract (setf *process* (ext:run-program command ;; :may-exec t :arguments args :wait (default :wait) :input input :output output)) (cond ((and (eq input :stream) (eq output :stream)) (assert (= (length *process*) 3)) (map nil (lambda (stream) (assert (streamp stream))) *process*) (setf $pty (first *process*) $stdin (second *process*) $stdout (third *process*))) ((eq input :stream) (assert (streamp *process*)) (setf $stdin *process* $stdout nil $pty nil)) ((eq output :stream) (assert (streamp *process*)) (setf $stdout *process* $stdout nil $pty nil)) (t (warn "~S" (list input output (default :error) (default :wait))) (setf $stdin nil $stdout nil $pty nil))))) (export '(run2 with-defaults)))) #+allegro (progn ;; NOTE allegro 8.1 won't let you pass any streams except fd streams and its ;; own terminal io. We let this be for input streams. for output streams the ;; workaround to support the API is ugly: (defstruct my-process command input input-stream output output-stream error error-stream frob-output-stream frob-error-stream status exit-code pid signal) (defun my-process-reap (*process*) (when (my-process-pid *process*) (multiple-value-bind (exit-code pid signal) (sys:reap-os-subprocess :pid (my-process-pid *process*) :wait t) (when exit-code (assert (= pid (my-process-pid *process*))) (warn "reaped ~S: new exit-code ~S ~@[pid ~S~] ~@[signal ~S~]." *process* exit-code pid signal) (setf (my-process-exit-code *process*) exit-code (my-process-signal *process*) signal (my-process-status *process*) (if signal :signalled :exited)))))) (defun my-process-clear (*process*) (setf (my-process-command *process*) nil (my-process-input *process*) nil (my-process-input-stream *process*) nil (my-process-output *process*) nil (my-process-output-stream *process*) nil (my-process-error *process*) nil (my-process-error-stream *process*) nil (my-process-frob-output-stream *process*) nil (my-process-frob-error-stream *process*) nil (my-process-status *process*) nil (my-process-exit-code *process*) nil (my-process-signal *process*) nil)) (defun my-process-close-streams (*process*) "Close created streams." (let (input-p closed-input output-p closed-output error-p closed-error) (when (streamp (my-process-input-stream *process*)) (ecase (my-process-input *process*) (:user-supplied) (:created (setq input-p t) (setq closed-input (close (my-process-input-stream *process*)))))) (when (streamp (my-process-output-stream *process*)) (ecase (my-process-output *process*) (:user-supplied) (:created (setq output-p t) (setq closed-output (close (my-process-output-stream *process*)))))) (when (streamp (my-process-error *process*)) (ecase (my-process-error *process*) (:user-supplied) (:created (setq error-p t) (setq closed-output (close (my-process-error *process*)))))) (when (or input-p output-p error-p) (warn "closed streams: ~S ~@[input: ~S~] ~@[output: ~S~] ~@[error: ~S~]" *process* (if input-p (list closed-input)) (if output-p (list closed-output)) (if error-p (list closed-error)))))) (defun my-process-set-command (*process* command args) (setf (my-process-command *process*) (or ;;#-mswindows ;;(apply 'vector (cons command args)) ;;#+mswindows (format nil "~A ~{~S~^ ~}" command args)))) (defvar *default-settings** (list :wait t :input nil :output (load-time-value cl:*standard-output*) :error :output)) (defmacro with-defaults ((&rest plist &key (wait t) (input nil) (error :output) (output 'cl:*standard-output*)) &body body) (declare (ignorable wait input output error)) `(let ((*default-settings** (nconc (list ,@plist) *default-settings**))) ,@body)) (defvar *process* (make-my-process)) (defun xfer1 (input-stream &optional (output-stream *standard-output*)) (do ((ch (read-char input-stream nil nil) (read-char input-stream nil nil))) ((null ch) (finish-output output-stream)) (write-char ch output-stream))) (defun run2 (command &rest args &aux frob-output frob-error) (declare (optimize (debug 3))) (macrolet ((default (x) `(getf *default-settings** ,x))) (when *process* (my-process-reap *process*) (my-process-close-streams *process*) (my-process-clear *process*)) (my-process-set-command *process* command args) (let ((input (default :input)) (output (default :output)) (error (default :error))) (multiple-value-bind (process-input process-output process-error process-pid) (excl:run-shell-command (my-process-command *process*) :wait nil :separate-streams t :input input :output (if (streamp output) (if (excl.osi::stream-to-fd output) output (setq frob-output :stream)) output) :error-output (if (streamp error) (if (excl.osi::stream-to-fd error) error (setq frob-error :stream)) error)) (setf (my-process-pid *process*) process-pid (my-process-status *process*) :launched) (cond (frob-output (assert (streamp process-output)) (warn "Frobbing process output stream ~S to ~S" process-output output) (setf (my-process-output *process*) :created (my-process-output-stream *process*) process-output (my-process-frob-output-stream *process*) output)) ((eq output :stream) (assert (streamp process-output)) (warn "User requested output :stream. Giving ~S" process-output) (setf (my-process-output *process*) :created (my-process-output-stream *process*) process-output)) (t (assert (null process-output)) (warn "User supplied output: ~S. No stream created." output) (setf (my-process-output *process*) :user-supplied (my-process-output-stream *process*) output))) (cond (frob-error (assert (streamp process-error)) (warn "Frobbing process error stream ~S to ~S" process-error error) (setf (my-process-error *process*) :created) (setf (my-process-error-stream *process*) process-error (my-process-frob-error-stream *process*) error)) ((eq error :stream) (assert (streamp process-error)) (warn "User requested error :stream. Giving ~S" process-error) (setf (my-process-error *process*) :created (my-process-error-stream *process*) process-error)) ((eq error :output) (assert (null process-error)) (warn "User redirected error to output. No stream created" error) (assert (null (my-process-error *process*))) (assert (null (my-process-error-stream *process*)))) (t (assert (null process-error)) (warn "User supplied error stream: ~S. No stream created." error) (setf (my-process-error *process*) :user-supplied (my-process-error-stream *process*) error))) (cond (process-input (assert (eq input :stream)) (warn "User supplied input :stream. Giving ~S" process-input) (setf (my-process-input *process*) :created (my-process-input-stream *process*) process-input)) (t (warn "User supplied input stream ~S used." input) (setf (my-process-input *process*) :user-supplied (my-process-input-stream *process*) input))) (assert (default :wait)) ; anything else untested. (when (default :wait) (when frob-error (xfer1 process-error error)) (when frob-output (xfer1 process-output output))) (warn "WAITing for process to be reaped.") (my-process-reap *process*)))) #+nil *process*) ;FINISHME (export '(with-defaults run2))) #+nil (progn (ensure-directories-exist "/tmp/xyz/foo/bar/" :verbose t) (touch "/tmp/xyz/foo/dummy0.txt") (ensure-directories-exist "/tmp/xyz/foo/emptydir/" :verbose t) (in-directory "/tmp/xyz/foo/bar/" (run2 "ln" "-s" "dummy0.txt" "link0.txt")) (user:in-directory "/tmp/xyz/foo/" (run2 "ln" "-s" "__" "badlink.txt")) (user:in-directory "/tmp/xyz/foo/bar/" (run2 "ln" "-s" "../../foo")) (last-command-status)) ;; ;; TODO: SUBPROCESS RUN PROGRAM ASYNCH OUTPUT TESTS ;; #+nil (defun sink (stream) (loop for c = (ignore-errors (lisp::read-char-no-hang stream nil stream)) while c if (eq c stream) return nil else do (format t "~a" c))) #+nil (defun read-line-no-hang (&optional (stream *standard-input*) (eof-errorp t) eof-value) (loop for c = (lisp::read-char-no-hang stream eof-errorp stream) while c if (eq c stream) return (values (if chars (coerce chars 'string) eof-value) t) else if (eql c #\Newline) return (values (coerce chars 'string) nil) else collect c into chars finally (return (values (coerce chars 'string) t)))) #+nil (defun pipe1 (stream &optional (output-stream t)) "Pipe characters from STREAM to OUTPUT-STREAM, while they come. A NIL value for OUTPUT-STREAM indicates a string must be returned. A T value stands for *STANDARD-OUTPUT*" (flet ((pipe (stream output-stream) (loop for c = (ignore-errors (lisp::read-char-no-hang stream nil stream)) while c if (eq c stream) return nil else do (format output-stream "~a" c)))) (if (null output-stream) (with-output-to-string (x) (pipe stream x)) (pipe stream output-stream)))) #+nil (defun %parse-ldd-line (line) (let ((tomatch "=> ")) (let ((pos1 (search "=>" line))) (when pos1 (incf pos1 (length tomatch)) (let ((pos2 (position #\space line :from-end t))) (when pos2 (subseq line pos1 pos2))))))) #+nil (defun ldddu (filename) "ldd | du -sck | sort -rn" (let (*process* $deps) (with-defaults (:output :stream) (run2 "ldd" filename) (when *process* (setq $deps (cons filename (loop for line = (read-line-no-hang $stdout) while line collect (%parse-ldd-line line)))) (with-output-to-string (stream) (let (*process*) (with-defaults (:output :stream) (apply 'run2 "du" "-sDck" $deps) (when *process* (with-defaults (:input $stdout :output stream) (let (*process*) (run2 "sort" "-rn"))))))))))) #+nil (ldddu "/usr/local/bin/xpdf") ;; ;; ;; #+nil (defun bunzip (pathname) "Reads PATHNAME. Yields user::$stdout to read from." (with-open-file (stream pathname) (with-defaults (:input stream :output :stream :wait nil) (run2 "bzip2" "-dc" "-")))) #+nil (defun bzip (pathname) "Supersedes PATHNAME. Yields user::$stdin to write to." (with-open-file (stream pathname :direction :output :if-exists :supersede) (with-defaults (:input :stream :output stream :wait nil) (run2 "bzip2" "-c" "-")))) ;;; ---------------------------------------------------------------------- ;;; ;;; WITH-OPEN-PIPE: ALTERNATIVE TO RUN2 ;;; #+cmu (defmacro with-open-pipe ((stream command &key (shell-type "/bin/sh")) &body body) `(let* ((.proc. (ext:run-program ,shell-type (list "-c" ,command) :input :stream :output :stream)) (,stream (make-two-way-stream (ext:process-output .proc.) (ext:process-input .proc.)))) (unwind-protect (progn ,@body) (close ,stream) (ext:process-close .proc.)))) #+lispworks (defmacro with-open-pipe ((stream command &key (shell-type "/bin/sh")) &body body) `(with-open-stream (,stream (sys:open-pipe ,command :shell-type ,shell-type :direction :io)) ,@body)) #+allegro (defmacro with-open-pipe ((stream command &key (shell-type "/bin/sh")) &body body) `(with-env-vars ((:SHELL ,shell-type)) (unwind-protect (multiple-value-bind (,stream .ignored. .pid.) (excl:run-shell-command ,command :input :stream :output :stream :separate-streams nil :wait nil) (declare (ignore .ignored. .pid.)) ;; TODO chk error and reap ,@body)))) ;; ;; WITH-OPEN-FILE EXAMPLES ;; (defun shasum (pathname) (let ((namestring (namestring pathname))) (with-open-pipe (pipe (format nil "shasum -t ~A" namestring)) (let* ((output (read-line pipe)) (pos (search namestring output))) (values (when (> pos 40) (subseq output 0 (- pos 2))) namestring))))) #+nil (shasum "/etc/passwd") ;;; ---------------------------------------------------------------------- ;;; ;;; STAT2 STATFILE INTERFACE: frobbing/simple-string file conversion ;;; ;;; STAT2-SIMPLE "Follows symlinks via stat(2)." ;;; STAT2 "Does not follow symlinks." ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +statbuf+ '(device inode mode nlink uid gid device-type total-size atime mtime ctime blocksize blocks))) #+cmu (defmacro stat2-helper (pathname &optional follow-symlinks &body body) (let ((pathnamevar (gensym))) `(let* ((,pathnamevar ,pathname) (namestring (unix::unix-namestring ,pathnamevar))) (unless namestring (error "~A does not exist." ,pathnamevar)) (multiple-value-bind ,(cons 'status +statbuf+) (if ,follow-symlinks (unix:unix-stat namestring) (unix:unix-lstat namestring)) (declare (special ,@+statbuf+)) (cond (status ,(if body `(progn ,@body) `(loop for x in +statbuf+ nconc (list x (symbol-value x))))) (t (let ((errno (UNIX:UNIX-ERRNO))) (assert (> errno 0)) (assert (= device errno)) (error "STAT FAILED with errno: ~D: ~A" errno (UNIX:GET-UNIX-ERROR-MSG errno))))))))) #+(and clisp syscalls unix) (defmacro stat2-helper (pathname follow-symlinks &body body) ;extra consing! `(let ((found (posix:file-stat ,pathname (not ,follow-symlinks)))) ;; CLISP behaviour as of 2.33.81 allows optional link-p for ;; file-stat to work on both regular files and symlinks. (when found (check-type found posix:file-stat) (let ((device (posix:file-stat-dev found)) (inode (posix:file-stat-ino found)) (mode (posix:file-stat-mode found)) (nlink (posix:file-stat-nlink found)) (uid (posix:file-stat-uid found)) (gid (posix:file-stat-gid found)) (device-type (posix:file-stat-rdev found)) (total-size (posix:file-stat-size found)) ;; CLISP returns times as the number of seconds since 1900-01-01 (atime (- (posix:file-stat-atime found) +unix-epoch+)) (mtime (- (posix:file-stat-mtime found) +unix-epoch+)) (ctime (- (posix:file-stat-ctime found) +unix-epoch+)) (blocksize (posix:file-stat-blksize found)) (blocks (posix:file-stat-blocks found))) (declare (special ,@+statbuf+)) (if (consp mode) (setq mode (posix:convert-mode mode))) ,(if body `(progn ,@body) `(loop for x in +statbuf+ nconc (list x (symbol-value x))))) ))) #+(and lispworks (not mswindows)) (defmacro stat2-helper (pathname follow-symlinks &body body) ;extra consing! (let ((pathnamevar (gensym)) (followsymlinksvar (gensym))) `(let ((,pathnamevar ,pathname) (,followsymlinksvar ,follow-symlinks)) (multiple-value-bind (found errno) (if ,followsymlinksvar (sys:get-file-stat ,pathnamevar) (sys::get-file-lstat ,pathnamevar)) (cond (found (check-type found system::stat) (let ((device (sys:file-stat-device found)) (inode (sys:file-stat-inode found)) (mode (sys:file-stat-mode found)) (nlink (sys:file-stat-links found)) (uid (sys:file-stat-owner-id found)) (gid (sys:file-stat-group-id found)) (device-type (sys:file-stat-device-type found)) (total-size (sys:file-stat-size found)) (atime (sys:file-stat-last-access found)) (mtime (sys:file-stat-last-modify found)) (ctime (sys:file-stat-last-change found)) (blocksize 512) ;; XXX FIXME (blocks (sys:file-stat-blocks found))) (declare (special ,@+statbuf+)) ,(if body `(progn ,@body) `(loop for x in +statbuf+ nconc (list x (symbol-value x)))))) (t (let ((errno1 (lw::errno-value))) (assert (> errno1 0)) (assert (= errno1 errno)) (error "~@[L~]STAT FAILED with errno: ~D." (not ,followsymlinksvar) errno)))))))) #+(and allegro (not mswindows)) (defmacro stat2-helper (pathname follow-symlinks &body body) ;extra consing! (let ((pathnamevar (gensym)) (followsymlinksvar (gensym))) `(let ((,pathnamevar ,pathname) (,followsymlinksvar ,follow-symlinks)) (handler-case (let ((found (if ,followsymlinksvar (excl.osi:stat ,pathnamevar) (excl.osi:lstat ,pathnamevar)))) (let ((device (excl.osi:stat-dev found)) (inode (excl.osi:stat-ino found)) (mode (excl.osi:stat-mode found)) (nlink (excl.osi:stat-nlink found)) (uid (excl.osi:stat-uid found)) (gid (excl.osi:stat-gid found)) (device-type (excl.osi:stat-rdev found)) (total-size (excl.osi:stat-size found)) (atime (- (excl.osi:stat-atime found) +unix-epoch+)) (mtime (- (excl.osi:stat-mtime found) +unix-epoch+)) (ctime (- (excl.osi:stat-ctime found) +unix-epoch+)) (blocksize 512) ;; XXX FIXME (blocks nil #+FIXME(excl.osi::stat-blocks found))) (declare (special ,@+statbuf+)) ,(if body `(progn ,@body) `(loop for x in +statbuf+ nconc (list x (symbol-value x)))))) (excl.osi:syscall-error (c) (let ((errno1 (excl.osi:syscall-error-errno c))) (assert (> errno1 0)) (excl.osi:perror errno1 "~@[L~]STAT FAILED with errno: ~D" (not ,followsymlinksvar) errno1))))))) (unless (fboundp 'stat2-helper) (defmacro stat2-helper (pathname follow-symlinks &body body) (declare (ignore pathname follow-symlinks body)) `(error "Stat not defined."))) (defmacro stat2-simple (pathname) `(stat2-helper ,pathname t)) (defmacro stat2 (pathname &rest body) `(stat2-helper ,pathname nil ,@body)) (export '(stat2 stat2-simple)) #|| (stat2-simple "/tmp/xyz/foo/bar/foo") (stat2-helper "/tmp/xyz/foo/bar/foo" nil) (directory-p #p"/tmp/xyz/foo/bar/foo/") (symbolic-link-p #p"/tmp/xyz/foo/bar/foo/") (stat2-helper #p"/tmp/xyz/foo/bar/foo/" nil) (stat2-helper "/tmp/xyz/foo/badlink.txt" nil) ||# ;;; ;;; ;;; From The stat(2) manpage ;;; (defvar S_IFMT #o170000 "bitmask for the file type bitfields") (defmacro frob-man2stat (string &rest ignored-docs) (declare (ignore ignored-docs)) (with-input-from-string (stream string) `(progn ,@(loop for sym = (let ((x (read stream nil stream))) (if (eq x stream) (loop-finish) x)) for mask = (let ((*read-base* 8)) (read stream)) for comment = (progn (peek-char t stream) (read-line stream nil)) collect (list 'defvar sym mask comment))))) (frob-man2stat "S_IFSOCK 0140000 socket S_IFLNK 0120000 symbolic link S_IFREG 0100000 regular file S_IFBLK 0060000 block device S_IFDIR 0040000 directory S_IFCHR 0020000 character device S_IFIFO 0010000 fifo S_ISUID 0004000 set UID bit S_ISGID 0002000 set GID bit (see below) S_ISVTX 0001000 sticky bit (see below) S_IRWXU 00700 mask for file owner permissions S_IRUSR 00400 owner has read permission S_IWUSR 00200 owner has write permission S_IXUSR 00100 owner has execute permission S_IRWXG 00070 mask for group permissions S_IRGRP 00040 group has read permission S_IWGRP 00020 group has write permission S_IXGRP 00010 group has execute permission S_IRWXO 00007 mask for permissions for others (not in group) S_IROTH 00004 others have read permission S_IWOTH 00002 others have write permisson S_IXOTH 00001 others have execute permission" ) " The set GID bit (S_ISGID) has several special uses: For a directory it indicates that BSD semantics is to be used for that directory: files created there inherit their group ID from the directory, not from the effective gid of the creating process, and directories created there will also get the S_ISGID bit set. For a file that does not have the group execution bit (S_IXGRP) set, it indicates mandatory file/record locking. The ‘sticky’ bit (S_ISVTX) on a directory means that a file in that directory can be renamed or deleted only by the owner of the file, by the owner of the directory, and by root." #+allegro (shadow :symbolic-link-p) (defun symbolic-link-p (pathname &optional (stats (stat2 pathname))) (= S_IFLNK (logand S_IFMT (getf stats 'mode)))) (defun directory-p (pathname &optional (stats (stat2 pathname))) (= S_IFDIR (logand S_IFMT (getf stats 'mode)))) (defun regular-file-p (pathname &optional (stats (stat2 pathname))) (= S_IFREG (logand S_IFMT (getf stats 'mode)))) (export '(symbolic-link-p directory-p regular-file-p)) #+nil (list S_IFMT S_IFLNK S_IFDIR S_IFREG) ;; => (61440 40960 16384 32768) #+nil (progn (directory-p "/tmp/xyz/") ;T (directory-p "/tmp/xyz/foo/bar/foo") ;NIL (directory-p "/tmp/xyz/foo/bar/foo/") ;T (CMUCL,CLISP, ACL) (directory-p "/tmp/xyz/foo/bar/foo/") ;NIL LWBUG FIXME (assert (not (directory-p "/tmp/xyz/foo/dummy0.txt"))) (assert (not (symbolic-link-p "/tmp/xyz/foo/dummy0.txt"))) (assert (regular-file-p "/tmp/xyz/foo/dummy0.txt")) (assert (not (directory-p "/tmp/xyz/foo/dummy0.txt"))) (assert (symbolic-link-p "/tmp/xyz/foo/badlink.txt")) (assert (not (regular-file-p "/tmp/xyz/foo/badlink.txt"))) (assert (not (directory-p "/tmp/xyz/foo/bar/foo"))) #+cmu (assert (eq (unix:unix-file-kind "/tmp/xyz/foo/bar/foo") :directory)) ;CMUBUG (assert (symbolic-link-p "/tmp/xyz/foo/bar/foo"))) ;; ;; STATFILE INTERFACE: PORTABLE EXAMPLES ;; (defun dates2 (path) (let ((stats (stat2-simple path))) (loop for x in '(atime mtime ctime) nconc (list x (iso-8601-date :utime (universal-time (getf stats x)) :stream nil))))) #+cmu (defun setdates2 (path plist) (destructuring-bind (&key ((atime atime) 0) ((mtime mtime)0) &allow-other-keys) plist (unix:unix-utimes (unix::unix-namestring (TRUENAME path)) atime 0 mtime 0))) #+(and clisp syscalls unix) ;FIXME unix-epoch? (defun setdates2 (path plist) (destructuring-bind (&key ((atime atime) 0) ((mtime mtime)0) &allow-other-keys) plist (posix:set-file-stat (namestring (truename path)) :atime atime :mtime mtime))) #+allegro (defun setdates2 (path plist) (destructuring-bind (&key ((atime atime) 0) ((mtime mtime) 0) &allow-other-keys) plist (excl.osi:utime (unix-namestring (TRUENAME path)) (+ atime +unix-epoch+) (+ mtime +unix-epoch+)))) #+(and lispworks unix) ; Xanalys (C) code by way of cl-http (progn (fli:define-c-typedef time_t :int) (fli:define-c-struct utimbuf (actime time_t) (modtime time_t)) (fli:define-foreign-function (unix-utime "utime" :source) ((name (:reference-pass :lisp-string-array)) (times (:pointer utimbuf))) :result-type :int)) #+(and lispworks win32) ; Xanalys (C) code by way of cl-http (progn (fli:define-c-struct _FILETIME (dw-low-date-time (:UNSIGNED :LONG)) (dw-high-date-time (:UNSIGNED :LONG))) (fli:define-c-typedef FILETIME (:struct _FILETIME)) (fli:define-foreign-function (set-file-time "SetFileTime") ((h-file win32:handle) (lp-creation-time (:pointer filetime)) (lp-last-access-time (:pointer filetime)) (lp-last-write-time (:pointer filetime))) :result-type win32:bool) (defconstant +windows-epoch+ 94354848000000000) (defun set-filetime-from-universal-time (utime filetime) (let ((filetime-value (+ (* utime 10000000) +windows-epoch+))) (setf (fli:foreign-slot-value filetime 'dw-high-date-time) (ash filetime-value -32)) (setf (fli:foreign-slot-value filetime 'dw-low-date-time) (logand filetime-value #xffffffff))))) #+(and lispworks (or unix win32)) (defun setdates2 (path plist &aux errno) (destructuring-bind (&key ((atime atime) 0) ((mtime mtime) 0) #+win32 ((ctime ctime) 0) ; creation time! &allow-other-keys) plist #+unix (fli:with-dynamic-foreign-objects ((buffer utimbuf)) (setf (fli:foreign-slot-value buffer 'actime) atime (fli:foreign-slot-value buffer 'modtime) mtime) (unless (zerop (unix-utime (unix-namestring (truename path)) buffer)) (error "SETDATES2 Failed on file ~A: ~A(~A)." path (lw:get-unix-error (setq errno (lw::errno-value))) errno))) #+win32 ; XXX UNTESTED (unless (with-open-file (stream (truename (unix-namestring pathname)) :direction :output :if-exists :overwrite :element-type '(unsigned-byte 8)) (set-filetime-from-universal-time (+ ctime +unix-epoch+) creation-filetime) (set-filetime-from-universal-time (+ mtime +unix-epoch+) modification-filetime) (set-filetime-from-universal-time (+ atime +unix-epoch+) access-filetime) (fli:with-dynamic-foreign-objects ((creation-filetime filetime) (modification-filetime filetime) (access-filetime filetime)) (set-file-time (io:file-stream-file-handle stream) creation-filetime access-filetime modification-filetime))) (error "SETDATES2 Failed on file ~A: ~A." path (lw:get-unix-error (setq errno (lw::errno-value))))))) (unless (fboundp 'setdates2) (defun setdates2 (path plist) (warn "SETDATES2 ~A ~A: Ignored" path plist))) (export '(setdates2)) ;; ;; (defmacro with-file-dates-preserved ((pathname) &body body) `(let ((stats (stat2-simple ,pathname))) (unwind-protect (progn ,@body) (setdates2 ,pathname stats)))) (defun touch (pathname &key (utime (get-universal-time)) (atime t) (mtime t)) "ATIME and UTIME can be universal times, Or they can be NIL (leave the time unchanged). Otherwise they default to the universal time in UTIME." (when atime (setq atime (- (if (numberp atime) atime utime) +unix-epoch+))) (when mtime (setq mtime (- (if (numberp mtime) mtime utime) +unix-epoch+))) (let (stats) (cond ((and atime mtime) (setq stats (list 'atime atime 'mtime mtime))) ((and (setq stats (stat2-simple pathname)) atime) (setf (getf stats 'atime) atime)) (mtime (setf (getf stats 'mtime) mtime)) (t (return-from touch NIL))) (unless (probe-file pathname) (with-open-file (stream pathname :direction :output ;CHECKME (LW) :if-does-not-exist :create) ())) (setdates2 pathname stats))) #+nil (touch "home:file.mac" :atime t :mtime nil) (defun unix-mtime (pathname) "Return the last modification time of PATHNAME as the number of seconds since Jan 1 1970 UTC." #+(or cmu (and lispworks (not mswindows)) (and clisp syscalls unix) allegro) (restart-case (getf (stat2 pathname) 'mtime) (continue () :report (lambda (stream) (format stream "Stat(mtime) Failed on ~A. Return 0." pathname)) 0)) #-(or cmu (and lispworks (not mswindows)) (and clisp syscalls unix)) (let ((x (ignoring-errors (file-write-date pathname)))) (cond (x (- x +unix-epoch+)) (t (cerror "Return 0 and Continue." "UNIX-MTIME ~A failed." pathname) 0)))) (defsetf unix-mtime (pathname) (unix-time) #+cmu `(unix:unix-utimes (unix::unix-namestring ,pathname) ,unix-time 0 ,unix-time 0) #-cmu `(with-simple-restart (continue "Skip ~S(~S)" ,pathname ,unix-time) (with-defaults (:output *standard-output*) (run2 "touch" (namestring (truename ,pathname)) "-m" "-t" (yymmddhhmm :stream nil :tz 0 :utime (universal-time ,unix-time)))))) (export '(with-file-dates-preserved touch unix-mtime)) #+nil (defun upcase-filename (p) (merge-pathnames (string-upcase (file-namestring p)) (make-pathname :name nil :version nil :type nil :defaults p) nil)) #+nil (defun rename-spaces-in-files (pathname-list) (loop for f in pathname-list for name = (pathname-name f) for new-name = (substitute #\_ #\space name) for g = (make-pathname :name new-name :defaults f) do (rename-file f g))) ;; Sun Jul 18 04:07:39 2004 +0530 (defun mac2unix-s (instream outstream) (loop for c1 = (read-char instream nil) while c1 if (char= c1 #\Return) do (terpri outstream) else do (write-char c1 outstream))) (defun mac2unix (path) (let ((stats (stat2-simple path)) (contents (with-output-to-string (outstream) (with-open-file (instream path :direction :input) (mac2unix-s instream outstream))))) (with-open-file (outstream path :direction :output :if-exists :supersede) (write-string contents outstream)) (setdates2 path stats)) path) ;;; ---------------------------------------------------------------------- ;;; ;;; DIRECTORY TRAVERSAL ;;; ;;; PROBE-DIRECTORY -- "Returns truename of PATH if PATH denotes a directory." ;;; #+clisp (shadow 'probe-directory) #+clisp (defun probe-directory (p) (cond ((ignoring-errors (ext:probe-directory p)) (truename p)) ((let ((x (directory-pathname p))) (when (ignoring-errors (ext:probe-directory x)) (truename x)))))) #+allegro (assert (eq 'probe-directory 'excl::probe-directory)) (unless (fboundp 'probe-directory) (defun probe-directory (path) (let ((p (probe-file path))) (when p (probe-file (directory-pathname p)))))) #|| (probe-file "/tmp/xyz/foo/bar/foo") => #P"/tmp/xyz/foo/bar/foo" => #P"/tmp/xyz/foo/" (LW) (probe-directory "/tmp/xyz") => #P"/tmp/xyz/" (LW) => #P"/tmp/xyz" (ACL) (probe-directory "/tmp/xyz/") => #P"/tmp/xyz/" (probe-directory "/tmp/xyz/foo/bar/foo") => #P"/tmp/xyz/foo/" (LW) => #P"/tmp/xyz/foo/bar/foo" (ACL) (probe-directory "/tmp/xyz/foo/bar/foo/") => #P"/tmp/xyz/foo/" (LW) => #P"/tmp/xyz/foo/bar/foo/" (probe-directory "/tmp/xyz/foo/dummy0.txt") ; NIL (probe-directory "/tmp/xyz/foo/dummy0.txt-not-there") ;NIL (probe-directory "/tmp/xyz/foo/badlink.txt") ;NIL (probe-directory "/tmp/xyz/foo/link0.txt") ;NIL (ensure-directories-exist "/tmp/zzz/foo/" :verbose t) (user:in-directory "/tmp/zzz/" (user:run2 "ln" "-svf" "foo" "bar")) (user:in-directory "/tmp/zzz/" (user:run2 "ln" "-svf" "bar" "car"))) (directory-p "/tmp/zzz/car") ; NIL (directory-p "/tmp/zzz/car" (stat2-simple "/tmp/zzz/car")) ; T ||# #+nil (defun find-dired-f (p &optional f) "OBSELETE. If F returns non-NIL, the return value was collected instead of the pathname." (loop for x in (directory (make-pathname :defaults p)) if (probe-directory x) nconc (find-dired-f x f) into inferiors else collect (or (and f (funcall f x)) x) into subs finally (return (nconc subs inferiors)))) ;;; ;;; ;;; (defvar *dired-truenamep* t) (defun my-directory (pathname) "Internal Helper function for DIRED, which see." (prog (my-directory-retry) (declare (special my-directory-retry)) retry (catch 'my-directory-error (return #+lispworks ;; LINK-TRANSPARENCY: Not applicable on windows. Initial value ;; T. Setting this value to NIL gives non-ANSI behaviour, and ;; truenames are not returned. NON-EXISTENT-LINK-DESTINATIONS: ;; Initial value NIL. Setting this value to T would include symlinks ;; with invalid targets. (let ((list (directory pathname :link-transparency nil :directories nil :non-existent-link-destinations T))) (if *dired-truenamep* (delete-duplicates (map-into list (lambda (x) (or (ignoring-errors (truename x)) x)) list) :test #'equal) list)) #+cmu ;; TRUENAMEP: Initial value T. Setting this value to NIL means ;; symbolic links in the result are not expanded. FOLLOW-LINKS: ;; Initial value T. Setting this to NIL then symbolic links are not ;; followed. (let ((list (directory pathname :all nil :check-for-subdirs nil :truenamep nil :follow-links t))) (if *dired-truenamep* (delete-duplicates (map-into list (lambda (x) (or (ignoring-errors (truename x)) x)) list) :test #'equal) list)) #+clisp (progn (assert *DIRED-TRUENAMEP* nil "MY-DIRECTORY: CLISP does not support non-ANSI semantics.") (delete-duplicates (nconc (directory (make-pathname :name nil :type nil :version nil :defaults pathname :directory (append (pathname-directory pathname) '(:wild))) :circle t :if-does-not-exist :keep) (directory (make-pathname :name :wild :type nil :version nil :directory (pathname-directory pathname) :defaults pathname) :circle t :if-does-not-exist :keep)) :test #'equal)) #+allegro (let* ((list1 (directory pathname :directories-are-files nil)) (list2 (directory pathname :directories-are-files t)) (files (intersection list1 list2 :test #'equal)) (dirs-as-files (set-difference list2 files :test #'equal))) #+nil (warn "list1=~S list2=~S dirs-as-files=~S" list1 list2 dirs-as-files) (nconc files (loop for x in dirs-as-files with y if (and *dired-truenamep* (symbolic-link-p x) (setq y (ignore-errors (truename x)))) collect (if *dired-truenamep* y x) else collect x))))) (when my-directory-retry (setq my-directory-retry nil) (go retry)))) #|| (let ((*DIRED-TRUENAMEP* nil)) (my-directory "/tmp/xyz/foo/")) => (#P"/tmp/xyz/foo/badlink.txt" #P"/tmp/xyz/foo/bar" #P"/tmp/xyz/foo/dummy0.txt" #P"/tmp/xyz/foo/emptydir") (let ((*DIRED-TRUENAMEP* T)) (my-directory "/tmp/xyz/foo/")) => (#P"/tmp/xyz/foo/badlink.txt" #P"/tmp/xyz/foo/bar/" #P"/tmp/xyz/foo/emptydir/" #P"/tmp/xyz/foo/dummy0.txt") (let ((*DIRED-TRUENAMEP* t)) (my-directory "/tmp/xyz/foo/bar/")) => (#P"/tmp/xyz/foo/") (let ((*DIRED-TRUENAMEP* nil)) (my-directory "/tmp/xyz/foo/bar/")) => (#P"/tmp/xyz/foo/bar/foo") (let ((*DIRED-TRUENAMEP* t)) (my-directory #p"/tmp/xyz/foo/bar/foo/bar/foo")) => (#P"/tmp/xyz/foo/") (let ((*DIRED-TRUENAMEP* nil)) (my-directory #p"/tmp/xyz/foo/bar/foo/bar/foo")) => (#P"/tmp/xyz/foo/bar/foo/bar/foo") ;; NOTE: LW returns ONLY directories even when DIRED-TRUENAME is NIL. ||# ;;; ;;; (defun descend-dired (path f depth maxdepth) "Internal helper function for DIRED which see." (if (etypecase maxdepth (null t) (function (funcall maxdepth path depth)) (number (< (1+ depth) maxdepth))) (dired path f (1+ depth) maxdepth) (list path))) (defvar *dired-follow-links* nil) #+lispworks ;; FIXME WORKAROUND (defun descend-dired-p (x) (if (sys::file-directory-p x) (if *dired-follow-links* (directory-pathname x) (if (not (sys::file-link-p x)) (directory-pathname x))))) #-lispworks (defun descend-dired-p (x) "Internal helper function for DIRED which see." (let ((stats (ignoring-errors (stat2-helper x *dired-follow-links*)))) (when (and stats (directory-p x stats)) (directory-pathname x)))) (defun dired (path &optional f (depth 0) maxdepth &aux p) "If F is non-NIL it should be a function that receieves 3 arguments PATHNAME DEPTH DIRECTORY-P. Maps F on each pathname encountered or collects all pathnames if F is NIL. MAXDEPTH can be NIL (no maximum depth), or a number or a function which takes a directory pathname and its descend-depth and should return non-NIL if that directory is to be descended. " (loop for x in (my-directory (make-pathname :name nil :version nil :type nil :defaults path)) if (setq p (descend-dired-p x)) if f do (funcall f p depth t) (descend-dired p f depth maxdepth) else nconc (descend-dired p f depth maxdepth) and collect p else if f do (funcall f x depth nil) else collect x)) #+nil (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/" nil 0 10)) #+nil (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/" (lambda (&rest x) (format t "~&=>~S~&" x)) 0 10)) #|| (let ((*dired-truenamep* t) (*dired-follow-links* t)) (dired #p"/tmp/xyz/" nil 0 1)) => (#P"/tmp/xyz/foo/") (let ((*dired-truenamep* t) (*dired-follow-links* t)) (dired #p"/tmp/xyz/foo/" nil 0 1)) => (#P"/tmp/xyz/foo/badlink.txt" #P"/tmp/xyz/foo/bar/" #P"/tmp/xyz/foo/emptydir/" #P"/tmp/xyz/foo/dummy0.txt") (let ((*dired-truenamep* nil) (*dired-follow-links* t)) (dired #p"/tmp/xyz/foo/" nil 0 1)) => (#P"/tmp/xyz/foo/badlink.txt" #P"/tmp/xyz/foo/bar/" #P"/tmp/xyz/foo/dummy0.txt" #P"/tmp/xyz/foo/emptydir/" #P"/tmp/xyz/foo/link0.txt") (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/" nil 0 1)) => (#P"/tmp/xyz/foo/badlink.txt" #P"/tmp/xyz/foo/bar/" #P"/tmp/xyz/foo/dummy0.txt" #P"/tmp/xyz/foo/emptydir/" #P"/tmp/xyz/foo/link0.txt") (let ((*dired-truenamep* t) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/" nil 0 1)) => (#P"/tmp/xyz/foo/badlink.txt" #P"/tmp/xyz/foo/bar/" #P"/tmp/xyz/foo/emptydir/" #P"/tmp/xyz/foo/dummy0.txt") (let ((*dired-truenamep* t) (*dired-follow-links* t)) (dired #p"/tmp/xyz/foo/bar/" nil 0 1)) => (#P"/tmp/xyz/foo/") (let ((*dired-truenamep* nil) (*dired-follow-links* t)) (dired #p"/tmp/xyz/foo/bar/" nil 0 1)) => (#P"/tmp/xyz/foo/bar/foo/") (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/bar/" nil 0 1)) => (#P"/tmp/xyz/foo/bar/foo") (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/bar/foo/bar/foo" nil 0 10)) => (#P"/tmp/xyz/foo/bar/foo/bar/foo") (stat2-simple "/tmp/xyz/foo/bar/foo/") ;16877 (stat2-simple "/tmp/xyz/foo/bar/foo") ;16877 (CMUCL) (stat2 "/tmp/xyz/foo/bar/foo/") ;16877 (CMUCL) 41471 (LW) (stat2 "/tmp/xyz/foo/bar/foo") ;41471 (unix:unix-lstat (stat2 (probe-directory "/tmp/xyz/foo/bar/foo/")) (directory-p "/tmp/xyz/foo/bar/foo") ;NIL (LW,CMUCL) (directory-p "/tmp/xyz/foo/bar/foo/") ;NIL (LW) T (CMUCL) (symbolic-link-p "/tmp/xyz/foo/bar/foo") ;T (LW) (getf (stat2 "/tmp/xyz/foo/bar/foo/") 'mode) ;41471 (list S_IFMT S_IFREG S_IFLNK S_IFDIR) (system::file-directory-p "/tmp/xyz/foo/bar/foo/") (symbolic-link-p "/tmp/xyz/foo/bar/foo/") ;T (LW) NIL (CMUCL, ACL) (let ((*dired-follow-links* t)) (dired "/tmp/xyz/" nil 0 10)) (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/" nil 0 10)) (let ((*dired-truenamep* nil) (*dired-follow-links* t)) (dired "/tmp/xyz/" nil 0 10)) (let ((*dired-truenamep* nil) (*dired-follow-links* t)) (dired #p"/tmp/xyz/foo/bar/foo/bar/foo" nil 0 10)) (let ((*dired-truenamep* T) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/" nil 0 10)) (let ((*dired-truenamep* nil) (*dired-follow-links* T)) (dired #p"/tmp/xyz/foo/" nil 0 10)) (let ((*dired-truenamep* T) (*dired-follow-links* T)) (dired #p"/tmp/xyz/foo/" nil 0 10)) ;; INVALID USAGE: (dired #p"/tmp/xyz/foo/bar/" (lambda (&rest x) (print x)) 0 10) (dired #p"/tmp/xyz/foo/bar/" nil 0 4) (dired #p"/tmp/xyz/" (lambda (&rest x) (print x)) 0 10) (dired #p"/tmp/xyz/" nil 0 10) ;;; INVALID (let ((*dired-truenamep* nil) (*dired-follow-links* T)) (dired #p"/tmp/xyz/foo/" nil 0 10)) ;;; INVALID (let ((*dired-truenamep* T) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/bar/" nil 0 10)) ;;; VALID (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (dired #p"/tmp/xyz/foo/" nil 0 10)) (dired "/home/madhu/cmu/src/code/" nil 0 1) (dired "home:cmu/src/code" nil 0 1) (length (dired #p"home:cmu/glibc22/"))) ||# ;; ;; DIRED EXAMPLES ;; (defun ls (&optional (dir (pwd)) &key (stream *standard-output*)) "~%~{~<~%~,70:;~a~>~^~t~}~%" (declare (ignore stream)) (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (let ((p (probe-directory dir))) (mapcar (lambda (pathname) (enough-namestring pathname p)) (dired p nil 0 1))))) #|| (ls "/tmp/xyz/") (ls "/tmp/xyz/foo/") (ls "/tmp/xyz/foo/bar") (ls "/tmp/xyz/foo/bar/") (let ((*dired-truenamep* nil)) (ls "/tmp/xyz/foo/bar/")) ||# ;; cl-fad compatible: blows up on circular links. (defun walk-directory (root-directory visitor &key directories test) (flet ((f (file depth directory-p) (declare (ignorable depth)) (when directory-p (unless directories (return-from f nil))) (when (or (null test) (and test (funcall test file))) (funcall visitor file)))) (dired root-directory #'f))) #|| (walk-directory "/tmp/xyz/" #'print) (walk-directory "/tmp/xyz/" #'print :directories t)) ||# (defun sort-files (path &optional (predicate #'<) &key (key (lambda (pathname) (unix-mtime pathname))) (datep t) (n 10) (ignore-rcsdirs t) (rcsdirs '(".git" "RCS" "CVS"))) "If KEY is not specified sort files rooted under PATH by modification time. If N is non-nil limit output to N items." (let ((*dired-truenamep* nil) (*dired-follow-links* nil)) (let (clist (clength 0)) (labels ((descendp (dir depth) (declare (ignore depth)) (let ((dircomp (pathname-directory dir))) (loop for (comp . rest) on dircomp when (endp rest) if (and ignore-rcsdirs (some (lambda (x) (string= comp x)) rcsdirs)) return nil finally (return t)))) (snarf-mtime (pathname depth dirp) (declare (ignore depth)) (unless dirp (let ((x (funcall key pathname))) (cond ((or (endp clist) (or (null n) (< clength n)) (funcall predicate x (cdar (nthcdr (1- n) clist)))) (setq clist (insert-ordered (cons pathname x) clist predicate :key #'cdr)) (when n (cond ((< clength n) (incf clength)) (t (setq clist (nbutlast clist 1))))))))))) (DIRED path #'snarf-mtime 0 #'descendp)) (if datep (loop for (mfile . mtime) in clist collect (cons mfile (DATE :stream nil :utime (universal-time mtime)))) clist)))) #|| (sort-files "/tmp/xyz/") ||# ;;; (defun cache-checksum (truename checksum-function checksum-length checksum-identifier checksum-cache path-cache &key if-exists (if-does-not-exist :create) computed-checksum) "Internal. Intern pathname TRUENAME in CHECKSUM-CACHE and PATH-CACHE, which are EQUAL hash-tables. CHECKSUM-FUNCTION called on funcalled on TRUENAME should return a string of length CHECKSUM-LENGTH, and NIL on failure. CHECKSUM-IDENTIFIER should is used to identify the property. PATH-CACHE can also be a filset trie." (when computed-checksum (assert (stringp computed-checksum)) (assert (= (length computed-checksum) checksum-length))) (multiple-value-bind (value1 foundp1) (gethash truename path-cache) (cond ((not foundp1) (ecase if-does-not-exist ((:soft)) ((:error (error "Checksum of ~S not cached." truename))) ((:create :check) (let ((checksum (or computed-checksum (funcall checksum-function truename) (error "Failed to compute a checksum.")))) (case if-does-not-exist (:create (with-simple-restart (ignore "Ignore") (assert (not (probe-directory truename))) (pushnew truename (gethash (setf (getf (gethash truename path-cache) checksum-identifier) checksum) checksum-cache) :test #'equal))) (:check (assert (string= checksum (getf (gethash truename path-cache) checksum-identifier))) (assert (find truename (gethash checksum checksum-cache) :test #'equal)))))))) ((eql if-exists :error) (error "Checksum of ~S already cached: ~S" truename (getf value1 checksum-identifier))) (t (let ((checksum (getf value1 checksum-identifier))) (ecase if-exists ((nil :soft) checksum) ((:error) (error "Sanity fails.")) ((:recompute) (with-simple-restart (ignore "Ignore") (assert (not (probe-directory truename))) (pushnew truename (gethash (setf (getf (gethash truename path-cache) checksum-identifier) (or computed-checksum (funcall checksum-function truename) (error "Failed to recompute Checksum."))) checksum-cache) :test #'equal))) ((:check) (assert (find truename (gethash checksum checksum-cache) :test #'equal)) checksum))))))) ;; FIXME. LW requires you to probe-file before calling this function. (defun sha1sum (pathname) ;; runs external program "Return a string signature or NIL on failure." (let* ((namestring #+cmu (unix::unix-namestring pathname) #-cmu (namestring pathname)) (output (with-output-to-string (stream) (with-defaults (:output stream) (or (with-simple-restart (continue "Ignore (sha1sum).") (run2 "sha1sum" "-t" namestring)) (return-from sha1sum nil))))) (pos (search namestring output))) (values (subseq output 0 (- pos 2)) namestring))) #|| HERE (with-defaults (:output :stream) (run2 "sha1sum" "-t" "/home/madhu/.clisprc.lisp")) (list $stdin $stdout $pty) (with-output-to-string (ostream) (copy-buffered-io $stdout ostream :element-type 'character))) ||# #|| (sha1sum "/tmp/xyz/foo/dummy0.txt") (sha1sum "/tmp/xyz/foo/dummy0.txt-not-there") ||# (defun fdupes (root-directory &optional recurse-p) (let ((sha1-hash (make-hash-table :test #'equal)) (path-hash (make-hash-table :test #'equal)) (*dired-truenamep* NIL) (*dired-follow-links* T)) ;cmu, lw (flet ((grok-sha1sum (pathname depth directory-p) (declare (ignore depth)) (unless directory-p (cache-checksum pathname #'sha1sum 40 :sha1sum sha1-hash path-hash :if-exists :error)))) (dired root-directory #'grok-sha1sum 0 (if recurse-p nil 1)) (loop for sha1sum being each hash-key of sha1-hash using (hash-value files) if (cdr files) collect files)))) #+nil (fdupes "/tmp/xyz/" t) (defun find-empty-dirs (p &optional include-non-empty-dirs-p) ;madhu 040914 "Return a list of pathnames of empty directories. If INCLUDE-NON-EMPTY-DIRS-P is non-NIL, include directories that contain only empty subdirectories (recursively), in the result." (declare (special my-directory-retry)) (let ((*dired-truenamep* NIL) (*dired-follow-links* T)) ; cmu (loop for x in (my-directory (make-pathname :name nil :type nil :version nil :defaults p)) for d = (probe-directory x) if (and d (not (ignoring-errors (symbolic-link-p x)))) collect d into dirs else count x into files finally (return (if (and (null dirs) (zerop files)) (list p) (let ((subdirs (loop for y in dirs when (find-empty-dirs y include-non-empty-dirs-p) nconc it))) (if (and include-non-empty-dirs-p (zerop files)) (if (remove-if (lambda (a) (member a subdirs :test #'equalp)) dirs) subdirs (cons p subdirs)) subdirs))))))) #+nil (find-empty-dirs #p"/tmp/xyz/") ;;; ---------------------------------------------------------------------- ;;; ;;; MISC MACROS ;;; (defmacro case-equal (which &body clauses) "Like case but uses EQUAL. Treats :OTHERWISE and T specially." (let ((switch (gensym)) final) `(let ((,switch ,which)) (cond ,@(loop for ((match . action) . rest) on clauses collect `(,(if (consp match) `(or ,@(loop for x in match collect `(equal ,switch ',x))) (if (and (symbolp match) (or (eq match t) (eq match :otherwise))) (setq final 't) `(equal ,switch ',match))) ,@(if action action '(nil))) when final do (if rest (error ":OTHERWISE or T not last clause on CASE") (loop-finish))))))) (defmacro ecase-equal (which &body clauses) "Like ECASE but uses EQUAL. Treats :OTHERWISE and T specially." (let ((switch (gensym)) matches) `(let ((,switch ,which)) (cond ,@(loop for ((match . action) . rest) on clauses collect `(,(if (consp match) `(or ,@(loop for x in match do (push x matches) collect `(equal ,switch ',x))) (if (and (symbolp match) (or (eq match t) (eq match :otherwise))) (error ":OTHERWISE or T not allowed ECASE") (progn (push match matches) `(equal ,switch ',match)))) ,@(if action action '(nil)))) (t (error "ECASE-EQUAL fell through. Wanted one of ~S" ',matches)))))) ;;; ---------------------------------------------------------------------- ;;; ;;; QUADRANTS, MATH ACCURACIES - PORTABLE ;;; ;;; ^ ;;; | ;;; II | I ;;;pi<----+---->0 ;;; III | IV ;;; | ;;; v (defun degrees->radians (degrees) (* pi degrees 1/180)) (defun degrees-mod180 (degrees) "Returns a value which lies in [-180 180]" (if (plusp degrees) (if (> (setq degrees (mod degrees 360)) 180) (mod degrees -180) degrees) (if (< (setq degrees (mod degrees -360)) -180) (mod degrees 180) degrees))) (defun radians->degrees (radians) (degrees-mod180 (* 180 (/ pi) radians))) #+nil (radians->degrees (degrees->radians 0.0d0)) ;; ;; from pktype <26-Sep-03 03:42:39 IST, madhu> ;; (defun round-to-accuracy (value digits-after-decimal-point) "Internal. Round VALUE to DIGITS decimal places." (declare (type (integer 0 10) digits-after-decimal-point)) (let ((precision (expt 10 digits-after-decimal-point))) (if (integerp value) value (coerce (/ (round (* precision value)) precision) (type-of value))))) (defconstant $1mb 1024) (defconstant $1gb (* $1mb $1mb)) (defun mb (&rest bytes) (/ (reduce #'+ bytes) (* 1024.0 1024.0))) (defun print-human (kb &optional stream &aux (abs (abs kb))) "Return a string unless STREAM is non-NIL." (multiple-value-bind (quantity units) (if (> abs $1gb) (values (round-to-accuracy (/ kb $1gb 1.0) 2) #\G) (if (> abs $1mb) (values (round-to-accuracy (/ kb $1mb 1.0) 2) #\M) (values kb #\K))) (format stream "~A~A" quantity units))) ;;; ---------------------------------------------------------------------- ;;; ;;; LIST UTILITIES - PORTABLE ;;; (defun compose (&rest functions) ; composes functions as if by m-v-c (lambda (&rest args) (values-list (reduce #'(lambda (&optional f x) (if f (multiple-value-list (apply f x)) x)) functions :from-end t :initial-value args)))) (defun group2 (list &key (test #'eql) (key #'identity)) "Internal. Return an alist, the cdr of each element of which is a list of elements of LIST which are grouped together; while the car is the value under KEY by which they are grouped. From f1pq5c$m8o$1@registered.motzarella.org." (let ((result nil)) (dolist (el list) (let* ((entry-key (funcall key el)) (entry (assoc entry-key result :test test))) (if entry (pushnew el (cdr entry)) (push (list entry-key el) result)))) result)) (export '(compose group2)) #+nil (defun nshuffle (seq &aux (len (length seq))) (loop for i below len for j = (random len) unless (= i j) do (rotatef (elt seq i) (elt seq j))) seq) #+nil (defun shuffle-n (seq &optional (k (length seq) k-supplied-p)) "shuffle all of SEQ. Stop when k elements have been shuffled. This generalizes Knuth's algorithm" ; (let ((n (length seq))) (dotimes (i k seq) (rotatef (elt seq i)(elt seq (+ i (random (- n i)))))))) #+nil (defun mapsome (predicate list &rest more-lists) "" (apply #'mapcan (lambda (&rest args) (when (apply predicate args) (copy-list args))) list more-lists)) #+nil (defun delete-nth (list position) "Deletes the item at position POSITION in list LIST. Modifies LIST. Returns a list of 2 elements: the deleted item and the modified list." (check-type position (integer 0)) (cond ((zerop position) (list (car list) (cdr list))) (t (let* ((tail (nthcdr (1- position) list)) (item (cadr tail))) (when tail (rplacd tail (cddr tail))) (list item list))))) #+nil (defun plist-sans-keys (plist &rest keys) ; <3247672165664225@naggum.no> (loop with sans for tail = (nth-value 2 (get-properties plist keys)) unless tail return (nreconc sans plist) do (loop until (eq plist tail) do (push (pop plist) sans) (push (pop plist) sans)) (setq plist (cddr plist)))) ;; ;; madhu 051224 GLB,LUB ;; (defun popmax (list &optional (cmp #'>) &key key) "destroy LIST while removing and returning the maximum element. Second value is the LIST." (when list (let ((max-cons list) max-prev-cons) (loop for prev-cons = list then cons for cons on (cdr list) if (funcall cmp (if key (funcall key (car cons)) (car cons)) (if key (funcall key (car max-cons)) (car max-cons))) do (setf max-cons cons max-prev-cons prev-cons)) (cond (max-prev-cons (setf (cdr max-prev-cons) (cdr max-cons)) (values (car max-cons) list)) (t (assert (eq max-cons list)) (values (car max-cons) (cdr max-cons))))))) (defun insert-ordered (item list &optional (predicate #'<) &key key test test-not) "Insert ITEM in LIST. may modify LIST. LIST is assumed to be sorted by PREDICATE. If TEST (or TEST-NOT) is non-NIL, it is used to determine if ITEM is present (or absent) in LIST, in which case it is not inserted. KEY if non-NIL is applied to both ITEM and elements of LIST before comparing them. However, unlike section 17.2.1 of the spec, if both TEST and TEST-NOT are NIL, no test is made." (if (endp list) (list item) (macrolet ((apply-key (key element) `(if ,key (funcall ,key ,element) ,element))) (let ((item-key (apply-key key item)) (obj-key (apply-key key (car list)))) (cond ((cond (test (funcall test item-key obj-key)) (test-not (not (funcall test-not item-key obj-key)))) list) ((funcall predicate item-key obj-key) (cons item list)) (t (loop for prev-cons = list then cons for cons on (cdr list) do (setq obj-key (apply-key key (car cons))) if (cond (test (funcall test item-key obj-key)) (test-not (not (funcall test-not item-key obj-key)))) return list else if (funcall predicate item-key obj-key) do (loop-finish) finally (setf (cdr prev-cons) (cons item cons)) (return list)))))))) (defmacro pushnew-ordered (obj place predicate &rest keys &environment env) "OBSELETE." (if (and (null (getf keys :test)) (null (getf keys :test-not))) (setf (getf keys :test) '#'eql)) ; XXX even if Keys is a literal. (if (and (symbolp place) (eq place (macroexpand place env))) `(setq ,place (insert-ordered ,obj ,place ,predicate ,@keys)) (multiple-value-bind (vars vals stores setter getter) (get-setf-expansion place env) (cond ((cdr stores) ;; Multiple values (let ((g (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) (rest obj)))) `(multiple-value-bind ,g ,obj (let* (,@(mapcar #'list vars vals)) (multiple-value-bind ,stores (values ,@(mapcar #'(lambda (a b) `(insert-ordered ,a ,b ,predicate ,@keys)) g (rest getter))) ,setter))))) (t ;; Single value (let ((g (gensym))) `(let* ((,g ,obj) ,@(mapcar #'list vars vals) (,@stores (insert-ordered ,g ,getter ,predicate ,@keys))) ,setter))))))) (defun ordered-intersection (list1 list2 predicate) "LIST1 and LIST2 are SORTED LISTS, ordered according to PREDICATE." (when (and list1 list2) (let (ret (car1 (car list1))(car2 (car list2))) (loop (when (or (endp list1) (endp list2)) (return)) (cond ((funcall predicate car1 car2) (setq list1 (cdr list1) car1 (car list1))) ((funcall predicate car2 car1) (setq list2 (cdr list2) car2 (car list2))) (t ;; deemed equal (push car1 ret) (setq list1 (cdr list1) car1 (car list1) list2 (cdr list2) car2 (car list2))))) (nreverse ret)))) #+nil (defun %last (vector &key (if-does-not-exist :soft)) (declare (type vector vector)) (let ((length (length vector))) (cond ((zerop length) (ecase if-does-not-exist (soft nil) (error "Cannot aref the last element of an empty vector"))) (t (aref vector (1- length)))))) #+nil (defsetf %last (vector) (new-element) (declare (type vector vector)) `(let ((length (length ,vector))) (cond ((zerop length)) (t (setf (aref ,vector (1- length)) ,new-element))))) #+nil (defun %butlast (vector &optional) (declare (type vector vector)) (let ((length (length vector))) (subseq vector 0 (1- length)))) #+nil (defun %nbutlast (vector &optional) (declare (type vector vector)) (let ((length (length vector))) (if (array-has-fill-pointer-p vector) (prog1 vector (setf (fill-pointer vector) (1- length))) (%butlast vector)))) #-allegro (defun suffixp (suffix sequence &key (test #'equalp) &aux idx) "Ends with" (or (null (setq idx (mismatch suffix sequence :from-end t :test test))) (zerop idx))) #-allegro (defun prefixp (prefix sequence &key (test #'equalp) &aux idx) "Begins with" (or (null (setq idx (mismatch prefix sequence :test test))) (>= idx (length prefix)))) (export '(prefixp suffixp)) ;; ;; madhu 050827 ;; #+nil (defun assq (KEY LIST) "Return non-nil if KEY is `eq' to the car of an element of LIST. The value is actually the first element of LIST whose car is KEY. Elements of LIST that are not conses are ignored." (loop for elem in list when (consp elem) do (destructuring-bind (car . cdr) elem (declare (ignore cdr)) (if (eq car key) (return elem))))) ;; ;; LOOP version of ;; IOTA ;; #+nil (defun range (begin end &optional (step 1 step-supplied-p)) (assert (not (zerop step))) (when (< end begin) (if step-supplied-p (unless (< step 0) (setq step (- step))) (setq step -1))) (loop for i below (ceiling (/ (- end begin) step)) collect (+ begin (* i step)))) ;;; ;;; 04-10-13 ;;; #+nil (defun implies (&rest clauses) (reduce (lambda (p q) (if p (if q t nil) t)) clauses)) #+nil (defun generate-e () ;; Author: nate holloway [Fri Oct 15 2004] (loop with n fixnum = 1 and x = 1 and y = 0 for old-digit = -1 then digit and digit = (truncate (+ y (/ x))) if (= old-digit digit) do (princ old-digit) (setq y (* (rem y 1) 10) x (/ x 10) digit (truncate y)) else do (setq x (* n x) n (1+ n) y (+ y (/ x))))) #+nil (defun cross (&rest lists) "" (reduce (lambda (list crosses) (mapcan (lambda (item) (mapcar (lambda (cross) (cons item cross)) crosses)) list)) lists :from-end t :initial-value '(()))) #+nil (defun uncross (list) ; madhu 050909 ;; for LIST of lots of sets of small cardinality (let ((result (make-array (length (car list)) :initial-element nil))) (loop for items in list do (loop for elem in items for i from 0 do (pushnew elem (aref result i)))) (map 'list 'nreverse result))) #+nil (defun prime-p (n) (loop for i from 2 to (isqrt n) never (zerop (mod n i)))) #+nil (defun nchoplist (item list) "NCHOPLIST (ITEM LIST) where ITEM is of the form (a0 .ITEM .... an) => Values (a0 ...), (ITEM .. an) -- if ITEM is in LIST, NIL otherwise. NOTE: Uses EQL to test if ITEM is in LIST. May modify LIST." (cond ((eql item (car list)) (values nil list)) (t (loop for prev = list then curr for curr = (cdr prev) then (cdr curr) while curr if (eql item (car curr)) return (multiple-value-prog1 (values list curr) (setf (cdr prev) nil)))))) #+nil (defun NREMOVE-AT (index list) "<87vfcteo3a.fsf@eva.rplacd.net>" (declare (inline NREMOVE-AT) (type (integer 0) index) (type list list)) (when (zerop index) (return-from NREMOVE-AT (cdr list))) (rplacd #1=(nthcdr (1- index) list) (cddr #1#)) list) #+nil (define-setf-expander nthcdr (n place &environment env) " <878y9pfbec.fsf@Astalo.kon.iki.fi> -- kon" (multiple-value-bind (vars vals store-vars writer-form reader-form) (get-setf-expansion place env) (let* ((gn (gensym)) (gstore (if store-vars (first store-vars) (gensym "STORE")))) (values (list* gn vars) (list* n vals) (list gstore) ;; Intentionally leaves 0.0 unrecognized. `(if (eql ,gn 0) ,(case (length store-vars) (0 `(progn ,writer-form ,gstore)) (1 writer-form) (t `(let ,(rest store-vars) (values ,writer-form)))) (setf (cdr (nthcdr (1- ,gn) ,reader-form)) ,gstore)) `(nthcdr ,gn ,reader-form))))) #+nil (defun make-lexicographic-comparator (&key (test #'<) (sort-keys (list 'identity)) (lhs-symbol 'x) (rhs-symbol 'y)) (labels ((make-simple-form (lhs rhs func) `(,test (,func ,lhs) (,func ,rhs))) (make-ordering-form (lhs-sym rhs-sym &key (test '<) keys) " S.E.Harris" (when keys (if (null (cdr keys)) (make-simple-form lhs-sym rhs-sym (car keys)) `(or ,(make-simple-form lhs-sym rhs-sym (car keys)) (and (not ,(make-simple-form rhs-sym lhs-sym (car keys))) ,(make-ordering-form lhs-sym rhs-sym :test test :keys (cdr keys)))))))) `(lambda (,lhs-symbol ,rhs-symbol) ,(make-ordering-form lhs-symbol rhs-symbol :test test :keys sort-keys)))) #+nil (make-lexicographic-comparator :test '> :sort-keys '(priority1 priority2)) #+nil (defun flatten (x &aux stack result) ; madhu 061207 ;; (flet ((rec (item) (if (atom item) (push item result) (loop for elem in item do (push elem stack))))) (declare (inline rec)) (rec x) (loop while stack do (funcall #'rec (pop stack))) result)) #+nil (defun tree-depth (tree &aux (global-depth 0) stack) ; madhu 061123 ;; ;; (flet ((level (list depth) (when (> (1+ depth) global-depth) (setq global-depth (1+ depth))) (loop for node in list when (consp node) do (push (list node (1+ depth)) stack)))) (declare (inline level)) (cond ((null tree) 0) ((atom tree) 1) (t (level tree 0) (loop while stack do (apply #'level (pop stack))) global-depth)))) (defun position-ordered (elem array &optional (predicate #'<) &key (test #'eql) (start 0) end) ;TESTME "Return the index of ELEM in the sorted sequence ARRAY, sorted by PREDICATE by performing binary search." (loop with low = start and high = (or end (length array)) for middle = (floor (+ high low) 2) while (< 1 (- high low)) do (if (funcall predicate elem (elt array middle)) (setf high middle) (setf low middle)) finally (if (funcall test elem (elt array low)) (return low)))) ;; Example: (defun remove-common-delimited-prefix (sorted-sequence delim-char) "SORTED-SEQUENCE is a sequence of sorted strings, each of which is a has components delimited by DELIM-CHAR. This function returns a new sequence which excludes strings which are proper prefixes of other strings in the sequence." (let ((i 0) (exclude-marker nil) (l (length sorted-sequence))) (delete exclude-marker (map (etypecase sorted-sequence (vector 'vector) (list 'list)) (lambda (x) (let ((j (if (< i (1- l)) (position-ordered x sorted-sequence #'string< :start (1+ i) :test (lambda (a b) (search a b)))))) (incf i) (if (and j (eql (char (elt sorted-sequence j) (length x)) delim-char)) exclude-marker x))) sorted-sequence)))) #+nil (remove-common-delimited-prefix #("car" "foo" "foo/bar") #\/) #+nil (defun removedirs (infile outfile) "find > INFILE. OUTFILE contains only files and empty directories." (with-open-file (stream outfile :direction :output :if-exists :supersede) (write-lines-to-stream (remove-common-delimited-prefix (sort (with-open-file (stream infile) (read-lines-from-stream stream)) #'string<) #\/) stream))) ;;; ---------------------------------------------------------------------- ;;; ;;; STREAM UTILITIES ;;; ;; ;; ;; #+nil (defvar *null-stream* (make-two-way-stream ;; #+nil(make-concatenated-stream) ; cmucl bug (make-string-input-stream "") (make-broadcast-stream))) #+nil ; Unix only (defmacro with-flames-to-devnull (&body body) "UTILITY. Bind *ERROR-OUTPUT* to /dev/null while executing BODY" `(with-open-file (*error-output* "/dev/null" :direction :output :if-exists :append) ,@body)) (defmacro with-flames-to-devnull (&body body) "UTILITY. Bind *ERROR-OUTPUT* to /dev/null while executing BODY" `(let ((*error-output* (make-broadcast-stream))) ,@body)) ;;; ---------------------------------------------------------------------- ;;; ;;; STRING UTILITIES = PORTABLE ;;; (defun substr (string &optional (start 0) end) "Like SUBSEQ but on simple base strings, and without allocating space." (make-array (if end (- end start) (- (length string) start)) :element-type (array-element-type string) :displaced-to string :displaced-index-offset start)) (export '(substr)) ;; ;; COMPARATOR [Mon Jun 07 10:23:42 2004 +0530] ;; #+nil (defun cmp (x y &key (start1 0) (start2 0) &aux p q) "Alphanumeric STRING-LESSP." (cond ((and (setq p (position-if #'digit-char-p x :start start1)) (setq q (position-if #'digit-char-p y :start start2))) (or (string-lessp x y :start1 start1 :start2 start2 :end1 p :end2 q) (and (string-equal x y :start1 start1 :start2 start2 :end1 p :end2 q) ; (multiple-value-bind (num1 idx1) (parse-integer x :start p :junk-allowed t) (multiple-value-bind (num2 idx2) (parse-integer y :start q :junk-allowed t) (or (< num1 num2) (and (= num1 num2) ; (cmp x y :start1 idx1 :start2 idx2)))))))) (t (string-lessp x y :start1 start1 :start2 start2)))) #+nil (defun safe-end (p &optional (start 0) end) (let ((len (length p))) (if end (if (<= end len) end (values len T)) len))) (defun safe-string-match-position (match line &key (test #'string=) (start1 0) end1 (start2 0) end2) "Internal. Look for the substring MATCH bounded by indices START1 and END1 in the string LINE (bounded by indices START2 and END2) by calling TEST with all 4 keyword arguments. If matched, return the position in LINE just past the match. Otherwise return NIL. The bounds END1 and END2 are treated as the lengths of MATCH and LINE if they are unspecified, NIL, or if they are larger than the corresponding lengths." (let ((abs-end1 (length match)) (abs-end2 (length line))) (let ((safe-end1 (if end1 (if (<= end1 abs-end1) end1 abs-end1) abs-end1)) (safe-end2 (if end2 (if (<= end2 abs-end2) end2 abs-end2) abs-end2))) (unless (> start1 safe-end1) (let ((len-match (- safe-end1 start1))) (unless (> start2 safe-end2) (when (<= len-match (- safe-end2 start2)) (let ((pos (+ start2 len-match))) (when (funcall test match line :start1 start1 :end1 safe-end1 :start2 start2 :end2 pos) pos))))))))) (defun position-if-find (char-bag string &key from-end (start 0) end) (position-if (lambda (c) (find c char-bag)) string :from-end from-end :start start :end end)) (defun string-split (char-bag string &key (start 0) end (collect-empty t)) (if (characterp char-bag) (setq char-bag (list char-bag))) (loop for begin = start then (1+ pos) for pos = (position-if-find char-bag string :start begin :end end) if (or collect-empty (or (if pos (< begin pos) (< begin (or end (length string)))))) collect (substr string begin (or pos end)) unless pos do (loop-finish))) (export '(substr safe-string-match-position string-split)) #+nil (string-split #\- "-freetype-bn ttdurga-medium-r-normal--22-160-100-100-p-74-bengali-cdac") ;; ;; STRING-SPLIT EXAMPLES ;; #+nil (defun parse-fonts.dir (directory) (let* ((file (make-pathname :name "fonts" :type "dir" :version nil :defaults directory))) (with-open-file (stream file) (let ((len (read stream)) (n 0)) (loop for line = (read-line stream nil) while line do (incf n) (setq line (string-trim '(#\Space #\Tab) line)) collect (let* ((pos1 (position #\Space line)) (pos2 (position #\Space line :from-end t))) (list (substr line 0 pos1) (substr line (1+ pos2)))) finally (assert (= len n))))))) #+nil (parse-fonts.dir #p"/usr/X11R6/lib/X11/fonts/75dpi/") ;;; ---------------------------------------------------------------------- ;;; ;;; READTABLES: VERBATIM STRING READERS - PORTABLE ;;; #+nil (defun $tring-reader (stream $ arg) ; doesnt escape backslash "Obselete" (declare (ignore $ arg)) (unless (char= (read-char stream t) #\") (error 'parse-error)) (loop for c = (read-char stream t) if (char= c #\") do (return (coerce string 'string)) else collect c into string)) ; Eg: (load #$"c:\madhu\vilisp-2.0\_clisprc.lisp") #+nil (set-dispatch-macro-character #\# #\$ #'$tring-reader) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *matching-delim-pairs* '((#\( . #\)) (#\{ . #\}) (#\[ . #\])) "Alist of (LDELIM . RDELIM) characters, for delimiting strings read by VERBATIM-STRING-READER.")) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *use-matching-delim-pairs-p* t "If non-NIL VERBATIM-STRING-READER will look in *MATCHING-DELIM-PAIRS* to find a matching string delimiter.")) (eval-when (:compile-toplevel :load-toplevel :execute) (defun verbatim-string-reader (stream $ arg) (declare (ignore arg) (ignore $)) (let* ((delim (read-char stream t)) (match (or (and *use-matching-delim-pairs-p* (cdr (assoc delim *matching-delim-pairs*))) delim))) (loop for c = (read-char stream t) if (char= c match) return (coerce string 'string) else collect c into string)))) (eval-when (:compile-toplevel :load-toplevel :execute) (set-dispatch-macro-character #\# #\$ #'verbatim-string-reader)) ;; this screws up in emacs and slime (and when loading clisp 2.34) (eval-when (:load-toplevel :execute) (setf (documentation 'verbatim-string-reader 'function) #$ lineno -))) do (write-line line output-stream)))) ;; [Sun Jan 30 09:07:53 2005 +0530] (defun uniq (in out &optional ($a (make-hash-table :test #'equal))) "Copies line from IN stream to OUT stream ignoring duplicates. Trims lines of leading and trailing whitespace. Only the last duplicate is retained." ;; 3 passes! (loop for lineno from 0 for line = (read-line in nil nil) while line do (setf (gethash (string-trim '(#\Space #\Tab #\Newline) line) $a) lineno)) (loop for (lineno . line) in (sort (loop for lineno being each hash-value of $a using (hash-key line) collect (cons lineno line)) #'< :key #'car) do (write-line line out))) #+nil (progn (with-open-file (in ".bash_history") (with-open-file (out "/tmp/.bash_history" :direction :output :if-exists :supersede :if-does-not-exist :create) (uniq in out))) ;; madhu 060204 BUG: this rename doesnt work #+nil (rename-file #p".bash_history.new" #p".bash_history.")) (defun copy-buffered-io (input output &key (block-size 4096) (element-type '(unsigned-byte 8)) (buffer (make-array block-size :element-type element-type))) "Copies INPUT into OUTPUT using BLOCK-SIZE blocks." (let ((actual-block-size (length buffer))) (loop for bytes-read = (read-sequence buffer input) do (write-sequence buffer output :end bytes-read) until (< bytes-read actual-block-size) summing bytes-read into total-bytes-written finally (return total-bytes-written)))) (defun |cat a > b| (file1 file2) (with-open-file (input file1 :element-type '(unsigned-byte 8)) (with-open-file (output file2 :direction :io :element-type '(unsigned-byte 8) :if-exists :overwrite :if-does-not-exist :create) (copy-buffered-io input output)))) (defun |cat a >> b| (src dest) (with-open-file (output dest :if-exists :append :if-does-not-exist :create :element-type '(unsigned-byte 8) :direction :output) (with-open-file (input src :element-type '(unsigned-byte 8)) (copy-buffered-io input output)))) (export '(copy-buffered-io |cat a > b| |cat a >> b|)) ;;; ;;; ;;; (defun ensure-buffer-with-capacity (size &key ((:buffer array)) (element-type (if array (array-element-type array) '(unsigned-byte 8)))) "Ensure that the adjustable array with fill-pointer in BUFFER has capcity to hold SIZE elements. BUFFER can be NIL in which case a new adjustable array with fill-pointer of given ELEMENT-TYPE and SIZE is returned." (cond (array (if (< (array-total-size array) size) (adjust-array array size :element-type element-type :fill-pointer t) (prog1 array (setf (fill-pointer array) size)))) (t (make-array size :element-type element-type :fill-pointer t :adjustable t)))) (defun slurp-file (pathname &optional buffer &key (element-type (if buffer (array-element-type buffer) '(unsigned-byte 8)))) "Slurp contents of PATHNAME into an adjustable array with fill-pointer of type ELEMENT-TYPE. BUFFER can be NIL, in which case a new array is allocated and returned, or an adjustable array with fill-pointer of appropriate element-type into which the file contents are read." (with-open-file (f pathname :element-type element-type) (let* ((size (file-length f)) (array (ensure-buffer-with-capacity size :buffer buffer :element-type element-type)) (ret (read-sequence array f))) (when (= ret size) array)))) ;; ;; Fri Oct 06 09:50:00 2006 +0530 ;; #+orig (defun replace-text-in-file (pathname match replacement &key (element-type 'character) buffer (match-len (length match)) (replacement-len (length replacement))) "Replace first occurrence of MATCH with REPLACEMENT" (if (< replacement-len match-len) (let ((array (slurp-file pathname element-type buffer))) (let ((pos (search match array))) (when pos (with-file-dates-preserved (pathname) (with-open-file (stream pathname :direction :output :if-exists :supersede :element-type element-type) (write-sequence array stream :end pos) (write-sequence replacement stream) (write-sequence array stream :start (+ pos match-len)) T))))) (with-file-dates-preserved (pathname) (with-open-file (stream pathname :direction :io :if-exists :overwrite ; MAKE SURE your lisp ;; doesnt treat OVERWRITE as SUPERSEDE. :element-type element-type) (let* ((size (file-length stream)) (array (ensure-buffer-with-capacity size :buffer buffer :element-type element-type)) (ret (read-sequence array stream)) (pos (progn (assert (= ret size)) (search match array)))) (when pos (assert (file-position stream pos)) (write-sequence replacement stream) (cond ((= match-len replacement-len) T) (T (write-sequence array stream :start (+ pos match-len)) T)))))))) (defun replace-text-in-file (pathname match replacement &key (element-type 'character) buffer (match-len (length match)) (replacement-len (length replacement)) replace-all) "Replace occurrence of MATCH with REPLACEMENT. If REPLACE-ALL is NIL, replace the first occurance." (if (or (< replacement-len match-len) (and replace-all (> replacement-len match-len))) (let* ((array (slurp-file pathname buffer :element-type element-type)) (beg 0) (pos (search match array))) (when pos (with-file-dates-preserved (pathname) (with-open-file (stream pathname :direction :output :if-exists :supersede :element-type element-type) (loop (write-sequence array stream :start beg :end pos) (write-sequence replacement stream) (setq beg (+ pos match-len)) (when (or (null replace-all) (null (setq pos (search match array :start2 beg)))) (write-sequence array stream :start beg) (return (values T 1)))))))) (with-file-dates-preserved (pathname) ;; loses when unmodified. also when replace-all but only one match (with-open-file (stream pathname :direction :io :if-exists :overwrite :element-type element-type) (let* ((size (file-length stream)) (array (ensure-buffer-with-capacity size :buffer buffer :element-type element-type)) (ret (read-sequence array stream)) beg (pos (progn (assert (= ret size)) (search match array)))) (when pos (loop (assert (file-position stream pos)) (write-sequence replacement stream) (setq beg (+ pos match-len)) (when (or (null replace-all) (null (setq pos (search match array :start2 beg)))) (unless (= match-len replacement-len) (write-sequence array stream :start beg)) (return (values T 2)))))))))) #+nil (let ((match-text "$Header: /mnt/hda5/src/CVS-cmucl/") (replacement-text "$Header: /usr/local/src/CVS-cmucl/") (buf (make-array 1024 :element-type 'character :adjustable t :fill-pointer t))) (flet ((fixrcshdr (pathname depth directory-p) (unless directory-p (when (replace-text-in-file pathname match-text replacement-text :buffer buf) (warn "Modified ~A" pathname))))) (dired #p"home:cmu/src/" #'fixrcshdr))) (defun slurp-stream (stream &optional buffer &key (element-type (stream-element-type stream)) (chunk-size 1024)) "Slurp contents of STREAM into an adjustable array with fill-pointer reading it in chunks of CHUNK-SIZE. BUFFER can be NIL in which case a new array is allocated an returned, or an adjustable array with fill-pointer of appropriate type for storing the contents of STREAM. " (loop for start = 0 then end for size = (+ start chunk-size) for array = (ensure-buffer-with-capacity size :buffer buffer :element-type element-type) then (ensure-buffer-with-capacity size :buffer array) for end = (read-sequence array stream :start start) do (cond ((zerop end) (return array)) ((< end size) (setf (fill-pointer array) end) (return array))))) (defun string->file (string filename) (with-open-file (stream filename :direction :output :if-exists :supersede :element-type (array-element-type string)) (write-sequence string stream))) (defun stream->file (stream filename &key ; madhu 061216 (element-type (stream-element-type stream)) (buffer-size 1024) (buffer (make-array buffer-size :element-type element-type))) "Supersede pathname FILENAME with the contents of STREAM by writing to it in chunks of BUFFER-SIZE." (with-open-file (outstream filename :if-exists :supersede :element-type element-type :direction :output) (loop for x = (read-sequence buffer stream) until (zerop x) do (write-sequence buffer outstream :end x)))) (export '(slurp-file ensure-buffer-with-capacity slurp-stream stream->file string->file)) (defun read-lines-from-stream (stream &optional lines-array (start 0) end &key (hint 1024)) "STREAM is a character stream. LINES-ARRAY if supplied should be an adjustable array with fill-pointer. START and END denote line numbers with the first line numbered as 0, which limit the lines read. END can be NIL indicating that stream should be read until End of File. Otherwise reading terminates after (END - START) lines have been read. Returns LINES-ARRAY." (loop with lines-array = (or lines-array (make-array hint :adjustable t :fill-pointer 0 :initial-element nil)) for line = (read-line stream nil) for i from 0 while (and line (or (null end) (< i end))) when (>= i start) do (vector-push-extend line lines-array) finally (return lines-array))) (defun write-lines-to-stream (lines-array &optional (stream *standard-output*) (start 0) end) (loop for i from start below (or end (length lines-array)) do (write-line (aref lines-array i) stream))) (defun slurp-lines (pathname &optional (start 0) end &key lines-array) (with-open-file (stream pathname) (read-lines-from-stream stream lines-array start end))) (defun dump-lines (lines-array pathname &optional (start 0) end) (with-open-file (stream pathname :direction :output :if-exists :supersede) (write-lines-to-stream lines-array stream start end))) (export '(slurp-lines dump-lines read-lines-from-stream write-lines-to-stream)) ;;; ---------------------------------------------------------------------- ;;; ;;; PORTABLE UNDEFMETHOD. Touched - Sat Apr 29 10:50:38 2006 +0530 ;;; (defun parse-undefmethod-args (args) "Return values METHOD-QUALIFIERS and METHOD-SPECIALIZERS from parsing ARGS of the form (DEFMETHOD NAME &REST ARGS)." (let (p q method-qualifiers specializers) (loop (cond ((and (atom (setq p (car args))) p) (push p method-qualifiers)) (t (return))) ; now P is the specialized-lambda-list (setq args (cdr args))) (loop (when (null p) (return)) (cond ((symbolp (setq q (car p))) (case q ((&aux &key &optional &rest &allow-other-keys) (return)) (t ; handle eql specializers: (push (find-class T) specializers)))) ((consp (cadr q)) (push (cadr q) specializers)) (t (push (find-class (cadr q)) specializers))) (setq p (cdr p))) (values (nreverse method-qualifiers) (nreverse specializers)))) #+nil (parse-undefmethod-args '(nil)) (defmacro undefmethod (function-name &rest args) `(let ((fdefn (fdefinition ',function-name))) (multiple-value-bind (qualifiers specializers) (parse-undefmethod-args ',args) (let ((meth (find-method fdefn qualifiers specializers))) (when meth (remove-method fdefn meth)))))) (export '(undefmethod)) ;;; ---------------------------------------------------------------------- ;;; ;;; MACROEXPAND DEBUGGING UTILITIES ;;; (defmacro debug-macro-call (form &environment env) ;; (let ((expansion (macroexpand-1 form env))) (format t "~S =expands-to ~S~&" form (macroexpand-1 form env)) expansion)) #+nil (defmacro array-access ((array access) &body body) `(macrolet ((,access (&rest indices) `(aref ,,array ,@indices))) ,@body)) #+nil (array-access (#(0 1 2 3) foo) (debug-macro-call (foo 0))) ;;; ---------------------------------------------------------------------- ;;; ;;; PORTABLE RESTART HACKERY - Touched madhu 050305 ;;; ;;; Do or do not. There is no try. --Yoda ;;; (defmacro choose-with-restarts-internal (choices &body body) (let ((choices-list (gensym))) `(let ((,choices-list ',choices)) (restart-case (progn ,@body) ,@(loop for choice in choices for i from 0 collect `(nil nil :report ,(format nil "Choose ~S:" choice) (nth ,i ,choices-list))))))) #+nil (choose-with-restarts-internal (foo bar car) (error "choose one")) (defun %choose-with-restarts (choices body-fn) (funcall (compile nil `(lambda () (choose-with-restarts-internal ,choices (funcall ,body-fn)))))) (defmacro choose-with-restarts (choices &body body) "CHOICES is evaluated to a list in the current lexical environment. BODY forms are evaluated in a dynamic environment where each item of CHOICES can be uniquely chosen by interactively invoking a particular restart. If BODY evaluates without entering the debugger, the macro returns result of evaluating the final form in BODY. However if the debugger is entered, the user may interactively invoke a restart and the corresponding item from CHOICES is returned. Eg: * (let ((choices '(yes no))) (ecase (choose-with-restarts choices (error \"Should I Stay or Should I go?\")) (yes 'blue-pill) (no 'yellow-pill))) " `(%choose-with-restarts ,choices (lambda () ,@body))) #+nil (%choose-with-restarts (list 'foo 'bar 'car 'var) #'(lambda () (error "foo-error"))) ;;; ---------------------------------------------------------------------- ;;; ;;; CMUCL RLWRAP SUPPORT - Touched Sun Jun 26 11:41:03 2005 +0530 ;;; ;;; breakchars: \"#'(),;\`\\|!?[]{} ;;; #+nil (defun ediweitz-make-cmucl-completions () (with-open-file (!!!-stream "home:.lisp_completions" :direction :output :if-exists :supersede) (let ((!!!-seen (make-hash-table :size 6000 :test #'equal)) (!!!-cl-package (find-package "CL")) (!!!-cl-user-package (find-package "CL-USER"))) (loop for !!!-package in (list-all-packages) do (let ((!!!-prefixes (if (or (eq !!!-package !!!-cl-package) (eq !!!-package !!!-cl-user-package)) (list "") (mapcar #'(lambda (!!!-prefix) (concatenate 'string (string-downcase !!!-prefix) ":")) (if (package-nicknames !!!-package) (package-nicknames !!!-package) (list (package-name !!!-package))))))) (loop for !!!-symbol being the symbols of !!!-package for !!!-symbol-name = (symbol-name !!!-symbol) when (or (eq (nth-value 1 (find-symbol !!!-symbol-name !!!-package)) :external) (eq !!!-package !!!-cl-user-package)) do (loop for !!!-prefix in !!!-prefixes do (let ((!!!-completion (format nil "~A~A~%" !!!-prefix (string-downcase !!!-symbol)))) (unless (or (gethash !!!-completion !!!-seen) (string= "!!!-" !!!-symbol-name :end2 (min (length !!!-symbol-name) 4))) (setf (gethash !!!-completion !!!-seen) t) (princ !!!-completion !!!-stream)))))))))) #+nil (ediweitz-make-cmucl-completions) ;;; ---------------------------------------------------------------------- ;;; ;;; PORTABLE PACKAGES ;;; (defun package-add-nicknames (pkg &rest nicknames) (rename-package (find-package pkg) (package-name pkg) (union nicknames (package-nicknames pkg) :test #'string=))) (defun package-remove-nicknames (pkg &rest nicknames) (rename-package (find-package pkg) (package-name pkg) (set-difference (package-nicknames pkg) nicknames :test #'string=))) (export '(package-add-nicknames package-remove-nicknames)) ;; undo some SBCL inspired ANSI-looniness ;; (package-add-nicknames "CL-USER" "USER") (defmacro extsyms (package) `(loop for sym being each external-symbol of ',package collect sym)) (defmacro pp (table) `(loop for key being each hash-key of ,table using (hash-value val) collect (cons key val))) (defun find-symbols (symbol-designator &optional (functionp t)) "Return a list of symbols named SYMBOL-DESIGNATOR from all packages" (etypecase symbol-designator (string) (symbol (setf symbol-designator (symbol-name symbol-designator)))) (let ((return-list nil)) (loop for package in (list-all-packages) for found-symbol = (find-symbol symbol-designator package) when found-symbol unless (keywordp found-symbol) ;XXX when (or (not functionp) (fboundp found-symbol)) do (pushnew found-symbol return-list)) return-list)) #+nil ;; Example: hopelessly broken (progn (shadow 'fdefinition) (defun fdefinition (function-name) (handler-bind ((undefined-function #'(lambda (c) (let ((choices (find-symbols function-name))) (when choices (return-from fdefinition (fdefinition (choose-with-restarts choices (error "Encountered Error ~S: ~A There was no function of that name in this package, However similar functions were found in other packages: ~S You may choose to return one of the those instead." c (cell-error-name c) choices))))))))) (cl:fdefinition function-name))) (fdefinition 'install-gc-hooks)) ;;; ;;; cleaning Up packages - Touched Sun Oct 30 21:24:15 2005 +0530 ;;; (defun clean-syms (pkg &optional (syms (loop for sym being each symbol of (setq pkg (find-package pkg)) when (eql pkg (symbol-package sym)) collect sym))) (warn "CLEANING: ~A~@[ Deps: ~A.~]" pkg (package-used-by-list pkg)) (loop with rem = (copy-list syms) for sym in syms if (fboundp sym) collect sym into functions if (boundp sym) collect sym into vars and if (hash-table-p (symbol-value sym)) collect sym into hashes end if (find-class sym nil) collect sym into classes finally (when classes (setq classes (sort classes #'STRING< :key #'symbol-name)) (warn "nuking classes ~A" classes) (loop for class in classes do (setf (find-class class) nil)) (setq rem (set-difference rem classes))) (when functions (setq functions (sort functions #'STRING< :key #'symbol-name)) (warn "nuking functions ~A" functions) (loop for func in functions do (fmakunbound func)) (setq rem (set-difference rem functions))) (when hashes (setq hashes (sort hashes #'STRING< :key #'symbol-name)) (warn "nuking hashes ~A" hashes) (loop for hash in hashes do (clrhash (symbol-value hash)) #+cmu (lisp::clobber-hash (symbol-value hash)))) (when vars (setq vars (sort vars #'STRING< :key #'symbol-name)) (warn "nuking vars ~A" vars) (loop for var in vars do (makunbound var)) (setq rem (set-difference rem functions :test #'eq))) (when rem (warn "remaining symbols: ~A" rem))) (loop for sym in syms do (unintern sym pkg))) ;; ;; pjb's cleaning packages imported into CL-USER ;; #+nil (MAPC (LAMBDA (USED) (UNUSE-PACKAGE USED "COMMON-LISP-USER")) (REMOVE (FIND-PACKAGE "COMMON-LISP") (COPY-SEQ (PACKAGE-USE-LIST "COMMON-LISP-USER")))) ;; ;; instead remove all symbols that arent in the use-list ;; #+nil (let ((pkg (find-package "COMMON-LISP-USER")) (use (list (find-package "EXTENSIONS") (find-package "COMMON-LISP")))) (clean-syms (loop for x being each symbol of pkg unless (some (lambda (p) (find-symbol (symbol-name x) p)) use) collect x) pkg)) #+nil (defmacro with-pkg-slots ((&rest slot-vars) obj pkg &body body) ; madhu 061205 "PKG is a package designator (evaluated) denoting the package in which slots-vars are looked up." ;; (let ((objvar (gensym))) `(let ((,objvar ,obj)) (declare (ignorable ,objvar)) (symbol-macrolet ,(loop for slot-var in slot-vars collect (etypecase slot-var (cons (assert (= (length slot-var) 2)) (list (car slot-var) `(slot-value ,objvar ',(cadr slot-var)))) (symbol (list slot-var `(slot-value ,objvar ',(find-symbol (symbol-name slot-var) pkg)))))) ,@body)))) ;;; ---------------------------------------------------------------------- ;;; ;;; LAZY EVALUATION: DELAY/FORCE - PORTABLE ;;; ;;; Touched - Tue 02 Mar 2004 09:36:20 AM IST ;;; #+nil (progn (defclass delayed-computation nil ((delayed :accessor force) ; delayed slot initially unbound! (computation :initarg :form))) (defmacro delay (&body body) `(make-instance 'delayed-computation :form (lambda () ,@body))) (defmethod slot-unbound :around ((class t) (obj delayed-computation) (slot (eql 'delayed))) ;compute the delayed slot - exactly once, on demand (setf (slot-value obj slot) (funcall (slot-value obj 'computation))))) #+nil (let ((foo 10)) ;(pprint (macroexpand-1'(delay(incf foo)))) (setq b1 (delay (incf foo))) (setq b2 (delay (incf foo))) (setq b3 (delay (incf foo))) (assert (= (force b1) 11)) (assert (= (force b1) 11)) (assert (= (force b2) 12)) (assert (= (force b3) 13)) (assert (= (force b3) 13)) ) ;;; ---------------------------------------------------------------------- ;;; ;;; UPTIME PORTABLE. Touched - Sat Jan 07 12:08:32 2006 +0530 ;;; (defvar *uptime-epoch* (get-universal-time) "When this file was loaded.") (defun uptime (&optional (now (get-universal-time)) human-readable) (case now ((t nil) (setq now (get-universal-time)))) (multiple-value-bind (second minute hour) (decode-universal-time now) (format t "~2,'0D:~2,'0D:~2,'0D ~T" hour minute second)) (multiple-value-bind (days diff) (truncate (- now *uptime-epoch*) 86400) (multiple-value-bind (hours diff) (truncate diff 3600) (multiple-value-bind (mins diff) (truncate diff 60) (multiple-value-bind (secs) (truncate diff) (if human-readable (format t "Up ~A day~:P ~A hour~:P ~A minute~:P ~A second~:P." days hours mins secs) (format t "Up ~A day~:P, ~2,'0D:~2,'0D" days hours mins)) (values days hours mins secs)))))) (export '(uptime)) ;;; ---------------------------------------------------------------------- ;;; ;;; My ad-hoc common-lisp controller. ;;; (defvar *my-registry-dir* "home:cmu/registry/") ; XXX (defgeneric register-sysdcl (NAME SYSDCL) (:documentation "Given an mk-defsystem system defintion file SYDCL, REGISTER-SYSDCL will arrange to have that file loaded upon a call to (require 'NAME). In addition the call to (require 'NAME) will compile and load the mk-defsystem system NAME.")) (defmethod register-sysdcl ((module-name string) (sysdcl pathname)) (with-open-file (stream (make-pathname :name (or #+cmu (concatenate 'string module-name "-library") module-name) :type "lisp" :version nil :defaults *my-registry-dir*) :direction :output :if-exists :supersede) ;so beware! (format stream ";;;; vim: ft=lisp ;;;; Touched: <~a, #'register-sysdcl> (in-package #:cl-user) #-mk-defsystem (require :defsystem) ; say no to defsystem (load ~s) (let ((mk::*operations-propagate-to-subsystems* nil)) (mk:load-system '~a :minimal-load t :compile-during-load t)) ;madhu (provide '~a)~%" (iso-8601-date :suppress-tz-p nil) (truename sysdcl) module-name module-name))) #+cmu (pushnew *my-registry-dir* (ext:search-list "modules:")) #+clisp (pushnew *my-registry-dir* custom:*load-paths*) #|| Eg: (ensure-directories-exist *my-registry-dir*) (register-sysdcl "cl-pdf" #p"cl-pdf-2.0.2/sysdcl.lisp") (register-sysdcl "f2cl" #p"f2cl-clocc/sysdcl.lisp") (require 'f2cl) (register-sysdcl "cl-ppcre" #p"cl-ppcre-0.5.7/sysdcl.lisp") (register-sysdcl "cl-who" #p"cl-who-0.3.0/sysdcl.lisp") (register-sysdcl "acl-compat" #p"portableaserve/sysdcl.lisp") (register-sysdcl "aserve" #p"portableaserve/sysdcl.lisp") ||# ;;; ---------------------------------------------------------------------- ;;; ;;; MK-DEFSYSTEM ;;; (defvar *defsystem-source-directory* "home:/cmu/clocc/src/defsystem-3.x/") ;XXX (eval-when (:load-toplevel :execute :compile-toplevel) (unless (find-package :make) (make-package :make))) #+nil (defparameter make::*dont-redefine-require* nil) ;XXX #+nil (defparameter make::*compile-during-load* t) ;XXX (let ((src (merge-pathnames "defsystem.lisp" *defsystem-source-directory*))) (when (probe-file src) (lc src))) (defmacro clmod (&rest modules) "compile and load DEFYSSTEM MODULES" `(with-compilation-unit #-cmu () #+cmu (:optimize '(optimize (speed #+byte-compile 0 #-byte-compile 2) (space 2) (inhibit-warnings 2) (safety #+small 0 #-small 1) (debug #+small .5 #-small 2)) :optimize-interface '(optimize-interface (safety #+small 1 #-small 2) (debug #+small .5 #-small 2)) :context-declarations '(((:and :external :global) (declare (optimize-interface (safety 2) (debug 1)))) ((:and :external :macro) (declare (optimize (safety 2)))) (:macro (declare (optimize (speed 0)))))) ,@(loop for name in modules for quotep = (typep name '(and symbol (not keyword))) collect `(,(find-symbol "OOS" "MAKE") ,@(if quotep `(',name) `(,name)) :load :force :new-source-and-dependents :minimal-load t :compile-during-load t)))) #+(and nil mk-defsystem) ;madhu 080807 don't (defun mklib (system &optional (defaults *default-pathname-defaults*)) "Creates a concatenated fasl file named SYSTEM-library.FASL from the fasl files of the given mk-defsystem system SYSTEM. The system should already be compiled. The concatenated file is written in the DEFAULTS directory. (FASL is the appropriate fasl pathname-type for the CMUCL system.)" (labels ((handle-load-only (component) ; "Return a list of fasl pathnames" (let* ((source-pathname (mk::component-full-pathname component :source)) (binary-pathname (mk::component-full-pathname component :binary)) (binary-truename (probe-file binary-pathname)) (compilation-required-p (cond (binary-truename (< (file-write-date binary-truename) (file-write-date (truename source-pathname)))) (t t)))) (restart-case (cerror "Skip this file" "Component ~S is load-only." component) (use-existing () :test (lambda (condition) (declare (ignore condition)) binary-truename) :report (lambda (stream) (format stream "Use already compiled (~:[Current~;Out of Date~]) binary: ~A" compilation-required-p binary-truename)) (list binary-truename)) (compile-and-use () :report (lambda (stream) (format stream "Compile ~A to ~A and use that fasl?" source-pathname binary-pathname)) (multiple-value-bind (output-truename warnings-p failure-p) (compile-file source-pathname :output-file binary-pathname) (declare (ignore warnings-p)) (cond (failure-p (cerror "Skip this file" "Compilation of ~A to produce ~A failed." source-pathname binary-pathname)) (t (list output-truename)))))))) (walk-components (component) (ecase (mk::component-type component) ((:file :private-file) (cond ((mk::component-load-only component) (handle-load-only component)) (t (list (mk::component-full-pathname component :binary))))) ((:module :system :subsystem :defsystem) (loop for x in (mk::component-components component) nconc (walk-components x))))) (handle-deps (system deps) (when deps (restart-case (cerror "Skip deps" "System ~S depends on: ~S" system deps) (recursively-load-deps () :report "Recursively handle deps" (loop for dep in deps for depsys = (mk:find-system dep) unless depsys do (cerror "OK" "Not handling unknown system: ~S" dep) else nconc (walk-components depsys))))))) (let* ((system (etypecase system (mk::component (ecase (mk::component-type system) (:defsystem system))) (symbol (mk:find-system system)) (string (mk:find-system system)))) (deps (mk::component-depends-on system)) (fasls (nconc (handle-deps system deps) (walk-components system))) (buf (make-array 2048 :element-type '(unsigned-byte 8))) (pathname (make-pathname :name (concatenate 'string (mk::component-name system) "-library") :type (or (mk::component-binary-extension system) #-cmu (pathname-type (compile-file-pathname "foo.lisp")) #+cmu (c:backend-fasl-file-type c:*target-backend*)) :version :newest