source: project/release/4/qwiki/trunk/qwiki-svn.scm

Last change on this file was 33983, checked in by sjamaan, 4 years ago

qwiki: Add (very bare bones) diffing option to history page.

This just delegates the diffing to svn-diff and uses colorize to
highlight the unified context diff output and any other stuff that
svn decides to put in there.

Hey, at least it's better than no diff ;)

File size: 7.1 KB
Line 
1;;
2;; qwiki-svn - Subversion implementation of revisioning system for qwiki
3;;
4;; Copyright (c) 2009-2017 Peter Bex
5;;
6;;  Redistribution and use in source and binary forms, with or without
7;;  modification, are permitted provided that the following conditions
8;;  are met:
9;;
10;;  - Redistributions of source code must retain the above copyright
11;;  notice, this list of conditions and the following disclaimer.
12;;
13;;  - Redistributions in binary form must reproduce the above
14;;  copyright notice, this list of conditions and the following
15;;  disclaimer in the documentation and/or other materials provided
16;;  with the distribution.
17;;
18;;  - Neither name of the copyright holders nor the names of its
19;;  contributors may be used to endorse or promote products derived
20;;  from this software without specific prior written permission.
21;;
22;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
23;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
24;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
25;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
26;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
27;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
28;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
29;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
30;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
31;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34;;  POSSIBILITY OF SUCH DAMAGE.
35
36(module qwiki-svn
37  (qwiki-repos-uri qwiki-repos-username qwiki-repos-password
38   get-history call-with-input-revision call-with-input-changeset
39   checkout-sources! update-sources! store-changes! undo-changes!
40   get-extended-property get-last-modified-revision)
41
42(import chicken scheme)
43(use data-structures regex posix files svn-client)
44
45;; The version control system's repos uri, username and password
46(define qwiki-repos-uri (make-parameter #f)) ; string, not uri-reference!
47(define qwiki-repos-username (make-parameter "anonymous"))
48(define qwiki-repos-password (make-parameter ""))
49
50;; Get the history for a given file starting at rev, going back in
51;; time.  If rev is #f, start at the latest revision.  If limit is not
52;; specified or #f, the full history is returned.  Otherwise, a
53;; maximum of that many items is returned.
54(define (get-history file rev #!optional limit)
55  (let ((history (reverse (svn-client-log
56                           file (if rev
57                                    (make-svn-opt-revision-number rev)
58                                    svn-opt-revision-head)
59                           (make-svn-opt-revision-number 0) (or limit 0) #f #f
60                           (qwiki-repos-username) (qwiki-repos-password)))))
61    (map (lambda (entry)
62           ;; What about the timezone?  Is it always GMT?  POSIX strptime
63           ;; doesn't know about this so we may need to use srfi-19...
64           (let* ((seconds-date (string-substitute "\\.[0-9]+.*" ""
65                                                   (svn-log-date entry)))
66                  (date (string->time (svn-log-date entry) "%Y-%m-%dT%H:%M")))
67             (list (svn-log-revision entry)
68                   (svn-log-author entry)
69                   date
70                   (svn-log-message entry))))
71         history)))
72
73(define (call-with-file-to-remove filename proc)
74  (handle-exceptions exn
75      (begin
76        (delete-file* filename)
77        (signal exn))
78    (let ((result (call-with-input-file filename
79                    (lambda (f)
80                      (handle-exceptions exn
81                          (begin (close-input-port f) (signal exn))
82                        (proc f))))))
83      (delete-file* filename)
84      result)))
85
86(define (call-with-input-revision file rev proc)
87  (let ((filename (svn-client-cat
88                   file (make-svn-opt-revision-number rev)
89                   (qwiki-repos-username) (qwiki-repos-password))))
90    (unless filename (error "No such file" file))
91    (call-with-file-to-remove filename proc)))
92
93;; This basically implements "svn diff -r<rev1>:<rev2>"
94(define (call-with-input-changeset source-path file rev1 rev2 proc)
95  (let ((filename (svn-diff file
96                            (make-svn-opt-revision-number rev1)
97                            (make-svn-opt-revision-number rev2)
98                            source-path #t
99                            (qwiki-repos-username)
100                            (qwiki-repos-password))))
101    (unless filename (error "No such file" file))
102    (call-with-file-to-remove filename proc)))
103
104(define (checkout-sources! source-path)
105  (svn-checkout (qwiki-repos-uri) source-path svn-opt-revision-head #t
106                (qwiki-repos-username) (qwiki-repos-password)))
107
108(define (update-sources! source-path)
109  (svn-update source-path svn-opt-revision-head #t
110              (qwiki-repos-username) (qwiki-repos-password)))
111
112(define (get-last-modified-revision path)
113  (and-let* ((i (get-info path)))
114    (svn-info-last-changed-rev i)))
115
116(define (get-info path)
117  (let ((info (svn-client-info path svn-opt-revision-unspecified
118                               svn-opt-revision-unspecified #f
119                               (qwiki-repos-username) (qwiki-repos-password))))
120    (and info (not (null? info)) (cadar info))))
121
122(define (store-changes! source-path message username password)
123  (or
124   (let* ((user (or username (qwiki-repos-username)))
125          (pass (or password (qwiki-repos-password))))
126     (let loop ((source-path source-path))
127       (if (get-info source-path)
128           (svn-commit source-path #t user pass message)
129           (begin
130             (loop (pathname-directory source-path)) ; Add parent dirs if needed
131             (svn-add source-path #t user pass)
132             (svn-commit source-path #t user pass message)))))
133   (error "Could not store changes")))
134
135(define (undo-changes! source-path)
136  (let ((info (get-info source-path)))
137    (when info
138      (svn-client-revert (list source-path) #t
139                         (qwiki-repos-username)
140                         (qwiki-repos-password)))
141   ;; If file exists and is not under version control, or only has
142   ;; been marked as added, we remove it
143    (when (or (not info)
144              (= (svn-info-rev info)
145                 (svn-opt-revision-number svn-opt-revision-unspecified)))
146      (if (directory? source-path)
147          (delete-directory source-path)
148          (delete-file* source-path))
149      (let* ((parent-path (pathname-directory source-path))
150             (parent-info (get-info parent-path)))
151        (unless (and parent-info
152                     (not (= (svn-info-rev parent-info)
153                             (svn-opt-revision-number
154                              svn-opt-revision-unspecified))))
155          (undo-changes! parent-path))))))
156
157(define (get-extended-property path property)
158  (and-let* ((retval (svn-propget property path svn-opt-revision-unspecified #t
159                                  (qwiki-repos-username) (qwiki-repos-password)))
160             (props (alist-ref path retval string=?))
161             (prop (car props)))
162    prop))
163
164)
Note: See TracBrowser for help on using the repository browser.