source: project/release/5/patch/trunk/patch.scm @ 38033

Last change on this file since 38033 was 38033, checked in by Ivan Raikov, 11 months ago

patch port to c5

File size: 6.6 KB
Line 
1;; Copyright (c) Tony Sidaway <tonysidaway@gmail.com>
2;;
3;; Permission is hereby granted, free of charge, to any person obtaining a copy of this
4;; software and associated documentation files (the "Software"), to deal in the Software
5;; without restriction, including without limitation the rights to use, copy, modify,
6;; merge, publish, distribute, sublicense, and/or sell copies of the Software, and to
7;; permit persons to whom the Software is furnished to do so, subject to the following
8;; conditions:
9;;
10;; The above copyright notice and this permission notice shall be included in all copies
11;; or substantial portions of the Software.
12;;
13;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED,
14;; INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
15;; PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE
16;; FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
17;; OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
18;; DEALINGS IN THE SOFTWARE.
19;;
20
21(module patch
22       
23        (make-patch apply-patch reverse-patch)
24
25        (import scheme (chicken base) (chicken format) (chicken io))
26        (import regex)
27
28;;
29;;@function (make-patch)
30;;
31;; Reads a GNU diffutils diff file on (current-input-port) and turns it
32;; into a patch definition on (current-output-port).
33
34
35(define (make-patch)
36  (let* ((match-string
37         (regexp "^([1-9][0-9]*)(,?)([1-9][0-9]*)?([dca])([1-9][0-9]*)(,?)([1-9][0-9]*)?"))
38        (lookahead-buffer '())
39        (lookahead-line (lambda ()
40            (if (null? lookahead-buffer)
41                (read-line)
42                (let ((ln (car lookahead-buffer)))
43                  (set! lookahead-buffer (cdr lookahead-buffer))
44                  ln))))
45        (putback-line (lambda (ln)
46            (set! lookahead-buffer (append lookahead-buffer (list ln))))))
47    (reverse
48     (let command-loop ((ln (lookahead-line)) (patch '()))
49       (if (eof-object? ln)
50           patch
51           (begin
52             (let ((match (string-match match-string ln)))
53               (or match (error format "No match to a diff command on this line: ~S" ln))
54               (set! match (cdr match))
55               (let ((start-line (list-ref match 0))
56                     (finish-line (list-ref match 2))
57                     (action (string->symbol (list-ref match 3)))
58                     (new-start-line (list-ref match 4))
59                     (new-finish-line (list-ref match 6))
60                     (lines-to-delete '())
61                     (lines-to-insert '()))
62                 (if (or (eq? action 'c) (eq? action 'd))
63                     (begin
64                       (set! lines-to-delete
65                             (reverse
66                              (let delete-loop ((ln (lookahead-line)) (lst '()))
67                                (cond
68                                 ((eof-object? ln) lst)
69                                 ((string=? (substring ln 0 1) "<")
70                                  (delete-loop (lookahead-line) (cons (substring ln 2) lst)))
71                                 (else
72                                  (if (eq? action 'd)
73                                      (putback-line ln))
74                                  lst)))))))
75                 (if (or (eq? action 'c) (eq? action 'a))
76                     (begin
77                       (set! lines-to-insert
78                             (reverse
79                              (let insert-loop ((ln (lookahead-line)) (lst '()))
80                                (cond
81                                 ((eof-object? ln) lst)
82                                 ((string=? (substring ln 0 1) ">")
83                                  (insert-loop (lookahead-line) (cons (substring ln 2) lst)))
84                                 (else
85                                  (putback-line ln)
86                                  lst)))))))
87                 (command-loop (lookahead-line)
88                               (cons (list
89                                      action
90                                      (and start-line (string->number start-line))
91                                      (and finish-line (string->number finish-line))
92                                      (and new-start-line (string->number new-start-line))
93                                      (and new-finish-line (string->number new-finish-line))
94                                      lines-to-delete
95                                      lines-to-insert)
96                                     patch))))))))))
97;;
98;;@function (apply-patch patch-definition)
99;;
100;; Applies a patch to a text stream on current-input-port and writes it to
101;; current-output-port.
102(define (apply-patch patch-definition)
103  (let ((line 0))
104    (for-each
105     (lambda (x)
106       (let ((action (list-ref x 0))
107             (start-line (list-ref x 1))
108             (finish-line (list-ref x 2))
109             (new-start-line (list-ref x 3))
110             (new-finish-line (list-ref x 4))
111             (lines-to-delete (list-ref x 5))
112             (lines-to-insert (list-ref x 6)))
113         (case action
114           ((a)
115            (let read-loop ((ln (read-line)))
116              (set! line (+ line 1))
117              (if (= (+ 1 start-line) line)
118                  (begin
119                    (let append-loop ((ins lines-to-insert))
120                      (if (not (null? ins))
121                          (begin
122                            (write-line (car ins))
123                            (append-loop (cdr ins)))))
124                    (write-line ln))
125                  (begin (write-line ln)
126                         (read-loop (read-line))))))
127           ((d)
128            (let read-loop ((ln (read-line)))
129              (set! line (+ line 1))
130              (if (= start-line line)
131                  (let delete-loop ((del lines-to-delete) (ln ln))
132                    (if (not (null? del))
133                        (begin
134                          (if (not (equal? (car del) ln))
135                              (error
136                               (format
137                                "Patch(d) failed, line ~S (line to be deleted does not match), to be deleted ~S, actually there: ~S"
138                                line (car del) ln)))
139                          (set! line (+ line 1))
140                          (delete-loop (cdr del) (read-line)))
141                        (begin
142                          (write-line ln))))
143                  (begin
144                    (write-line ln)
145                    (read-loop (read-line))))))
146           ((c)
147            (let read-loop ((ln (read-line)))
148              (set! line (+ line 1))
149              (if (= start-line line)
150                  (begin
151                    (let append-loop ((ins lines-to-insert))
152                      (if (not (null? ins))
153                          (begin
154                            (write-line (car ins))
155                            (append-loop (cdr ins)))))
156                    (let delete-loop ((del lines-to-delete) (ln ln))
157                      (if (not (null? del))
158                          (begin
159                            (if (not (equal? (car del) ln))
160                                (error
161                                 (format
162                                  "Patch(c) failed line ~S (line to be deleted does not match)"
163                                  line)))
164                            (set! line (+ line 1))
165                            (delete-loop (cdr del) (read-line)))
166                          (if (not (eof-object? ln))
167                              (write-line ln)))))
168                  (begin
169                    (write-line ln)
170                    (read-loop (read-line)))))))))
171     patch-definition))
172  (let loop ((ln (read-line)))
173    (if (not (eof-object? ln))
174        (begin
175          (write-line ln)
176          (loop (read-line))))))
177;;
178;;@function (reverse-patch patch-definition)
179;;
180;; Reverses a patch definition, producing a new patch that, when applied to
181;; the result of applying the original patch, will reproduce the original
182;; input file.
183(define (reverse-patch patch-definition)
184  (map
185   (lambda (x)
186     (let ((action (list-ref x 0))
187           (start-line (list-ref x 1))
188           (finish-line (list-ref x 2))
189           (new-start-line (list-ref x 3))
190           (new-finish-line (list-ref x 4))
191           (lines-to-delete (list-ref x 5))
192           (lines-to-insert (list-ref x 6)))
193       (case action
194         ((a)
195          (list 'd new-start-line new-finish-line start-line finish-line lines-to-insert lines-to-delete))
196         ((c)
197          (list 'c new-start-line new-finish-line start-line finish-line lines-to-insert lines-to-delete))
198         ((d)
199          (list 'a new-start-line new-finish-line start-line finish-line lines-to-insert lines-to-delete)))))
200   patch-definition))
201
202)
Note: See TracBrowser for help on using the repository browser.