1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
|
; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.
; This produces the auto-generated part of the Windows installer
; source code.
; WINDOWS-FILE_NAME-SHORT-NAME implements the algorithm described on:
; http://support.microsoft.com/kb/142982/EN-US/
; (Except we use _ instead of ~.)
; We need this to generate an installer, among other things.
; The silliness of this crap makes Mike's head spin.
; ,open srfi-13 srfi-14
(define *ms-dos-invalid-characters*
(char-set-union char-set:whitespace
;; the spec also sez #\., which is ... silly
(char-set #\" #\/ #\\ #\[ #\] #\: #\; #\= #\,)))
; OTHERS is a list of the file names generated previously
; This may return #f if everything is taken---Mike has no idea what
; Windows does in that case.
(define (windows-file-name-short-name file-name others)
(call-with-values
(lambda ()
;; find the dot relevant for separating base from extension
(let loop ((f (string-upcase
(string-delete *ms-dos-invalid-characters* file-name))))
(let ((last-dot-index (string-index-right f #\.)))
(cond
((not last-dot-index) (values f ""))
((= (- (string-length f) 1)
last-dot-index)
(loop (substring f 0 (- (string-length f) 1))))
(else
(values (substring f 0 last-dot-index)
(substring f (+ 1 last-dot-index) (string-length f))))))))
(lambda (base extension)
(let* ((extension (if (> (string-length extension) 3)
(substring extension 0 3)
extension))
(attach-extension
(if (string=? "" extension)
values
(lambda (base) (string-append base "." extension)))))
;; try the ~1, ~2, ... short versions
(if (or (> (string-length base) 8)
(string-index file-name char-set:whitespace))
(let ((prefix (string-append (substring base 0
(min 6 (string-length base)))
"_")))
(let loop ((digit 1))
(if (> digit 9)
#f
(let ((attempt
(attach-extension (string-append prefix
(number->string digit)))))
(if (not (member attempt others))
attempt
(loop (+ 1 digit)))))))
(attach-extension base))))))
(define *non-slashes* (char-set-complement (char-set #\/)))
; returns a pair of directory (itself a list) and base file name
(define (split-file-name f)
(let ((rev-components (reverse (string-tokenize f *non-slashes*))))
(cons (reverse (cdr rev-components))
(car rev-components))))
(define (write-file-elements-include-file file-names uuids output-file-name)
(call-with-output-file output-file-name
(lambda (port)
(display "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" port)
(newline port)
(display "<Include>" port)
(newline port)
(write-file-elements file-names uuids port)
(display "</Include>" port)
(newline port))))
; organize the directories into a tree
; returns a tree = list of (union string (cons subdir tree))
(define (tree-ize-directory-alist alist)
(call-with-values
(lambda ()
(partition (lambda (pair) (null? (car pair))) alist))
(lambda (file-pairs directory-pairs)
(let* ((prefixes (delete-duplicates (map caar directory-pairs)))
(subdirectories
(map (lambda (prefix)
(let* ((with-prefix-pairs
(filter (lambda (pair)
(string=? prefix (caar pair)))
directory-pairs))
(omit-prefix
(map (lambda (pair)
(cons (cdar pair) (cdr pair)))
with-prefix-pairs)))
(cons prefix (tree-ize-directory-alist omit-prefix))))
prefixes)))
(append subdirectories (concatenate (map cdr file-pairs)))))))
; write the WiX file elements for a given list of file names
(define (write-file-elements file-names uuids port)
(let* ((split-names (map split-file-name file-names))
(directories (delete-duplicates (map car split-names)))
(alist
(map (lambda (directory)
(cons directory
(filter-map (lambda (split-name)
(if (equal? directory (car split-name))
(cdr split-name)
#f))
split-names)))
directories))
(tree (tree-ize-directory-alist alist)))
(write-directory-tree '() tree (make-uuid-source uuids) port)))
(define (make-uuid-source uuids)
(lambda ()
(let ((uuid (car uuids)))
(set! uuids (cdr uuids))
uuid)))
(define (write-directory-tree directory alist uuid-source port)
(if (not (null? directory))
(begin
(display "<Directory Id=\"" port)
(display (directory-id directory) port)
(display "\" Name=\"" port)
(display (windows-file-name-short-name (car (reverse directory))
'()) ; not completely kosher
port)
(display "\" LongName=\"" port)
(display (car (reverse directory)) port)
(display "\" >" port)
(newline port)))
(call-with-values
(lambda () (partition string? alist))
(lambda (file-names directory-entries)
(if (not (null? file-names))
(begin
(display "<Component Id=\"" port)
(display (component-id directory) port)
(display "\" Guid=\"" port)
(display (uuid-source) port)
(display "\">" port)
(newline port)
(let ((used-file-names (list '()))) ; poor man's cell
(for-each (lambda (file-name)
(write-file-element port directory file-name used-file-names))
file-names))
(display "</Component>" port)
(newline port)))
(for-each (lambda (entry)
(write-directory-tree (append directory (list (car entry)))
(cdr entry)
uuid-source
port))
directory-entries)))
(if (not (null? directory))
(begin
(display "</Directory>" port)
(newline port))))
(define (quote-component comp)
(list->string
(map (lambda (ch)
(if (char=? ch #\-)
#\.
ch))
(string->list comp))))
; insert separators between the components
(define (components->string directory separator)
(let ((id #f))
(for-each (lambda (component)
(if id
(set! id (string-append id separator component))
(set! id component)))
directory)
id))
(define (components->quoted-string dir sep)
(components->string (map quote-component dir) sep))
(define (directory-id directory)
(components->quoted-string directory "_"))
(define (file-id directory base)
(components->quoted-string (append directory (list base)) "_"))
(define (file-src directory base)
(components->string (append directory (list base)) "/"))
(define (component-id directory)
(components->quoted-string (append directory (list "component")) "_"))
(define (write-file-element port directory base-name used-file-names)
(display "<File Id=\"" port)
(display (file-id directory base-name) port)
(display "\" Name=\"" port)
(let ((short-name (windows-file-name-short-name base-name (car used-file-names))))
(set-car! used-file-names (cons short-name (car used-file-names)))
(display short-name port))
(display "\" LongName=\"" port)
(display base-name port)
(display "\" src=\"" port)
(display (file-src directory base-name) port)
(display "\" DiskId=\"1\" Vital=\"yes\" />" port)
(newline port))
|
