Changeset 14796


Ignore:
Timestamp:
May 13, 2011, 8:38:13 PM (8 years ago)
Author:
gz
Message:

add get-svn-changes, runs svn diff and parses the result

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/misc.lisp

    r14714 r14796  
    856856    #-windows-target nil)
    857857
     858(defun run-svn (args &key (output :string) (error :output) (if-fail :error ifp))
     859  (if (eq output :stream)
     860    (external-process-output-stream (run-program *svn-program* args :output :stream :error error :wait nil))
     861    (flet ((check-status (proc)
     862             (multiple-value-bind (status exit-code) (external-process-status proc)
     863               (unless (and (eq status :exited) (or (not ifp) (zerop exit-code)))
     864                 (if (eq if-fail :error)
     865                   (error "Running \"svn ~a\" produced exit status ~s, code ~s" (car args) status exit-code)
     866                   (return-from run-svn if-fail))))
     867             proc))
     868      (if (eq output :string)
     869        (with-output-to-string (stream)
     870          (check-status (run-program *svn-program* args :output stream :error error)))
     871        (check-status (run-program *svn-program* args :output output :error error))))))
     872
    858873(defun svn-info-component (component)
    859   (let* ((component-length (length component)))
    860     (let* ((s (make-string-output-stream)))
    861       (multiple-value-bind (status exit-code)
    862           (external-process-status
    863            (run-program *svn-program*  (list "info" (native-translated-namestring "ccl:")) :output s :error :output))
    864         (when (and (eq :exited status) (zerop exit-code))
    865           (with-input-from-string (output (get-output-stream-string s))
    866             (do* ((line (read-line output nil nil) (read-line output nil nil)))
    867                  ((null line))
    868               (when (and (>= (length line) component-length)
    869                          (string= component line :end2 component-length))
    870                 (return-from svn-info-component
    871                   (string-trim " " (subseq line component-length)))))))))
    872     nil))
     874  (let ((component-length (length component))
     875        (string (run-svn (list "info" (native-translated-namestring "ccl:")) :if-fail nil)))
     876    (when string
     877      (with-input-from-string (output string)
     878        (do* ((line (read-line output nil nil) (read-line output nil nil)))
     879             ((null line))
     880          (when (and (>= (length line) component-length)
     881                     (string= component line :end2 component-length))
     882            (return-from svn-info-component
     883              (string-trim " " (subseq line component-length))))))
     884      nil)))
    873885
    874886(defun svn-url () (svn-info-component "URL:"))
     
    923935    nil))
    924936
     937
     938;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     939;;
     940;; svn diffs
     941
     942(defun get-svn-changes (&key (directory (current-directory)) (revision :base) (reverse nil))
     943  "Run svn diff to compare REVISION and working copy of DIRECTORY, and return a list of
     944  the changed regions (in the form of source notes) in the working copy.  If REVERSE is true,
     945  returns regions in the REVISION version rather than the working copy."
     946  (let* ((svn-revision (format nil "-r~a" revision))
     947         (diff (run-svn `("diff" ,svn-revision ,(native-translated-namestring directory)))))
     948    (unless (equal diff "")
     949      (unless (string-equal "Index: " diff :end2 7)
     950        (error "Cannot understand svn output: ~s" diff))
     951      (parse-svn-changes diff directory (if reverse svn-revision)))))
     952
     953(defun parse-svn-changes (string directory svn-revision)
     954  ;; Parse svn diff output string into source-note's
     955  (unless (equal string "")
     956    (assert (string-equal "Index: " string :end2 7))
     957    (loop
     958      for pos = 7 then (+ end 8)
     959      as file = (subseq string pos (setq pos (position #\newline string :start pos)))
     960      as pathname = (merge-pathnames file directory)
     961      as end = (search #.(%str-cat (string #\newline) "Index: ") string :start2 pos)
     962      nconc (parse-svn-changes-in-file string pos end pathname svn-revision)
     963      while end)))
     964
     965(defun parse-svn-changes-in-file (string pos end pathname svn-revision)
     966  (let* ((line-ranges (parse-svn-changed-lines-in-file string (1+ pos) (or end (length string)) svn-revision))
     967         (lines (loop for (start-line . line-count) in line-ranges
     968                  collect start-line
     969                  collect (+ start-line line-count)))
     970         ;; Convert line ranges to character ranges.
     971         (line-posns (flet ((posns (stream)
     972                              (flet ((skip-lines (stream count)
     973                                       (let ((chars 0))
     974                                         (loop while (> count 0)
     975                                           do (let ((ch (read-char stream)))
     976                                                (loop until (or (eql ch #\newline) (null ch))
     977                                                  do (incf chars)
     978                                                  do (setq ch (read-char stream nil)))
     979                                                (when ch (incf chars))
     980                                                (decf count)))
     981                                         chars)))
     982                                (loop
     983                                  for last-line = 1 then line-no
     984                                  for last-pos = 0 then pos
     985                                  for line-no in (remove-duplicates (sort lines #'<))
     986                                  for pos = (+ last-pos (skip-lines stream (- line-no last-line)))
     987                                  collect (cons line-no pos)))))
     988                       (if svn-revision
     989                         (let ((stream (run-svn `("cat"
     990                                                  ,svn-revision
     991                                                  ,(native-translated-namestring pathname))
     992                                                :output :stream)))
     993                           (posns stream))
     994                         (with-open-file (stream pathname) (posns stream))))))
     995    (loop for (start-line . line-count) in line-ranges
     996      collect (make-source-note :filename pathname
     997                                :start-pos (cdr (assq start-line line-posns))
     998                                :end-pos (cdr (assq (+ start-line line-count) line-posns))))))
     999
     1000
     1001(defun parse-svn-changed-lines-in-file (string start end svn-revision)
     1002  (flet ((next-line (str start end)
     1003           (let ((pos (position #\Newline str :start start :end end)))
     1004             (if pos (1+ pos) end))))
     1005    (unless (eql start end)
     1006      (assert
     1007       (let ((pos start))
     1008         (and (loop repeat 67 always (eql (char string pos) #\=) do (incf pos))
     1009              (eql (char string pos) #\Newline)
     1010              (string-equal "--- " string :start2 (incf pos) :end2 (+ pos 4))
     1011              (setq pos (position #\newline string :start pos))
     1012              (string-equal "+++ " string :start2 (incf pos) :end2 (+ pos 4))
     1013              (< pos end)
     1014              (or (null (setq pos (position #\newline string :start pos :end end)))
     1015                  (string-equal "@@ -" string :start2 (1+ pos) :end2 (+ pos 5))))))
     1016      (when (setq start (search #.(%str-cat (string #\newline) "@@ -") string :start2 start :end2 end))
     1017        (incf start)
     1018        (loop
     1019          do (incf start 4)
     1020          collect (multiple-value-bind (start-line npos)
     1021                                       (parse-integer string
     1022                                                      :start (if svn-revision
     1023                                                               start
     1024                                                               (1+ (position #\+ string :start start :end end)))
     1025                                                      :end end
     1026                                                      :junk-allowed t)
     1027                    (assert (eql (char string npos) #\,))
     1028                    (multiple-value-bind (num-lines npos) (parse-integer string :start (1+ npos) :end end
     1029                                                                         :junk-allowed t)
     1030                      (assert (eql (char string npos) #\space))
     1031                      ;; adjust for context lines
     1032                      (loop with first = t
     1033                        as ch = (and (< (setq npos (next-line string npos end)) end)
     1034                                     (char string npos))
     1035                        while (memq ch '(#\space #\+ #\-))
     1036                        do (cond ((eq ch #\space)
     1037                                  (decf num-lines)
     1038                                  (when first (incf start-line)))
     1039                                 (t (setq first nil)))
     1040                        finally (setq start npos))
     1041                      (cons start-line num-lines)))
     1042          while (and (< (+ start 4) end) (string-equal "@@ -" string :start2 start :end2 (+ start 4)))
     1043          finally (assert (eql start end)))))))
     1044
     1045
     1046
     1047
     1048;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    9251049
    9261050;;; Scan the heap, collecting infomation on the primitive object types
Note: See TracChangeset for help on using the changeset viewer.