;;;; FILE IDENTIFICATION
;;;;
;;;; Name: getopt.lisp
-;;;; Purpose: Excerpted from cl-getopt package
+;;;; Purpose: Excerpted from cl-getopt package
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Sep 2003
;;;;
(defun decompose-arg (arg option-type)
"Returns base-name,argument"
(let ((start (ecase option-type
- (:long 2)
- (:short 1)))
- (name-end (position #\= arg)))
+ (:long 2)
+ (:short 1)))
+ (name-end (position #\= arg)))
(values (subseq arg start name-end)
- (when name-end (subseq arg (1+ name-end))))))
+ (when name-end (subseq arg (1+ name-end))))))
(defun analyze-arg (arg)
"Analyzes an argument. Returns option-type,base-name,argument"
(let* ((option-type (cond ((is-short-option arg) :short)
- ((is-long-option arg) :long)
- (t :arg))))
+ ((is-long-option arg) :long)
+ (t :arg))))
(if (or (eq option-type :short) (eq option-type :long))
- (multiple-value-bind (base arg) (decompose-arg arg option-type)
- (values option-type base arg))
- (values :arg arg nil))))
+ (multiple-value-bind (base arg) (decompose-arg arg option-type)
+ (values option-type base arg))
+ (values :arg arg nil))))
(defun find-option (name options)
"Find an option in option list. Handles using unique abbreviations"
(let* ((option-names (mapcar #'car options))
- (pos (match-unique-abbreviation name option-names)))
+ (pos (match-unique-abbreviation name option-names)))
(when pos
(nth pos options))))
"Returns position of ABBR in STRINGS. ABBR may be a unique abbreviation.
Returns NIL if no match found."
(let ((len (length abbr))
- (matches nil))
+ (matches nil))
(dotimes (i (length strings))
(let* ((s (nth i strings))
- (l (length s)))
- (cond
- ((= len l)
- (when (string= abbr s)
- (push (cons s i) matches)))
- ((< len l)
- (when (string= abbr (subseq s 0 len))
- (push (cons s i) matches))))))
+ (l (length s)))
+ (cond
+ ((= len l)
+ (when (string= abbr s)
+ (push (cons s i) matches)))
+ ((< len l)
+ (when (string= abbr (subseq s 0 len))
+ (push (cons s i) matches))))))
(when (= 1 (length matches))
(cdr (first matches)))))
(setq finished-options t))
(t
(let ((arg (car pos)))
- (multiple-value-bind (option-list option-type base-name argument)
- (match-option (car pos) options)
- (cond
- (option-list
- (cond
- (argument
- (case (second option-list)
- (:none
- (push base-name errors))
- (t
- (push (cons base-name argument) out-opts))))
- ((null argument)
- (if (and (eq :required (second option-list)) (null (cdr pos)))
- (push base-name errors)
- (if (or (is-short-option (second pos))
- (is-long-option (second pos)))
- (if (eq :required (second option-list))
- (push base-name errors)
- (push (cons base-name (third option-list)) out-args))
- (progn
- (push (cons base-name (second pos)) out-opts)
- (setq pos (cdr pos))))))))
- (t
- (if (or (eq :long option-type)
- (eq :short option-type))
- (push (nth-value 0 (decompose-arg arg option-type)) errors)
- (push arg out-args))))))))))
+ (multiple-value-bind (option-list option-type base-name argument)
+ (match-option (car pos) options)
+ (cond
+ (option-list
+ (cond
+ (argument
+ (case (second option-list)
+ (:none
+ (push base-name errors))
+ (t
+ (push (cons base-name argument) out-opts))))
+ ((null argument)
+ (if (and (eq :required (second option-list)) (null (cdr pos)))
+ (push base-name errors)
+ (if (or (is-short-option (second pos))
+ (is-long-option (second pos)))
+ (if (eq :required (second option-list))
+ (push base-name errors)
+ (push (cons base-name (third option-list)) out-args))
+ (progn
+ (push (cons base-name (second pos)) out-opts)
+ (setq pos (cdr pos))))))))
+ (t
+ (if (or (eq :long option-type)
+ (eq :short option-type))
+ (push (nth-value 0 (decompose-arg arg option-type)) errors)
+ (push arg out-args))))))))))
(let ((lines '()))
(with-open-file (in file :direction :input)
(let ((eof (gensym)))
- (do ((line (read-line in nil eof)
- (read-line in nil eof)))
- ((eq line eof))
- (push line lines)))
+ (do ((line (read-line in nil eof)
+ (read-line in nil eof)))
+ ((eq line eof))
+ (push line lines)))
(nreverse lines))))
(defun flatten (lis)
(cond ((atom lis) lis)
- ((listp (car lis))
- (append (flatten (car lis)) (flatten (cdr lis))))
- (t (append (list (car lis)) (flatten (cdr lis))))))
+ ((listp (car lis))
+ (append (flatten (car lis)) (flatten (cdr lis))))
+ (t (append (list (car lis)) (flatten (cdr lis))))))
(defun mklist (obj)
"Make into list if atom"
(defun directory-tree (filename)
"Returns a tree of pathnames for sub-directories of a directory"
(let* ((root (canonicalize-directory-name filename))
- (subdirs (loop for path in (directory
- (make-pathname :name :wild
- :type :wild
- :defaults root))
- when (probe-directory path)
- collect (canonicalize-directory-name path))))
+ (subdirs (loop for path in (directory
+ (make-pathname :name :wild
+ :type :wild
+ :defaults root))
+ when (probe-directory path)
+ collect (canonicalize-directory-name path))))
(when (find nil subdirs)
(error "~A" subdirs))
(when (null root)
(error "~A" root))
(if subdirs
- (cons root (mapcar #'directory-tree subdirs))
- (if (probe-directory root)
- (list root)
- (error "root not directory ~A" root)))))
+ (cons root (mapcar #'directory-tree subdirs))
+ (if (probe-directory root)
+ (list root)
+ (error "root not directory ~A" root)))))
(defun canonicalize-directory-name (filename)
(flet ((un-unspecific (value)
- (if (eq value :unspecific) nil value)))
+ (if (eq value :unspecific) nil value)))
(let* ((path (pathname filename))
- (name (un-unspecific (pathname-name path)))
- (type (un-unspecific (pathname-type path)))
- (new-dir
- (cond ((and name type) (list (concatenate 'string name "." type)))
- (name (list name))
- (type (list type))
- (t nil))))
+ (name (un-unspecific (pathname-name path)))
+ (type (un-unspecific (pathname-type path)))
+ (new-dir
+ (cond ((and name type) (list (concatenate 'string name "." type)))
+ (name (list name))
+ (type (list type))
+ (t nil))))
(if new-dir
- (make-pathname
- :directory (append (un-unspecific (pathname-directory path))
- new-dir)
- :name nil :type nil :version nil :defaults path)
- path))))
+ (make-pathname
+ :directory (append (un-unspecific (pathname-directory path))
+ new-dir)
+ :name nil :type nil :version nil :defaults path)
+ path))))
(defun probe-directory (filename)
(let ((path (canonicalize-directory-name filename)))
#+allegro (excl:probe-directory path)
#+clisp (values
- (ignore-errors
- (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory
- path)))
+ (ignore-errors
+ (#+lisp=cl ext:probe-directory #-lisp=cl lisp:probe-directory
+ path)))
#+(or cmu scl) (eq :directory (unix:unix-file-kind (namestring path)))
#+lispworks (lw:file-directory-p path)
#+sbcl (eq :directory (sb-unix:unix-file-kind (namestring path)))
(cond
((not (null dir))
(when (and (typep dir 'logical-pathname)
- (translate-logical-pathname dir))
+ (translate-logical-pathname dir))
(setq dir (translate-logical-pathname dir)))
(when (stringp dir)
(setq dir (parse-namestring dir)))
(setq cl:*default-pathname-defaults* dir))
(t
(let ((dir
- #+allegro (excl:current-directory)
- #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
- #+(or cmu scl) (ext:default-directory)
- #+sbcl (sb-unix:posix-getcwd/)
- #+cormanlisp (ccl:get-current-directory)
- #+lispworks (hcl:get-working-directory)
- #+mcl (ccl:mac-default-directory)
- #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
+ #+allegro (excl:current-directory)
+ #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
+ #+(or cmu scl) (ext:default-directory)
+ #+sbcl (sb-unix:posix-getcwd/)
+ #+cormanlisp (ccl:get-current-directory)
+ #+lispworks (hcl:get-working-directory)
+ #+mcl (ccl:mac-default-directory)
+ #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
(when (stringp dir)
- (setq dir (parse-namestring dir)))
+ (setq dir (parse-namestring dir)))
dir))))
#+allegro (excl.osi:command-output cmd :directory directory :whole whole)
#+sbcl
(let* ((out (make-array '(0) :element-type 'character :fill-pointer 0
- :adjustable t))
- (err (make-array '(0) :element-type 'character :fill-pointer 0
- :adjustable t))
- (status
- (sb-impl::process-exit-code
- (with-output-to-string (out-stream out)
- (with-output-to-string (err-stream err)
- (sb-ext:run-program
- "/bin/sh"
- (list "-c" cmd)
- :input nil :output out-stream :error err-stream))))))
+ :adjustable t))
+ (err (make-array '(0) :element-type 'character :fill-pointer 0
+ :adjustable t))
+ (status
+ (sb-impl::process-exit-code
+ (with-output-to-string (out-stream out)
+ (with-output-to-string (err-stream err)
+ (sb-ext:run-program
+ "/bin/sh"
+ (list "-c" cmd)
+ :input nil :output out-stream :error err-stream))))))
(values out err status))
)
(defun is-vcs-directory (x)
(and (pathnamep x)
(or
- (string= "CVS"
- (car (last (pathname-directory x))))
- (string= ".svn"
- (car (last (pathname-directory x)))))))
+ (string= "CVS"
+ (car (last (pathname-directory x))))
+ (string= ".svn"
+ (car (last (pathname-directory x)))))))
(defun is-cvs-managed (dir)
(probe-directory (merge-pathnames
- (make-pathname :directory '(:relative "CVS"))
- dir)))
+ (make-pathname :directory '(:relative "CVS"))
+ dir)))
(defun is-svn-managed (dir)
(probe-directory (merge-pathnames
- (make-pathname :directory '(:relative ".svn"))
- dir)))
+ (make-pathname :directory '(:relative ".svn"))
+ dir)))
(defun filter-tree (tree)
"Called for a directory tree. First argument is name of current tree.
Returns a list of directories managed by CVS or SVN."
(when (and (listp tree) (not (is-vcs-directory (car tree))))
(let* ((managed-pair
- (cond
- ((find ".svn" (cdr tree)
- :key (lambda (x) (when (pathnamep (car x))
- (car (last (pathname-directory (car x))))))
- :test 'equal)
- (cons (car tree) :svn))
- ((find "CVS" (cdr tree)
- :key (lambda (x) (when (pathnamep (car x))
- (car (last (pathname-directory (car x))))))
- :test 'equal)
- (cons (car tree) :cvs))))
- (managed (car managed-pair))
- (type (cdr managed-pair)))
+ (cond
+ ((find ".svn" (cdr tree)
+ :key (lambda (x) (when (pathnamep (car x))
+ (car (last (pathname-directory (car x))))))
+ :test 'equal)
+ (cons (car tree) :svn))
+ ((find "CVS" (cdr tree)
+ :key (lambda (x) (when (pathnamep (car x))
+ (car (last (pathname-directory (car x))))))
+ :test 'equal)
+ (cons (car tree) :cvs))))
+ (managed (car managed-pair))
+ (type (cdr managed-pair)))
(let ((vcs-removed
- (do* ((pos (cdr tree) (cdr pos))
- (curr (car pos) (car pos))
- (res nil))
- ((null pos) (nreverse res))
- (when (and (not (is-vcs-directory (car curr)))
- (or (not managed)
- (not (is-managed-dir (car curr) managed type))))
- (push curr res)))))
- (if vcs-removed
- (if managed
- (cons managed (flatten
- (delete-if #'null
- (mapcar 'filter-tree vcs-removed))))
- (flatten (delete-if #'null (mapcar 'filter-tree vcs-removed))))
- managed))
+ (do* ((pos (cdr tree) (cdr pos))
+ (curr (car pos) (car pos))
+ (res nil))
+ ((null pos) (nreverse res))
+ (when (and (not (is-vcs-directory (car curr)))
+ (or (not managed)
+ (not (is-managed-dir (car curr) managed type))))
+ (push curr res)))))
+ (if vcs-removed
+ (if managed
+ (cons managed (flatten
+ (delete-if #'null
+ (mapcar 'filter-tree vcs-removed))))
+ (flatten (delete-if #'null (mapcar 'filter-tree vcs-removed))))
+ managed))
)))
(defun is-managed-dir (subdir dir type)
(let* ((entries-path
- (merge-pathnames
- (ecase type
- (:svn
- (make-pathname :name "entries" :type nil
- :directory '(:relative ".svn")))
- (:cvs
- (make-pathname :name "Entries" :type nil
- :directory '(:relative "CVS"))))
- dir))
- (entries (read-file-to-strings entries-path))
- (dir-name (car (last (pathname-directory subdir))))
- (match (case type
- (:svn
- (concatenate 'string "name=\"" dir-name "\""))
- (:cvs
- (concatenate 'string "D/" dir-name "////")))))
+ (merge-pathnames
+ (ecase type
+ (:svn
+ (make-pathname :name "entries" :type nil
+ :directory '(:relative ".svn")))
+ (:cvs
+ (make-pathname :name "Entries" :type nil
+ :directory '(:relative "CVS"))))
+ dir))
+ (entries (read-file-to-strings entries-path))
+ (dir-name (car (last (pathname-directory subdir))))
+ (match (case type
+ (:svn
+ (concatenate 'string "name=\"" dir-name "\""))
+ (:cvs
+ (concatenate 'string "D/" dir-name "////")))))
(case type
(:svn
(some (lambda (line) (string= match (string-trim-whitespace line)))
- entries))
+ entries))
(:cvs
(or
- (some (lambda (line) (string= match (string-trim-whitespace line)))
- entries)
- (is-cvs-managed subdir))))))
+ (some (lambda (line) (string= match (string-trim-whitespace line)))
+ entries)
+ (is-cvs-managed subdir))))))
(defun process-vcs-directory (dir action options)
(flet ((process (dir type-name)
- (let* ((vcs-cmd
- (ecase action
- (:update
- (format nil "~A update" type-name))
- (:status
- (format nil "~A status" type-name))
- (:commit
- (format nil "~A commit~A" type-name
- (aif (find "m" options :key #'car :test 'string=)
- (format nil " -m \"~A\"" (cdr it))
- "")))))
- (cmd (format nil "(cd ~A; ~A)" (namestring dir) vcs-cmd)))
- (format t "~A ~A:~%" vcs-cmd (namestring dir))
- (multiple-value-bind (output error status)
- (shell-command-output cmd :directory dir :whole t)
- (if (zerop status)
- (format t "~A~%" output)
- (format t "Exit status ~D: ~A ~A~%" status output error))))))
+ (let* ((vcs-cmd
+ (ecase action
+ (:update
+ (format nil "~A update" type-name))
+ (:status
+ (format nil "~A status" type-name))
+ (:commit
+ (format nil "~A commit~A" type-name
+ (aif (find "m" options :key #'car :test 'string=)
+ (format nil " -m \"~A\"" (cdr it))
+ "")))))
+ (cmd (format nil "(cd ~A; ~A)" (namestring dir) vcs-cmd)))
+ (format t "~A ~A:~%" vcs-cmd (namestring dir))
+ (multiple-value-bind (output error status)
+ (shell-command-output cmd :directory dir :whole t)
+ (if (zerop status)
+ (format t "~A~%" output)
+ (format t "Exit status ~D: ~A ~A~%" status output error))))))
(cond
((is-cvs-managed dir)
(process dir "cvs"))
(process dir "svn"))
(t
(format *error-output*
- "INTERAL ERROR: not a version control system directory ~A" dir)
+ "INTERAL ERROR: not a version control system directory ~A" dir)
(quit 1)))))
(defvar *progname* "")
(format *error-output* "usage: ~A action [OPTIONS]~%" *progname*)
(if msg
(progn
- (apply #'format *error-output* msg msg-args)
- (write-char #\Newline *error-output*))
+ (apply #'format *error-output* msg msg-args)
+ (write-char #\Newline *error-output*))
(format *error-output*
- "Processes a source-control managed directory tree~%"))
+ "Processes a source-control managed directory tree~%"))
(format *error-output* "Action: update, commit, or status~%")
(format *error-output* "OPTIONS~%")
(format *error-output* " -m <str> Set commit string~%"))
(t
(let ((pos (match-unique-abbreviation arg '("update" "commit" "status"))))
(cond
- ((eql pos 0) :update)
- ((eql pos 1) :commit)
- ((eql pos 2) :status)
- (t
- (usage "Unknown action: ~A" arg)
- (quit 1)))))))
+ ((eql pos 0) :update)
+ ((eql pos 1) :commit)
+ ((eql pos 2) :status)
+ (t
+ (usage "Unknown action: ~A" arg)
+ (quit 1)))))))
(defun main (&optional (argv (command-line-arguments)))
(let ((*progname* (car argv)))
(multiple-value-bind (args options errors)
- (getopt (cdr argv) '(("m" :required)))
+ (getopt (cdr argv) '(("m" :required)))
(when (or errors (/= 1 (length args)))
- (usage)
- (quit 1))
+ (usage)
+ (quit 1))
(let ((action (parse-action-arg (first args))))
- (unless action
- (usage "Invalid action ~A" (first args))
- (quit 1))
- (dolist (dir (mklist (filter-tree (directory-tree (cwd)))))
- (process-vcs-directory dir action options))))
+ (unless action
+ (usage "Invalid action ~A" (first args))
+ (quit 1))
+ (dolist (dir (mklist (filter-tree (directory-tree (cwd)))))
+ (process-vcs-directory dir action options))))
(quit 0)))
;;(main)