| 1 | ;;; Copyright (C) 2007, 2008 Magnus Henoch |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; This program is free software; you can redistribute it and/or |
|---|
| 4 | ;;; modify it under the terms of the GNU General Public License as |
|---|
| 5 | ;;; published by the Free Software Foundation; either version 2 of the |
|---|
| 6 | ;;; License, or (at your option) any later version. |
|---|
| 7 | ;;; |
|---|
| 8 | ;;; This program is distributed in the hope that it will be useful, |
|---|
| 9 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
|---|
| 10 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
|---|
| 11 | ;;; General Public License for more details. |
|---|
| 12 | ;;; |
|---|
| 13 | ;;; You should have received a copy of the GNU General Public License |
|---|
| 14 | ;;; along with this program; if not, write to the Free Software |
|---|
| 15 | ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
|---|
| 16 | |
|---|
| 17 | (in-package :darcs) |
|---|
| 18 | |
|---|
| 19 | (defvar *darcs-commands* () |
|---|
| 20 | "List of commands that can be executed from the command line. |
|---|
| 21 | Each element is a symbol that names the command. The corresponding |
|---|
| 22 | function is named cmd-SYMBOL, and is called with all command line |
|---|
| 23 | arguments but the first one. It should return an integer exit code.") |
|---|
| 24 | |
|---|
| 25 | (eval-when (:compile-toplevel :load-toplevel) |
|---|
| 26 | (defun command-function (command) |
|---|
| 27 | "Turn a command symbol into a function symbol." |
|---|
| 28 | (intern (format nil "CMD-~A" command) :darcs))) |
|---|
| 29 | |
|---|
| 30 | (defun handle-command-line (argv) |
|---|
| 31 | "Handle a command line, emulating the real darcs client. |
|---|
| 32 | ARGV is a list of strings. This function is to be called in some |
|---|
| 33 | platform-dependent manner, while being portable itself. An integer |
|---|
| 34 | exit code is returned." |
|---|
| 35 | (let* ((command (find (car argv) *darcs-commands* :test #'string-equal)) |
|---|
| 36 | (function (when command (command-function command)))) |
|---|
| 37 | (if (null command) |
|---|
| 38 | (progn |
|---|
| 39 | (if (null argv) |
|---|
| 40 | (format *error-output* "No command given!~%") |
|---|
| 41 | (format *error-output* "Invalid command '~A'!~%" (car argv))) |
|---|
| 42 | (usage) |
|---|
| 43 | 1) |
|---|
| 44 | (handler-case |
|---|
| 45 | (let ((retval (funcall function (cdr argv)))) |
|---|
| 46 | (fresh-line) |
|---|
| 47 | (if (numberp retval) |
|---|
| 48 | retval |
|---|
| 49 | (progn |
|---|
| 50 | (warn "~A didn't give a proper exit code." command) |
|---|
| 51 | 0))) |
|---|
| 52 | (invalid-arguments (c) |
|---|
| 53 | (with-accessors ((ctrl simple-condition-format-control) |
|---|
| 54 | (args simple-condition-format-arguments)) c |
|---|
| 55 | (when ctrl |
|---|
| 56 | (apply #'format *error-output* ctrl args))) |
|---|
| 57 | (command-usage command) |
|---|
| 58 | 1))))) |
|---|
| 59 | |
|---|
| 60 | (defun usage () |
|---|
| 61 | "Print usage information about commands to *ERROR-OUTPUT*." |
|---|
| 62 | (format *error-output* "Usage: darcs COMMAND ...~%~%Commands:~%") |
|---|
| 63 | (dolist (cmd *darcs-commands*) |
|---|
| 64 | (let ((function (command-function cmd))) |
|---|
| 65 | (format *error-output* " ~A~15,2T~A~%" |
|---|
| 66 | cmd |
|---|
| 67 | (car (split-sequence:split-sequence |
|---|
| 68 | #\Newline (get function 'darcs-documentation) |
|---|
| 69 | :count 1)))))) |
|---|
| 70 | |
|---|
| 71 | (defun command-usage (command) |
|---|
| 72 | "Print longer documentation for COMMAND." |
|---|
| 73 | (format *error-output* "~&~A~%" (get (command-function command) 'darcs-documentation))) |
|---|
| 74 | |
|---|
| 75 | (defmacro define-darcs-command (name options operands docstring &body body) |
|---|
| 76 | "Define a darcs command called NAME. |
|---|
| 77 | NAME is passed to COMMAND-FUNCTION to make the name of the function. |
|---|
| 78 | OPTIONS is a list of variables holding OPTION structures, describing |
|---|
| 79 | the options accepted by the commnad. |
|---|
| 80 | OPERANDS is a destructuring lambda list for the non-option arguments |
|---|
| 81 | accepted by the command." |
|---|
| 82 | (flet ((option-symbol (name) |
|---|
| 83 | (intern (concatenate 'string "OPT-" (symbol-name name))))) |
|---|
| 84 | (let ((function (command-function name)) |
|---|
| 85 | (args-sym (gensym)) |
|---|
| 86 | (options-sym (gensym)) |
|---|
| 87 | (operands-sym (gensym))) |
|---|
| 88 | `(progn |
|---|
| 89 | (pushnew ',name *darcs-commands*) |
|---|
| 90 | (defun ,function (,args-sym) ,docstring |
|---|
| 91 | (multiple-value-bind (,options-sym ,operands-sym) |
|---|
| 92 | (getopt ,args-sym |
|---|
| 93 | (list ,@(mapcar #'option-symbol options))) |
|---|
| 94 | ,@(when (null options) |
|---|
| 95 | `((declare (ignore ,options-sym)))) |
|---|
| 96 | (let ,(mapcar |
|---|
| 97 | (lambda (o) |
|---|
| 98 | `(,o (cdr (assoc (option-keyword ,(option-symbol o)) ,options-sym)))) |
|---|
| 99 | options) |
|---|
| 100 | ;; XXX: what if this fails? |
|---|
| 101 | (destructuring-bind ,operands ,operands-sym |
|---|
| 102 | ,@body)))) |
|---|
| 103 | (setf (get ',function 'darcs-documentation) |
|---|
| 104 | ;; XXX: documentation for operands |
|---|
| 105 | ,(if (null options) |
|---|
| 106 | docstring |
|---|
| 107 | `(format nil |
|---|
| 108 | "~A~%~%~:{~A~30,5T~A~%~}" |
|---|
| 109 | ,docstring |
|---|
| 110 | (mapcar |
|---|
| 111 | (lambda (opt) |
|---|
| 112 | (list |
|---|
| 113 | (cond |
|---|
| 114 | ((and (option-short opt) |
|---|
| 115 | (option-long opt)) |
|---|
| 116 | (format nil "--~A~@[=~A~], -~C" |
|---|
| 117 | (option-long opt) |
|---|
| 118 | (option-arg opt) |
|---|
| 119 | (option-short opt))) |
|---|
| 120 | ((option-short opt) |
|---|
| 121 | (format nil "-~C~@[ ~A~]" |
|---|
| 122 | (option-short opt) |
|---|
| 123 | (option-arg opt))) |
|---|
| 124 | ((option-long opt) |
|---|
| 125 | (format nil "--~A~@[=~A~]" |
|---|
| 126 | (option-long opt) |
|---|
| 127 | (option-arg opt))) |
|---|
| 128 | (t |
|---|
| 129 | (error "Option ~A has neither short nor long argument form." (option-keyword opt)))) |
|---|
| 130 | (option-help opt))) |
|---|
| 131 | (list ,@(mapcar #'option-symbol options)))))))))) |
|---|
| 132 | |
|---|
| 133 | (defparameter opt-repodir |
|---|
| 134 | (make-option |
|---|
| 135 | :keyword :repodir |
|---|
| 136 | :long "repodir" |
|---|
| 137 | :arg "DIRECTORY" |
|---|
| 138 | :help "Use DIRECTORY instead of current directory")) |
|---|
| 139 | |
|---|
| 140 | (defun find-repo (&optional (dir *default-pathname-defaults*)) |
|---|
| 141 | "Find repository in current directory or above. |
|---|
| 142 | Signal an error if there is none, else return the repository root. |
|---|
| 143 | If DIR is specified, search for repository there instead." |
|---|
| 144 | (if (fad:directory-exists-p (upath-subdir dir '("_darcs"))) |
|---|
| 145 | (fad:directory-exists-p dir) ;get directory truename |
|---|
| 146 | (let ((parent-dir (ignore-errors |
|---|
| 147 | (fad:directory-exists-p |
|---|
| 148 | (merge-pathnames |
|---|
| 149 | (make-pathname :directory '(:relative :up)) |
|---|
| 150 | dir))))) |
|---|
| 151 | (if (and parent-dir (not (equal dir parent-dir))) |
|---|
| 152 | (find-repo parent-dir) |
|---|
| 153 | (error "Not in a darcs repo."))))) |
|---|
| 154 | |
|---|
| 155 | (defmacro with-repo (repodir &body body) |
|---|
| 156 | "Given a --repodir argument, canonicalize it and change directory accordingly. |
|---|
| 157 | That is, if there is no --repodir option, don't change current directory, |
|---|
| 158 | and bind variable to the repository root directory. |
|---|
| 159 | If there is a --repodir option, ensure it refers to an existing directory, |
|---|
| 160 | and change the current directory to it. |
|---|
| 161 | \(This is actually how the original darcs does it.\)" |
|---|
| 162 | (let ((original-repodir (gensym))) |
|---|
| 163 | `(let* ((,original-repodir ,repodir) |
|---|
| 164 | (,repodir |
|---|
| 165 | (if ,repodir |
|---|
| 166 | (or (fad:directory-exists-p ,repodir) |
|---|
| 167 | (error "Directory ~A does not exist." ,repodir)) |
|---|
| 168 | (find-repo))) |
|---|
| 169 | ;; If explicit --repodir argument was specified, change directory. |
|---|
| 170 | ;; Otherwise, leave it, even if the actual repository is in a |
|---|
| 171 | ;; parent directory. |
|---|
| 172 | (*default-pathname-defaults* |
|---|
| 173 | (if (null ,original-repodir) |
|---|
| 174 | *default-pathname-defaults* |
|---|
| 175 | (fad:pathname-as-directory ,repodir)))) |
|---|
| 176 | ,@body))) |
|---|
| 177 | |
|---|
| 178 | (define-darcs-command add (repodir) (&rest files-and-dirs |
|---|
| 179 | &aux already-there) |
|---|
| 180 | "Add files and directories for later recording. |
|---|
| 181 | |
|---|
| 182 | Usage: darcs add FILE ..." |
|---|
| 183 | (with-repo repodir |
|---|
| 184 | (dolist (file files-and-dirs) |
|---|
| 185 | (handler-case |
|---|
| 186 | (progn |
|---|
| 187 | (add-file repodir file) |
|---|
| 188 | ;; (format t "~&Added ~A" file) |
|---|
| 189 | ) |
|---|
| 190 | (already-in-repository (c) |
|---|
| 191 | ;; Save the files and directories that are already in the |
|---|
| 192 | ;; repository for pretty error printing. |
|---|
| 193 | (push (slot-value c 'file) already-there)))) |
|---|
| 194 | (when already-there |
|---|
| 195 | (setf already-there (nreverse already-there)) |
|---|
| 196 | (let* ((with-path (mapcar (lambda (f) (merge-pathnames f repodir)) already-there)) |
|---|
| 197 | (nfiles 0) |
|---|
| 198 | (ndirs 0)) |
|---|
| 199 | (dolist (f with-path) |
|---|
| 200 | (let ((truename (fad:file-exists-p f))) |
|---|
| 201 | (assert truename) |
|---|
| 202 | (if (fad:directory-pathname-p f) |
|---|
| 203 | (incf ndirs) |
|---|
| 204 | (incf nfiles)))) |
|---|
| 205 | (assert (= (+ nfiles ndirs) (length already-there))) |
|---|
| 206 | ;; We want the message to look just like darcs', in order to |
|---|
| 207 | ;; pass its test suite (in particular tests/add.pl). |
|---|
| 208 | (format *error-output* |
|---|
| 209 | "~&The following ~A already in the repository" |
|---|
| 210 | (cond |
|---|
| 211 | ((zerop nfiles) |
|---|
| 212 | (if (= ndirs 1) |
|---|
| 213 | "directory is" |
|---|
| 214 | "directories are")) |
|---|
| 215 | ((zerop ndirs) |
|---|
| 216 | (if (= nfiles 1) |
|---|
| 217 | "file is" |
|---|
| 218 | "files are")) |
|---|
| 219 | (t |
|---|
| 220 | "files and directories are"))) |
|---|
| 221 | (format *error-output* ":~%~{ ~A~}" already-there)))) |
|---|
| 222 | 0) |
|---|
| 223 | |
|---|
| 224 | (define-darcs-command whatsnew () () |
|---|
| 225 | "See what has been changed in the working directory. |
|---|
| 226 | |
|---|
| 227 | Usage: darcs whatsnew" |
|---|
| 228 | (diff-repo-display (find-repo))) |
|---|
| 229 | |
|---|
| 230 | (define-darcs-command init (repodir) () |
|---|
| 231 | "Initialize a darcs repository in the current directory." |
|---|
| 232 | (let ((repodir (or repodir |
|---|
| 233 | *default-pathname-defaults*))) |
|---|
| 234 | (format t "Creating repo in ~A...~%" repodir) |
|---|
| 235 | (create-repo repodir) |
|---|
| 236 | 0)) |
|---|
| 237 | |
|---|
| 238 | (defparameter opt-author |
|---|
| 239 | (make-option |
|---|
| 240 | :keyword :author |
|---|
| 241 | :short #\A |
|---|
| 242 | :long "author" |
|---|
| 243 | :arg "EMAIL" |
|---|
| 244 | :help "specify author id")) |
|---|
| 245 | |
|---|
| 246 | (defparameter opt-all-patches |
|---|
| 247 | (make-option |
|---|
| 248 | :keyword :all-patches |
|---|
| 249 | :short #\a |
|---|
| 250 | :long "all" |
|---|
| 251 | :help "answer yes to all patches")) |
|---|
| 252 | |
|---|
| 253 | (defparameter opt-patch-name |
|---|
| 254 | (make-option |
|---|
| 255 | :keyword :patch-name |
|---|
| 256 | :short #\m |
|---|
| 257 | :long "patch-name" |
|---|
| 258 | :arg "PATCHNAME" |
|---|
| 259 | :help "name of patch")) |
|---|
| 260 | |
|---|
| 261 | (defparameter opt-ask-deps |
|---|
| 262 | (make-option |
|---|
| 263 | :keyword :ask-deps |
|---|
| 264 | :long "ask-deps" |
|---|
| 265 | :help "ask for extra dependencies")) |
|---|
| 266 | |
|---|
| 267 | (define-darcs-command record |
|---|
| 268 | (author all-patches patch-name ask-deps repodir) |
|---|
| 269 | (&rest files) |
|---|
| 270 | "Save changes in the working copy to the repository as a patch." |
|---|
| 271 | (with-repo repodir |
|---|
| 272 | (let* ((author (or author |
|---|
| 273 | ;; XXX: other ways to indicate author |
|---|
| 274 | (progn |
|---|
| 275 | (format *query-io* "~&Who is the author? ") |
|---|
| 276 | (finish-output *query-io*) |
|---|
| 277 | (read-line *query-io*)))) |
|---|
| 278 | (patch-name (or patch-name |
|---|
| 279 | (progn |
|---|
| 280 | (format *query-io* "~&What is the patch name? ") |
|---|
| 281 | (finish-output *query-io*) |
|---|
| 282 | (read-line *query-io*)))) |
|---|
| 283 | (files (mapcar |
|---|
| 284 | (lambda (file) |
|---|
| 285 | (setf file (enough-namestring file repodir)) |
|---|
| 286 | (if (fad:directory-exists-p file) |
|---|
| 287 | (sanitize-filename file :type :directory) |
|---|
| 288 | (sanitize-filename file :type :file))) |
|---|
| 289 | files))) |
|---|
| 290 | ;; XXX: long log |
|---|
| 291 | |
|---|
| 292 | (let ((patches (diff-repo repodir))) |
|---|
| 293 | (flet ((ask (patch) |
|---|
| 294 | ;; If any files were specified, use only patches |
|---|
| 295 | ;; touching those files/directories. |
|---|
| 296 | (if (or (null files) |
|---|
| 297 | (and (typep patch 'file-patch) |
|---|
| 298 | (member (patch-filename patch) files :test #'equal)) |
|---|
| 299 | (and (typep patch 'directory-patch) |
|---|
| 300 | (member (patch-directory patch) files :test #'equal))) |
|---|
| 301 | ;; If all-patches was requested, record all patches |
|---|
| 302 | ;; matching the file criterion. |
|---|
| 303 | (or all-patches |
|---|
| 304 | (progn |
|---|
| 305 | (display-patch patch *query-io*) |
|---|
| 306 | (y-or-n-p "Record patch ~A?" patch))) |
|---|
| 307 | nil))) |
|---|
| 308 | (record-patches repodir patch-name author :now nil |
|---|
| 309 | (select-patches patches #'ask)) |
|---|
| 310 | (format t "~&Finished recording patch '~A'~%" patch-name) |
|---|
| 311 | 0))))) |
|---|
| 312 | |
|---|
| 313 | (define-darcs-command pull |
|---|
| 314 | (all-patches repodir) |
|---|
| 315 | (&rest from-repositories) |
|---|
| 316 | "Copy and apply patches from another repository to this one." |
|---|
| 317 | (let* ((ourrepo |
|---|
| 318 | (if repodir |
|---|
| 319 | (or (fad:directory-exists-p repodir) |
|---|
| 320 | (error "Directory ~A does not exist." repodir)) |
|---|
| 321 | (find-repo))) |
|---|
| 322 | ;; If explicit --repodir argument was specified, change directory. |
|---|
| 323 | ;; Otherwise, leave it, even if the actual repository is in a |
|---|
| 324 | ;; parent directory. |
|---|
| 325 | (*default-pathname-defaults* |
|---|
| 326 | (if (null repodir) |
|---|
| 327 | *default-pathname-defaults* |
|---|
| 328 | (fad:pathname-as-directory ourrepo)))) |
|---|
| 329 | |
|---|
| 330 | (if from-repositories |
|---|
| 331 | ;; Get truename for all repositories, if they are local paths. |
|---|
| 332 | (map-into |
|---|
| 333 | from-repositories |
|---|
| 334 | (lambda (dir) |
|---|
| 335 | (setf dir (make-upath dir)) |
|---|
| 336 | (when (typep dir 'pathname) |
|---|
| 337 | (setf dir (or |
|---|
| 338 | (fad:directory-exists-p dir) |
|---|
| 339 | (error "Directory ~A does not exist." dir)))) |
|---|
| 340 | dir) |
|---|
| 341 | from-repositories) |
|---|
| 342 | ;; If no remote repository specified, use the default one. |
|---|
| 343 | (setf from-repositories (list nil))) |
|---|
| 344 | |
|---|
| 345 | ;; We can't pull from ourselves. |
|---|
| 346 | (when (member ourrepo from-repositories :test #'equal) |
|---|
| 347 | (error "Can't pull from current repository!")) |
|---|
| 348 | |
|---|
| 349 | (dolist (theirrepo from-repositories) |
|---|
| 350 | (pull ourrepo theirrepo :select-patches (if all-patches :all :ask))) |
|---|
| 351 | |
|---|
| 352 | ;; Change the default repository. |
|---|
| 353 | (when (first from-repositories) |
|---|
| 354 | (set-default-repo ourrepo (upath-to-string (first from-repositories) :truename t))) |
|---|
| 355 | |
|---|
| 356 | 0)) |
|---|
| 357 | |
|---|
| 358 | (define-darcs-command get |
|---|
| 359 | (repodir) |
|---|
| 360 | (from) |
|---|
| 361 | "Get a copy of a repository." |
|---|
| 362 | (setf from (make-upath from)) |
|---|
| 363 | (let* ((to (or |
|---|
| 364 | ;; Either there is an explicit repodir... |
|---|
| 365 | repodir |
|---|
| 366 | ;; ...or we make one relative to the current directory. |
|---|
| 367 | (make-pathname |
|---|
| 368 | :directory |
|---|
| 369 | (list :relative |
|---|
| 370 | (typecase from |
|---|
| 371 | ;; If we have a local pathname, use the last component. |
|---|
| 372 | (pathname |
|---|
| 373 | (or (pathname-name from) |
|---|
| 374 | (car (last (pathname-directory from))))) |
|---|
| 375 | ;; Otherwise, use the part from the last slash. |
|---|
| 376 | (t |
|---|
| 377 | (let* ((s (upath-to-string from)) |
|---|
| 378 | (last-slash (position #\/ s :from-end t))) |
|---|
| 379 | (if last-slash |
|---|
| 380 | (subseq s (1+ last-slash)) |
|---|
| 381 | s))))))))) |
|---|
| 382 | (get-repo from to)) |
|---|
| 383 | 0) |
|---|
