Commit | Line | Data |
---|---|---|
848f30d0 TTN |
1 | #!/bin/sh |
2 | # aside from this initial boilerplate, this is actually -*- scheme -*- code | |
3 | main='(module-ref (resolve-module '\''(scripts api-diff)) '\'main')' | |
4 | exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" | |
5 | !# | |
6 | ;;; api-diff --- diff guile-api.alist files | |
7 | ||
6e7d5622 | 8 | ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. |
848f30d0 TTN |
9 | ;; |
10 | ;; This program is free software; you can redistribute it and/or | |
11 | ;; modify it under the terms of the GNU General Public License as | |
12 | ;; published by the Free Software Foundation; either version 2, or | |
13 | ;; (at your option) any later version. | |
14 | ;; | |
15 | ;; This program is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
18 | ;; General Public License for more details. | |
19 | ;; | |
20 | ;; You should have received a copy of the GNU General Public License | |
21 | ;; along with this software; see the file COPYING. If not, write to | |
92205699 MV |
22 | ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
23 | ;; Boston, MA 02110-1301 USA | |
848f30d0 TTN |
24 | |
25 | ;;; Author: Thien-Thi Nguyen <ttn@gnu.org> | |
26 | ||
27 | ;;; Commentary: | |
28 | ||
4ab4e780 TTN |
29 | ;; Usage: api-diff [-d GROUPS] ALIST-FILE-A ALIST-FILE-B |
30 | ;; | |
848f30d0 | 31 | ;; Read in the alists from files ALIST-FILE-A and ALIST-FILE-B |
4ab4e780 TTN |
32 | ;; and display a (count) summary of the groups defined therein. |
33 | ;; Optional arg "--details" (or "-d") specifies a comma-separated | |
34 | ;; list of groups, in which case api-diff displays instead the | |
35 | ;; elements added and deleted for each of the specified groups. | |
848f30d0 | 36 | ;; |
4ab4e780 | 37 | ;; For scheme programming, this module exports the proc: |
848f30d0 | 38 | ;; (api-diff A-file B-file) |
848f30d0 TTN |
39 | ;; |
40 | ;; Note that the convention is that the "older" alist/file is | |
41 | ;; specified first. | |
42 | ;; | |
4ab4e780 | 43 | ;; TODO: Develop scheme interface. |
848f30d0 TTN |
44 | |
45 | ;;; Code: | |
46 | ||
47 | (define-module (scripts api-diff) | |
48 | :use-module (ice-9 common-list) | |
4ab4e780 TTN |
49 | :use-module (ice-9 format) |
50 | :use-module (ice-9 getopt-long) | |
51 | :autoload (srfi srfi-13) (string-tokenize) | |
52 | :export (api-diff)) | |
848f30d0 TTN |
53 | |
54 | (define (read-alist-file file) | |
55 | (with-input-from-file file | |
56 | (lambda () (read)))) | |
57 | ||
4ab4e780 TTN |
58 | (define put set-object-property!) |
59 | (define get object-property) | |
60 | ||
61 | (define (read-api-alist-file file) | |
62 | (let* ((alist (read-alist-file file)) | |
63 | (meta (assq-ref alist 'meta)) | |
64 | (interface (assq-ref alist 'interface))) | |
65 | (put interface 'meta meta) | |
66 | (put interface 'groups (let ((ht (make-hash-table 31))) | |
67 | (for-each (lambda (group) | |
68 | (hashq-set! ht group '())) | |
69 | (assq-ref meta 'groups)) | |
70 | ht)) | |
71 | interface)) | |
72 | ||
73 | (define (hang-by-the-roots interface) | |
74 | (let ((ht (get interface 'groups))) | |
75 | (for-each (lambda (x) | |
76 | (for-each (lambda (group) | |
77 | (hashq-set! ht group | |
78 | (cons (car x) | |
79 | (hashq-ref ht group)))) | |
80 | (assq-ref x 'groups))) | |
81 | interface)) | |
82 | interface) | |
83 | ||
84 | (define (diff? a b) | |
85 | (let ((result (set-difference a b))) | |
86 | (if (null? result) | |
87 | #f ; CL weenies bite me | |
88 | result))) | |
848f30d0 | 89 | |
4ab4e780 TTN |
90 | (define (diff+note! a b note-removals note-additions note-same) |
91 | (let ((same? #t)) | |
92 | (cond ((diff? a b) => (lambda (x) (note-removals x) (set! same? #f)))) | |
93 | (cond ((diff? b a) => (lambda (x) (note-additions x) (set! same? #f)))) | |
94 | (and same? (note-same)))) | |
848f30d0 | 95 | |
4ab4e780 TTN |
96 | (define (group-diff i-old i-new . options) |
97 | (let* ((i-old (hang-by-the-roots i-old)) | |
98 | (g-old (hash-fold acons '() (get i-old 'groups))) | |
99 | (g-old-names (map car g-old)) | |
100 | (i-new (hang-by-the-roots i-new)) | |
101 | (g-new (hash-fold acons '() (get i-new 'groups))) | |
102 | (g-new-names (map car g-new))) | |
103 | (cond ((null? options) | |
104 | (diff+note! g-old-names g-new-names | |
105 | (lambda (removals) | |
106 | (format #t "groups-removed: ~A\n" removals)) | |
107 | (lambda (additions) | |
108 | (format #t "groups-added: ~A\n" additions)) | |
109 | (lambda () #t)) | |
110 | (for-each (lambda (group) | |
111 | (let* ((old (assq-ref g-old group)) | |
112 | (new (assq-ref g-new group)) | |
113 | (old-count (and old (length old))) | |
114 | (new-count (and new (length new))) | |
115 | (delta (and old new (- new-count old-count)))) | |
ef018514 | 116 | (format #t " ~5@A ~5@A : " |
4ab4e780 | 117 | (or old-count "-") |
ef018514 TTN |
118 | (or new-count "-")) |
119 | (cond ((and old new) | |
120 | (let ((add-count 0) (sub-count 0)) | |
121 | (diff+note! | |
122 | old new | |
123 | (lambda (subs) | |
124 | (set! sub-count (length subs))) | |
125 | (lambda (adds) | |
126 | (set! add-count (length adds))) | |
127 | (lambda () #t)) | |
128 | (format #t "~5@D ~5@D : ~5@D" | |
129 | add-count (- sub-count) delta))) | |
130 | (else | |
131 | (format #t "~5@A ~5@A : ~5@A" "-" "-" "-"))) | |
132 | (format #t " ~A\n" group))) | |
4ab4e780 TTN |
133 | (sort (union g-old-names g-new-names) |
134 | (lambda (a b) | |
135 | (string<? (symbol->string a) | |
136 | (symbol->string b)))))) | |
137 | ((assq-ref options 'details) | |
138 | => (lambda (groups) | |
139 | (for-each (lambda (group) | |
140 | (let* ((old (or (assq-ref g-old group) '())) | |
141 | (new (or (assq-ref g-new group) '())) | |
142 | (>>! (lambda (label ls) | |
143 | (format #t "~A ~A:\n" group label) | |
144 | (for-each (lambda (x) | |
145 | (format #t " ~A\n" x)) | |
146 | ls)))) | |
147 | (diff+note! old new | |
148 | (lambda (removals) | |
149 | (>>! 'removals removals)) | |
150 | (lambda (additions) | |
151 | (>>! 'additions additions)) | |
152 | (lambda () | |
153 | (format #t "~A: no changes\n" | |
154 | group))))) | |
155 | groups))) | |
156 | (else | |
157 | (error "api-diff: group-diff: bad options"))))) | |
848f30d0 TTN |
158 | |
159 | (define (api-diff . args) | |
4ab4e780 TTN |
160 | (let* ((p (getopt-long (cons 'api-diff args) |
161 | '((details (single-char #\d) | |
162 | (value #t)) | |
163 | ;; Add options here. | |
164 | ))) | |
165 | (rest (option-ref p '() '("/dev/null" "/dev/null"))) | |
166 | (i-old (read-api-alist-file (car rest))) | |
167 | (i-new (read-api-alist-file (cadr rest))) | |
168 | (options '())) | |
169 | (cond ((option-ref p 'details #f) | |
170 | => (lambda (groups) | |
171 | (set! options (cons (cons 'details | |
172 | (map string->symbol | |
173 | (string-tokenize | |
174 | groups | |
175 | #\,))) | |
176 | options))))) | |
177 | (apply group-diff i-old i-new options))) | |
848f30d0 TTN |
178 | |
179 | (define main api-diff) | |
180 | ||
181 | ;;; api-diff ends here |