;;; xtla.el --- Arch interface for emacs ;; Copyright (C) 2003-2004 by Stefan Reichoer ;; Author: Stefan Reichoer, ;; xtla.el 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 2, or (at your option) ;; any later version. ;; xtla.el is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; 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., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary ;; Usage: ;; put the following in your .emacs: (require 'xtla) ;; To Edit a logfile issue: M-x xtla-edit-log ;; In this mode you can hit C-c C-d to show the changes ;; Edit the log file and save it ;; After that you issue M-x xtla-commit (bound to C-c C-c) to commit the files ;; Warning: I do not use tla very often (at the moment) ;; So I do not use more functionality as it is implemented at the moment ;; If you find xtla.el useful, and you have some ideas to improve it ;; please share them with me (Patches are preferred :-)) ;; todo: ;; Many things (defvar xtla-edit-arch-command nil) (defvar xtla-pre-commit-window-configuration nil) (defvar xtla-log-edit-file-name nil) (defvar xtla-log-edit-file-buffer nil) (defvar xtla-my-id-history nil) (defun xtla-add-face (str face &optional keymap) (when svn-highlight (add-text-properties 0 (length str) `(face ,face ,@(when keymap `(mouse-face highlight local-map ,keymap))) str)) str) (defun xtla-choose-face-to-add (condition text face1 face2) "If condition then add face1 to text, else add face2 to text." (if condition (xtla-add-face text face1) (xtla-add-face text face2))) (defface xtla-marked-face '((((type tty) (class color)) (:foreground "magenta" :weight light)) (((class color) (background light)) (:foreground "magenta")) (((class color) (background dark)) (:foreground "yellow")) (t (:weight bold))) "Face to highlight a marked entry in xtla buffers" :group 'xtla-faces) (defface xtla-archive-name-face '((((type tty) (class color)) (:foreground "lightblue" :weight light)) (((class color) (background light)) (:foreground "blue4")) (((class color) (background dark)) (:foreground "lightskyblue1")) (t (:weight bold))) "Face to highlight xtla archive names." :group 'xtla-faces) (defun xtla-run-arch (run-asynchron clear-process-buffer cmdtype &rest arglist) (if (eq (process-status "arch") nil) (progn (when xtla-edit-arch-command (setq arglist (append arglist (split-string (read-from-minibuffer (format "arch %s %S " cmdtype arglist))))) (when (eq xtla-edit-arch-command t) (xtla-toggle-edit-cmd-flag t)) (message "xtla-run-arch %s: %S" cmdtype arglist)) (let* ((proc-buf (get-buffer-create "*arch-process*")) (arch-proc)) (when (listp (car arglist)) (setq arglist (car arglist))) (save-excursion (set-buffer proc-buf) (setq buffer-read-only nil) (fundamental-mode) (if clear-process-buffer (delete-region (point-min) (point-max)) (goto-char (point-max))) (setq xtla-process-cmd cmdtype) (setq xtla-status-mode-line-process-status (format " running %s" cmdtype)) (xtla-status-update-mode-line) (sit-for 0.1) (if run-asynchron (progn (setq xtla-proc (apply 'start-process "arch" proc-buf "tla" arglist)) (set-process-sentinel xtla-proc 'xtla-process-sentinel)) ;;(message "running synchron: tla %S" arglist) (apply 'call-process "tla" nil proc-buf nil arglist) (setq xtla-status-mode-line-process-status "") (xtla-status-update-mode-line))))) (error "You can only run one arch process at once!"))) (defun xtla-show-process-buffer-internal (&optional scroll-to-top) (pop-to-buffer "*arch-process*") (when scroll-to-top (goto-char (point-min))) (other-window 1)) (defun xtla-get-process-output () (save-excursion (set-buffer "*arch-process*") (buffer-substring-no-properties (point-min) (- (point-max) 1)))) (defun xtla-status-update-mode-line () ;;(setq xtla-status-mode-line-process ;; (concat xtla-status-mode-line-process-edit-flag xtla-status-mode-line-process-status)) (force-mode-line-update)) (defun xtla-make-log () (interactive) (xtla-run-arch nil t 'make-log "make-log") (xtla-get-process-output)) (defun xtla-edit-log () "Edit the tla log file." (interactive) (setq xtla-pre-commit-window-configuration (current-window-configuration)) (when (get-buffer "*arch-process*") (kill-buffer "*arch-process*")) (setq xtla-log-edit-file-name (xtla-make-log)) (find-file xtla-log-edit-file-name) (setq xtla-log-edit-buffer (current-buffer)) (xtla-log-edit-mode) (end-of-line)) (defun xtla-what-changed () (interactive) (let ((no-changes)) (xtla-run-arch nil t 'what-changed "what-changed" "--diffs") (save-excursion (set-buffer "*arch-process*") (diff-mode) (setq no-changes (= (- (point-max) (point-min)) 1))) (if no-changes (message "No changes in this arch working copy") (xtla-show-process-buffer-internal t)))) (defun xtla-commit () (interactive) (xtla-run-arch nil t 'commit "commit") (xtla-show-process-buffer-internal t)) (defun xtla-changelog () (interactive) (xtla-run-arch nil t 'changelog "changelog") (xtla-show-process-buffer-internal t)) (defun xtla-tree-lint () (interactive) (xtla-run-arch nil t 'tree-lint "tree-lint") (xtla-show-process-buffer-internal t)) (defun xtla-get-tree-root () (xtla-run-arch nil t 'tree-root "tree-root") (xtla-get-process-output)) (defun xtla-my-id (arg) (interactive "P") (let ((id (progn (xtla-run-arch nil t 'my-id "my-id") (xtla-get-process-output))) (new-id)) (if arg (progn (setq new-id (read-string "New arch id: " id xtla-my-id-history id)) (when (not (string= id new-id)) (message "Setting id to: %s" new-id) (xtla-run-arch nil t 'my-id "my-id" new-id))) (message "Arch my-id: %s" id)))) (defun xtla-tree-lint () (interactive) (xtla-run-arch nil t 'tree-lint "tree-lint") (xtla-show-process-buffer-internal t)) (defun xtla-archives () (interactive) (xtla-run-arch nil t 'archives "archives") (setq xtla-archive-list nil) (save-excursion (let ((archive-name) (archive-location) (old-point-pos -1)) (set-buffer "*arch-process*") (goto-char (point-min)) (while (> (line-end-position) (line-beginning-position)) (setq archive-name (buffer-substring (line-beginning-position) (line-end-position))) (beginning-of-line-text 2) (setq archive-location (buffer-substring (point) (line-end-position))) (setq old-point-pos (point)) (forward-line 1) (setq xtla-archive-list (append xtla-archive-list (list (list archive-name archive-location))))))) ;;(message "archives: %S" xtla-archive-list) (pop-to-buffer "*xtla-archives*") (let ((a-list xtla-archive-list) (my-default-archive (xtla-my-default-archive)) (archive-name) (start-pos) (overlay)) (toggle-read-only -1) (delete-region (point-min) (point-max)) (while a-list (setq archive-name (caar a-list)) (setq start-pos (point)) (insert (xtla-choose-face-to-add (string= archive-name my-default-archive) archive-name 'xtla-marked-face 'xtla-archive-name-face)) (newline) (insert " " (cadar a-list)) (newline) (setq overlay (make-overlay start-pos (point))) (overlay-put overlay 'xtla-archive-info archive-name) (setq a-list (cdr a-list)))) (delete-backward-char 1) (xtla-archive-list-mode)) (defun xtla-get-archive-info () (let ((overlay (car (overlays-at (point))))) (when overlay (overlay-get overlay 'xtla-archive-info)))) (defun xtla-my-default-archive (&optional new-default) (cond ((stringp new-default) (xtla-run-arch nil t 'my-default-archive "my-default-archive" new-default)) (t (xtla-run-arch nil t 'my-default-archive "my-default-archive") (xtla-get-process-output)))) ;; -------------------------------------------------------------------------------- ;; xtla-log-edit-mode: ;; -------------------------------------------------------------------------------- (defvar xtla-log-edit-mode-map () "Keymap used in xtla-log-edit-mode buffers.") (when (not xtla-log-edit-mode-map) (setq xtla-log-edit-mode-map (make-sparse-keymap)) (define-key xtla-log-edit-mode-map [(control ?c) (control ?c)] 'xtla-log-edit-done) (define-key xtla-log-edit-mode-map [(control ?c) (control ?d)] 'xtla-what-changed) (define-key xtla-log-edit-mode-map [(control ?c) (control ?l)] 'xtla-changelog) (define-key xtla-log-edit-mode-map [(control ?c) (control ?q)] 'xtla-log-edit-abort)) (easy-menu-define xtla-log-edit-mode-menu xtla-log-edit-mode-map "'xtla-log-edit-mode' menu" '("Xtla-Log" ["Commit" xtla-log-edit-done t] ["Show What changed" xtla-what-changed t] ["Show Changelog" xtla-changelog t] ["Tree Lint" xtla-tree-lint t] ["Abort" xtla-log-edit-abort t])) (defun xtla-log-edit-mode () "Major Mode to edit xtla log messages. Commands: \\{xtla-log-edit-mode-map} " (interactive) (kill-all-local-variables) (use-local-map xtla-log-edit-mode-map) (easy-menu-add xtla-log-edit-mode-menu) (setq major-mode 'xtla-log-edit-mode) (setq mode-name "xtla-log-edit")) (defun xtla-log-edit-abort () (interactive) (bury-buffer) (set-window-configuration xtla-pre-commit-window-configuration)) (defun xtla-log-edit-done () (interactive) (save-buffer) (xtla-commit) (kill-buffer (current-buffer))) ;; -------------------------------------------------------------------------------- ;; xtla-archive-list-mode: ;; -------------------------------------------------------------------------------- (defvar xtla-archive-list-mode-map () "Keymap used in xtla-archive-list-mode buffers.") (when (not xtla-archive-list-mode-map) (setq xtla-archive-list-mode-map (make-sparse-keymap)) (define-key xtla-archive-list-mode-map [return] 'xtla-archive-select-default) (define-key xtla-archive-list-mode-map [?n] 'xtla-archive-next) (define-key xtla-archive-list-mode-map [?p] 'xtla-archive-previous) (define-key xtla-archive-list-mode-map [?q] 'xtla-archive-quit)) (easy-menu-define xtla-archive-list-mode-menu xtla-archive-list-mode-map "'xtla-archive-list-mode' menu" '("Xtla-Archives" ["Select default archive" xtla-archive-select-default t] )) (defun xtla-archive-list-mode () "Major Mode to show arch archives: \\{xtla-archive-list-mode-map} " (interactive) (kill-all-local-variables) (use-local-map xtla-archive-list-mode-map) (easy-menu-add xtla-archive-list-mode-menu) (setq major-mode 'xtla-archive-list-mode) (setq mode-name "xtla-archives") (let ((view-read-only nil)) (toggle-read-only 1))) (defun xtla-archive-select-default () (interactive) (when (xtla-get-archive-info) (let ((pos (point))) (xtla-my-default-archive (xtla-get-archive-info)) (xtla-archives) (goto-char pos)))) (defun xtla-archive-next () (interactive) (forward-line 2) (beginning-of-line)) (defun xtla-archive-previous () (interactive) (forward-line -2) (beginning-of-line)) (defun xtla-archive-quit () (interactive) (kill-buffer (current-buffer))) ;; -------------------------------------------------------------------------------- ;; Misc functions ;; -------------------------------------------------------------------------------- (defun xtla-insert-arch-tag () "Insert a unique arch-tag in the current file." (interactive) (let ((uuid (shell-command-to-string "uuidgen"))) (insert (concat (or comment-start "") " arch-tag: " uuid)))) (provide 'xtla) ;; Local Variables: ;; arch-tag: f2eee8c5-0f20-4fc7-b1c1-6cef4dff8a5a ;; End: