(eval-when-compile (require 'cl))
(require 'pcvs-util)
(require 'pcvs-info)
(defvar cvs-execute-single-dir)
(defcustom cvs-update-prog-output-skip-regexp "$"
"*A regexp that matches the end of the output from all cvs update programs.
That is, output from any programs that are run by CVS (by the flag -u
in the `modules' file - see cvs(5)) when `cvs update' is performed should
terminate with a line that this regexp matches. It is enough that
some part of the line is matched.
The default (a single $) fits programs without output."
:group 'pcl-cvs
:type '(regexp :value "$"))
(defcustom cvs-parse-ignored-messages
'("Executing ssh-askpass to query the password.*$"
".*Remote host denied X11 forwarding.*$")
"*A list of regexps matching messages that should be ignored by the parser.
Each regexp should match a whole set of lines and should hence be terminated
by `$'."
:group 'pcl-cvs
:type '(repeat regexp))
(defvar cvs-start)
(defvar cvs-current-dir)
(defvar cvs-current-subdir)
(defvar dont-change-disc)
(defconst cvs-parse-known-commands
'("status" "add" "commit" "update" "remove" "checkout" "ci")
"List of CVS commands whose output is understood by the parser.")
(defun cvs-parse-buffer (parse-spec dont-change-disc &optional subdir)
"Parse current buffer according to PARSE-SPEC.
PARSE-SPEC is a function of no argument advancing the point and returning
either a fileinfo or t (if the matched text should be ignored) or
nil if it didn't match anything.
DONT-CHANGE-DISC just indicates whether the command was changing the disc
or not (useful to tell the difference between `cvs-examine' and `cvs-update'
output.
The path names should be interpreted as relative to SUBDIR (defaults
to the `default-directory').
Return a list of collected entries, or t if an error occurred."
(goto-char (point-min))
(let ((fileinfos ())
(cvs-current-dir "")
(case-fold-search nil)
(cvs-current-subdir (or subdir "")))
(while (not (or (eobp) (eq fileinfos t)))
(let ((ret (cvs-parse-run-table parse-spec)))
(cond
((cvs-fileinfo-p ret) (push ret fileinfos))
((and (consp ret) (cvs-fileinfo-p (car ret)))
(setq fileinfos (append ret fileinfos)))
((null ret) (setq fileinfos t))
(t nil))))
(nreverse fileinfos)))
(defsubst cvs-parse-msg () (buffer-substring cvs-start (1- (point))))
(defmacro cvs-match (re &rest matches)
"Try to match RE and extract submatches.
If RE matches, advance the point until the line after the match and
then assign the variables as specified in MATCHES (via `setq')."
(cons 'cvs-do-match
(cons re (mapcar (lambda (match)
`(cons ',(first match) ,(second match)))
matches))))
(defun cvs-do-match (re &rest matches)
"Internal function for the `cvs-match' macro.
Match RE and if successful, execute MATCHES."
(when (looking-at re)
(goto-char (match-end 0))
(when (and (eolp) (< (point) (point-max))) (forward-char))
(dolist (match matches t)
(let ((val (cdr match)))
(set (car match) (if (integerp val) (match-string val) val))))))
(defmacro cvs-or (&rest alts)
"Try each one of the ALTS alternatives until one matches."
`(let ((-cvs-parse-point (point)))
,(cons 'or
(mapcar (lambda (es)
`(or ,es (ignore (goto-char -cvs-parse-point))))
alts))))
(def-edebug-spec cvs-or t)
(defun cvs-parse-run-table (parse-spec)
"Run PARSE-SPEC and provide sensible default behavior."
(unless (bolp) (forward-line 1)) (let ((cvs-start (point)))
(cvs-or
(funcall parse-spec)
(dolist (re cvs-parse-ignored-messages)
(when (cvs-match re) (return t)))
(and
(cvs-match ".*$")
(cvs-create-fileinfo 'MESSAGE cvs-current-dir " "
(cvs-parse-msg) :subtype 'ERROR)))))
(defun cvs-parsed-fileinfo (type path &optional directory &rest keys)
"Create a fileinfo.
TYPE can either be a type symbol or a cons of the form (TYPE . SUBTYPE).
PATH is the filename.
DIRECTORY influences the way PATH is interpreted:
- if it's a string, it denotes the directory in which PATH (which should then be
a plain file name with no directory component) resides.
- if it's nil, the PATH should not be trusted: if it has a directory
component, use it, else, assume it is relative to the current directory.
- else, the PATH should be trusted to be relative to the root
directory (i.e. if there is no directory component, it means the file
is inside the main directory).
The remaining KEYS are passed directly to `cvs-create-fileinfo'."
(let ((dir directory)
(file path))
(unless (stringp directory)
(setq dir (or (file-name-directory path) (if directory "")))
(setq file (file-name-nondirectory path)))
(let ((type (if (consp type) (car type) type))
(subtype (if (consp type) (cdr type))))
(when dir (setq cvs-current-dir dir))
(apply 'cvs-create-fileinfo type
(concat cvs-current-subdir (or dir cvs-current-dir))
file (cvs-parse-msg) :subtype subtype keys))))
(defun cvs-parse-table ()
"Table of message objects for `cvs-parse-process'."
(let (c file dir path type base-rev subtype)
(cvs-or
(cvs-parse-status)
(cvs-parse-merge)
(cvs-parse-commit)
(and
(cvs-match "\\([MARCUPNJ?]\\) \\(.*\\)$" (c 1) (path 2))
(let ((code (aref c 0)))
(cvs-parsed-fileinfo
(case code
(?M 'MODIFIED)
(?A 'ADDED)
(?R 'REMOVED)
(?? 'UNKNOWN)
(?C
(if (not dont-change-disc) 'CONFLICT
(with-temp-buffer
(insert-file-contents path)
(goto-char (point-min))
(if (re-search-forward "^<<<<<<< " nil t)
'CONFLICT 'NEED-MERGE))))
(?J 'NEED-MERGE) ((?U ?P)
(if dont-change-disc 'NEED-UPDATE
(cons 'UP-TO-DATE (if (eq code ?U) 'UPDATED 'PATCHED)))))
path 'trust)))
(and
(cvs-match "pcl-cvs: descending directory \\(.*\\)$" (dir 1))
(setq cvs-current-subdir dir))
(and
(cvs-match "cvs[.ex]* [a-z]+: ")
(cvs-or
(and
(cvs-match "\\(Examining\\|Updating\\) \\(.*\\)$" (dir 2))
(let ((dir (if (string= "." dir) "" (file-name-as-directory dir))))
(cvs-parsed-fileinfo 'DIRCHANGE "." dir)))
(and
(cvs-match "New directory `\\(.*\\)' -- ignored$" (dir 1))
(cvs-parsed-fileinfo 'MESSAGE " " (file-name-as-directory dir)))
(and
(cvs-or
(cvs-match "warning: \\(.*\\) is not (any longer) pertinent$" (file 1))
(cvs-match "\\(.*\\) is no longer in the repository$" (file 1)))
(cvs-parsed-fileinfo 'DEAD file))
(and
(cvs-or
(cvs-match "scheduling file `\\(.*\\)' for addition.*$" (path 1))
(cvs-match "re-adding file \\(.*\\) (in place of .*)$" (path 1)))
(cvs-parsed-fileinfo 'ADDED path))
(and
(cvs-match "\\(.*\\), version \\(.*\\), resurrected$"
(path 1) (base-rev 2))
(cvs-parsed-fileinfo '(UP-TO-DATE . RESURRECTED) path nil
:base-rev base-rev))
(and
(cvs-match "removed `\\(.*\\)'$" (path 1))
(cvs-parsed-fileinfo 'DEAD path))
(and
(cvs-match "scheduling `\\(.*\\)' for removal$" (file 1))
(cvs-parsed-fileinfo 'REMOVED file))
(and
(cvs-match "warning: \\(.*\\) was lost$" (path 1))
(cvs-match (concat "U " (regexp-quote path) "$"))
(cvs-parsed-fileinfo (if dont-change-disc
'MISSING
'(UP-TO-DATE . UPDATED))
path))
(and
(cvs-match "conflict: ")
(cvs-or
(cvs-match "removed \\(.*\\) was modified by second party$"
(path 1) (subtype 'REMOVED))
(cvs-match "\\(.*\\) created independently by second party$"
(path 1) (subtype 'ADDED))
(cvs-match "\\(.*\\) is modified but no longer in the repository$"
(path 1) (subtype 'MODIFIED)))
(cvs-match (concat "C " (regexp-quote path)))
(cvs-parsed-fileinfo (cons 'CONFLICT subtype) path))
(and
(cvs-or
(cvs-match "move away \\(.*\\); it is in the way$" (file 1))
(cvs-match "warning: new-born \\(.*\\) has disappeared$" (file 1))
(cvs-match "sticky tag .* for file `\\(.*\\)' is not a branch$"
(file 1)))
(cvs-parsed-fileinfo 'MESSAGE file))
(and (cvs-match "use `.+ add' to create an entry for \\(.*\\)$" (path 1))
(cvs-parsed-fileinfo 'UNKNOWN path))
(and (cvs-match "Up-to-date check failed for `\\(.+\\)'$" (file 1))
(cvs-parsed-fileinfo 'NEED-MERGE file))
(and (cvs-match ".* files with '?/'? in their name.*$")
(not cvs-execute-single-dir)
(setq cvs-execute-single-dir t)
(cvs-create-fileinfo
'MESSAGE "" " "
"*** Add (setq cvs-execute-single-dir t) to your .emacs ***
See the FAQ file or the variable's documentation for more info."))
(cvs-match "\\[..:..:..\\] \\(waiting for\\|obtained\\) .*lock in .*$")
(cvs-match ".* should be removed and is still there$")
(cvs-match "use '.+ commit' to \\sw+ th\\sw+ files? permanently$")
(cvs-match "nothing known about .*$")
(cvs-match "checksum failure after patch to .*; will refetch$")
(cvs-match "refetching unpatchable files$")
(cvs-match "Rebuilding administrative file database$")
(cvs-match "--> Using per-directory sticky tag `.*'")
(and
(cvs-match "Executing.*$")
(re-search-forward cvs-update-prog-output-skip-regexp))))
(and
(cvs-match "cvs[.ex]* \\[[a-z]+ aborted\\]:.*$")
(cvs-parsed-fileinfo 'MESSAGE ""))
(cvs-match "Directory .* added to the repository$")
)))
(defun cvs-parse-merge ()
(let (path base-rev head-rev handled type)
(and
(cvs-match "RCS file: .*$")
(cvs-match "retrieving revision \\([0-9.]+\\)$" (base-rev 1))
(cvs-match "retrieving revision \\([0-9.]+\\)$" (head-rev 1))
(cvs-match "Merging differences between [0-9.]+ and [0-9.]+ into \\(.*\\)$"
(path 1))
(cvs-or (cvs-match "\\(rcs\\)?merge:?\\( warning\\)?: \\(overlaps\\|conflicts\\) \\(or other problems \\)?during merge$" (type 'CONFLICT)) t)
(cvs-or
(and
(cvs-match "cvs[.ex]* [a-z]+: ")
(cvs-or
(cvs-match "conflicts found in \\(.*\\)$" (path 1) (type 'CONFLICT))
(cvs-match "could not merge .*$")
(cvs-match "restoring \\(.*\\) from backup file .*$" (path 1))))
t)
(let ((qfile (regexp-quote path)))
(cvs-or
(and
(cvs-match (concat "C \\(.*" qfile "\\)$") (path 1) (type 'CONFLICT))
(cvs-or (cvs-match (concat "U \\(.*" qfile "\\)$")) t))
(cvs-match (concat "M \\(.*" qfile "\\)$") (path 1))
(cvs-match (concat "^\\(.*" qfile
"\\) already contains the differences between .*$")
(path 1) (type '(UP-TO-DATE . MERGED)))
t)
(cvs-parsed-fileinfo (if dont-change-disc 'NEED-MERGE
(or type '(MODIFIED . MERGED))) path nil
:merge (cons base-rev head-rev))))))
(defun cvs-parse-status ()
(let (nofile path base-rev head-rev type)
(and
(cvs-match
"===================================================================$")
(cvs-match "File: \\(no file \\)?\\(.*[^ \t]\\)[ \t]+Status: "
(nofile 1) (path 2))
(cvs-or
(cvs-match "Needs \\(Checkout\\|Patch\\)$"
(type (if nofile 'MISSING 'NEED-UPDATE)))
(cvs-match "Up-to-date$"
(type (if nofile '(UP-TO-DATE . REMOVED) 'UP-TO-DATE)))
(cvs-match ".*[Cc]onflict.*$" (type 'CONFLICT))
(cvs-match "Locally Added$" (type 'ADDED))
(cvs-match "Locally Removed$" (type 'REMOVED))
(cvs-match "Locally Modified$" (type 'MODIFIED))
(cvs-match "Needs Merge$" (type 'NEED-MERGE))
(cvs-match "Unknown$" (type 'UNKNOWN)))
(cvs-match "$")
(cvs-or
(cvs-match " *Version:[ \t]*\\([0-9.]+\\).*$" (base-rev 1))
(cvs-match " *Working revision:[ \t]*-?\\([0-9.]+\\).*$" (base-rev 1))
(cvs-match " *Working revision:.*$"))
(cvs-or
(cvs-match " *RCS Version:[ \t]*\\([0-9.]+\\)[ \t]*.*$" (head-rev 1))
(cvs-match " *Repository revision:[ \t]*\\([0-9.]+\\)[ \t]*\\(.*\\)$"
(head-rev 1))
(cvs-match " *Repository revision:.*"))
(cvs-or
(and (cvs-match " *Sticky Tag:[ \t]*\\(.*\\)$") (cvs-match " *Sticky Date:[ \t]*\\(.*\\)$") (cvs-match " *Sticky Options:[ \t]*\\(.*\\)$")) t)
(cvs-match "$")
(cvs-or (cvs-match " *Existing Tags:\n\\(\t.*\n\\)*$") t)
(cvs-parsed-fileinfo type path nil
:base-rev base-rev
:head-rev head-rev))))
(defun cvs-parse-commit ()
(let (path base-rev subtype)
(cvs-or
(and
(cvs-match "\\(Checking in\\|Removing\\) \\(.*\\);$" (path 2))
(cvs-match ".*,v <-- .*$")
(cvs-or
(cvs-match "new revision: delete; previous revision: \\([0-9.]*\\)$"
(subtype 'REMOVED) (base-rev 1))
(cvs-match "initial revision: \\([0-9.]*\\)$"
(subtype 'ADDED) (base-rev 1))
(cvs-match "new revision: \\([0-9.]*\\); previous revision: .*$"
(subtype 'COMMITTED) (base-rev 1)))
(cvs-match "done$")
(progn
(vc-delete-automatic-version-backups (expand-file-name path))
(cvs-parsed-fileinfo (cons 'UP-TO-DATE subtype) path 'trust
:base-rev base-rev)))
(cvs-match "RCS file: .*\ndone$"))))
(provide 'pcvs-parse)