X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/47854a55680b5809811caf72f66ecbe8289c2855..3a0f6aac0db3b1961c759a278d2bc67b501ddd0a:/lisp/vc-arch.el diff --git a/lisp/vc-arch.el b/lisp/vc-arch.el index ecaee28c6d..cc8c8ae3c1 100644 --- a/lisp/vc-arch.el +++ b/lisp/vc-arch.el @@ -1,16 +1,16 @@ ;;; vc-arch.el --- VC backend for the Arch version-control system -;; Copyright (C) 2004, 2005, 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. ;; Author: FSF (see vc.el for full credits) ;; Maintainer: Stefan Monnier ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -18,9 +18,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -50,13 +48,18 @@ ;; - C-x v u does not work. ;; - C-x v s does not work. ;; - C-x v r does not work. -;; - VC-dired does not work. +;; - VC directory listings do not work. ;; - And more... ;;; Code: (eval-when-compile (require 'vc) (require 'cl)) +;;; Properties of the backend + +(defun vc-arch-revision-granularity () 'repository) +(defun vc-arch-checkout-model (files) 'implicit) + ;;; ;;; Customization options ;;; @@ -193,10 +196,12 @@ Only the value `maybe' can be trusted :-(." (defun vc-arch-root (file) "Return the root directory of a Arch project, if any." (or (vc-file-getprop file 'arch-root) - (vc-file-setprop - ;; Check the =tagging-method, in case someone naively manually - ;; creates a {arch} directory somewhere. - file 'arch-root (vc-find-root file "{arch}/=tagging-method")))) + ;; Check the =tagging-method, in case someone naively manually + ;; creates a {arch} directory somewhere. + (let ((root (vc-find-root file "{arch}/=tagging-method"))) + (when root + (vc-file-setprop + file 'arch-root root))))) (defun vc-arch-register (files &optional rev comment) (if rev (error "Explicit initial revision not supported for Arch")) @@ -327,7 +332,7 @@ Return non-nil if FILE is unchanged." (setq rev (replace-match (cdr rule) t nil rev)))) (format "Arch%c%s" (case (vc-state file) - ((up-to-date needs-patch) ?-) + ((up-to-date needs-update) ?-) (added ?@) (t ?:)) rev))) @@ -345,9 +350,11 @@ Return non-nil if FILE is unchanged." (save-excursion (let ((rej (concat buffer-file-name ".rej"))) (when (and buffer-file-name (vc-arch-diff3-rej-p rej)) - (if (not (re-search-forward "^<<<<<<< " nil t)) - ;; The .rej file is obsolete. - (condition-case nil (delete-file rej) (error nil))))))) + (unless (re-search-forward "^<<<<<<< " nil t) + ;; The .rej file is obsolete. + (condition-case nil (delete-file rej) (error nil)) + ;; Remove the hook so that it is not called multiple times. + (remove-hook 'after-save-hook 'vc-arch-delete-rej-if-obsolete t)))))) (defun vc-arch-find-file-hook () (let ((rej (concat buffer-file-name ".rej"))) @@ -365,8 +372,6 @@ Return non-nil if FILE is unchanged." (message "There are unresolved conflicts in %s" (file-name-nondirectory rej)))))) -(defun vc-arch-checkout-model (file) 'implicit) - (defun vc-arch-checkin (files rev comment) (if rev (error "Committing to a specific revision is unsupported")) ;; FIXME: This implementation probably only works for singleton filesets @@ -421,7 +426,7 @@ Return non-nil if FILE is unchanged." (defun vc-arch-command (buffer okstatus file &rest flags) "A wrapper around `vc-do-command' for use in vc-arch.el." - (apply 'vc-do-command buffer okstatus vc-arch-command file flags)) + (apply 'vc-do-command (or buffer "*vc*") okstatus vc-arch-command file flags)) (defun vc-arch-init-revision () nil) @@ -483,16 +488,20 @@ Return non-nil if FILE is unchanged." (defun vc-arch-trim-make-sentinel (revs) (if (null revs) (lambda (proc msg) (message "VC-Arch trimming ... done")) - `(lambda (proc msg) - (message "VC-Arch trimming %s..." ',(file-name-nondirectory (car revs))) - (rename-file ,(car revs) ,(concat (car revs) "*rm*")) + (lexical-let ((revs revs)) + (lambda (proc msg) + (message "VC-Arch trimming %s..." (file-name-nondirectory (car revs))) + (rename-file (car revs) (concat (car revs) "*rm*")) (setq proc (start-process "vc-arch-trim" nil - "rm" "-rf" ',(concat (car revs) "*rm*"))) - (set-process-sentinel proc (vc-arch-trim-make-sentinel ',(cdr revs)))))) + "rm" "-rf" (concat (car revs) "*rm*"))) + (set-process-sentinel proc (vc-arch-trim-make-sentinel (cdr revs))))))) (defun vc-arch-trim-one-revlib (dir) "Delete half of the revisions in the revision library." (interactive "Ddirectory: ") + (let ((garbage (directory-files dir 'full "\\`,," 'nosort))) + (when garbage + (funcall (vc-arch-trim-make-sentinel garbage) nil nil))) (let ((revs (sort (delq nil (mapcar