- cl-darcs-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[Cl-darcs-cvs] r67 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Nov '06

22 Nov '06

Author: mhenoch Date: Wed Nov 22 15:00:24 2006 New Revision: 67 Added: cl-darcs/trunk/diff.lisp Modified: cl-darcs/trunk/cl-darcs.asd Log: Start hacking diff Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Wed Nov 22 15:00:24 2006 @@ -21,7 +21,9 @@ ;; Files and directories :cl-fad ;; Regexps - :cl-ppcre) + :cl-ppcre + ;; Diff + :cl-difflib) :components ((:file "packages") Added: cl-darcs/trunk/diff.lisp ============================================================================== --- (empty file) +++ cl-darcs/trunk/diff.lisp Wed Nov 22 15:00:24 2006 @@ -0,0 +1,57 @@ +;;; Copyright (C) 2006 Magnus Henoch +;;; +;;; This program 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 of the +;;; License, or (at your option) any later version. +;;; +;;; This program 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 this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(in-package :darcs) + +(defun diff-file (original modified &key filename) + "Find changes between ORIGINAL and MODIFIED. +Return a list of HUNK-PATCHes. Use FILENAME as their filename." + (setf original (make-upath original)) + (setf modified (make-upath modified)) + (let* ((original-lines + (with-open-stream (in (open-upath original :binary t)) + (loop for line = (read-binary-line in nil) + while line collect line))) + (modified-lines + (with-open-stream (in (open-upath modified :binary t)) + (loop for line = (read-binary-line in nil) + while line collect line))) + + ;; using equalp is safe (i.e. non-case-clobbering), as + ;; we use bytes instead of characters + (opcodes (difflib:get-opcodes + (make-instance 'difflib:sequence-matcher + :a original-lines + :b modified-lines + :test-function #'equalp))) + + patches) + + (dolist (opcode opcodes) + (unless (eql (difflib:opcode-tag opcode) :equal) + (push + (make-instance 'hunk-patch + :filename filename + :line-number (difflib:opcode-j1 opcode) + :old (subseq original-lines + (difflib:opcode-i1 opcode) + (difflib:opcode-i2 opcode)) + :new (subseq modified-lines + (difflib:opcode-j1 opcode) + (difflib:opcode-j2 opcode))) + patches))) + + (nreverse patches)))

1 0

[Cl-darcs-cvs] r66 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Nov '06

22 Nov '06

Author: mhenoch Date: Wed Nov 22 13:46:37 2006 New Revision: 66 Modified: cl-darcs/trunk/util.lisp Log: Add *scanner-cache*, matches-one-of, file-binary-p and file-boring-p. Modified: cl-darcs/trunk/util.lisp ============================================================================== --- cl-darcs/trunk/util.lisp (original) +++ cl-darcs/trunk/util.lisp Wed Nov 22 13:46:37 2006 @@ -274,3 +274,30 @@ (copy-directory source-file target-file :excluding excluding)) (t (fad:copy-file source-file target-file))))))) + +(defvar *scanner-cache* (make-hash-table :test 'equal) + "Hash table for scanners created for filename regexp tests. +Creating a scanner is slow, but using it is fast.") + +(defun matches-one-of (regexps string) + "Return true if some of REGEXPS match STRING. +Cache scanners for faster execution beyond first time." + (dolist (regexp regexps) + (let ((scanner (or + (gethash regexp *scanner-cache*) + (setf (gethash regexp *scanner-cache*) + (cl-ppcre:create-scanner regexp))))) + (when (cl-ppcre:scan scanner string) + (return t))))) + +(defun file-binary-p (repo filename) + "Return true if FILENAME names a binary file. +Uses the regexps specified in REPO." + (let ((binary-regexps (get-preflist repo "binaries"))) + (matches-one-of binary-regexps filename))) + +(defun file-boring-p (repo filename) + "Return true if FILENAME names a boring file. +Uses the regexps specified in REPO." + (let ((binary-regexps (get-preflist repo "boring"))) + (matches-one-of binary-regexps filename)))

1 0

[Cl-darcs-cvs] r65 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Nov '06

01 Nov '06

Author: mhenoch Date: Tue Oct 31 19:39:23 2006 New Revision: 65 Modified: cl-darcs/trunk/cl-darcs.asd Log: Add dependency on cl-ppcre Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Tue Oct 31 19:39:23 2006 @@ -19,7 +19,9 @@ ;; Ironclad's SHA1 doesn't work with CLISP yet #+clisp :sb-sha1 ;; Files and directories - :cl-fad) + :cl-fad + ;; Regexps + :cl-ppcre) :components ((:file "packages")

1 0

[Cl-darcs-cvs] r64 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Nov '06

01 Nov '06

Author: mhenoch Date: Tue Oct 31 19:37:45 2006 New Revision: 64 Modified: cl-darcs/trunk/pull.lisp Log: Use PATCHINFO instead of PI in lambda functions. Modified: cl-darcs/trunk/pull.lisp ============================================================================== --- cl-darcs/trunk/pull.lisp (original) +++ cl-darcs/trunk/pull.lisp Tue Oct 31 19:37:45 2006 @@ -36,12 +36,12 @@ ;; XXX: This is where we pick which of their patches we want to ;; pull. (let* ((their-patches - (mapcar (lambda (pi) - (read-patch-from-repo theirrepo pi)) + (mapcar (lambda (patchinfo) + (read-patch-from-repo theirrepo patchinfo)) only-theirs)) (our-patches - (mapcar (lambda (pi) - (read-patch-from-repo ourrepo pi)) + (mapcar (lambda (patchinfo) + (read-patch-from-repo ourrepo patchinfo)) only-ours)) (merged-patches (patches (merge-patches (make-instance 'composite-patch

1 0

[Cl-darcs-cvs] r63 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Nov '06

01 Nov '06

Author: mhenoch Date: Tue Oct 31 19:35:28 2006 New Revision: 63 Modified: cl-darcs/trunk/cl-darcs.asd Log: Load INFLATE through REQUIRE on ACL Modified: cl-darcs/trunk/cl-darcs.asd ============================================================================== --- cl-darcs/trunk/cl-darcs.asd (original) +++ cl-darcs/trunk/cl-darcs.asd Tue Oct 31 19:35:28 2006 @@ -49,3 +49,7 @@ ;; Franz' inflate implementation #-allegro (:file "ifstar") #-allegro (:file "inflate" :depends-on ("ifstar")))) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :inflate))

1 0

[Cl-darcs-cvs] r62 - cl-darcs/trunk
by mhenoch＠common-lisp.net 01 Nov '06

01 Nov '06

Author: mhenoch Date: Tue Oct 31 19:34:20 2006 New Revision: 62 Modified: cl-darcs/trunk/upath.lisp Log: Change package references from PURI to NET.URI. Makes the code work on ACL, and that is a nickname for the PURI package anyway. Modified: cl-darcs/trunk/upath.lisp ============================================================================== --- cl-darcs/trunk/upath.lisp (original) +++ cl-darcs/trunk/upath.lisp Tue Oct 31 19:34:20 2006 @@ -18,7 +18,7 @@ ;; "Universal pathname" - can refer to either a local or a remote ;; file. For local files, just use pathnames. For remote files, use -;; the PURI library. +;; the PURI library. (Or the real thing, if we're using ACL) (defun make-upath (path) "Turn PATH into a \"universal pathname\". @@ -28,12 +28,12 @@ (ctypecase path (pathname path) - (puri:uri + (net.uri:uri path) (string (if (or (string= path "http://" :end1 7) (string= path "https://" :end1 8)) - (puri:parse-uri path) + (net.uri:parse-uri path) (pathname path))))) (defun upath-subdir (base subdirs &optional filename) @@ -44,16 +44,16 @@ (pathname-directory subdirs) subdirs)))) (ctypecase base - (puri:uri - (let* ((current-path (puri:uri-parsed-path base)) + (net.uri:uri + (let* ((current-path (net.uri:uri-parsed-path base)) (new-path (cond ((null current-path) (cons :absolute subdirs-list)) (t (append current-path subdirs-list)))) - (new-uri (puri:copy-uri base))) - (setf (puri:uri-parsed-path new-uri) (if filename + (new-uri (net.uri:copy-uri base))) + (setf (net.uri:uri-parsed-path new-uri) (if filename (append new-path (list filename)) new-path)) new-uri)) @@ -70,7 +70,7 @@ else CHARACTER." (setf upath (make-upath upath)) (ctypecase upath - (puri:uri + (net.uri:uri (dformat "~&Opening ~A..." upath) (let ((client-request (net.aserve.client:make-http-client-request upath :proxy *http-proxy*))) (net.aserve.client:read-client-response-headers client-request) @@ -84,7 +84,7 @@ (dformat "~&Redirected to ~A." new-location) (net.aserve.client:client-request-close client-request) (open-upath - (puri:uri new-location) + (net.uri:uri new-location) :redirect-max-depth (1- redirect-max-depth) :binary binary))) (t (error "Couldn't read ~A: ~A ~A."

1 0

[Cl-darcs-cvs] r61 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Oct '06

22 Oct '06

Author: mhenoch Date: Sun Oct 22 08:51:15 2006 New Revision: 61 Modified: cl-darcs/trunk/write-patch.lisp Log: Add WRITE-PATCH method for MERGER-PATCH Modified: cl-darcs/trunk/write-patch.lisp ============================================================================== --- cl-darcs/trunk/write-patch.lisp (original) +++ cl-darcs/trunk/write-patch.lisp Sun Oct 22 08:51:15 2006 @@ -150,3 +150,12 @@ (patch-move-to patch))) stream) (write-byte 10 stream)) +(defmethod write-patch ((patch merger-patch) stream) + (write-as-bytes "merger " stream) + (write-as-bytes (merger-version patch) stream) + (write-as-bytes " (" stream) + (write-byte 10 stream) + (write-patch (merger-first patch) stream) + (write-patch (merger-second patch) stream) + (write-as-byte #\) stream) + (write-byte 10 stream))

1 0

[Cl-darcs-cvs] r60 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Oct '06

22 Oct '06

Author: mhenoch Date: Sun Oct 22 08:38:57 2006 New Revision: 60 Modified: cl-darcs/trunk/apply-patch.lisp cl-darcs/trunk/prefs.lisp Log: Add has-prefs-dir. Don't apply CHANGE-PREF-PATCHes unless there is a prefs directory. Modified: cl-darcs/trunk/apply-patch.lisp ============================================================================== --- cl-darcs/trunk/apply-patch.lisp (original) +++ cl-darcs/trunk/apply-patch.lisp Sun Oct 22 08:38:57 2006 @@ -89,15 +89,18 @@ (apply-patch-list (patches patch) repodir)) (defmethod apply-patch ((patch change-pref-patch) repodir) - (with-accessors ((pref change-pref-which) - (from change-pref-from) - (to change-pref-to)) patch - (let ((old-value (or (get-pref repodir pref) ""))) - (unless (string= from old-value) - (warn - "While changing pref ~S to ~S, expected old value to be ~S, but it was ~S." - pref to from old-value)) - (set-pref repodir pref to)))) + ;; Maybe we're applying the patch to a pristine directory, in which + ;; case we don't care about preferences. + (when (has-prefs-dir repodir) + (with-accessors ((pref change-pref-which) + (from change-pref-from) + (to change-pref-to)) patch + (let ((old-value (or (get-pref repodir pref) ""))) + (unless (string= from old-value) + (warn + "While changing pref ~S to ~S, expected old value to be ~S, but it was ~S." + pref to from old-value)) + (set-pref repodir pref to))))) (defmethod apply-patch ((patch add-file-patch) repodir) "Create a file in REPODIR, by PATCH." Modified: cl-darcs/trunk/prefs.lisp ============================================================================== --- cl-darcs/trunk/prefs.lisp (original) +++ cl-darcs/trunk/prefs.lisp Sun Oct 22 08:38:57 2006 @@ -16,6 +16,13 @@ (in-package :darcs) +(defun has-prefs-dir (repo) + "Return true if REPO has a _darcs/prefs subdirectory." + ;; This is currently only used for checking whether we should write + ;; preferences, so it doesn't matter that this implementation + ;; doesn't work for HTTP. + (fad:directory-exists-p (upath-subdir repo '("_darcs" "prefs")))) + (defun read-prefs (upath) "Read all preferences from repository at UPATH. Return an alist with strings."

1 0

[Cl-darcs-cvs] r59 - cl-darcs/trunk
by mhenoch＠common-lisp.net 22 Oct '06

22 Oct '06

Author: mhenoch Date: Sun Oct 22 08:26:30 2006 New Revision: 59 Modified: cl-darcs/trunk/write-patch.lisp Log: Use write-as-bytes instead of write-sequence in WRITE-PATCH for CHANGE-PREF-PATCH. Modified: cl-darcs/trunk/write-patch.lisp ============================================================================== --- cl-darcs/trunk/write-patch.lisp (original) +++ cl-darcs/trunk/write-patch.lisp Sun Oct 22 08:26:30 2006 @@ -134,9 +134,9 @@ (write-as-bytes "changepref " stream) (write-as-bytes (change-pref-which patch) stream) (write-byte 10 stream) - (write-sequence (change-pref-from patch) stream) + (write-as-bytes (change-pref-from patch) stream) (write-byte 10 stream) - (write-sequence (change-pref-to patch) stream) + (write-as-bytes (change-pref-to patch) stream) (write-byte 10 stream)) (defmethod write-patch ((patch move-patch) stream)

1 0

[Cl-darcs-cvs] r58 - cl-darcs/trunk
by mhenoch＠common-lisp.net 16 Oct '06

16 Oct '06

Author: mhenoch Date: Mon Oct 16 04:39:52 2006 New Revision: 58 Modified: cl-darcs/trunk/patch-core.lisp cl-darcs/trunk/unreadable-stream.lisp Log: Use print-unreadable-object. Modified: cl-darcs/trunk/patch-core.lisp ============================================================================== --- cl-darcs/trunk/patch-core.lisp (original) +++ cl-darcs/trunk/patch-core.lisp Mon Oct 16 04:39:52 2006 @@ -24,10 +24,8 @@ :documentation "List of patches making up the composite patch."))) (defmethod print-object ((patch composite-patch) stream) - (if *print-readably* - (call-next-method) - (format stream "#<~A: ~W>" - (type-of patch) (patches patch)))) + (print-unreadable-object (patch stream :type t) + (write (patches patch) :stream stream))) (defclass split-patch (patch) ((patches :accessor patches :initarg :patches :initform ()))) @@ -37,8 +35,8 @@ (:documentation "Base class for patches affecting a single file.")) (defmethod print-object ((patch file-patch) stream) - (if *print-readably* (call-next-method) - (format stream "#<~A: ~A>" (type-of patch) (patch-filename patch)))) + (print-unreadable-object (patch stream :type t) + (princ (patch-filename patch) stream))) (defclass hunk-patch (file-patch) ((line-number :accessor hunk-line-number :initarg :line-number @@ -50,12 +48,12 @@ (:documentation "A single patch \"hunk\".")) (defmethod print-object ((patch hunk-patch) stream) - (if *print-readably* (call-next-method) - (format stream "#<~A: ~A ~A~[~:;~:*-~A~]~[~:;~:*+~A~]>" - (type-of patch) (patch-filename patch) - (hunk-line-number patch) - (length (hunk-old-lines patch)) - (length (hunk-new-lines patch))))) + (print-unreadable-object (patch stream :type t) + (format stream "~A ~A~[~:;~:*-~A~]~[~:;~:*+~A~]" + (patch-filename patch) + (hunk-line-number patch) + (length (hunk-old-lines patch)) + (length (hunk-new-lines patch))))) (defclass add-file-patch (file-patch) () @@ -81,18 +79,19 @@ (:documentation "A patch that replaces one token with another.")) (defmethod print-object ((patch token-replace-patch) stream) - (if *print-readably* (call-next-method) - (format stream "#<~A: ~A: s/~A/~A/ (~S)>" (type-of patch) (patch-filename patch) - (old-token patch) (new-token patch) - (token-regexp patch)))) + (print-unreadable-object (patch stream :type t) + (format stream "~A: s/~A/~A/ (~S)" + (patch-filename patch) + (old-token patch) (new-token patch) + (token-regexp patch)))) (defclass directory-patch (patch) ((directory :accessor patch-directory :initarg :directory)) (:documentation "Base class for patches affecting a directory.")) (defmethod print-object ((patch directory-patch) stream) - (if *print-readably* (call-next-method) - (format stream "#<~A: ~A>" (type-of patch) (patch-directory patch)))) + (print-unreadable-object (patch stream :type t) + (princ (patch-directory patch) stream))) (defclass add-dir-patch (directory-patch) () @@ -112,14 +111,12 @@ (:documentation "A named patch.")) ;XXX: what does that mean? (defmethod print-object ((patch named-patch) stream) - (if *print-readably* - (call-next-method) - (let ((patchinfo (named-patch-patchinfo patch))) - (format stream "#<~A: ~A ~A: ~<~W~:>>" - (type-of patch) - (patchinfo-date patchinfo) - (patchinfo-name patchinfo) - (named-patch-patch patch))))) + (print-unreadable-object (patch stream :type t) + (let ((patchinfo (named-patch-patchinfo patch))) + (format stream "~A ~A: ~<~W~:>" + (patchinfo-date patchinfo) + (patchinfo-name patchinfo) + (named-patch-patch patch))))) (defclass change-pref-patch (patch) ((pref :initarg :pref :accessor change-pref-which) @@ -128,13 +125,11 @@ (:documentation "A patch for changing a preference.")) (defmethod print-object ((patch change-pref-patch) stream) - (if *print-readably* - (call-next-method) - (format stream "#<~A: ~A: s/~S/~S/>" - (type-of patch) - (change-pref-which patch) - (change-pref-from patch) - (change-pref-to patch)))) + (print-unreadable-object (patch stream :type t) + (format stream "~A: s/~S/~S/" + (change-pref-which patch) + (change-pref-from patch) + (change-pref-to patch)))) (defclass move-patch (patch) ((from :initarg :from :accessor patch-move-from) @@ -142,12 +137,10 @@ (:documentation "A patch that moves a file.")) (defmethod print-object ((patch move-patch) stream) - (if *print-readably* - (call-next-method) - (format stream "#<~A: ~A -> ~A>" - (type-of patch) - (patch-move-from patch) - (patch-move-to patch)))) + (print-unreadable-object (patch stream :type t) + (format stream "~A -> ~A" + (patch-move-from patch) + (patch-move-to patch)))) ;; XXX: this class is probably incorrect and insufficient. (defclass merger-patch (patch) @@ -159,14 +152,12 @@ (unwindings :initarg :unwindings :accessor merger-unwindings))) (defmethod print-object ((patch merger-patch) stream) - (if *print-readably* - (call-next-method) - (format stream "#<~A ~:[(inverted) ~;~]~A: ~A ~A>" - (type-of patch) - (merger-inverted patch) - (merger-version patch) - (merger-first patch) - (merger-second patch)))) + (print-unreadable-object (patch stream :type t) + (format stream "~:[(inverted) ~;~]~A: ~A ~A" + (merger-inverted patch) + (merger-version patch) + (merger-first patch) + (merger-second patch)))) ;; There are more kinds of patches... let's implement them when need ;; arises. Modified: cl-darcs/trunk/unreadable-stream.lisp ============================================================================== --- cl-darcs/trunk/unreadable-stream.lisp (original) +++ cl-darcs/trunk/unreadable-stream.lisp Mon Oct 16 04:39:52 2006 @@ -190,5 +190,5 @@ (push (list 0 (length line) line :line) buffer)))) (defmethod print-object ((object unreadable-stream) stream) - (if *print-readably* (call-next-method) - (format stream "#<~A ~A ~A>" (type-of object) (slot-value object 'buffer) (slot-value object 'stream)))) + (print-unreadable-object (object stream :type t) + (format stream "~A ~A" (slot-value object 'buffer) (slot-value object 'stream))))

1 0