Re: Incomplete output from "cvs annotate"

[Kim F. Storm]

Simon Josefsson <address@hidden> writes:

> > Last time I checked, neither SSH nor CVS understood Elisp :-)
> 
> Bummer.  (Implement the CVS protocol in elisp...?)

You can start here :-) 

;;; cvscli.el --- cvs client commands

;; Copyright (C) 1999,2004 Kim F. Storm <address@hidden>
;;                    All rights reserved.

;; Run CVS commands towards CVS server directly in emacs.

(defvar cvscli-server-connection nil
  "Current connection to cvs server")

(defvar cvscli-current-config nil
  "Current cvs server/directory configuration.
This is a list with 6 elements: (DIR REPOSITORY PASSWD USER SERVER ROOT)")

(defvar cvscli-passwd-alist nil
  "Passwords alist to use for cvs connections (from .cvspass).")

(defvar cvscli-keep-connection t
  "*When non-nil, keep connection to cvs server.")

(defun cvscli-open-connection (dir)
  (let* 
      ((config (cvscli-get-config dir))
       (action
        (catch 'oc
          (if (or (null cvscli-server-connection)
                  (eq (process-status cvscli-server-connection) 'closed))
              (throw 'oc 'open))        ; no current connection
          (if (or (not (string-equal (nth 4 cvscli-current-config) (nth 4 
config)))
                  (not (string-equal (nth 3 cvscli-current-config) (nth 3 
config)))
                  (not (string-equal (nth 5 cvscli-current-config) (nth 5 
config))))
              (throw 'oc 'reopen))      ; wrong server, user, or root
          (if (not (string-equal (nth 1 cvscli-current-config) (nth 1 config)))
              (throw 'oc 'setrep))      ; wrong repository
          'done)))

    (if (eq action 'reopen)
        (progn
          (cvscli-close-connection)
          (setq action 'open)))

    (if (eq action 'open)
        (if (catch 'cvserr
              (if (not (setq cvscli-server-connection (open-network-stream 
"cvscli" "*vc-info*" (nth 4 config) 2401)))
                  (throw 'cvserr t))

              (save-excursion
                (set-buffer (process-buffer cvscli-server-connection))
                (erase-buffer)
                (set-process-coding-system cvscli-server-connection 
'raw-text-unix 'raw-text-unix)
                ;; (set-process-filter cvscli-server-connection 
'cvscli-check-file-filter)
                (cvscli-send-string (concat "BEGIN AUTH REQUEST\n"
                                            (nth 5 config) "\n"
                                            (nth 3 config) "\n"
                                            (nth 2 config) "\n"
                                            "END AUTH REQUEST\n"))

                ;; response: I LOVE YOU\n
                (accept-process-output cvscli-server-connection 3)
                (goto-char (point-min))
                (if (not (looking-at "I LOVE YOU"))
                    (progn
                      (cvscli-close-connection)
                      (throw 'cvserr t)))

                (erase-buffer)
                (cvscli-send-string (concat "Root " (nth 5 config)  "\n"))
                (cvscli-send-string "\
Valid-responses ok error\
 Valid-requests Checked-in New-entry Checksum Copy-file Updated Created\
 Update-existing Merged Patched Mode Removed Remove-entry Set-static-directory\
 Clear-static-directory Set-sticky Clear-sticky Template Set-checkin-prog\
 Set-update-prog Notified Module-expansion M E F
UseUnchanged
Global_option -r
Case
"))
              (setq action 'setrep)
              nil)
            (cvscli-close-connection)))

    (if (eq action 'setrep)
        (progn
          (cvscli-send-string (concat "Directory .\n" (nth 1 config) "\n"))
          (setq action 'done)))

    (setq cvscli-current-config config))

  (if cvscli-server-connection
      (save-excursion
        (set-buffer (process-buffer cvscli-server-connection))
        (erase-buffer)))

  cvscli-server-connection)


(defun cvscli-close-connection ()
  (if cvscli-server-connection
      (progn
        (if (eq (process-status cvscli-server-connection) 'open)
            (delete-process cvscli-server-connection))
        ; (kill-buffer (process-buffer cvscli-server-connection))
        (setq cvscli-server-connection nil))))
  
(defun cvscli-send-string (str &optional resp)
  ;; (message "Send: %s" str)
  (process-send-string cvscli-server-connection str)
  (if resp
      (let (ok done)
        (save-excursion
          (set-buffer (process-buffer cvscli-server-connection))
          (while (not done)
            (if (not (accept-process-output cvscli-server-connection 3))
            (setq done t)
          (let ((pm (process-mark cvscli-server-connection)) s)
            (cond
             ((= pm 3)
              (setq ok (string-equal (buffer-substring (- pm 3) pm) "ok\n")))
             ((> pm 3)
              (setq ok (string-equal (buffer-substring (- pm 4) pm) "\nok\n"))))
            (setq done ok))))
          (if ok
              (progn
                (set-marker (process-mark cvscli-server-connection) (- 
(point-max) 3))
                (delete-region (- (point-max) 3) (point-max))))
          ok))
    t))

(defun cvscli-check-file (file &optional dir)
  (if (null dir)
      (setq dir default-directory))
  (let (entry ok fbuf) 
    (setq ok
          (and (cvscli-open-connection dir)
               (setq entry (cvscli-get-entry dir file))
               (cvscli-send-string (concat "Argument " file 
                                           "\nEntry /" file "/" (nth 1 entry) 
"//" (nth 3 entry) "/" (or (nth 4 entry) "")))
               (save-excursion 
                 (if (and (setq fbuf (find-buffer-visiting (concat dir file)))
                          (set-buffer fbuf)
                          (not buffer-read-only))
                     (save-restriction
                       (widen)
                       (cvscli-send-string (concat "\nModified " file 
"\nu=rw,g=rw,o=rw\n" (- (point-max) (point-min)) "\n"))
                       (process-send-region cvscli-server-connection 
(point-min) (point-max)))
                   
                   (cvscli-send-string (concat "\nUnchanged " file "\n")))
                 t)
               (cvscli-send-string "status\n" t)
               (cvscli-send-string (concat "Argument " file "\neditors\n") t)
               (cvscli-send-string (concat "Argument " file "\nlog\n") t)))
    (if ok
        (save-excursion
          (set-buffer (process-buffer cvscli-server-connection))
          (goto-char (point-min))
          (while (and
                  (not (looking-at "head:"))
                       (search-forward-regexp "^M " nil t))
            (replace-match "" nil t))))

    (if (not cvscli-keep-connection)
        cvscli-close-connection)
    ok))
      
(defun cvscli-get-config (dir)
  (if (and cvscli-current-config
           (string-equal dir (car cvscli-current-config)))
      cvscli-current-config
    (if (null cvscli-passwd-alist)
        (let ((pw (expand-file-name "~/.cvspass")))
          (if (file-exists-p pw)
              (let ((buf (find-file-noselect pw)) p s)
                (save-excursion
                  (set-buffer buf)
                  (goto-char (point-min))
                  (while (not (eobp))
                    (setq s (point))
                    (if (not (search-forward " " nil t))
                        (forward-line 1)
                      (setq s (buffer-substring s (1- (point))))
                      (setq p (point))
                      (end-of-line)
                      (setq p (buffer-substring p (point)))
                      (setq cvscli-passwd-alist (cons (cons s p) 
cvscli-passwd-alist))
                      (forward-char 1))))
                (kill-buffer buf)))))
    (let ((rep (concat dir "/CVS/Repository")) 
          (root (concat dir "/CVS/Root")) 
          config)
      (if (and (file-exists-p root)
               (file-exists-p rep))
          (progn
            (let ((buf (find-file-noselect root)) pw rep)
              (save-excursion
                (set-buffer buf)
                (setq rep (buffer-substring (point-min) (1- (point-max))))
                (setq config (split-string rep "[:@]")))
              (kill-buffer buf)
              (if config
                  (setcar config 
                          (and (setq pw (assoc rep cvscli-passwd-alist)) (cdr 
pw)))))
            (let ((buf (find-file-noselect rep)) s)
              (save-excursion
                (set-buffer buf)
                (setq config (cons (buffer-substring (point-min) (1- 
(point-max))) config)))
              (kill-buffer buf))))
      (and config
           (cons dir config)))))

(defun cvscli-get-entry (dir file)
  (let ((entry (concat dir "/CVS/Entries")) s)
    (if (file-exists-p entry)
        (let ((buf (find-file-noselect entry)))
          (save-excursion
            (set-buffer buf)
            (goto-char (point-min))
            (if (search-forward-regexp (concat "^/" file "/") nil t)
                (let (b)
                  (beginning-of-line)
                  (setq b (point))
                  (end-of-line)
                  (setq s (split-string (buffer-substring b (point)) "/")))))
          (kill-buffer buf)))
    s))


(defun cvscli-check-file-filter (process output-string)
  (let ((old-buffer (current-buffer)))
    (unwind-protect
        (let ((moving))
          (set-buffer (process-buffer process))
          (setq moving (= (point) (process-mark process)))
          (save-excursion
            ;; Insert the text, moving the process-marker.
            (goto-char (process-mark process))
            (insert output-string)
            (set-marker (process-mark process) (point)))

          ;;(while (string-match "\r" filtered-string)
          ;;     (setq filtered-string
          ;;   (replace-match "" nil nil filtered-string)))
          (if moving (goto-char (process-mark process))))
      (set-buffer old-buffer))))

  

(defun vc-ocvs-fetch-master-properties (file fail-ok)
  ;; Fetch those properties of FILE that are stored in the CVS repository file.
  (save-excursion
    ;; Call "cvs emacs" in the right directory, passing only the
    ;; nondirectory part of the file name -- otherwise CVS might 
    ;; silently give a wrong result.
    (let ((default-directory (file-name-directory file)))
      (or (cvscli-check-file (file-name-nondirectory file) default-directory)
          (vc-simple-command 0 "cvs" (file-name-nondirectory file) "emacs")))
    (set-buffer (get-buffer "*vc-info*"))
    (vc-parse-buffer
     ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:",
     ;; and CVS 1.4a1 says "Repository revision:".
     '(("\\(RCS Version\\|RCS Revision\\|Repository revision\\):[\t 
]+\\([0-9.]+\\)" 2)
       ("^File: [^ \t]+[ \t]+Status: \\(.*\\)" 1))
     file
     '(vc-latest-version vc-cvs-status))
    (vc-parse-buffer
     '(("Sticky Tag:[ \t]*\\([^\n ]+\\)" 1)
       ("Sticky Date:[ \t]*\\([^\n ]+\\)" 1)
       ("Sticky Options:[ \t]*\\([^\n ]+\\)" 1))
     file
     '(vc-sticky-tag vc-sticky-date vc-sticky-options))
    (let ((stag (vc-file-getprop file 'vc-sticky-tag))
          (sdate (vc-file-getprop file 'vc-sticky-date))
          (soptions (vc-file-getprop file 'vc-sticky-options)))
      (if (and stag (string-match stag "(none)"))
          (vc-file-setprop file 'vc-sticky-tag nil))
      (if (and sdate (string-match sdate "(none)"))
          (vc-file-setprop file 'vc-sticky-date nil))
      (if (and soptions (string-match soptions "(none)"))
          (vc-file-setprop file 'vc-sticky-options nil)))

    ;; Translate those status values that we understand into symbols.
    ;; Any other value is converted to nil.
    (let ((status (vc-file-getprop file 'vc-cvs-status)))
      (cond 
       ((string-match "Up-to-date" status)
        (vc-file-setprop file 'vc-cvs-status 'up-to-date)
        (vc-file-setprop file 'vc-checkout-time
                         (nth 5 (file-attributes file))))
       ((vc-file-setprop file 'vc-cvs-status
                         (cond 
                          ((string-match "Locally Modified"    status) 
'locally-modified)
                          ((string-match "Needs Merge"         status) 
'needs-merge)
                          ((string-match "Needs \\(Checkout\\|Patch\\)" status) 
                           'needs-checkout)
                          ((string-match "Unresolved Conflict" status) 
'unresolved-conflict)
                          ((string-match "Locally Added"       status) 
'locally-added)
                          (t 'unknown)
                          )))))
    (vc-parse-locks file (buffer-substring-no-properties (point-min) 
(point-max)))
    (vc-parse-buffer
     '(("^Head: \\(.*\\)" 1))
     file
     '(vc-latest-version))
    ))


-- 
Kim F. Storm <address@hidden> http://www.cua.dk