diff options
| -rw-r--r-- | lisp/vc/vc-cvs.el | 204 | ||||
| -rw-r--r-- | test/lisp/vc/vc-cvs-tests.el | 107 |
2 files changed, 246 insertions, 65 deletions
diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index 6e0246ea762..b826390a034 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -26,6 +26,7 @@ (require 'vc-rcs) (eval-when-compile (require 'vc)) +(eval-when-compile (require 'cl-lib)) (require 'log-view) (declare-function vc-checkout "vc" (file &optional rev)) @@ -813,7 +814,10 @@ individually should stay local." 'yes 'no)))))))))))) (defun vc-cvs-repository-hostname (dirname) - "Hostname of the CVS server associated to workarea DIRNAME." + "Hostname of the CVS server associated to workarea DIRNAME. + +Returns nil if there is not hostname or the hostname could not be +determined because the CVS/Root specification is invalid." (let ((rootname (expand-file-name "CVS/Root" dirname))) (when (file-readable-p rootname) (with-temp-buffer @@ -822,73 +826,143 @@ individually should stay local." default-file-name-coding-system))) (vc-insert-file rootname)) (goto-char (point-min)) - (nth 2 (vc-cvs-parse-root - (buffer-substring (point) - (line-end-position)))))))) - -(defun vc-cvs-parse-uhp (path) - "Parse user@host/path into (user@host /path)." - (if (string-match "\\([^/]+\\)\\(/.*\\)" path) - (list (match-string 1 path) (match-string 2 path)) - (list nil path))) - -(defun vc-cvs-parse-root (root) - "Split CVS ROOT specification string into a list of fields. -A CVS root specification of the form - [:METHOD:][[USER@]HOSTNAME]:?/path/to/repository + (let ((hostname + (nth 2 (vc-cvs-parse-root + (buffer-substring (point) + (line-end-position)))))) + (unless (string= hostname "") + hostname)))))) + +(cl-defun vc-cvs-parse-root (root) + "Split CVS Root specification string into a list of fields. + +A CVS Root specification of the form + [:METHOD:][[[USER][:PASSWORD]@]HOSTNAME][:[PORT]]/pathname/to/repository is converted to a normalized record with the following structure: - \(METHOD USER HOSTNAME CVS-ROOT). + \(METHOD USER HOSTNAME PATHNAME). + The default METHOD for a CVS root of the form - /path/to/repository -is `local'. + /pathname/to/repository +is \"local\". The default METHOD for a CVS root of the form - [USER@]HOSTNAME:/path/to/repository -is `ext'. -For an empty string, nil is returned (invalid CVS root)." - ;; Split CVS root into colon separated fields (0-4). - ;; The `x:' makes sure, that leading colons are not lost; - ;; `HOST:/PATH' is then different from `:METHOD:/PATH'. - (let* ((root-list (cdr (split-string (concat "x:" root) ":"))) - (len (length root-list)) - ;; All syntactic varieties will get a proper METHOD. - (root-list - (cond - ((= len 0) - ;; Invalid CVS root - nil) - ((= len 1) - (let ((uhp (vc-cvs-parse-uhp (car root-list)))) - (cons (if (car uhp) "ext" "local") uhp))) - ((= len 2) - ;; [USER@]HOST:PATH => method `ext' - (and (not (equal (car root-list) "")) - (cons "ext" root-list))) - ((= len 3) - ;; :METHOD:PATH or :METHOD:USER@HOSTNAME/PATH - (cons (cadr root-list) - (vc-cvs-parse-uhp (nth 2 root-list)))) - (t - ;; :METHOD:[USER@]HOST:PATH - (cdr root-list))))) - (if root-list - (let ((method (car root-list)) - (uhost (or (cadr root-list) "")) - (root (nth 2 root-list)) - user host) - ;; Split USER@HOST - (if (string-match "\\(.*\\)@\\(.*\\)" uhost) - (setq user (match-string 1 uhost) - host (match-string 2 uhost)) - (setq host uhost)) - ;; Remove empty HOST - (and (equal host "") - (setq host nil)) - ;; Fix windows style CVS root `:local:C:\\project\\cvs\\some\\dir' - (and host - (equal method "local") - (setq root (concat host ":" root) host nil)) - ;; Normalize CVS root record - (list method user host root))))) + [USER@]HOSTNAME:/pathname/to/repository +is \"ext\". + +If METHOD is explicitly \"local\" or \"fork\", then the pathname +starts immediately after the method block. This must be used on +Windows platforms when pathnames start with a drive letter. + +Note that, except for METHOD, which is defaulted if not present, +other optional fields are returned as nil if not syntactically +present, or as the empty string if delimited but empty. + +Returns nil in case of an unparsable CVS root (including the +empty string) and issues a warning. This function doesn't check +that an explicit method is valid, or that some fields are empty +or nil but should not for a given method." + (let (method user password hostname port pathname + ;; IDX set by `next-delim' as a side-effect + idx) + (cl-labels + ((invalid (reason &rest args) + (apply #'lwarn '(vc-cvs) :warning + (concat "vc-cvs-parse-root: Can't parse '%s': " reason) + root args) + (cl-return-from vc-cvs-parse-root)) + (no-pathname () + (invalid "No pathname")) + (next-delim (start) + ;; Search for a :, @ or /. If none is found, there can be + ;; no path at the end, which is an error. + (setq idx (string-match-p "[:@/]" root start)) + (if idx (aref root idx) (no-pathname))) + (grab-user (start end) + (setq user (substring root start end))) + (at-hostname-block (start) + (let ((cand (next-delim start))) + (cl-ecase cand + (?: + ;; Could be : before PORT and PATHNAME, or before + ;; PASSWORD. We search for a @ to disambiguate. + (let ((colon-idx idx) + (cand (next-delim (1+ idx)))) + (cl-ecase cand + (?: + (invalid + (eval-when-compile + (concat "Hostname block: Superfluous : at %s " + "or missing @ before")) + idx)) + (?@ + ;; USER:PASSWORD case + (grab-user start colon-idx) + (delimited-password (1+ colon-idx) idx)) + (?/ + ;; HOSTNAME[:[PORT]] case + (grab-hostname start colon-idx) + (delimited-port (1+ colon-idx) idx))))) + (?@ + (grab-user start idx) + (at-hostname (1+ idx))) + (?/ + (if (/= idx start) + (grab-hostname start idx)) + (at-pathname idx))))) + (delimited-password (start end) + (setq password (substring root start end)) + (at-hostname (1+ end))) + (grab-hostname (start end) + (setq hostname (substring root start end))) + (at-hostname (start) + (let ((cand (next-delim start))) + (cl-ecase cand + (?: + (grab-hostname start idx) + (at-port (1+ idx))) + (?@ + (invalid "Hostname: Unexpected @ after index %s" start)) + (?/ + (grab-hostname start idx) + (at-pathname idx))))) + (delimited-port (start end) + (setq port (substring root start end)) + (at-pathname end)) + (at-port (start) + (let ((end (string-match-p "/" root start))) + (if end (delimited-port start end) (no-pathname)))) + (at-pathname (start) + (setq pathname (substring root start)))) + (when (string= root "") + (invalid "Empty string")) + ;; Check for a starting ":" + (if (= (aref root 0) ?:) + ;; 3 possible cases: + ;; - :METHOD: at start. METHOD doesn't have any @. + ;; - :PASSWORD@ at start. Must be followed by HOSTNAME. + ;; - :[PORT] at start. Must be followed immediately by a "/". + ;; So, find the next character equal to ":", "@" or "/". + (let ((cand (next-delim 1))) + (cl-ecase cand + (?: + ;; :METHOD: case + (setq method (substring root 1 idx)) + ;; Continue + (if (member method '("local" "fork")) + (at-pathname (1+ idx)) + (at-hostname-block (1+ idx)))) + (?@ + ;; :PASSWORD@HOSTNAME case + (delimited-password 1 idx)) + (?/ + ;; :[PORT] case. + (at-port 1 idx)))) + ;; No starting ":", there can't be any METHOD. + (at-hostname-block 0))) + (unless method + ;; Default the method if not specified + (setq method + (if (or user password hostname port) "ext" "local"))) + (list method user hostname pathname))) ;; XXX: This does not work correctly for subdirectories. "cvs status" ;; information is context sensitive, it contains lines like: diff --git a/test/lisp/vc/vc-cvs-tests.el b/test/lisp/vc/vc-cvs-tests.el new file mode 100644 index 00000000000..99ac9c8eb96 --- /dev/null +++ b/test/lisp/vc/vc-cvs-tests.el @@ -0,0 +1,107 @@ +;;; vc-cvs-tests.el --- tests for vc/vc-cvs.el -*- lexical-binding:t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Olivier Certner <olce.emacs@certner.fr> +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'vc-cvs) + +(ert-deftest vc-cvs-test-parse-root--local-no-method () + (vc-cvs-test--check-parse-root + "/home/joe/repo" + '("local" nil nil "/home/joe/repo"))) + +(ert-deftest vc-cvs-test-parse-root--local-windows-drive-letter () + (vc-cvs-test--check-parse-root + ":local:c:/users/joe/repo" + '("local" nil nil "c:/users/joe/repo"))) + +(ert-deftest vc-cvs-test-parse-root--ext-no-method-host-no-port-colon () + (vc-cvs-test--check-parse-root + "host/home/serv/repo" + '("ext" nil "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--pserver-host-no-port-colon () + (vc-cvs-test--check-parse-root + ":pserver:host/home/serv/repo" + '("pserver" nil "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--pserver-host-port-colon () + (vc-cvs-test--check-parse-root + ":pserver:host:/home/serv/repo" + '("pserver" nil "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--ext-no-method-user-host-no-port-colon () + (vc-cvs-test--check-parse-root + "usr@host/home/serv/repo" + '("ext" "usr" "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--ext-no-method-user-host-port-colon () + (vc-cvs-test--check-parse-root + "usr@host:/home/serv/repo" + '("ext" "usr" "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--pserver-user-password-host-no-port-colon () + (vc-cvs-test--check-parse-root + ":pserver:usr:passwd@host/home/serv/repo" + '("pserver" "usr" "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--pserver-user-password-host-port-colon () + (vc-cvs-test--check-parse-root + ":pserver:usr:passwd@host:/home/serv/repo" + '("pserver" "usr" "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--pserver-user-password-host-port () + (vc-cvs-test--check-parse-root + ":pserver:usr:passwd@host:28/home/serv/repo" + '("pserver" "usr" "host" "/home/serv/repo"))) + +;; Next 3 tests are just to err on the side of caution. It doesn't +;; seem that CVS 1.12 can ever produce such lines. + +(ert-deftest + vc-cvs-test-parse-root--ext-no-method-user-password-host-no-port-colon + () + (vc-cvs-test--check-parse-root + "usr:passwd@host/home/serv/repo" + '("ext" "usr" "host" "/home/serv/repo"))) + +(ert-deftest + vc-cvs-test-parse-root--ext-no-method-user-password-host-port-colon + () + (vc-cvs-test--check-parse-root + "usr:passwd@host:/home/serv/repo" + '("ext" "usr" "host" "/home/serv/repo"))) + +(ert-deftest + vc-cvs-test-parse-root--ext-no-method-user-password-host-port + () + (vc-cvs-test--check-parse-root + "usr:passwd@host:28/home/serv/repo" + '("ext" "usr" "host" "/home/serv/repo"))) + + +(defun vc-cvs-test--check-parse-root (input expected-output) + (should (equal (vc-cvs-parse-root input) expected-output))) + +;;; vc-cvs-tests.el ends here |