;;; find-atfs.el -- find-file interface to AtFS ;;; Author: Juergen Nickelsen ;;; $Header: /local/repository/cvsroot/web-seiten/emacs/find-atfs.el,v 1.2 2003/12/23 07:18:54 ni Exp $ ;;; ;;; See the variable atfs-copyright for a copyright notice below. ;;; ;;; Provides: ;;; - AtFS versions can be read directly into an Emacs buffer by ;;; invoking find-file with the version ID (with version number ;;; or symbolic name). ;;; - Filename completion is done on version IDs as well. ;;; - If find-file tries to read a non-existent file, and an AtFS ;;; history of that file exists, the default version of this history ;;; will be read instead. ;;; - minor mode atfs-mode (without any features yet, but its name ;;; appears in the mode line) ;;; - toggle-read-only on a version checks a version out and a busy ;;; file in with asking for change intent resp. log message. ;;; - toggle-read-only on a file asks if the file shall be checked ;;; in as AtFS version. ;;; - If Emacs is running as TkEmacs, appropriate notifications ;;; are sent to the Message Broadcast Server on checkin/checkout. ;;; (Not yet functional) ;;; To install it: ;;; Put the file find-atfs.el into a directory of your Emacs ;;; load-path. ;;; Put the following line in your ~/.emacs file or in Emacs' ;;; systemwide default.el: ;;; (load "find-atfs") ;;; Requirements: ;;; - Emacs 18.58, a later Emacs 18 version, or Lucid Emacs 19 ;;; for the new call-process function, which returns ;;; a meaningful value ;;; - the shapeTools programs (vl, vcat) in $PATH, or appropriate ;;; settings of the user-customizable variables (see below) ;;; BUGS: ;;; - due to a bug in vbind(1) it is not possible to read AtFS versions ;;; where the filename (sans version) contains a pair of matching ;;; brackets with at least one character between them. ;;; - depends strongly on some internals of find-file-noselect, which ;;; may change in future Emacs versions ;;; - completion on version IDs is slow ;;; - environment variables in filenames are not expanded ;;; - some still unknown ;;; Redefined functions: ;;; - file-writable-p ;;; - file-exists-p ;;; - vc-toggle-read-only or toggle-read-only ;;; - find-file (require 'callp-err) (provide 'find-atfs) (defconst atfs-copyright " Copyright (C) 1993,1994 by the author(s). This software is published in the hope that it will be useful, but WITHOUT ANY WARRANTY for any part of this software to work correctly or as described in the manuals. See the ShapeTools Public License for details. Permission is granted to use, copy, modify, or distribute any part of this software but only under the conditions described in the ShapeTools Public License. A copy of this license is supposed to have been given to you along with ShapeTools in a file named LICENSE. Among other things, this copyright notice and the Public License must be preserved on all copies. ") (defconst atfs-AtFS-version "$Header: /local/repository/cvsroot/web-seiten/emacs/find-atfs.el,v 1.2 2003/12/23 07:18:54 ni Exp $") ;;; user options (defvar atfs-kill-version-buffer-on-checkout t "*If non-nil, kill the buffer of a version when it is checked out. Otherwise put it at the end of the buffer list.") (defvar atfs-find-file-always-complete nil "*If non-nil, always do completion on version IDs in find-file. Otherwise completion is done only with prefix argument.") (defvar atfs-completion-show-versions nil "*If non-nil, all versions are shown when doing completion.") (defvar atfs-keep-position-on-checkout t "*If non-nil, try to keep point at the same position on check in/out. This will not always succeed.") (defvar atfs-offer-symname-completions nil "*If non-nil, offer completion of symbolic names of versions as well. Not yet implemented.") (defvar atfs-offer-selrule-completions nil "*If non-nil, offer completion of version selection rules as well. Not yet implemented.") (defvar atfs-default-vbind-rules "" "*String containing default version binding rules. These rules are considered by atfs-readin-version which is called by find-file. Not yet implemented, implicit default rule is most_recent.") ;;; key bindings (defvar atfs-install-key-bindings t "If non-nil, key bindings are installed when loading find-atfs. If this is set to nil before loading find-atfs, key bindings are not installed. It is set to nil after installing the key bindings. To re-install the key bindings, set it to t and re-load find-atfs. Note: There are no special key bindings of find-atfs yet.") (if atfs-install-key-bindings (progn ;; no special key bindings yet (setq atfs-install-key-bindings nil))) ;;; user-customizable variables (defvar atfs-vcat-command "vcat" "Name (possibly pathname) with which vcat(1) can be invoked.") (defvar atfs-vcat-options '("-q") "Options to give to vcat for reading the contents of a version.") (defvar atfs-vl-command "vl" "Name (possibly pathname) with which vl(1) can be invoked.") (defvar atfs-vl-completion-options '("-A" "-fast") "List of options given to vl when doing completions.") (defvar atfs-vlog-command "vlog" "Name (possibly pathname) with which vlog(1) can be invoked.") ;; switch off attribute expansion: $__xpoff$ (defvar atfs-intent-format "vl -lastsaved -format '$____Intent__$\\n' %s > %s" "Format string for the command to retrieve the change intent.") ;; $__xpon$ (defvar atfs-retrv-command "retrv" "Name (possibly pathname) with which retrv(1) can be invoked.") (defvar atfs-retrv-format "%s -f -lock -intent @%s %s" "Format string for retrv(1) command. Arguments: atfs-retrv-command, file with change intent, version id.") (defvar atfs-save-command "save" "Name (possibly pathname) with which save(1) can be invoked.") (defvar atfs-save-format "%s -f -logmsg @%s %s %s" "Format string for save(1) command. Arguments: atfs-save-command, file with log message, atfs-save-setvnum-option with argument (if setvnum desired), filename.") (defvar atfs-save-setvnum-option "-setvnum %s" "Option format for save with setting of version number.") (defvar atfs-vbind-command "vbind" "Name (possibly pathname) with which vbind(1) can be invoked.") (defvar atfs-bourne-shell-command "/bin/sh" "Name (possibly pathname) with which sh(1) can be invoked.") ;;; variables (defvar atfs-restore-position-fallback 200 "Number of characters to go backward or forward if context can't be found.") (defvar atfs-save-position-context 200 "Number of characters to store as context when saving a position.") (defvar atfs-buffer-version-id nil "If non-nil, file in this buffer is an AtFS version with this version ID.") (make-variable-buffer-local 'atfs-buffer-version-id) (defvar atfs-temp-buffer " *atfs-temp*" "Name of temporary buffer for command output.") (defconst atfs-version-match-re "^\\([^[]+\\)\\(\\[[^]]+\\]\\)$" "Regexp matching an AtFS version ID. First group matches the filename part, second group the version part. We assume that \"[\" and \"]\" do not appear in the filename part.") (defconst atfs-canonical-version-match-re "^\\([^[]+\\)\\(\\[[0-9]+\\.[0-9]+\\]\\)$" "Regexp matching the canonical form of an AtFS version ID. First group matches the filename part, second group the version part.") (defconst atfs-function-prefix "atfs-" "Prefix for functions used for redefining Emacs functions.") (defconst atfs-original-function-prefix "atfs-original-" "Prefix for the name of redefined functions. The redefined functions are reachable under the original name prefixed with this string.") (defconst atfs-mbs-notification-alist '((create . "objectCreate") (delete . "objectDelete"))) (defvar atfs-mode-buffers-alist nil "Alist of buffers with AtFS versions. The car of each pair is the buffer, the cdr the name of the version in this buffer.") (defvar atfs-user-home-directory (regexp-quote (getenv "HOME")) "Home-directory of the user.") (defvar atfs-completion-cache-list nil "List of cached completions for atfs-find-file. Consists of lists: First element is the (expanded) name of the directory. Second is the list of completions. third to sixth are mtime of the directory and mtime of the AtFS directory, if it exists. Used by atfs-get-completion-alist.") (defconst atfs-data-directory "AtFS/Data" "Name of the subdirectory wgere AtFS stores its versions.") (defvar atfs-be-version-aware nil "If non-nil, several functions redefined by find-atfs look for AtFS versions. Otherwise Emacs' normal functions are invoked. Functions like atfs-find-file-not-found-hook etc. set this to t temporarily.") ;;; macro atfs-save-match-data ;; The following shamelessly stolen from ange-ftp -- I guess ;; I couldn't do it any better. The setting of case-fold-search isn't ;; needed here, so I took that out. Thanks to Andy Norman. (defmacro atfs-save-match-data (&rest body) "Execute the BODY forms, restoring the global value of the match data." (let ((original (make-symbol "match-data"))) (list 'let (list (list original '(match-data))) (list 'unwind-protect (cons 'progn body) (list 'store-match-data original))))) ;; should be indented like save-excursion etc. (put 'atfs-save-match-data 'lisp-indent-hook 0) ;;; redefine functions: ;;; - file-writable-p ;;; - file-exists-p ;;; - vc-toggle-read-only or toggle-read-only ;;; - find-file ;;; set hooks: find-file-hooks, find-file-not-found-hooks (defun atfs-function-redefine (function-symbol &optional new-function old-function) "Redefine the function of FUNCTION-SYMBOL for use with `find-atfs'. The original function is bound to a symbol whose name is FUNCTION-SYMBOL prefixed with `atfs-original-function-prefix'. The function which is bound to FUNCTION-SYMBOL afterwards has the name of this symbol prefixed with `atfs-function-prefix'. If optional second argument NEW-FUNCTION is non-nil, this function will be bound to FUNCTION-SYMBOL. If optional third argument OLD-FUNCTION is non-nil, this is the symbol the original function will be bound to afterwards." (let ((atfs-symbol (or new-function (intern (concat atfs-function-prefix (symbol-name function-symbol))))) (atfs-original-symbol (or old-function (intern (concat atfs-original-function-prefix (symbol-name function-symbol)))))) (if (not (fboundp atfs-original-symbol)) (progn (fset atfs-original-symbol (symbol-function function-symbol)) (fset function-symbol atfs-symbol))))) ;; Be clever finding the `toggle'-function to be redefined. ;; Try the following in this order: ;; (1) Use vc-toggle-read-only if it is bound to C-x C-q. ;; (2) Use toggle-read-only if it is bound to C-x C-q. ;; (3) Use vc-toggle-read-only if it exists. ;; (4) Use toggle-read-only. (defun atfs-locate-toggle-function-to-be-redefined () "Determine which `toggle-read-only'-function is to be redefined." (or (if (and (fboundp 'vc-toggle-read-only) (eq (lookup-key (current-global-map) "\C-x\C-q") 'vc-toggle-read-only)) 'vc-toggle-read-only) (if (eq (lookup-key (current-global-map) "\C-x\C-q") 'toggle-read-only) 'toggle-read-only) (if (fboundp 'vc-toggle-read-only) 'vc-toggle-read-only) 'toggle-read-only)) (atfs-function-redefine 'file-writable-p) (atfs-function-redefine 'file-exists-p) (atfs-function-redefine (atfs-locate-toggle-function-to-be-redefined) 'atfs-toggle-read-only 'atfs-original-toggle-read-only) (atfs-function-redefine 'find-file) (if (not (memq 'atfs-find-file-hook find-file-hooks)) (setq find-file-hooks (cons 'atfs-find-file-hook find-file-hooks))) (if (not (memq 'atfs-find-file-not-found-hook find-file-not-found-hooks)) (setq find-file-not-found-hooks (cons 'atfs-find-file-not-found-hook find-file-not-found-hooks))) ;;; the hook functions: ;;; - atfs-find-file-not-found-hook ;;; - atfs-find-file-hook (defun atfs-find-file-not-found-hook () "Try to read an AtFS version of a file which has not been found. To be placed into find-file-not-found-hooks. This function is also called when a file exists, but cannot be read." ;; if file exists, it is probably not readable. (if (atfs-file-exists-p buffer-file-name) nil (let ((atfs-be-version-aware t) (version-id (atfs-get-version-id buffer-file-name))) (if version-id ;; Ok, we have. Perhaps it is already in a buffer other than ;; this? (let ((buffer (get-file-buffer version-id))) (if (and buffer (not (eq buffer (current-buffer)))) ;; We already have a buffer with this version, so let's ;; use that one. (progn ;; This is awful cheating! ;; It depends very much on the internals ;; of find-file-noselect. ;; Don't try this at home, kids! (setq filename version-id) (setq buf buffer) (kill-buffer (current-buffer)) (set-buffer buffer) (setq error nil) t) ;; we must read the version from the archive (if (not (equal buffer-file-name version-id)) (message (if (atfs-version-p buffer-file-name) "Using version %s" "Using last saved version %s") (file-name-nondirectory version-id))) (if (atfs-readin-version version-id) (progn ;success (setq error nil) t)))) ;; No version exists. But if the name looks like an AtFS ;; version, complain. (if (atfs-version-p buffer-file-name) (progn (kill-buffer (current-buffer)) (error "No appropriate AtFS version found"))))))) (defun atfs-find-file-hook () "Hook to be executed after find-file. If the file in the current buffer is an AtFS version, invoke atfs-mode and make sure the buffer-name is something useful." (let ((id (atfs-get-buffer-version-id (current-buffer)))) (if id (atfs-save-match-data (setq atfs-buffer-version-id id) (atfs-mode 1) (let ((newname (file-name-nondirectory atfs-buffer-version-id))) (if (not (string-match (concat "^" (regexp-quote newname)) (buffer-name))) (if (not (get-buffer newname)) (rename-buffer newname) (let* ((count 2)) (while (get-buffer (format "%s<%d>" newname count)) (setq count (1+ count))) (rename-buffer (format "%s<%d>" newname count)))))))))) ;;; AtFS support functions: ;;; - atfs-get-version-id ;;; - atfs-readin-version ;;; - atfs-get-version-list ;;; - atfs-get-symnames (yet to come) ;;; - atfs-get-rulenames (yet to come) (defun atfs-get-version-list (directory &optional options pattern) "Return list of versions in DIRECTORY. Optional second argument OPTIONS is a list containing vl-options. If optional third argument PATHNAME is non-nil, full pathnames are returned. Optional fourth argument PATTERN is a pattern for the version name. If the child process terminates with a non-zero status, return nil." (let* ((optstring "") command) (while options (setq optstring (concat optstring (car options) " ")) (setq options (cdr options))) (setq command (format "cd %s ; %s %s %s" directory atfs-vl-command optstring (regexp-quote (or pattern "*")))) (atfs-command-to-list command))) (defun old-atfs-get-version-list (directory &optional options pathname pattern) "Return list of versions in DIRECTORY. Optional second argument OPTIONS is a list containing vl-options. If optional third argument PATHNAME is non-nil, full pathnames are returned. Optional fourth argument PATTERN is a pattern for the version name. If the child process terminates with a non-zero status, return nil." (let ((tmp-buffer (get-buffer-create atfs-temp-buffer)) result) (save-excursion (set-buffer tmp-buffer) (erase-buffer) (setq result (apply 'call-process atfs-vl-command nil t nil (append options (list directory)))) (if (stringp result) ;; child process has been killed by a signal (error "Signal %s killed vl %s, " result filename)) (if (zerop result) (let ((vlist (atfs-buffer-to-list))) (if pathname vlist (mapcar 'file-name-nondirectory vlist))))))) (defun atfs-get-version-id (filename &optional all-versions) "If an AtFS version of FILENAME exists, return the id of the default version as a string or just the filename, if there is only a busy version. If optional second argument ALL-VERSIONS is non-nil, a list of all matching version IDs is returned (e.g. for completion). Returns nil if no appropriate version is found. I try to compensate for a bug in vl(1) by not allowing \"[...]\" in a file or version name *before* the and, i.e. atfs-get-version-id returns nil for a name like \"foo.c[2.5].Z\"." (atfs-save-match-data (if (string-match "^.+\\[[^]]+\\].+$" filename) nil ; fake, see above (let ((tmp-buffer (get-buffer-create atfs-temp-buffer)) (path (file-name-directory filename)) result version-list) (save-excursion (set-buffer tmp-buffer) (erase-buffer) (setq result (if all-versions (call-process atfs-vbind-command nil t nil "-set" filename) (call-process atfs-vbind-command nil t nil filename))) (if (stringp result) ;; vbind has been killed by a signal (error "Signal %s killed vbind %s, " result filename)) (if (zerop result) (progn ; success (setq version-list (atfs-buffer-to-list 'reverse)) (if all-versions (mapcar (function (lambda (name) (concat path name))) version-list) (concat path (car version-list)))))))))) (defun atfs-readin-version (version-id &optional signal) "Reads VERSION from the AtFS archive into the current buffer at point. If optional argument SIGNAL is non-nil, signal a file-error if the version could not be retrieved. Point is at point-min afterwards. Sets buffer-modified-p, buffer-read-only, normal-mode, and buffer-file-name. Include buffer in atfs-mode-buffers-alist." (let ((result (apply 'call-process atfs-vcat-command nil t nil (append atfs-vcat-options (list version-id))))) (if (or (stringp result) (not (zerop result))) (if signal (signal 'file-error (list atfs-vcat-command "error: " result version-id))) (goto-char (point-min)) (set-buffer-modified-p nil) (setq buffer-read-only t) (buffer-disable-undo (current-buffer)) ;; normal-mode needs buffer-file-name without version number (setq buffer-file-name (atfs-file-name-sans-version version-id)) (normal-mode) (atfs-include-in-buffers-alist (current-buffer) version-id) (setq buffer-file-name version-id) t))) ; success ;;; minor mode atfs-mode ;;; No features yet, but its name appears in the mode line. (defvar atfs-mode nil "Pseudo minor mode for visiting AtFS files. No special features yet, just shows its name in the mode line.") (make-variable-buffer-local 'atfs-mode) (setq-default atfs-mode nil) (if (not (assq 'atfs-mode minor-mode-alist)) (setq minor-mode-alist (cons '(atfs-mode " AtFS") minor-mode-alist))) (defun atfs-mode (&optional arg) "Minor mode for visiting AtFS versions. Toggle atfs-mode, or turn it on iff optional ARG is positive. No features yet." (setq atfs-mode (if (null arg) (not atfs-mode) (> (prefix-numeric-value arg) 0)))) ;;; minor utility functions (defun atfs-version-exists-p (filename) "Return non-nil if a version history of FILENAME exists. Currently we use the kludge of checking the AtFS/Data/FILENAME file." (file-exists-p (concat (file-name-directory filename) "AtFS/Data/" (file-name-nondirectory filename)))) (defun atfs-command-to-list (command &optional raise-error) "Execute COMMAND and return the output as a list of strings. If COMMAND returns a non-zero exit status, return nil. If optional second argument RAISE-ERROR is non-nil, an error is raised if COMMAND returns a non-zero exit status." (let ((tmp-buffer (get-buffer-create atfs-temp-buffer)) result) (save-excursion (set-buffer tmp-buffer) (erase-buffer) (if (call-process-with-error command t (not raise-error)) (atfs-buffer-to-list))))) (defun atfs-include-in-buffers-alist (buffer version-id) "Make sure BUFFER containing VERSION-ID appears in atfs-mode-buffers-alist." (let ((pair (assq buffer atfs-mode-buffers-alist))) (if (not pair) (setq atfs-mode-buffers-alist (cons (cons buffer version-id) atfs-mode-buffers-alist))))) (defun atfs-delete-from-buffers-alist (buffer) "Delete BUFFER from atfs-mode-buffers-alist." (let ((pair (assq buffer atfs-mode-buffers-alist))) (if pair (setq atfs-mode-buffers-alist (delq pair atfs-mode-buffers-alist))))) (defun atfs-get-buffer-version-id (buffer) "Look up BUFFER's version name in atfs-mode-buffers-alist. If buffer does not contain a version, return nil." (let ((pair (assq buffer atfs-mode-buffers-alist))) (if pair (cdr pair)))) (defun atfs-buffer-to-list (&optional reverse buffer) "Return a list of all lines in the current buffer. If optional argument REVERSE is non-nil, return the reverse list. Optional second argument BUFFER means scan this buffer." (let ((llist nil) opoint) (if buffer (set-buffer buffer)) (goto-char (point-max)) (while (not (bobp)) (setq opoint (1- (point))) (forward-line -1) (setq llist (cons (buffer-substring (point) opoint) llist))) (if reverse (nreverse llist) llist))) (defun atfs-file-name-sans-version (version-id) "Return the filename part of VERSION-ID." (atfs-save-match-data (if (string-match atfs-version-match-re version-id) (substring version-id 0 (match-end 1)) version-id))) (defun atfs-version-p (filename &optional canonical) "Return non-nil if FILENAME is the name of an AtFS version. If optional second argument CANONICAL is non-nil, return non-nil only if the name is a canonical version ID." (atfs-save-match-data (string-match (if canonical atfs-canonical-version-match-re atfs-version-match-re) filename))) (defun atfs-file-writable-p (filename) ; replacement for file-writable-p "Return t if file FILENAME can be written or created by you. Note: This function has been modified to work with find-atfs-version." (if (atfs-version-p filename 'canonical) ;; this is a fake, but keeps after-find-file ;; from complaining too much. nil (atfs-original-file-writable-p filename))) (defun atfs-file-exists-p (filename) ; replacement for file-exists-p "Return t if FILENAME or AtFS version of it exists. (This does not mean you can read it.) See also file-readable-p and file-attributes." (if atfs-be-version-aware (or (atfs-original-file-exists-p filename) (file-directory-p filename) (atfs-get-version-id filename)) (atfs-original-file-exists-p filename))) (defun atfs-edit-description-file (descfile &optional message initial-contents noerase) "Edit a description file, e.g. for a \"save\" or \"retrv\" command. DESCFILE is the Name of the file. Optional second arg MESSAGE is prepended to the \"Type C-c C-c to continue\" message in the echo area. Optional third arg INITIAL-CONTENTS is a string inserted into the buffer. If optional fourth arg NOERASE is non-nil, the contents of DESCFILE is not erased before editing. The buffer visiting DESCFILE is shown in a separate window. The window configuration is restored afterwards." (save-window-excursion (let ((buffer (find-file-noselect descfile)) (intro (concat (if message (concat message " and type ") "Type ") "\\[exit-recursive-edit] to continue"))) (condition-case error-condition (progn (pop-to-buffer buffer) (if (not noerase) (erase-buffer)) ; just in case (if initial-contents (insert initial-contents)) (local-set-key "\C-c\C-c" 'exit-recursive-edit) (message (substitute-command-keys intro)) (recursive-edit) (write-file buffer-file-name) ; force writing of file (kill-buffer buffer)) (error (set-buffer-modified-p nil) (condition-case dummy (delete-file descfile) (error)) (kill-buffer buffer) (signal (car error-condition) (cdr error-condition))))))) (defun atfs-execute-save (file log-file &optional vnum) "Save FILE as AtFS version. Take the log message from LOG-FILE. Return the version-id of the save version as a string. Optional third arg VNUM is the version number to use as a string." (let ((tmp-buffer (generate-new-buffer " *atfs-save*"))) (unwind-protect (save-excursion (atfs-save-match-data (set-buffer tmp-buffer) (call-process-with-error (format atfs-save-format atfs-save-command (expand-file-name log-file) (if vnum (format atfs-save-setvnum-option vnum) "") file) t) (goto-char (point-min)) (if (re-search-forward (format "^\\(%s\\[[0-9]+\\.[0-9]+\\]\\) %s.$" (regexp-quote file) "saved") (point-max) t) (buffer-substring (match-beginning 1) (match-end 1))))) (kill-buffer tmp-buffer)))) ;;; Check in/out (defun atfs-toggle-read-only () ; replacement for vc-toggle-read-only "Change whether this buffer is visiting its file read-only. Note: This function has been modified to work with AtFS. If the buffer contains an AtFS version, a checkout is offered. If it contains a writable file, a checkin is offered." (interactive) (if (or atfs-buffer-version-id (and buffer-file-name buffer-read-only (atfs-version-exists-p buffer-file-name) (atfs-file-exists-p buffer-file-name))) (progn (if (yes-or-no-p (format "Check this %s out with lock? " (if atfs-buffer-version-id "version" "file"))) (atfs-do-checkout (or atfs-buffer-version-id buffer-file-name) t t nil atfs-keep-position-on-checkout) (message "Buffer still read-only."))) (if (and buffer-file-name (not buffer-read-only) (file-directory-p "./AtFS/Data") (yes-or-no-p "Check this file in as AtFS version? ")) (atfs-do-checkin buffer-file-name t t nil atfs-keep-position-on-checkout) (atfs-original-toggle-read-only)))) (defun atfs-do-checkin (file &optional find-file save log-message keep-position) "Check FILE in as AtFS version. If optional second argument FIND-FILE is non-nil, read the default version of the file into a buffer. If optional third argument SAVE is non-nil, silently save the buffer of FILE if it is modified. Optional fourth argument LOG-MESSAGE is used as a log-message for the resulting version. If optional fifth argument KEEP-POSITION is non-nil, try to keep point at the same position (only with FIND-FILE)." (interactive (list (expand-file-name (read-file-name "Check in file: " default-directory buffer-file-name nil)) t t)) (let* ((tmp-file (concat default-directory (make-temp-name "atfs-"))) (old-buffer (get-file-buffer file)) version position) (if keep-position (setq position (atfs-save-position nil))) (if (and save old-buffer) (save-excursion (set-buffer old-buffer) (save-buffer))) (if log-message (save-excursion (let ((buffer (find-file-noselect tmp-file))) (set-buffer buffer) (erase-buffer) (insert log-message) (save-buffer 0))) ; don't make a backup (call-process-with-error (format atfs-intent-format file (expand-file-name tmp-file)) nil 'noerror) (atfs-edit-description-file tmp-file "Edit log message" nil t)) (message "Saving %s..." file) (setq version (atfs-execute-save file tmp-file)) ;; (atfs-mbs-notify version 'create) ;; (atfs-mbs-notify file 'delete) (delete-file tmp-file) (kill-buffer old-buffer) (message "Saving %s...done" file) (if find-file (progn (find-file file) (if keep-position (atfs-restore-position position nil)))))) (defun atfs-do-checkout (version &optional lock find-file intent keep-position) "Check VERSION out from the AtFS archive. If optional second argument LOCK is non-nil, ask for a change intent and check out with lock. If optional third argument FIND-FILE is non-nil, read the busy file into an Emacs buffer and switch to that buffer. Optional fourth argument INTENT is used as a change intent if the version is to be checked out with lock. If optional fifth argument KEEP-POSITION is non-nil, try to keep point at the same position (only with FIND-FILE)." (interactive (list (expand-file-name (read-file-name "Check out version: " default-directory atfs-buffer-version-id nil)) (yes-or-no-p "Check out with lock? ") t)) (let* ((tmp-file (concat default-directory (make-temp-name "atfs-"))) (filename (atfs-file-name-sans-version version)) position pos-string) (if keep-position (setq position (atfs-save-position t))) (atfs-edit-description-file tmp-file "Edit change intent" intent) (message "Retrieving %s..." version) (call-process-with-error (format atfs-retrv-format atfs-retrv-command (expand-file-name tmp-file) version) nil) ;; (atfs-mbs-notify filename 'create) (if lock (delete-file tmp-file)) (let ((vbuf (get-file-buffer version))) (if atfs-kill-version-buffer-on-checkout (kill-buffer vbuf) (bury-buffer vbuf))) (message "Retrieving %s...done" version) (if find-file (progn (find-file filename) (if keep-position (atfs-restore-position position t)))))) ;; save and restore context position (defun atfs-save-position (backwards) "Return the current position in the selected window as a list. First element is the value of point. Second element is the substring following (if BACKWARDS is non-nil) or preceding (if BACKWARDS is nil) point (number of characters is atfs-save-position-context). Third element is the difference between point and the first character in the window. This position is used to return to the same position in a file after checking in or out a version." (let* ((pos (point)) (pos-string (if backwards (buffer-substring (max (point-min) (- pos atfs-save-position-context)) pos) (buffer-substring pos (min (point-max) (+ pos atfs-save-position-context))))) (window-pos (- pos (window-start)))) (list pos pos-string window-pos))) (defun atfs-restore-position (position backwards) "Restore the saved POSITION in the selected window. If BACKWARDS is non-nil, the context is searched for backwards. For a description of POSITION, see the documentation of atfs-save-position." (goto-char (car position)) (atfs-save-match-data (if backwards (if (search-backward (car (cdr position)) nil t) (goto-char (match-end 0)) (goto-char (min (+ (point) atfs-restore-position-fallback) (point-max))) (if (search-backward (car (cdr position)) nil t) (goto-char (match-end 0)))) (if (search-forward (car (cdr position)) nil t) (goto-char (match-beginning 0)) (goto-char (max (- (point) atfs-restore-position-fallback) (point-max))) (if (search-forward (car (cdr position)) nil t) (goto-char (match-beginning 0)))))) (set-window-start (selected-window) (- (point) (car (cdr (cdr position)))))) ;;; completion on version names (defun atfs-clear-completion-cache () "Clear completion cache. For testing purposes only." (interactive) (setq atfs-completion-cache-list nil)) (defun atfs-find-file (filename) "Edit file FILENAME. Switch to a buffer visiting file FILENAME, creating one if none already exists. This function has been modified to work with atfs-mode. If atfs-find-file-always-complete is non-nil or prefix arg is given, completion is done on versions as well." (interactive (let ((atfs-be-version-aware)) (list (if (or current-prefix-arg atfs-find-file-always-complete) (atfs-read-version-id "Find Version: " default-directory) (read-file-name "Find file: " default-directory))))) (let ((atfs-be-version-aware)) (switch-to-buffer (find-file-noselect filename)))) (defun atfs-read-version-id (prompt dir) "Read version id prompting with PROMPT and completing in directory DIR." (let ((directory (atfs-massage-file-name dir))) (completing-read prompt 'atfs-read-version-id-internal nil nil directory))) (defun atfs-massage-file-name (filename) "Construct a canonical representation of FILENAME." (atfs-save-match-data (let* ((old-name (concat default-directory filename)) new-name) (catch 'ready (while t (setq new-name (cond ((string-match (concat "^" atfs-user-home-directory "/") old-name) (concat "~/"(substring old-name (match-end 0)))) ((string-match "^.*/~" old-name) (concat "~" (substring old-name (match-end 0)))) ((string-match "^.*//" old-name) (concat "/" (substring old-name (match-end 0)))) ((equal old-name "~") "~/") (t old-name))) (if (equal new-name old-name) (throw 'ready new-name) (setq old-name new-name))))))) (defun atfs-read-version-id-internal (file-name pred flag) "Internal to be called by completing-read. Do not call this." (setq file-name (atfs-massage-file-name file-name)) (let* ((dir (file-name-directory file-name)) (nondir (file-name-nondirectory file-name)) vlist) (if dir (progn (setq vlist (atfs-get-completion-alist (expand-file-name dir))) (cond ((null flag) (let ((completion (try-completion nondir vlist))) (if (stringp completion) (concat dir completion) completion))) ((eq 'lambda flag) (assoc nondir vlist)) ((eq 't flag) (all-completions nondir vlist))))))) (defun atfs-get-completion-alist (directory) "Return list of possible completions in DIRECTORY. Completions are cached in atfs-completion-cache-list. A cache entry is only valid if the mtimes of the directory and the associated AtFS data directory have not changed in between." (let* ((clist (assoc directory atfs-completion-cache-list)) (dirattrs (file-attributes directory)) (atfsattrs (file-attributes (concat directory atfs-data-directory))) (mtimes (append (elt dirattrs 6) (elt atfsattrs 6)))) (if (and clist (equal mtimes (cdr (cdr clist)))) (car (cdr clist)) (atfs-new-completion-alist directory nil mtimes)))) (defun atfs-new-completion-alist (directory cache-entry mtimes) "Return a new list of possible completions in DIRECTORY. DIRECTORY has to be expanded. If CACHE-ENTRY is non-nil, update this entry with the completions and MTIMES. Otherwise create a new entry in atfs-completion-cache-list." (message "Making completion list...") (let* ((vl-options (if atfs-completion-show-versions atfs-vl-completion-options (cons "-h" atfs-vl-completion-options))) (completions (if (file-directory-p (concat directory atfs-data-directory)) (mapcar (function (lambda (filename) (list (if (file-directory-p (concat directory filename)) (concat filename "/") filename)))) (atfs-get-version-list directory vl-options)) (mapcar 'list (file-name-all-completions "" directory)))) (entry (or cache-entry (progn (setq atfs-completion-cache-list (cons (cons directory nil) atfs-completion-cache-list)) (car atfs-completion-cache-list))))) (rplacd entry (cons completions mtimes)) completions)) ;;; Local Variables: ;;; eval: (put 'atfs-save-match-data 'lisp-indent-hook 0) ;;; End: ;; End of file