From 5d66ace14bf1d859d364e0004335d1a6800e0d40 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 12 Sep 2003 17:35:01 +0000 Subject: [PATCH] r7840: rename directory --- INSTALL | 8 ++ Makefile | 21 ++++++ debian/changelog | 5 ++ debian/compat | 1 + debian/control | 15 ++++ debian/copyright | 37 +++++++++ debian/rules | 78 +++++++++++++++++++ debian/upload.sh | 4 + getopt-excerpt.lisp | 136 ++++++++++++++++++++++++++++++++++ kmrcl-excerpt.lisp | 169 ++++++++++++++++++++++++++++++++++++++++++ loader.lisp | 24 ++++++ main.lisp | 177 ++++++++++++++++++++++++++++++++++++++++++++ package.lisp | 17 +++++ vcs-tree.1 | 34 +++++++++ vcs-tree.asd | 46 ++++++++++++ 15 files changed, 772 insertions(+) create mode 100644 INSTALL create mode 100644 Makefile create mode 100644 debian/changelog create mode 100644 debian/compat create mode 100644 debian/control create mode 100644 debian/copyright create mode 100755 debian/rules create mode 100755 debian/upload.sh create mode 100644 getopt-excerpt.lisp create mode 100644 kmrcl-excerpt.lisp create mode 100644 loader.lisp create mode 100644 main.lisp create mode 100644 package.lisp create mode 100644 vcs-tree.1 create mode 100644 vcs-tree.asd diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..153a2f1 --- /dev/null +++ b/INSTALL @@ -0,0 +1,8 @@ +This program requires the SBCL Common Lisp system (http://www.sbcl.org) +to compile and run. Because of its use of a new feature in the +sb-executable module, vcs-tree requires SBCL version 0.8.3.55 or greater. + +Once you have SBCL installed on your system, you can give the command + make +which will create the executable file "vcs-tree". You can then copy +that file to any directory in your path, such as /usr/local/bin/ diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..e963a25 --- /dev/null +++ b/Makefile @@ -0,0 +1,21 @@ +############################################################################## +# FILE IDENTIFICATION +# +# Name: Makefile +# Purpose: Makefile for the vcs-tree, creates binary executable +# Author: Kevin M. Rosenberg +# Date Started: Sep 2003 +# +# $Id: Makefile 7061 2003-09-07 06:34:45Z kevin $ +############################################################################## + + +pkg :=vcs-tree +sources :=$(pkg).asd main.lisp loader.lisp package.lisp kmrcl-excerpt.lisp + +$(pkg): $(sources) + $(MAKE) clean + sbcl --load "$(pkg).asd" --eval "(asdf:oos 'asdf:load-op '$(pkg))" --eval "(sb-ext:quit :unix-status 0)" + +clean: + rm -f *.fasl $(pkg) diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..5dd7483 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,5 @@ +vcs-tree (0.1-1) unstable; urgency=low + + * Initial upload + + -- Kevin M. Rosenberg Fri, 12 Sep 2003 08:26:41 -0600 diff --git a/debian/compat b/debian/compat new file mode 100644 index 0000000..b8626c4 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +4 diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..9ae19c6 --- /dev/null +++ b/debian/control @@ -0,0 +1,15 @@ +Source: vcs-tree +Section: devel +Priority: optional +Maintainer: Kevin M. Rosenberg +Build-Depends: debhelper (>> 4.0.0), sbcl +Standards-Version: 3.6.1.0 + +Package: vcs-tree +Architecture: i386 sparc powerpc mips mipsel alpha +Depends: ${shlibs:Depends}, sbcl (>= 0.8.3.53) +Description: Version Control System Tree Walker + vcs-tree walks through a directory tree and performs actions on CVS + or Subversion directories. vcs-tree works differently than just using + CVS or Subversion since vcs-tree finds and processes directories + that are below non-version control system managed directories. diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..1fa8ba0 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,37 @@ +Debian Copyright Section +======================== + +Upstream Source URL: http://files.b9.com/vcs-tree/ +Upstream Authors: Kevin M. Rosenberg +Debian Maintainer: Kevin M. Rosenberg + + +Upstream Copyright Statement +============================ +Copyright (c) 2003 Kevin M. Rosenberg + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of the contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..f9f80d2 --- /dev/null +++ b/debian/rules @@ -0,0 +1,78 @@ +#!/usr/bin/make -f + +pkg := vcs-tree +debpkg := vcs-tree + + +bin-dir := usr/bin +doc-dir := usr/share/doc/$(debpkg) + + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + # Add here commands to compile the package. + $(MAKE) ${pkg} + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + # Add here commands to clean up after the build process. + $(MAKE) clean + rm -f debian/${debpkg}.postinst.* debian/${debpkg}.prerm.* + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + # Add here commands to install the package into debian/xlunit. + dh_installdirs $(bin-dir) + dh_install ${pkg} $(bin-dir) + +# Build architecture-independent files here. +binary-indep: build install + + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot +# dh_installdebconf + dh_installdocs + dh_installexamples +# dh_installmenu +# dh_installlogrotate +# dh_installemacsen +# dh_installpam +# dh_installmime +# dh_installinit +# dh_installcron + dh_installman ${pkg}.1 +# dh_installinfo +# dh_undocumented + dh_installchangelogs + dh_strip + dh_compress + dh_fixperms +# dh_makeshlibs + dh_installdeb +# dh_perl + dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure + diff --git a/debian/upload.sh b/debian/upload.sh new file mode 100755 index 0000000..7e4770a --- /dev/null +++ b/debian/upload.sh @@ -0,0 +1,4 @@ +#!/bin/sh +set -e + +dup vcs-tree -Uftp.med-info.com -D/home/ftp/vcs-tree -C"/home/kevin/bin/remove-old-versions vcs-tree latest" -su $* diff --git a/getopt-excerpt.lisp b/getopt-excerpt.lisp new file mode 100644 index 0000000..1d2fa61 --- /dev/null +++ b/getopt-excerpt.lisp @@ -0,0 +1,136 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: getopt.lisp +;;;; Purpose: Excerpted from cl-getopt package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Sep 2003 +;;;; +;;;; $Id: package.lisp 7814 2003-09-10 12:56:02Z kevin $ +;;;; +;;;; ************************************************************************* + +(in-package vcs-tree) + + +(defun is-short-option (arg) + (and (>= (length arg) 2) + (char= #\- (schar arg 0)) + (char/= #\- (schar arg 1)))) + +(defun is-option-terminator (arg) + (and (= 2 (length arg)) + (char= #\- (schar arg 0)) + (char= #\- (schar arg 1)))) + +(defun is-long-option (arg) + (and (> (length arg) 2) + (char= #\- (schar arg 0)) + (char= #\- (schar arg 1)) + (char/= #\- (schar arg 3)))) + +(defun decompose-arg (arg option-type) + "Returns base-name,argument" + (let ((start (ecase option-type + (:long 2) + (:short 1))) + (name-end (position #\= arg))) + + (values (subseq arg start 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)))) + (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)))) + + +(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))) + (when pos + (nth pos options)))) + +(defun match-option (arg options) + "Matches an argument to an option. Returns option-list,option-type,base-name,argument" + (multiple-value-bind (option-type base-name argument) (analyze-arg arg) + (let ((match (find-option base-name options))) + (values match option-type (when match (car match)) argument)))) + + +;;; EXPORTED functions + +(defun match-unique-abbreviation (abbr strings) + "Returns position of ABBR in STRINGS. ABBR may be a unique abbreviation. +Returns NIL if no match found." + (let ((len (length abbr)) + (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)))))) + (when (= 1 (length matches)) + (cdr (first matches))))) + + +(defun getopt (args options) + "Processes a list of arguments and options. Returns filtered argument +list and alist of options. +opts is a list of option lists. The fields of the list are + - NAME name of the long option + - HAS-ARG with legal values of :NONE, :REQUIRED, :OPTIONAL + - VAL value to return for a option with no arguments" + (do ((pos args (cdr pos)) + (finished-options) + (out-opts) + (out-args) + (errors)) + ((null pos) (values (nreverse out-args) (nreverse out-opts) errors)) + (cond + (finished-options + (push (car pos) out-args)) + ((is-option-terminator (car pos)) + (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)))))))))) + diff --git a/kmrcl-excerpt.lisp b/kmrcl-excerpt.lisp new file mode 100644 index 0000000..66e6bf1 --- /dev/null +++ b/kmrcl-excerpt.lisp @@ -0,0 +1,169 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: vcs-tree -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: kmrcl-excerpt.lisp +;;;; Purpose: Excerpted functions from KMRCL to support vcs-tree +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Sep 2003 +;;;; +;;;; $Id: xlunit.asd 7061 2003-09-07 06:34:45Z kevin $ +;;;; ************************************************************************* + +(in-package vcs-tree) + +(defun read-file-to-strings (file) + "Opens a reads a file. Returns the contents as a list of strings" + (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))) + (nreverse lines)))) + + +(defvar *whitespace-chars* '(#\space #\tab #\return #\linefeed)) + +(defun string-trim-whitespace (str) + (string-trim *whitespace-chars* str)) + +(defmacro aif (test then &optional else) + `(let ((it ,test)) + (if it ,then ,else))) + +(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)))))) + +(defun mklist (obj) + "Make into list if atom" + (if (listp obj) obj (list obj))) + +(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)))) + (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))))) + + +(defun canonicalize-directory-name (filename) + (flet ((un-unspecific (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)))) + (if new-dir + (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))) + #+(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))) + #-(or allegro clisp cmu lispworks sbcl scl) + (probe-file path))) + + +(defun cwd (&optional dir) + "Change directory and set default pathname" + (cond + ((not (null dir)) + (when (and (typep dir 'logical-pathname) + (translate-logical-pathname dir)) + (setq dir (translate-logical-pathname dir))) + (when (stringp dir) + (setq dir (parse-namestring dir))) + #+allegro (excl:chdir dir) + #+clisp (#+lisp=cl ext:cd #-lisp=cl lisp:cd dir) + #+(or cmu scl) (setf (ext:default-directory) dir) + #+cormanlisp (ccl:set-current-directory dir) + #+(and mcl (not openmcl)) (ccl:set-mac-default-directory dir) + #+openmcl (ccl:cwd dir) + #+gcl (si:chdir dir) + #+lispworks (hcl:change-directory 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 "."))) + (when (stringp dir) + (setq dir (parse-namestring dir))) + dir)))) + + + +(defun quit (&optional (code 0)) + "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function." + #+allegro (excl:exit code :quiet t) + #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code) + #+(or cmu scl) (ext:quit code) + #+cormanlisp (win32:exitprocess code) + #+gcl (lisp:bye code) + #+lispworks (lw:quit :status code) + #+lucid (lcl:quit code) + #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1))) + #+mcl (ccl:quit code) + #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl) + (error 'not-implemented :proc (list 'quit code))) + + +(defun command-line-arguments () + #+allegro (system:command-line-arguments) + #+sbcl sb-ext:*posix-argv* + ) + +(defun shell-command-output (cmd &key directory whole) + #+allegro (excl.osi:command-output cmd :directory directory :whole whole) + #+sbcl + (let* ((out (make-array '(0) :element-type 'base-char :fill-pointer 0 + :adjustable t)) + (err (make-array '(0) :element-type 'base-char :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)) + ) diff --git a/loader.lisp b/loader.lisp new file mode 100644 index 0000000..937aca1 --- /dev/null +++ b/loader.lisp @@ -0,0 +1,24 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: cl-user -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: loader.lisp +;;;; Purpose: loads any required modules, contains RUN function +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Sep 2003 +;;;; +;;;; $Id: xlunit.asd 7061 2003-09-07 06:34:45Z kevin $ +;;;; ************************************************************************* + +(in-package :cl-user) + +;;; Nothing to load since the executable contains all of the required +;;; fasls + + +(defun run () + (handler-case + (funcall #'vcs-tree::main (list* "vcs-tree" (cdr *posix-argv*))) + (error (c) + (format *error-output* "vcs-tree failed due to error:~% ~A~%" c) + (sb-ext:quit :unix-status 1)))) diff --git a/main.lisp b/main.lisp new file mode 100644 index 0000000..85c3aff --- /dev/null +++ b/main.lisp @@ -0,0 +1,177 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: vcs-tree -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: main.lisp +;;;; Purpose: Main functions for vcs-tree +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Sep 2003 +;;;; +;;;; Process all subdirectories that are managed by either CVS or SVN +;;;; +;;;; $Id: xlunit.asd 7061 2003-09-07 06:34:45Z kevin $ +;;;; ************************************************************************* + + +(in-package vcs-tree) + +(defun is-vcs-directory (x) + (and (pathnamep x) + (or + (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))) + +(defun is-svn-managed (dir) + (probe-directory (merge-pathnames + (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))) + (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)) + ))) + +(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 "////"))))) + (case type + (:svn + (some (lambda (line) (string= match (string-trim-whitespace line))) + entries)) + (:cvs + (or + (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 ((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)) + "")))))) + (multiple-value-bind (output error status) + (shell-command-output cmd :directory dir :whole t) + (if (zerop status) + (format t "~A ~A: ~A~%" cmd (namestring dir) output) + (format t "~A ~A: ~A ~A ~A~%" cmd (namestring dir) output + error status)))))) + (cond + ((is-cvs-managed dir) + (process dir "cvs")) + ((is-svn-managed dir) + (process dir "svn")) + (t + (format *error-output* + "INTERAL ERROR: not a version control system directory ~A" dir) + (quit 1))))) + +(defvar *progname* "") + +(defun usage (&optional msg &rest msg-args) + (format *error-output* "usage: ~A action [OPTIONS]~%" *progname*) + (if msg + (progn + (apply #'format *error-output* msg msg-args) + (write-char #\Newline *error-output*)) + (format *error-output* + "Processes a source-control managed directory tree~%")) + (format *error-output* "Action: update, commit, or status~%") + (format *error-output* "OPTIONS~%") + (format *error-output* " -m Set commit string~%")) + +(defun parse-action-arg (arg) + (cond + ((string= arg "ci") + :commit) + (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))))))) + + +(defun main (&optional (argv (command-line-arguments))) + (let ((*progname* (car argv))) + (multiple-value-bind (args options errors) + (getopt (cdr argv) '(("m" :required))) + (when (or errors (/= 1 (length args))) + (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)))) + (quit 0))) + +;;(main) +;;(quit 0) + + diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..31f298a --- /dev/null +++ b/package.lisp @@ -0,0 +1,17 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: vcs-tree -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Package definition for vcs-tree +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Sep 2003 +;;;; +;;;; $Id: xlunit.asd 7061 2003-09-07 06:34:45Z kevin $ +;;;; ************************************************************************* + +(in-package cl-user) +(defpackage vcs-tree + (:use #:cl) + (:export #:main)) +(in-package vcs-tree) diff --git a/vcs-tree.1 b/vcs-tree.1 new file mode 100644 index 0000000..db17f2a --- /dev/null +++ b/vcs-tree.1 @@ -0,0 +1,34 @@ +.\" -*- NROFF -*- +.\" +.\" vcs-tree.1 +.\" +.\" Author: Kevin Rosenberg +.\" +.\" $Id: vcs-tree.1,v 1.5 2002/05/03 10:45:52 kevin Exp $ +.\" +.TH "vcs-tree" "1" "" "Kevin M. Rosenberg" "Utilities" +.SH "NAME" +vcs-tree \- Version Control System Tree Walker + +.SH "SYNOPSIS" +.B vcs-tree action [OPTIONS] + +.SH "DESCRIPTION " +\fIvcs-tree\fP walks through a directory tree and performs actions +on Subversion and CVS managed directories. As opposed to CVS and +Subversion, \fIvcs-tree\fP finds and operates on +directories even if they are below non-version control system +managed directories. + +.SH "ACTIONS" +update, status, or commit. Abbreviations are +accepted. + +.SH "OPTIONS" +\fIvcs-tree\fP accepts the following options: +.TP 16 +.B \-m +Sets the commit message when performing an commit action. + +.SH "AUTHOR" +Kevin Rosenberg diff --git a/vcs-tree.asd b/vcs-tree.asd new file mode 100644 index 0000000..41a3034 --- /dev/null +++ b/vcs-tree.asd @@ -0,0 +1,46 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: vcs-tree-system -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: vcs-tree.asd +;;;; Purpose: ASDF file for vcs-tree to create executable +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Sep 2003 +;;;; +;;;; $Id: xlunit.asd 7061 2003-09-07 06:34:45Z kevin $ +;;;; ************************************************************************* + +(in-package vcs-tree-system) +(defpackage vcs-tree-system (:use #:cl #:asdf)) +(in-package vcs-tree-system) + +(require 'sb-executable) + +;;; From asdf-install.asd +(defclass exe-file (cl-source-file) ()) +(defmethod perform :after ((o compile-op) (c exe-file)) + (sb-executable:make-executable + (make-pathname :name "vcs-tree" + :type nil + :defaults (component-pathname c)) + '("package.fasl" "kmrcl-excerpt.fasl" "getopt-excerpt.fasl" "main.fasl" + "loader.fasl") + :initial-function "RUN" + :muffled-warning t)) + +(defmethod perform ((o load-op) (c exe-file)) nil) + +(defsystem vcs-tree + :version "0.1" + :components ((:file "package") + (:exe-file "loader" :depends-on ("main")) + (:file "kmrcl-excerpt" :depends-on ("package")) + (:file "getopt-excerpt" :depends-on ("package")) + (:file "main" :depends-on ("kmrcl-excerpt" "getopt-excerpt")))) + +(defmethod perform :after ((o load-op) (c (eql (find-system :vcs-tree)))) + (provide 'vcs-tree)) + +(defmethod perform ((o test-op) (c (eql (find-system :vcs-tree)))) + t) + -- 2.34.1