;;; tla-core.el --- Core of xtla ;; Copyright (C) 2003-2004 by all contributors ;; Author: Stefan Reichoer, ;; Contributions from: ;; Matthieu Moy ;; Masatake YAMATO ;; Milan Zamazal ;; Martin Pool ;; Robert Widhopf-Fenk ;; Mark Triggs ;; This file 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. ;; This file 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., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This file provides the low-level functions used by xtla.el ;;; History: ;; This file was created to split out some commonly-used functionality. ;;; Code: (eval-and-compile (require 'dvc-core)) (eval-and-compile (require 'dvc-utils)) (require 'tla-defs) (require 'tla-autoconf) (eval-and-compile (require 'dvc-lisp)) (require 'ewoc) ;; ---------------------------------------------------------------------------- ;; Compatibility stuff ;; ---------------------------------------------------------------------------- (eval-when-compile (require 'cl) (if (featurep 'xemacs) (require 'dvc-xemacs) (require 'dvc-emacs))) (require 'pp) ;; ;; Arch branch: baz, tla, ... ;; (defun tla--executable () "Return the Arch executable to use. Can be either tla or baz." (cond ((eq tla-arch-branch 'tla) tla-executable) ((eq tla-arch-branch 'baz) baz-executable))) (defun tla-arch-branch-name () "Return the name of the branch of arch, as a string." (symbol-name tla-arch-branch)) (defun tla-arch-branch-name-caps () "Return the name of the branch of arch, as a capitalized string." (capitalize (symbol-name tla-arch-branch))) ;;;###autoload (defun tla-tree-root (&optional location no-error interactive) "Return the tree root for LOCATION, nil if not in a local tree. Computation is done from withing Emacs, by looking at an {arch} directory in a parent buffer of LOCATION. This is therefore very fast. If LOCATION is nil, the tree root is returned, and it is guaranteed to end in a \"/\" character. If NO-ERROR is non-nil, don't raise an error if LOCATION is not an arch managed tree (but return nil)." (interactive) (dvc-tree-root-helper "{arch}/=tagging-method" (or interactive (interactive-p)) "%S is not in an arch-managed tree!" location no-error)) (defun tla--last-visited-inventory-buffer () "Return the last visited xtla's inventory buffer." (let ((inventories (remove nil (mapcar (lambda (elt) (when (buffer-live-p (cadr elt)) elt)) (cdr (assoc 'inventory dvc-buffers-tree))))) (bl (buffer-list))) (cadr (car (sort inventories (lambda (a b) (let ((aindex (dvc-position (cadr a) bl)) (bindex (dvc-position (cadr b) bl))) (< aindex bindex)))))))) (defun tla-show-inventory-buffer () "Switch to the last visited inventory buffer." (interactive) (dvc-switch-to-buffer (tla--last-visited-inventory-buffer))) (defun tla-use-tla () "From now, use tla." (interactive) (tla-autoconf-reset) (setq tla-arch-branch 'tla)) (defun tla-use-baz () "From now, use baz." (interactive) (tla-autoconf-reset) (setq tla-arch-branch 'baz)) (defun tla--run-tla-async (arguments &rest keys) "Run tla asynchronously. See `dvc-run-dvc-async'" (if (and tla-arch-branch (not (eq tla-arch-branch 'none))) (apply 'dvc-run-dvc-async tla-arch-branch arguments keys) (error "No tla variant is installed on your system"))) (defun tla--run-tla-sync (arguments &rest keys) "Run tla synchronously. See `dvc-run-dvc-sync'" (if (and tla-arch-branch (not (eq tla-arch-branch 'none))) (apply 'dvc-run-dvc-sync tla-arch-branch arguments keys) (error "No tla variant is installed on your system"))) ;; ---------------------------------------------------------------------------- ;; Arch name manipulators ;; ====================== ;; ;; Normally in xtla, a name, a revision specifier is represented as a ;; list like: ;; ;; ("archive" "category" "branch" "version" "revision") ;; ;; Nil is permitted as the element. However the list length must be 5 ;; like: ;; ;; (nil "category" "branch" nil nil) ;; ;; In other hand, in tla command, the name must be represented as a ;; string like: ;; ;; "archive/category--branch--version--revision" ;; ;; So we have to convert a name in different representation in many ;; cases. ;; ;; * tla--name-split-* is for converting from a string representation ;; to a list representation. There are semi-qualified version and ;; fully-qualified version. ;; ;; - semi-qualified: "category--branch--version--revision". ;; `tla--name-split-semi-qualified' expects a name string without ;; archive component. The archive field of returned list is filled ;; with nil. ;; ;; - fully-qualified: "archive/category--branch--version--revision". ;; `tla--name-split' expects a name string including archive. ;; ;; * tla--name-construct-* is for converting from a list ;; representation to a string representation. The functions accept ;; arguments two ways. ;; ;; - normal passing: (tla--name-construct "archive" "category"...) ;; - packed passing: (tla--name-construct '("archive" "category"...)) ;; ;; There are semi-qualified version and fully-qualified version. ;; - semi-qualified: `tla--name-construct-semi-qualified' connects ;; arguments with "--". ;; - fully-qualified: `tla--name-construct" connects the first argument ;; and the rest with "/". About the rest, ;; `tla--name-construct-semi-qualified' is applied. ;; ;; * tla--name-{archive|category|branch|version|revision} is for ;; extracting a component from a name. The both representations are ;; acceptable. ;; ;; * tla--name-mask is for replace a component in the name list with nil. ;; ;; ---------------------------------------------------------------------------- ;; ;; String representation -> List representation ;; (defun tla--name-split-semi-qualified (name &optional archive) "Split \"--\" connected string NAME into 5 elements list. The first element is always nil if ARCHIVE is not given. If ARCHIVE is given, use it as the first. Even if the elements in name are less than 5, the list is filled by nil to make the length 5. ELISP> (tla--name-split-semi-qualified \"branch--category--version--revision\" \"archive\") (\"archive\" \"branch\" \"category\" \"version\" \"revision\") ELISP> (tla--name-split-semi-qualified \"branch--category--version--revision\") (nil \"branch\" \"category\" \"version\" \"revision\") ELISP> (tla--name-split-semi-qualified \"branch--category--version\") (nil \"branch\" \"category\" \"version\" nil) ELISP> (tla--name-split-semi-qualified \"branch--category--version\" \"archive\") (\"archive\" \"branch\" \"category\" \"version\" nil) ELISP> (tla--name-split-semi-qualified \"branch--category\" \"archive\") (\"archive\" \"branch\" \"category\" nil nil) ELISP> (tla--name-split-semi-qualified \"branch--category\" nil) (nil \"branch\" \"category\" nil nil) ELISP> (tla--name-split-semi-qualified \"branch--category--\" nil) (nil \"branch\" \"category\" \"\" nil)" (let ((list (tla--name-split-semi-qualified-internal name))) (while (> 4 (length list)) (setq list (cons nil list))) (let ((result (cons archive (nreverse list)))) (when (tla--is-version-string (nth 2 result)) (setq result (list (nth 0 result) (nth 1 result) "" (nth 2 result) (nth 3 result)))) result))) (defun tla--is-version-string (string) "Non-nil if STRING is a candidate for a version name. That is, if it contains only digits and dots. The regexp here is less strict than the one of tla, but must verify \(tla--is-version-string string) => string can't be a branch name." (and string (string-match "^[0-9\.]+$" string))) (defun tla--name-split-semi-qualified-internal (name) "Helper function for `tla--name-split-semi-qualified'. Splits a semi-qualified NAME." (if (string-match "^\\(.+\\)--\\(\\([^-]\\|-[^-]\\)*\\)" name) (cons (match-string 2 name) (tla--name-split-semi-qualified-internal (match-string 1 name))) (cons name nil))) (defun tla--name-split (name) "Parse a fully qualified revision NAME, but possibly incomplete. email@address.com--arch/cat--branch--ver -> (\"email@address.com--arch\" \"cat\" \"branch\" \"ver\" nil) email@address.com--arch/cat -> (\"email@address.com--arch\" \"cat\" nil nil nil) email@address.com--arch -> (\"email@address.com--arch\" nil nil nil nil)" (if (string-match "\\(.*\\)/\\(.*\\)" name) (tla--name-split-semi-qualified (match-string 2 name) (match-string 1 name)) (if (string= name "") (list nil nil nil nil nil) (list name nil nil nil nil)))) ;; ;; List representation -> string ;; (defun tla--name-construct-semi-qualified (&rest comp) "Concatenate COMP with \"--\". This function can accept strings or a list which contains strings. ELISP> (tla--name-construct-semi-qualified \"a\" \"b\" \"c\") \"a--b--c\" ELISP> (tla--name-construct-semi-qualified (list \"a\" \"b\" \"c\")) \"a--b--c\"" (if (consp (car comp)) (setq comp (car comp))) (if (string= (cadr comp) "") ;; Unnamed branch. (concat (car comp) "--" (mapconcat 'identity (remove nil (cddr comp)) "--")) (mapconcat 'identity (remove nil comp) "--"))) (defun tla--name-construct (archive &optional category branch version revision) "Create the revision name ARCHIVE/CATEGORY--BRANCH--VERSION--REVISION. The arguments may be nil. If ARCHIVE is a revision name list like (archive category branch version revision), the list element is mapped to arguments before creating the fully qualified revision name. If the branch name is the empty string and the version is defined, then, we have an unnamed branch. The full name is archive/category--version." (when (consp archive) (setq category (tla--name-category archive) branch (tla--name-branch archive) version (tla--name-version archive) revision (tla--name-revision archive) ;; archive must be last archive (tla--name-archive archive))) (let ((semi (tla--name-construct-semi-qualified category branch version revision))) (concat (and archive (not (string= archive "")) (concat archive (when category "/"))) semi))) (defun tla-revision-id-to-list (rev-id) (dvc-trace "rev-id=%S" rev-id) (unless (or (eq (car rev-id) 'tla) (eq (car rev-id) 'baz)) (error "%S is not a tla/baz revision ID." rev-id)) (let* ((data (dvc-revision-get-data rev-id)) (type (dvc-revision-get-type rev-id))) (dvc-trace "data=%S" data) (dvc-trace "type=%S" type) (case type (revision (car data)) (previous-revision (tla-revision-direct-ancestor (nth 1 (car data)) (nth 1 data))) (otherwise (error "TODO: type of revision not implemented: %S" type))))) ;; ;; Get a component from a list or string. ;; (defun tla--name-archive (target) "Get archive component from TARGET. Both representation of TARGET, a string and a list is acceptable." (when (stringp target) (setq target (tla--name-split target))) (car target)) (defun tla--name-category (target) "Get category component from TARGET. Both representation of TARGET, a string and a list is acceptable." (when (stringp target) (setq target (tla--name-split target))) (cadr target)) (defun tla--name-branch (target) "Get branch component from a TARGET. Both representation of TARGET, a string and a list is acceptable." (when (stringp target) (setq target (tla--name-split target))) (car (cddr target))) (defun tla--name-version (target) "Get version component from TARGET. Both representation of TARGET, a string and a list is acceptable." (when (stringp target) (setq target (tla--name-split target))) (cadr (cddr target))) (defun tla--name-revision (target) "Get revision component from TARGET. Both representation of TARGET, a string and a list is acceptable." (when (stringp target) (setq target (tla--name-split target))) (car (cddr (cddr target)))) ;; ;; Utilities ;; Mask a specified component in the name. ;; (defun tla--name-mask (original do-construct-p &optional archive-mask category-mask branch-mask version-mask revision-mask) "Mask ORIGINAL, a tla revision name by masks; and return the masked value. If DO-CONSTRUCT-P is given, the result is converted to a string by `tla--name-construct'. ARCHIVE-MASK, CATEGORY-MASK, BRANCH-MASK, VERSION-MASK and REVISION-MASK should be either nil or t, and indicate whether that field should be masked. If a mask value is nil, the associated element in ORIGINAL is set to nil. Else If a mask value is a string, the associated element in ORIGINAL is set to the string. Else the associated element in ORIGINAL is not changed. Examples: ELISP> (tla--name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") nil t t t t nil) (\"a\" \"c\" \"b\" \"v\" nil) ELISP> (tla--name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") nil t t t nil nil) (\"a\" \"c\" \"b\" nil nil) ELISP> (tla--name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") t t t t nil nil) \"a/c--b\" ELISP> (tla--name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") t nil nil nil nil t) \"r\" ELISP> (tla--name-mask '(\"a\" \"c\" \"b\" \"v\" \"r\") t nil nil nil t t) \"v--r\" ELISP>" (when (stringp original) (setq original (tla--name-split original))) (when (consp original) (let ((masked (list (if archive-mask (if (stringp archive-mask) archive-mask (tla--name-archive original))) (if category-mask (if (stringp category-mask) category-mask (tla--name-category original))) (if branch-mask (if (stringp branch-mask) branch-mask (tla--name-branch original))) (if version-mask (if (stringp version-mask) version-mask (tla--name-version original))) (if revision-mask (if (stringp revision-mask) revision-mask (tla--name-revision original)))))) (if do-construct-p (tla--name-construct masked) masked)))) (defun tla--name-match (target mask) "Compare the fully qualified revision list TARGET with a MASK. Each parameter is a list. The elements of the both lists are compared via a regexp match. When the mask part of a component is nil, this comparision is skipped. Here are some examples: \(tla--name-match '(\"xsteve@nit.at--public\" \"xtla\" \"main\" \"0.1\" \"patch-116\") '(nil \"xt.*\" \"main\" nil nil)) => t \(tla--name-match '(\"xsteve@nit.at--public\" \"xtla\" \"main\" \"0.1\" \"patch-116\") '(nil \"xt.*\" \"devel\" nil nil)) => nil" ;" (let ((tl target) (ml mask) (t-part) (m-part) (matching t)) (while tl (setq t-part (car tl)) (setq m-part (car ml)) (when m-part (setq matching (string-match m-part t-part))) (if matching (progn (setq tl (cdr tl)) (setq ml (cdr ml))) (setq tl nil))) (if matching t nil))) (defun tla--name-match-from-list (target match-list) "Match TARGET against a list of possible matches. Every entry of MATCH-LIST is a list that contains a match element and a possible result. The target is matched against the elements in the match-list. If a match is found return the corresponding result, otherwise return nil." (let ((ml match-list) (match) (data) (result)) (while (and (not result) ml) (setq match (caar ml)) (setq data (car (cdar ml))) ;;(message "match: %s, data: %s" match data) (setq result (when (tla--name-match target match) data)) (setq ml (cdr ml))) result)) ;; example: ;;(setq tla-apply-patch-mapping ;; '(((nil "atla" nil nil nil) "~/work/tlaaaa") ;; ((nil "xtla" nil nil nil) "~/work/tla/xtla"))) ;;(tla--name-match-from-list ;; '("xsteve@nit.at--public" "xtla" "main" "0.1" "patch-116") tla-apply-patch-mapping) ;; TODO: Use tla--archive-tree. (defun tla--version-head (archive category branch version) "Return the newest revision for ARCHIVE/CATEGORY--BRANCH--VERSION." (tla--run-tla-sync (list "revisions" (tla--name-construct archive category branch version)) :finished (lambda (output error status arguments) (with-current-buffer output (goto-char (point-max)) (re-search-backward "^.") (buffer-substring-no-properties (point) (line-end-position)))))) ;; ---------------------------------------------------------------------------- ;; Archive tree manipulators ;; ---------------------------------------------------------------------------- (defvar tla--archive-tree-archives-complete nil "Non-nil when the list of archives is built. In tla--archive-tree, the list of archives is built by running \"baz archives\", but some items can be added also while adding categories, branches, ... In this case, this variable remains nil so that \"baz archives\" is ran next time, to get the full list of archives.") (defvar tla--archive-tree nil "Arch archive/category/branch/version/revision are stored in assoc list: ((\"xsteve@nit.at--public\" \"http://arch.xsteve.at/2004\") [...] (\"mbp@sourcefrog.net--2004\" \"http://sourcefrog.net/arch/mbp@sourcefrog.net--2004\" (\"xtla\") (\"tilly\") [...] (\"dupes\" (\"mainline\" (\"0.1\"))) [...] (\"archzoom\")) (\"mark@dishevelled.net--2003-mst\" \"http://members.iinet.net.au/~mtriggs/arch/\") (\"lord@emf.net--2004\" \"http://regexps.srparish.net/{archives}/lord@emf.net--2004\") [...] (\"Matthieu.Moy@imag.fr--public\" \"http://www-verimag.imag.fr/webdav/moy/public\" (\"xtla\" (\"main\" (\"0.1\" (\"patch-228\" \"Merged from Robert (patch8-9), Milan (patch21-22), Stefan (patch5-8)\" \"Matthieu Moy \" \"2004-06-03 20:13:11 GMT\") (\"patch-227\" \"Fix default-directory in tla--run-tla-sync, fix in dvc-diff-ediff\" \"Matthieu Moy \" \"2004-06-03 15:26:15 GMT\") [...] (\"patch-1\" \"typo\" \"Matthieu Moy \" \"2004-04-07 22:57:00 GMT\") (\"base-0\" \"tag of xsteve@nit.at--public/xtla--main--0.1--patch-5\" \"Matthieu Moy \" \"2004-04-07 22:52:39 GMT\"))))) [...] ) This list is initially empty, and is built/rebuilt on demand.") ;; Utilities (defun tla--archive-tree-setcdr (parent value &optional rest) "In PARENT, update VALUE. REST are the items that are already present." (let* ((current (cdr parent)) (list-details (assoc value current))) (if (or (null current) (null list-details)) ;; rest is '("summary" "creator" "date") when value is "patch-N" (setcdr parent (cons (cons value rest) current)) (if (and list-details rest) ;; Field already there. update details. (setcdr list-details rest))))) (defun tla--archive-tree-setcddr (parent value) "In PARENT, update VALUE." (let ((current (cddr parent))) (if (or (null current) (null (assoc value current))) (setcdr (cdr parent) (cons (cons value nil) current))))) ;; Archive (defun tla--archive-tree-add-archive (archive locations &optional old) "Add ARCHIVE at LOCATIONS to the archive tree. If OLD is provided, it is an old archive tree from which some information can be found (this is useful to keep the category/branch/version info for existing archives)." (if (tla--archive-tree-get-archive archive) (let* ((a (tla--archive-tree-get-archive archive)) (val (cdr a)) (oldlocation (car val))) (setcar (cdr a) (or locations oldlocation))) (let ((oldinfo (tla--archive-tree-get-archive archive old)) (newinfo (list archive locations))) (when oldinfo (setcdr (cdr newinfo) (cddr oldinfo))) ;; list of versions. (setq tla--archive-tree (cons newinfo tla--archive-tree))))) (defun tla--archive-tree-get-archive (archive &optional archive-tree) "Get the value of ARCHIVE from ARCHIVE-TREE. If ARCHIVE-TREE is not given, `tla--archive-tree' is used." (assoc archive (or archive-tree tla--archive-tree))) ;; Category (defun tla--archive-tree-add-category (archive category) "Add a new category to ARCHIVE named CATEGORY." (tla--archive-tree-add-archive archive nil) (tla--archive-tree-setcddr (tla--archive-tree-get-archive archive) category)) (defun tla--archive-tree-get-category (archive category) "From ARCHIVE, get CATEGORY." (assoc category (cdr (cdr (tla--archive-tree-get-archive archive))))) ;; Branch (defun tla--archive-tree-add-branch (archive category branch) "Add a new branch to ARCHIVE's CATEGORY named BRANCH." (tla--archive-tree-add-category archive category) (tla--archive-tree-setcdr (tla--archive-tree-get-category archive category) branch)) (defun tla--archive-tree-get-branch (archive category branch) "Get a branch from ARCHIVE's CATEGORY named BRANCH." (assoc branch (cdr (tla--archive-tree-get-category archive category)))) ;; Version (defun tla--archive-tree-add-version (archive category branch version) "Add a new version to ARCHIVE CATEGORY BRANCH named VERSION." (tla--archive-tree-add-branch archive category branch) (tla--archive-tree-setcdr (tla--archive-tree-get-branch archive category branch ) version)) (defun tla--archive-tree-get-version (archive category branch version) "Get a version from ARCHIVE CATEGORY BRANCH named VERSION." (assoc version (cdr (tla--archive-tree-get-branch archive category branch)))) ;; Revision (defun tla--archive-tree-add-revision (archive category branch version revision &optional rev-struct) "Add a new revision to ARCHIVE CATEGORY BRANCH VERSION named REVISION." (tla--archive-tree-add-version archive category branch version) (tla--archive-tree-setcdr (tla--archive-tree-get-version archive category branch version) revision rev-struct)) (defun tla--archive-tree-get-revision (archive category branch version revision) "Get a revision from ARCHIVE CATEGORY BRANCH VERSION named REVISION." (assoc revision (cdr (tla--archive-tree-get-version archive category branch version)))) (defun tla--archive-tree-get-revision-struct (archive category branch version revision) "Get a revision from ARCHIVE CATEGORY BRANCH VERSION named REVISION. Return a structure `tla--revision'." (or (cdr (assoc revision (cdr (tla--archive-tree-get-version archive category branch version)))) (progn (tla--archive-tree-build-revisions archive category branch version t) (cdr (assoc revision (cdr (tla--archive-tree-get-version archive category branch version))))))) ;; Archive tree builders (defun tla--archive-tree-build (basename &optional use-cache ignore-error) "Generic version of tla--archive-tree-build-*. BASENAME is used as a base for this tree. If USE-CACHE is non-nil, load details from the cache where possible. If IGNORE-ERROR is non-nil, don't throw errors." (when (stringp basename) (setq basename (tla--name-split basename))) (let ((archive (tla--name-archive basename)) (category (tla--name-category basename)) (branch (tla--name-branch basename)) (version (tla--name-version basename))) (cond (version (tla--archive-tree-build-revisions archive category branch version use-cache ignore-error)) (branch (tla--archive-tree-build-versions archive category branch use-cache ignore-error)) (category (tla--archive-tree-build-branches archive category use-cache ignore-error)) (archive (tla--archive-tree-build-categories archive use-cache ignore-error)) (t (tla--archive-tree-build-archives use-cache ignore-error))))) (defun tla--archive-tree-build-archives (&optional use-cache ignore-error) "Builds the list of archives. If USE-CACHE is non-nil, load details from the cache where possible. If IGNORE-ERROR is non-nil, don't throw errors." (when (or (not use-cache) (not tla--archive-tree) (not tla--archive-tree-archives-complete)) (tla--run-tla-sync `("archives" ,(when (tla-archives-has-all-locations-option) "--all-locations")) :finished 'dvc-null-handler :error (if ignore-error 'dvc-null-handler 'dvc-default-error-function)) (setq tla--archive-tree-archives-complete t) (let ((old-archive-tree tla--archive-tree)) (setq tla--archive-tree nil) (save-excursion (let (archive-name) (set-buffer dvc-last-process-buffer) (goto-char (point-min)) (while (> (line-end-position) (line-beginning-position)) (setq archive-name (buffer-substring-no-properties (line-beginning-position) (line-end-position))) (forward-line 1) (let (archive-locations) (while (looking-at "^ \\(.*\\)$") (push (match-string 1) archive-locations) (forward-line 1)) (tla--archive-tree-add-archive archive-name ;; ;; Make master archive becoming the ;; first of list of the list. ;; (reverse archive-locations) old-archive-tree)))))))) (defun tla--archive-tree-build-categories (archive &optional use-cache ignore-error) "Build the list of categories for ARCHIVE in `tla--archive-tree'. If USE-CACHE is non-nil, load details from the cache where possible. If IGNORE-ERROR is non-nil, don't throw errors." (tla--archive-tree-build-archives t ignore-error) (when (or (not use-cache) (not (cddr (tla--archive-tree-get-archive archive)))) (let ((basename archive)) (message "building categories for `%s'..." basename) (tla--run-tla-sync (list "categories" basename) :finished 'dvc-null-handler :error (if ignore-error 'dvc-null-handler 'dvc-default-error-function)) (message "building categories for `%s'...done" basename) (sit-for 0) (message nil)) (with-current-buffer dvc-last-process-buffer (let (category) (goto-char (point-min)) (while (> (line-end-position) (line-beginning-position)) (setq category (buffer-substring-no-properties (line-beginning-position) (line-end-position))) (forward-line 1) (tla--archive-tree-add-category archive category) ))))) (defun tla--archive-tree-build-branches (archive category &optional use-cache ignore-error) "Build the list of branches for ARCHIVE/CATEGORY in `tla--archive-tree'. If USE-CACHE is non-nil, load details from the cache where possible. If IGNORE-ERROR is non-nil, don't throw errors." (tla--archive-tree-build-categories archive t ignore-error) (when (or (not use-cache) (not (cdr (tla--archive-tree-get-category archive category)))) (let ((basename (tla--name-construct archive category))) (message "building branches for `%s'..." basename) (tla--run-tla-sync (list "branches" basename) :finished 'dvc-null-handler :error (if ignore-error 'dvc-null-handler 'dvc-default-error-function)) (message "building branches for `%s'...done" basename) (sit-for 0) (message nil)) (with-current-buffer dvc-last-process-buffer (let (branch) (goto-char (point-min)) (while (> (line-end-position) (line-beginning-position)) (setq branch (buffer-substring-no-properties (line-beginning-position) (line-end-position))) (tla--archive-tree-add-branch archive category (if (looking-at ".*--") (tla--name-branch (tla--name-split-semi-qualified branch)) ;; unnamed branch "")) (forward-line 1)))))) (defun tla--archive-tree-build-versions (archive category branch &optional use-cache ignore-error) "Build the version list in ARCHIVE/CATEGORY--BRANCH in `tla--archive-tree'. If USE-CACHE is non-nil, load details from the cache where possible. If IGNORE-ERROR is non-nil, don't throw errors." (tla--archive-tree-build-branches archive category t ignore-error) (when (or (not use-cache) (not (cdr (tla--archive-tree-get-branch archive category branch)))) (let ((basename (tla--name-construct archive category branch))) (message "building versions for `%s'..." basename) (tla--run-tla-sync (list "versions" basename) :finished 'dvc-null-handler :error (if ignore-error 'dvc-null-handler 'dvc-default-error-function)) (message "building versions for `%s'...done" basename) (sit-for 0) (message nil)) (with-current-buffer dvc-last-process-buffer (let (version) (goto-char (point-min)) (while (> (line-end-position) (line-beginning-position)) (setq version (buffer-substring-no-properties (line-beginning-position) (line-end-position))) (forward-line 1) (tla--archive-tree-add-version archive category branch (tla--name-version (tla--name-split-semi-qualified version)))))))) (defun tla--read-field (field) "Read the contents of FIELD from a log buffer. Must be called from a log file buffer. Returns the content of the field FIELD. FIELD is just the name of the field, without trailing \": \"" (save-excursion (goto-char (point-min)) (if (re-search-forward (concat "^" field ": ") nil t) (buffer-substring-no-properties (point) (progn (re-search-forward "^[^ \t]") (- (point) 2))) ;; back to the end of the last line ;; of the field. ""))) (defun tla--read-field-str (field log-as-string) "Read the contents of FIELD from a log buffer. Returns the content of the field FIELD, extracted from the log LOG-AS-STRING. FIELD is just the name of the field, without trailing \": \"" (with-temp-buffer (insert log-as-string) (tla--read-field field))) (defun tla--read-complete-log-string (&optional buffer) "Read the output of \"baz .. --complete-log\", starting at \"N chars\". Return the log as a string." (with-current-buffer (or buffer (current-buffer)) (dvc-funcall-if-exists set-buffer-multibyte nil) (let ((chars (string-to-number (buffer-substring-no-properties (point) (search-forward " "))))) (forward-line 1) (let ((result (buffer-substring-no-properties (point) (progn (forward-char chars) (point))))) result)))) (defun tla--skip-complete-log (&optional buffer) "Skip a log in the output of \"baz .. --complete-log\", starting at \"N chars\". Same as `tla--read-complete-log-string', but don't return anything and is faster." (with-current-buffer (or buffer (current-buffer)) (dvc-funcall-if-exists set-buffer-multibyte nil) (let ((chars (string-to-number (buffer-substring-no-properties (point) (search-forward " "))))) (forward-line 1) (forward-char chars)))) (defun tla--read-complete-log-struct (&optional buffer) "Read the output of \"baz .. --complete-log\", starting at \"N chars\". Return the log as a string." (tla--parse-log-file (tla--read-complete-log-string buffer))) (defun tla--parse-log-file (log-as-string) "Parses a log file and return a structure `tla--revision'." (let ((rev-struct (make-tla--revision)) archive) (with-temp-buffer (insert log-as-string) (goto-char (point-min)) (while (re-search-forward "^\\([A-Za-z0-9_-]*\\): ?" nil t) (let ((header (match-string-no-properties 1)) (begin (point))) (forward-line 1) (while (looking-at "^[\t ]") (forward-line 1)) (let ((value (buffer-substring-no-properties begin (- (point) 1)))) (cond ((string= header "Summary") (setf (tla--revision-summary rev-struct) value)) ((string= header "Creator") (setf (tla--revision-creator rev-struct) value)) ((string= header "Standard-date") (setf (tla--revision-date rev-struct) value)) ((string= header "New-patches") (setf (tla--revision-merges rev-struct) (split-string value))) ((string= header "Revision") (setf (tla--revision-revision rev-struct) (tla--name-split-semi-qualified value))) ((string= header "Archive") (setq archive value)) )))) (forward-line 1) (setf (tla--revision-body rev-struct) (buffer-substring-no-properties (point) (point-max))) (setf (car (tla--revision-revision rev-struct)) archive) (setf (tla--revision-merges rev-struct) (remove (tla--name-construct (tla--revision-revision rev-struct)) (tla--revision-merges rev-struct)))) (setf (tla--revision-log rev-struct) log-as-string) rev-struct)) (defun tla--archive-tree-build-revisions (archive category branch version &optional use-cache ignore-error need-complete-info callback) "Build the revision list in ARCHIVE/CATEGORY--BRANCH--VERSION. Updates `tla--archive-tree'. If USE-CACHE is non-nil, load details from the cache where possible. If IGNORE-ERROR is non-nil, don't throw errors. If CALLBACK is non-nil, run the process asynchronously and call callback afterwards." (tla--archive-tree-build-versions archive category branch t ignore-error) (when (or (not use-cache) (not (cdr (tla--archive-tree-get-version archive category branch version))) (and need-complete-info (not (cdar (cdr (tla--archive-tree-get-version archive category branch version)))))) (let ((details (or dvc-revisions-shows-summary dvc-revisions-shows-date dvc-revisions-shows-creator)) (basename (tla--name-construct archive category branch version))) (message "building revisions for `%s'..." basename) (funcall (if callback 'tla--run-tla-async 'tla--run-tla-sync) `("revisions" ,@(when details (if (tla-revisions-has-complete-log-option) '("--complete-log") '("--summary" "--date" "--creator"))) ,basename) :error (if ignore-error 'dvc-null-handler 'dvc-default-error-function) :finished (dvc-capturing-lambda (output errors status arguments) (message "building revisions for `%s'...done" (capture basename)) (sit-for 0) (message nil) (with-current-buffer output (let (revision date creator summary rev-struct) (goto-char (point-min)) (while (> (line-end-position) (line-beginning-position)) (setq revision (buffer-substring-no-properties (line-beginning-position) (line-end-position))) (while (string-match ".*password: $" revision) (forward-line 1) (setq revision (buffer-substring-no-properties (line-beginning-position) (line-end-position)))) (forward-line 1) (if (capture details) (if (tla-revisions-has-complete-log-option) (setq rev-struct (tla--read-complete-log-struct)) (skip-chars-forward " ") (setq date (buffer-substring-no-properties (point) (line-end-position))) (forward-line 1) (skip-chars-forward " ") (setq creator (buffer-substring-no-properties (point) (line-end-position))) (forward-line 1) (skip-chars-forward " ") (setq summary (buffer-substring-no-properties (point) (progn (re-search-forward "^\\([^ \t]\\|$\\)") (previous-line 1) (end-of-line) (point)))) (forward-line 1) (setq rev-struct (make-tla--revision :creator creator :summary summary :date date :revision (list (capture archive) (capture category) (capture branch) (capture version) revision)))) (setq rev-struct nil)) (tla--archive-tree-add-revision (capture archive) (capture category) (capture branch) (capture version) revision rev-struct)))) (when (capture callback) (funcall (capture callback)))))))) (defun tla--revisions-tree-contains-details (archive category branch version) "Whether VERSION has already been listed full details. Details include summary lines, dates, and creator in the archive tree." (let ((vtree (tla--archive-tree-get-version archive category branch version))) (and (cdr vtree) ;; revision list is here (cadr (cadr vtree))))) ;; summary line also ;; ---------------------------------------------------------------------------- ;; Revlib tree manipulators ;; ---------------------------------------------------------------------------- (defvar tla--revlib-tree nil "Same as `tla--archive-tree', but for revision library. Does not contain details for revisions, since they would be redundant with the archive tree.") (defun tla--revlib-tree-get-archive (archive &optional archive-tree) "Get ARCHIVE from ARCHIVE-TREE. If ARCHIVE-TREE is not given, `tla--revlib-tree' is used instead." (assoc archive (or archive-tree tla--revlib-tree))) (defun tla--revlib-tree-build-archives (&optional use-cache ignore-error) "Build the list of archives in `tla--revlib-tree'. If USE-CACHE is non-nil, load from the cache where possible. If IGNORE-ERROR is non-nil, error is not reported. Return non-nil if the tree entry for archives are updated." (when (or (not use-cache) (not tla--revlib-tree)) (tla--run-tla-sync '("library-archives") :finished 'dvc-null-handler :error (if ignore-error 'dvc-null-handler 'dvc-default-error-function)) (let ((old-revlib-tree tla--revlib-tree) ) (setq tla--revlib-tree nil) (save-excursion (let ((archive-name) (tmp tla--archive-tree) (tla--archive-tree tla--revlib-tree) result) (set-buffer dvc-last-process-buffer) (goto-char (point-min)) (while (> (line-end-position) (line-beginning-position)) (setq result t) (setq archive-name (buffer-substring-no-properties (line-beginning-position) (line-end-position))) (forward-line 1) (tla--archive-tree-add-archive archive-name nil old-revlib-tree)) (setq tla--revlib-tree tla--archive-tree tla--archive-tree tmp) result))))) (defun tla--revlib-tree-get-category (archive category) "Get a category from ARCHIVE named CATEGORY." (assoc category (cdr (cdr (tla--revlib-tree-get-archive archive))))) (defun tla--revlib-tree-build-categories (archive &optional use-cache ignore-error) "Builds the list of categories for an ARCHIVE in `tla--revlib-tree'. If USE-CACHE is non-nil, load from the cache where possible. If IGNORE-ERROR is non-nil, error is not reported. Return non-nil if the tree entry for categories are updated." (when (or (not use-cache) (not (cddr (tla--revlib-tree-get-archive archive)))) (tla--run-tla-sync (list "library-categories" archive) :finished 'dvc-null-handler :error (if ignore-error 'dvc-null-handler 'dvc-default-error-function)) (with-current-buffer dvc-last-process-buffer (let (category (tmp tla--archive-tree) (tla--archive-tree tla--revlib-tree) result) (goto-char (point-min)) (while (> (line-end-position) (line-beginning-position)) (setq result t) (setq category (buffer-substring-no-properties (line-beginning-position) (line-end-position))) (forward-line 1) (tla--archive-tree-add-category archive category)) (setq tla--revlib-tree tla--archive-tree tla--archive-tree tmp) result)))) (defun tla--revlib-tree-get-branch (archive category branch) "From ARCHIVE/CATEGORY, get BRANCH." (assoc branch (cdr (tla--revlib-tree-get-category archive category)))) (defun tla--revlib-tree-build-branches (archive category &optional use-cache ignore-error) "Build the list of branches for ARCHIVE/CATEGORY in `tla--revlib-tree'. If USE-CACHE is non-nil, load from the cache where possible. If IGNORE-ERROR is non-nil, error is not reported. Return non-nil if the tree entry for branches are updated." (when (or (not use-cache) (not (cdr (tla--revlib-tree-get-category archive category)))) (tla--run-tla-sync (list "library-branches" (tla--name-construct archive category)) :finished 'dvc-null-handler :error (if ignore-error 'dvc-null-handler 'dvc-default-error-function)) (with-current-buffer dvc-last-process-buffer (let (branch (tmp tla--archive-tree) (tla--archive-tree tla--revlib-tree) result) (goto-char (point-min)) (while (> (line-end-position) (line-beginning-position)) (setq result t) (setq branch (buffer-substring-no-properties (line-beginning-position) (line-end-position))) (forward-line 1) (tla--archive-tree-add-branch archive category (tla--name-branch (tla--name-split-semi-qualified branch)))) (setq tla--revlib-tree tla--archive-tree tla--archive-tree tmp) result)))) (defun tla--revlib-tree-get-version (archive category branch version) "Get ARCHIVE/CATEGORY--BRANCH--VERSION from the revlib tree." (assoc version (cdr (tla--revlib-tree-get-branch archive category branch)))) (defun tla--revlib-tree-build-versions (archive category branch &optional use-cache ignore-error) "Build the versions list in ARCHIVE/CATEGORY/BRANCH in `tla--archive-tree'. If USE-CACHE is non-nil, load from the cache where possible. If IGNORE-ERROR is non-nil, error is not reported. Return non-nil if the tree entry for versions are updated." (when (or (not use-cache) (not (cdr (tla--revlib-tree-get-branch archive category branch)))) (tla--run-tla-sync (list "library-versions" (tla--name-construct archive category branch)) :finished 'dvc-null-handler :error (if ignore-error 'dvc-null-handler 'dvc-default-error-function)) (with-current-buffer dvc-last-process-buffer (let (version (tmp tla--archive-tree) (tla--archive-tree tla--revlib-tree) result) (goto-char (point-min)) (while (> (line-end-position) (line-beginning-position)) (setq result t) (setq version (buffer-substring-no-properties (line-beginning-position) (line-end-position))) (forward-line 1) (tla--archive-tree-add-version archive category branch (tla--name-version (tla--name-split-semi-qualified version)))) (setq tla--revlib-tree tla--archive-tree tla--archive-tree tmp) result)))) (defun tla--revlib-tree-get-revision (archive category branch version revision) "Get ARCHIVE/CATEGORY--BRANCH--VERSION--REVISION from the revlib tree." (assoc revision (cdr (tla--revlib-tree-get-version archive category branch version)))) (defun tla--revlib-tree-build-revisions (archive category branch version &optional use-cache ignore-error) "Build the revision list of ARCHIVE/CATEGORY--BRANCH--VERSION. Updates `tla--revlib-tree'. If IGNORE-ERROR is non-nil, error is not reported. Return non-nil if the tree entry for revisions are updated." (when (or (not use-cache) (not (cdr (tla--revlib-tree-get-version archive category branch version)))) (tla--run-tla-sync (list "library-revisions" (tla--name-construct archive category branch version)) :finished 'dvc-null-handler :error (if ignore-error 'dvc-null-handler 'dvc-default-error-function)) (with-current-buffer dvc-last-process-buffer (let (revision (tmp tla--archive-tree) (tla--archive-tree tla--revlib-tree) result) (goto-char (point-min)) (while (> (line-end-position) (line-beginning-position)) (setq result t) (setq revision (buffer-substring-no-properties (line-beginning-position) (line-end-position))) (forward-line 1) (tla--archive-tree-add-revision archive category branch version revision)) (setq tla--revlib-tree tla--archive-tree tla--archive-tree tmp) result )))) ;; ---------------------------------------------------------------------------- ;; Name reading engine ;; ---------------------------------------------------------------------------- ;;Currently only able to read a full revision starting from nothing. (defun tla-name-read-refresh-cache () "Function to be called from the minibuffer while reading a name." (interactive) (tla--archive-tree-build (tla--name-construct (butlast (delete nil (tla--name-split (minibuffer-contents)))))) (setq tla--archive-tree nil)) (defvar tla--name-read-arguments "This value should not be refereed." "Used to suppress warnings from the byte code compiler. This variable is a just placeholder introduced to suppress the warnings from byte code compiler. Variable `tla--name-read-arguments' should be bound in `let'. Variable `tla--name-read-arguments' is used for passing information from `tla-name-read' to functions called internally from `tla-name-read'. Use function `tla--name-read-arguments' to get the information") (defun tla--name-read-arguments (key) "Get `tla-name-read' context information associated to KEY. `tla-name-read' calls some functions to read a tla name. In the functions, the arguments passed to `tla-name-read'(context information) are needed to know. However, `tla-name-read' cannot pass the context information directly to the functions because the functions are something to do with Emacs's completion mechanism; and the mechanism specifies the number of arguments of the functions. So the context information is passed via a local variable, `tla--name-read-arguments', defined in let. Symbol `archive', `category', `branch', `version', or `revision' are acceptable as KEY." (cdr (assoc key tla--name-read-arguments))) (defun tla--name-read-complete (string predicate what) "Completion function for name reading. Displays STRING and prompts for something satisfying PREDICATE. This function uses the free variables archive, category, branch, version, and revision. If one of these variables is non-nil, it means the corresponding value must be read from keyboard. REMINDER: this function may be called several times, with different values for WHAT: - nil : The function must return the longest prefix - t : The function must return the list of completions - 'lambda : The function must return t if the completion correspond to an exact match, nil otherwise. (so that Emacs can distinguish between \"sole completion\" and \"complete, but not unique\"." (if (and (eq what 'lambda) (string-match "/\\(.*--\\)?$" string)) ;; The caller just want to know whether this is a full ;; completion. This can not be the case with such suffix. nil (let* ((empty-branch nil) (use-cache (not current-prefix-arg)) (splited (tla--name-split string)) (archive-loc (tla--name-archive splited)) (category-loc (tla--name-category splited)) (branch-loc (tla--name-branch splited)) (version-loc (tla--name-version splited)) (revision-loc (tla--name-revision splited)) (suffix (cond ((and (tla--name-read-arguments 'category) (not category-loc) "/")) ((and (tla--name-read-arguments 'branch) (not branch-loc) "--")) ((and (tla--name-read-arguments 'version) (not version-loc) "--")) ((and (tla--name-read-arguments 'revision) (not revision-loc) "--")) (t nil))) (maybep (cond ((eq 'maybe (tla--name-read-arguments 'category)) t) ((and (eq 'maybe (tla--name-read-arguments 'branch)) archive-loc category-loc) t) ((and (eq 'maybe (tla--name-read-arguments 'version)) archive-loc category-loc branch-loc) t) ((and (eq 'maybe (tla--name-read-arguments 'revision)) archive-loc category-loc branch-loc version-loc) t) (t nil))) (completions (cond ;; If the user started to write a revision ... (revision-loc ;; ... and if the user is supposed to be prompted a ;; revision (when (tla--name-read-arguments 'revision) (let ((dvc-revisions-shows-summary nil) (dvc-revisions-shows-date nil) (dvc-revisions-shows-creator nil)) (tla--archive-tree-build-revisions archive-loc category-loc branch-loc version-loc use-cache t)) (cdr (tla--archive-tree-get-version archive-loc category-loc branch-loc version-loc)))) (version-loc (when (tla--name-read-arguments 'version) (tla--archive-tree-build-versions archive-loc category-loc branch-loc use-cache t) (cdr (tla--archive-tree-get-branch archive-loc category-loc branch-loc)))) ;; If the user started a branch ... (branch-loc ;; And a branch is needed (when (tla--name-read-arguments 'branch) (tla--archive-tree-build-branches archive-loc category-loc use-cache t) (let ((result (cdr (tla--archive-tree-get-category archive-loc category-loc)))) (when (and (string= branch-loc "") (tla--name-read-arguments 'version) (let ((empty-br-exists nil)) (dolist (branch (cdr (tla--archive-tree-get-category archive-loc category-loc))) (when (string= (car branch) "") (setq empty-br-exists t))) empty-br-exists)) (tla--archive-tree-build-versions archive-loc category-loc "") (setq empty-branch (tla--archive-tree-get-branch archive-loc category-loc "")) (when empty-branch ;; Remove the "" branch to avoid the ---- ;; completion. (let ((tmp result)) (setq result nil) (while tmp (when (not (string= (caar tmp) "")) (setq result (cons (car tmp) result))) (setq tmp (cdr tmp)))))) result))) (category-loc (when (tla--name-read-arguments 'category) (tla--archive-tree-build-categories archive-loc use-cache t) (cddr (tla--archive-tree-get-archive archive-loc)))) (t (when (tla--name-read-arguments 'archive) (tla--archive-tree-build-archives use-cache t) tla--archive-tree))))) (let* ((base (mapcar (lambda (x) (tla--name-construct (delete nil (list (when category-loc archive-loc) (when branch-loc category-loc) (when version-loc branch-loc) (when revision-loc version-loc) (car x))))) completions)) (sans-suffix (and maybep suffix)) (empty-branch-versions (and empty-branch (mapcar (lambda (x) (tla--name-construct archive-loc category-loc "" (car x))) (cdr empty-branch)))) (completions (funcall 'all-completions string (nconc (mapcar (lambda (x) (list (concat x suffix))) base) (when sans-suffix (mapcar (lambda (x) (list x)) base)) (when empty-branch (mapcar (lambda (x) (list x)) empty-branch-versions))) predicate))) (let ((result (cond ((eq what t) ;; We just want the list of completions completions) ((eq (length completions) 1) ;; There's only one completion (if (eq what 'lambda) (string= (car completions) string) (cond ((string= (car completions) string) t) (t (car completions))))) ;; there are several possible completions (t (if (eq what 'lambda) ;; complete, but not unique ? (member string completions) (try-completion string (mapcar 'list completions))))))) ;; (dvc-trace "string=%s predicate=%S what=%s ==> result=%S\ncompletions=%S" ;; string predicate what result completions) result))))) (defconst tla-part-of-name-regex "\\([^/ \t\n-]\\|-[^-]\\)+") ;;;###autoload (defun tla-make-name-regexp (level slash-mandatory exact) "Make a regexp for an Arch name (archive, category, ...). LEVEL can be 0 (archive), 1 (category), 2 (branch), 3 (version) or 4 (revision). If SLASH-MANDATORY is non-nil, the '/' after the archive name is mandatory. (allows to distinguish between Arch archives and emails. If EXACT is non-nil, match exactly LEVEL." (let ((qmark (if exact "" "?"))) (concat "\\([^/@ \t\n]+" "@" "[^/ \t\n]+" ;; email "\\(--" "[^/ \t\n]+\\)?" ;; suffix (not mandatory) (when (>= level 1) (concat "/\\(" ;; Separator archive/category tla-part-of-name-regex ;; category (when (>= level 2) (concat "\\(" "--" tla-part-of-name-regex ;; branch (when (>= level 3) (concat "\\(" "--" "[0-9]+[.0-9]*" ;; version (when (>= level 4) (concat "\\(" "--" "\\(base\\|patch\\|version\\|versionfix\\)-[0-9]+" ;; patch "\\)" qmark)) "\\)" qmark)) "\\)" qmark)) "\\)" qmark)) "\\)" ;; end of group (when (and slash-mandatory (< level 1)) "/") "\\( \\|\n\\|:\\)"))) (defun tla-get-name-at-point () "Provides a default value for tla-name-read. It first looks, if a name is found near point. If this does not succeed, use the revision at point, when in tla-changelog-mode." (interactive) (let ((name)) (save-excursion (if (re-search-backward "[ \t\n]" (point-min) t) (goto-char (1+ (point))) (beginning-of-line)) (when (looking-at (tla-make-name-regexp 4 nil nil)) (setq name (match-string 1)))) (unless name (when (eq major-mode 'tla-changelog-mode) (setq name (tla-changelog-revision-at-point)))) name)) ;; Test cases ;; (tla-name-read "enter category: " "Matthieu.Moy@imag.fr--public" 'prompt) ;; (tla-name-read "branch: " "lord@emf.net--2004" 'prompt 'prompt) ;; (tla-name-read "revision: " 'prompt 'prompt 'prompt 'prompt 'prompt) ;; (tla-name-read "revision or version: " 'prompt 'prompt 'prompt 'prompt 'maybe) ;; (tla-name-read "revision or version: " "jet@gyve.org--xtla" "xtla" "jet" 'prompt 'maybe) ;; (defvar tla--name-read-history nil) ; TODO: multiple history list? (defvar tla--name-read-debug nil "If non-nil, `condition-case' in `tla-name-read' is made disabled.") (defun tla-name-read (&optional prompt archive category branch version revision) "Read a name. To get help on the user interface of `tla-name-read', please type M-x tla-name-read-help RET. Function reading an archive location from keyboard. Read name is expressed in a list built by `tla--name-split'. First argument PROMPT is the prompt the user will get. Next arguments ARCHIVE CATEGORY BRANCH VERSION and REVISION are either the default value, or a request for a value. They can take four values: - A string means the default value, and will be used as an initial input. - The symbol 'prompt means the value will be prompted from the user. The user will HAVE to give this value. - The symbol 'maybe means the value will be prompted, but is optional for the user. - nil means the value won't be prompted. They should appear in the same order as above. Example: - Read a category in archive \"Matthieu.Moy@imag.fr--public\": (tla-name-read \"enter category: \" \"Matthieu.Moy@imag.fr--public\" 'prompt) - Read a revision, anywhere: (tla-name-read \"revision: \" 'prompt 'prompt 'prompt 'prompt 'prompt) - Read either a revision or a version: (tla-name-read \"revision: \" 'prompt 'prompt 'prompt 'prompt 'maybe) While prompting, a menu \"Xtla\" is added to the menubar. The following commands are available: \\{tla--name-read-minibuf-map}" ;; use the defaults found under point if no defaults have been provided (let ((l (tla-get-name-at-point))) (when l (setq l (tla--name-split l)) (if (and archive (symbolp archive)) (setq archive (or (nth 0 l) archive))) (if (and category (symbolp category)) (setq category (or (nth 1 l) category))) (if (and branch (symbolp branch)) (setq branch (or (nth 2 l) branch))) (if (and version (symbolp version)) (setq version (or (nth 3 l) version))) (if (and revision (symbolp revision)) (setq revision (or (nth 4 l) revision))))) (let ((tla--name-read-arguments `((archive . ,archive) (category . ,category) (branch . ,branch) (version . ,version) (revision . ,revision)))) (if tla--name-read-debug (tla--name-read-internal prompt archive category branch version revision) (condition-case reason (tla--name-read-internal prompt archive category branch version revision) ((quit error) (run-hooks 'tla-name-read-error-hook) (signal (car reason) (cdr reason))))))) (defun tla--name-read-internal (prompt archive category branch version revision) "See `tla-name-read'." (run-hooks 'tla-name-read-init-hook) (let* ((minibuffer-local-completion-map tla--name-read-minibuf-map) (result (tla--name-construct (delete 'maybe (delete 'prompt (list archive category branch version revision))))) (first-try t) not-finished too-long last-empty) ;; Without in some case 'maybe is ignored by tla--prompt-not-finished ;; and never the control flow enters the while loop. ;; We need C language's do-while loop. (while (or first-try not-finished too-long last-empty) (unless first-try (unless (eq this-command 'choose-completion) (ding) (message (cond (not-finished "%s%s [incomplete input: %s]") (too-long "%s%s [too long input for: %s]") (last-empty (concat "%s%s [empty " last-empty " name]")) (t (error (concat "case not managed." " Please submit a bug report")))) prompt result (tla--name-read-required-input archive category branch version revision)) (sit-for 2) (message nil))) (setq result (dvc-completing-read (or prompt "Location: ") 'tla--name-read-complete nil nil result 'tla--name-read-history) first-try nil) (setq not-finished (tla--prompt-not-finished result archive category branch version revision)) (setq too-long (tla--prompt-too-long result archive category branch version revision)) (setq last-empty (tla--prompt-last-empty result))) (when result (setq result (tla--name-split result))) (run-hook-with-args 'tla-name-read-final-hook result) result)) (defun tla--prompt-not-finished (result archive category branch version revision) "Check whether user input is complete. True if RESULT (a string) is not sufficient when the user is prompted for ARCHIVE CATEGORY BRANCH VERSION REVISION." (let ((res-split (tla--name-split result))) (or (and (eq archive 'prompt) ;; archive required (not (tla--name-archive res-split))) ;; but not provided (and (eq category 'prompt) (not (tla--name-category res-split))) (and (eq branch 'prompt) (not (tla--name-branch res-split))) (and (eq version 'prompt) (not (tla--name-version res-split))) (and (eq revision 'prompt) (not (tla--name-revision res-split)))))) (defun tla--prompt-too-long (result archive category branch version revision) "Check whether the user has entered too many elements. True if RESULT (a string) contains too many elements when the user is prompted for ARCHIVE CATEGORY BRANCH VERSION REVISION. For example, will return true if the user entered foo@bar--2004/xtla--main while prompted only for a category." (let ((res-split (tla--name-split result))) (or (and (not revision) ;; revision not needed (tla--name-revision res-split)) ;; but provided (and (not version) (tla--name-version res-split)) (and (not branch) (tla--name-branch res-split)) (and (not category) (tla--name-category res-split)) (and (not archive) (tla--name-archive res-split))))) (defun tla--prompt-last-empty (result) "Check whether the last field is empty. Non-nil if RESULT (a string) is terminated by \"--\" or \"/\". This means the user entered a delimiter but not the element after. When non-nil, the returned value is a string giving the name of the item that is currently empty. (eg: archive, category, ...)" (let ((res-split (tla--name-split result))) (cond ((equal (tla--name-archive res-split) "") "archive" ) ((equal (tla--name-category res-split) "") "category") ((and (equal (tla--name-branch res-split) "") (not (tla--name-version res-split))) "branch" ) ((equal (tla--name-version res-split) "") "version" ) ((equal (tla--name-revision res-split) "") "revision") (t nil)))) (defun tla--name-read-required-input (archive category branch version revision) "Return string which represents the elements to be readin `tla-name-read'. If ARCHIVE, CATEGORY, BRANCH, VERSION or REVISION are equal to 'maybe, the corresponding element will be optionally read. If any of these are non-nil (but not 'maybe), the corresponding element will be required. If any of these are nil, the correpsonding element is not required." (concat (cond ((eq archive 'maybe) "[A]") (archive "A") (t "")) (cond ((eq category 'maybe) "[/C]") (category "/C") (t "")) (cond ((eq branch 'maybe) "[--B]") (branch "--B") (t "")) (cond ((eq version 'maybe) "[--V]") (version "--V") (t "")) (cond ((eq revision 'maybe) "[--R]") (revision "--R") (t "")))) (defun tla--location-type (location) "Return the type of LOCATION." (cond ((string-match "^ftp://" location) 'ftp) ((string-match "^sftp://" location) 'sftp) ((string-match "^http://" location) 'http) (t 'local))) (defun tla--archive-type (archive) "Return the type of ARCHIVE." (cond ((string-match "SOURCE$" archive) 'source) ;; archive-MIRROR, archive-MIRROR-2 should be treated as mirror ((string-match ".+-MIRROR" archive) 'mirror) (t 'normal))) ;; (tla--archive-name-source "a") ;; (tla--archive-name-source "a-SOURCE") ;; (tla--archive-name-source "a-MIRROR") (defun tla--archive-name-source (archive &optional existence-check) "Make source archive name from ARCHIVE. If EXISTENCE-CHECK is non-nil, check whether the made source archive name already exists or not; return nil if it doesn't exists. Example: ELISP> (tla--archive-name-source \"jet@gyve.org--xtla\") \"jet@gyve.org--xtla-SOURCE\" ELISP> (tla--archive-name-source \"jet@gyve.org--xtla-MIRROR\") \"jet@gyve.org--xtla\" ELISP> (tla--archive-name-source \"jet@gyve.org--xtla-SOURCE\") nil" (let* ((type (tla--archive-type archive)) (source (cond ((eq 'normal type) (concat archive "-SOURCE")) ((eq 'mirror type) (string-match "\\(.*\\)-MIRROR$" archive) (match-string 1 archive)) (t nil)))) (if existence-check (progn (tla--archive-tree-build-archives t) (when (and source (tla--archive-tree-get-archive source)) source)) source))) ;; (tla--archive-name-mirror "a") ;; (tla--archive-name-mirror "a-SOURCE") ;; (tla--archive-name-mirror "a-MIRROR") (defun tla--archive-name-mirror (archive &optional existence-check) "Make mirror archive name from ARCHIVE. If EXISTENCE-CHECK is non-nil, check whether the made mirror archive name already exists or not; return nil if it doesn't exists. Example: ELISP> (tla--archive-name-mirror \"jet@gyve.org--xtla\") \"jet@gyve.org--xtla-MIRROR\" ELISP> (tla--archive-name-mirror \"jet@gyve.org--xtla-SOURCE\") \"jet@gyve.org--xtla\" ELISP> (tla--archive-name-mirror \"jet@gyve.org--xtla-MIRROR\") nil" (let* ((type (tla--archive-type archive)) (mirror (cond ((eq 'normal type) (concat archive "-MIRROR")) ((eq 'source type) (string-match "\\(.*\\)-SOURCE" archive) (match-string 1 archive)) (t nil)))) (if existence-check (progn (tla--archive-tree-build-archives t) (when (and mirror (tla--archive-tree-get-archive mirror)) mirror)) mirror))) (defun tla-revision-direct-ancestor (&optional revision num) "Compute the direct ancestor of REVISION. REVISION must be provided as a list, and a list is returned. If revision is nil, return the ancestor of the last revision of the local tree." (interactive (list (tla-name-read "Compute direct ancestor of: " 'prompt 'prompt 'prompt 'prompt 'prompt))) (let ((ancestor (tla--run-tla-sync (list "ancestry-graph" "--immediate" (and revision (tla--name-construct revision))) :finished (lambda (output error status arguments) (tla--name-split (dvc-buffer-content output)))))) (when (interactive-p) (message "Ancestor of: %s\n is: %s" (tla--name-construct ancestor) (tla--name-construct revision))) (if (or (eq num 1) (eq num nil)) ancestor (tla-revision-direct-ancestor ancestor (- num 1))))) ;; Copied from ediff-mouse-event-p. I prefer keeping this duplication ;; to avoid one more dependancy on ediff.el (whose interface may ;; change one day ...) (defsubst tla--mouse-event-p (event) "Return true if EVENT is a mouse-related event." (if (featurep 'xemacs) (dvc-do-in-xemacs (button-event-p event)) (dvc-do-in-gnu-emacs (string-match "mouse" (format "%S" (event-basic-type event)))))) (defun tla-escape (string &optional unescape message) "Return the pika escaped value of STRING. If pika escaping is not supported by tla, return STRING. If UNESCAPE is non-nil, returns the unescaped version of string. If MESSAGE is non-nil or if run interactively, also display the value as a message." (interactive "sString to escape: ") (let ((res (if (and (string-match (if unescape "\\\\" "[^a-zA-Z._+,{}-]") string) (tla-has-escape-command)) ;; We need to do the (un)escaping (tla--run-tla-sync (list "escape" (when unescape "--unescaped") string) :finished (lambda (output error status arguments) (dvc-buffer-content output))) string))) (when (or (interactive-p) message) (message res)) res)) (defun tla-unescape (string) "Run \"tla escape --unescaped\" on STRING. Return STRING if \"tla escape\" is not available." (interactive "sString to unescape: ") (when string (tla-escape string t (interactive-p)))) ;; ---------------------------------------------------------------------------- ;; Saving and loading state variables ;; ---------------------------------------------------------------------------- ;; (setq tla--archive-tree nil) ;; (setq tla--revlib-tree nil) (provide 'tla-core) ;;; tla-core.el ends here