1 | |
---|
2 | ;; |
---|
3 | ;; Scheme Image Gallery Management Application |
---|
4 | ;; |
---|
5 | ;; Based on the igal program by Eric Pop. |
---|
6 | ;; SXML templates based on code by Oleg Kiselyov. |
---|
7 | ;; CD image creation code by Walter C. Pelissero. |
---|
8 | ;; |
---|
9 | ;; |
---|
10 | ;; Copyright 2007 Ivan Raikov |
---|
11 | ;; |
---|
12 | ;; This program is free software: you can redistribute it and/or |
---|
13 | ;; modify it under the terms of the GNU General Public License as |
---|
14 | ;; published by the Free Software Foundation, either version 3 of the |
---|
15 | ;; License, or (at your option) any later version. |
---|
16 | ;; |
---|
17 | ;; This program is distributed in the hope that it will be useful, but |
---|
18 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
---|
20 | ;; General Public License for more details. |
---|
21 | ;; |
---|
22 | ;; A full copy of the GPL license can be found at |
---|
23 | ;; <http://www.gnu.org/licenses/>. |
---|
24 | ;; |
---|
25 | |
---|
26 | |
---|
27 | (require-extension srfi-13) |
---|
28 | (require-extension posix) |
---|
29 | (require-extension extras) |
---|
30 | (require-extension regex) |
---|
31 | (require-extension utils) |
---|
32 | (require-extension args) |
---|
33 | (require-extension sxml-transforms) |
---|
34 | (require-extension doctype) |
---|
35 | (require-extension utf8) |
---|
36 | (require-extension uri) |
---|
37 | (require-extension fmt) |
---|
38 | |
---|
39 | |
---|
40 | (define s+ string-append) |
---|
41 | |
---|
42 | (define lookup-def |
---|
43 | (lambda (k lst . rest) |
---|
44 | (let-optionals rest ((default #f)) |
---|
45 | (alist-ref k lst eq? default)))) |
---|
46 | |
---|
47 | |
---|
48 | |
---|
49 | (define (fpesc dir . rest) |
---|
50 | (if (null? rest) |
---|
51 | (s+ "\"" dir "\"") |
---|
52 | (s+ "\"" dir dirsep (apply s+ rest) "\""))) |
---|
53 | |
---|
54 | (foreign-declare "#include <math.h>") |
---|
55 | (define mkdtemp (foreign-lambda c-string "mkdtemp" c-string)) |
---|
56 | (define log10 (foreign-lambda double "log10" double)) |
---|
57 | |
---|
58 | (define (sigma:warning x . rest) |
---|
59 | (let loop ((port (open-output-string)) (objs (cons x rest))) |
---|
60 | (if (null? objs) |
---|
61 | (begin |
---|
62 | (newline port) |
---|
63 | (print-error-message (get-output-string port) |
---|
64 | (current-error-port) "SIGMA warning: ")) |
---|
65 | (begin (display (car objs) port) |
---|
66 | (display " " port) |
---|
67 | (loop port (cdr objs)))))) |
---|
68 | |
---|
69 | (define (sigma:error x . rest) |
---|
70 | (let ((port (open-output-string))) |
---|
71 | (if (port? x) |
---|
72 | (begin |
---|
73 | (display "[" port) |
---|
74 | (display (port-name x) port) |
---|
75 | (display "] " port))) |
---|
76 | (let loop ((objs (if (port? x) rest (cons x rest)))) |
---|
77 | (if (null? objs) |
---|
78 | (begin |
---|
79 | (newline port) |
---|
80 | (error 'SIGMA (get-output-string port))) |
---|
81 | (begin (display (car objs) port) |
---|
82 | (display " " port) |
---|
83 | (loop (cdr objs))))))) |
---|
84 | |
---|
85 | |
---|
86 | (define SHARED-DIR (chicken-home)) |
---|
87 | |
---|
88 | (define SIGMA-DIR (make-pathname SHARED-DIR "sigma")) |
---|
89 | |
---|
90 | (define-constant slide-tmpl-file "slide-template.scm") |
---|
91 | (define-constant index-tmpl-file "index-template.scm") |
---|
92 | (define-constant css-tmpl-file "sigma.css") |
---|
93 | (define-constant caption-file ".captions") |
---|
94 | (define-constant sigma-dir ".sigma") |
---|
95 | (define-constant thumbprefix ".thumb_") |
---|
96 | (define-constant slideprefix ".slide_") |
---|
97 | |
---|
98 | (define dirsep (string ##sys#pathname-directory-separator)) |
---|
99 | |
---|
100 | (define local-sigma-dir |
---|
101 | (let ((env (current-environment))) |
---|
102 | (let ((home (alist-ref "HOME" env string=?))) |
---|
103 | (if home (s+ home dirsep sigma-dir) |
---|
104 | sigma-dir)))) |
---|
105 | |
---|
106 | |
---|
107 | ;; default command-line argument values |
---|
108 | (define opt_a #f) ; to write image size under thumbnails in index page |
---|
109 | (define opt_c #f) ; -c to use user-supplied captions |
---|
110 | (define opt_C #f) ; same as -c, but preserve image names as captions |
---|
111 | (define opt_d ".") ; look in current directory "." |
---|
112 | (define opt_f #f) ; -f to force thumbnail regeneration |
---|
113 | (define opt_g "Default Gallery Title") ; gallery title |
---|
114 | (define opt_h #f) ; print help |
---|
115 | (define opt_k #f) ; -k for the captions to also be used as slide titles |
---|
116 | (define opt_n 20) ; -n maximum thumbnails per index page |
---|
117 | (define opt_R #f) ; -R to descend subdirectories recursively |
---|
118 | (define opt_t #f) ; if specified, place image gallery in this directory |
---|
119 | (define opt_u #f) ; write captions under thumbnails on index page |
---|
120 | (define opt_U #f) ; write image names under thumbnails on index page |
---|
121 | (define opt_x #f) ; -x to omit the image count from the caption |
---|
122 | (define opt_y 75) ; max height of a thumbnail (defaults to 75) |
---|
123 | (define opt_ad #f) ; write out only dimensions |
---|
124 | (define opt_as #f) ; write out only file size |
---|
125 | (define opt_author ; specify author name |
---|
126 | (let ((user (alist-ref "USER" (current-environment) string=?))) |
---|
127 | (if user (car (string-split (fifth (user-information user)) ",")) ""))) |
---|
128 | (define opt_yslide #f) ; max height of the slides. use if images are huge. |
---|
129 | (define opt_con "") ; options to be passed to convert |
---|
130 | (define opt_help #f) ; displays brief usage message; same as -h |
---|
131 | (define opt_hls #f) ; --hls to create a highlights page |
---|
132 | (define opt_hls-main #f) ; --hls-main to create a highlights page as the main page |
---|
133 | (define opt_html-ext "html") ; extension of output HTML files |
---|
134 | (define opt_html-index "index") ; name of the main thumbnail index file |
---|
135 | (define opt_html-hindex "hindex") ; name of the highlights index file |
---|
136 | (define opt_in #f) ; --in to use image file names for the .html files |
---|
137 | (define opt_sp slideprefix) ; changes the slide filename prefix |
---|
138 | (define opt_tp thumbprefix) ; changes the thumbnail filename prefix |
---|
139 | (define opt_top #f) ; if specified, create top-level index |
---|
140 | ; file in directories that only contain |
---|
141 | ; subfolders but no images |
---|
142 | (define opt_up #f) ; if specified, generate "Up" link even for top-level image galleries |
---|
143 | (define opt_verbose 1) ; verbose mode |
---|
144 | (define opt_xy #f) ; scale thumbs to n pixels in their longer dimension |
---|
145 | (define opt_www #f) ; makes everything world-readable |
---|
146 | |
---|
147 | (define opt_gcd #f) ;; the same as -g, but also sets the |
---|
148 | ;; name of the CD image file |
---|
149 | |
---|
150 | (define opt_cd-file "Photos") ;; name of CD image file |
---|
151 | (define opt_cd-dir ;; directory for CD image output |
---|
152 | (let ((env (current-environment))) |
---|
153 | (let ((home (alist-ref "HOME" env string=?))) |
---|
154 | (if home (s+ home dirsep "tmp") |
---|
155 | (s+ dirsep "tmp"))))) |
---|
156 | |
---|
157 | |
---|
158 | |
---|
159 | (define opts |
---|
160 | `( |
---|
161 | ,(args:make-option (a) #:none "write image sizes under thumbnails on index page" |
---|
162 | (set! opt_a #t)) |
---|
163 | ,(args:make-option (c) #:none "first generate and then use captions" |
---|
164 | (set! opt_c #t)) |
---|
165 | ,(args:make-option (C) #:none "like -c, but preserve file names as captions" |
---|
166 | (set! opt_C #t)) |
---|
167 | ,(args:make-option (d) (required: "DIR") |
---|
168 | (s+ "operate on files in directory DIR (default: " opt_d ")") |
---|
169 | (set! opt_d arg)) |
---|
170 | ,(args:make-option (f) #:none "force thumbnail regeneration and scaled slides" |
---|
171 | (set! opt_f #t)) |
---|
172 | ,(args:make-option (g) (required: "TITLE") (s+ "gallery title (default: " opt_g ")") |
---|
173 | (set! opt_g arg)) |
---|
174 | ,(args:make-option (k) #:none "use the image captions for the HTML slide titles" |
---|
175 | (set! opt_k #t)) |
---|
176 | ,(args:make-option (R) #:none "recursively descend subdirectories" |
---|
177 | (set! opt_R #t)) |
---|
178 | ,(args:make-option (t) (required: "DIR") |
---|
179 | "place gallery files in directory DIR (will be created if it doesn't exist)" |
---|
180 | (set! opt_t arg)) |
---|
181 | ,(args:make-option (u) #:none "write captions under thumbnails on index page" |
---|
182 | (set! opt_u #t)) |
---|
183 | ,(args:make-option (U) #:none "write slide names under thumbnails on index page" |
---|
184 | (set! opt_U #t)) |
---|
185 | ,(args:make-option (x) #:none "omit the image count from the captions" |
---|
186 | (set! opt_x #t)) |
---|
187 | ,(args:make-option (y) (required: "N") |
---|
188 | (s+ "scale all thumbnails to the same height " |
---|
189 | "(default: " (number->string opt_y) ")") |
---|
190 | (set! opt_y (string->number arg))) |
---|
191 | |
---|
192 | ,(args:make-option (ad) #:none "like -a, but write only the image dimensions" |
---|
193 | (set! opt_ad #t)) |
---|
194 | ,(args:make-option (as) #:none "like -a, but write only the file size (in kbytes)" |
---|
195 | (set! opt_as #t)) |
---|
196 | ,(args:make-option (author) (required: "AUTHOR") (s+ "specify author name " |
---|
197 | "(default: " opt_author ")") |
---|
198 | (set! opt_author arg)) |
---|
199 | ,(args:make-option (con) (required: "OPTS") "options to pass to convert" |
---|
200 | (set! opt_con arg)) |
---|
201 | ,(args:make-option (cd-dir) (required: "DIR") (s+ "directory for CD image output (default: " |
---|
202 | opt_cd-dir ")") |
---|
203 | (set! opt_cd-dir arg)) |
---|
204 | ,(args:make-option (cd-file) (required: "DIR") (s+ "name of CD image file if --gcd is not specified (default: " |
---|
205 | opt_cd-file ")") |
---|
206 | (set! opt_cd-file arg)) |
---|
207 | ,(args:make-option (gcd) (required: "TITLE") (s+ "like -g, but also sets CD image file name") |
---|
208 | (set! opt_g arg) |
---|
209 | (set! opt_gcd arg)) |
---|
210 | ,(args:make-option (hls) #:none "creates a highlights page" |
---|
211 | (set! opt_hls #t)) |
---|
212 | ,(args:make-option (hls-main) #:none "creates a highlights page as the main page" |
---|
213 | (set! opt_hls #t) |
---|
214 | (set! opt_hls-main #t)) |
---|
215 | ,(args:make-option (html-ext) (required: "SUFFIX") |
---|
216 | (s+ "suffix of output HTML files (default: " opt_html-ext ")") |
---|
217 | (set! opt_html-ext arg)) |
---|
218 | ,(args:make-option (html-index) (required: "NAME") |
---|
219 | (s+ "name (without suffix) of the main thumbnail " |
---|
220 | "index file (default: " opt_html-index ")") |
---|
221 | (set! opt_html-index arg)) |
---|
222 | ,(args:make-option (html-hindex) (required: "NAME") |
---|
223 | (s+ "name (without suffix) of the highlights " |
---|
224 | "index file (default: " opt_html-hindex ")") |
---|
225 | (set! opt_html-hindex arg)) |
---|
226 | ,(args:make-option (in) #:none "use image file names for the HTML slide files" |
---|
227 | (set! opt_in #t)) |
---|
228 | ,(args:make-option (sp) (required: "PREFIX") (s+ "sets the slide image prefix " |
---|
229 | "(default: " opt_sp ")") |
---|
230 | (set! opt_sp arg)) |
---|
231 | ,(args:make-option (top) #:none "create index pages for directories that only contain subfolders" |
---|
232 | (set! opt_top #t)) |
---|
233 | ,(args:make-option (tp) (required: "PREFIX") (s+ "sets the thumbnail image prefix " |
---|
234 | "(default: " opt_tp ")") |
---|
235 | (set! opt_tp arg)) |
---|
236 | ,(args:make-option (up) #:none "create Up links even in top-level image galleries" |
---|
237 | (set! opt_up #t)) |
---|
238 | ,(args:make-option (verbose) (required: "LEVEL") |
---|
239 | (s+ "set verbose mode (0: quiet; 1: info; 2: debug)") |
---|
240 | (set! opt_verbose (string->number arg))) |
---|
241 | ,(args:make-option (www) #:none "makes all SIGMA files world-readable" |
---|
242 | (set! opt_www #t)) |
---|
243 | ,(args:make-option (xy) (required: "N") "scale thumbnails to N pixels in their longer dimension" |
---|
244 | (set! opt_xy (number->string arg))) |
---|
245 | ,(args:make-option (yslide) (required: "N") "scale slides to the given maximum height" |
---|
246 | (set! opt_yslide (string->number arg))) |
---|
247 | ,(args:make-option (h help) #:none "Print help" |
---|
248 | (usage)))) |
---|
249 | |
---|
250 | |
---|
251 | ;; Use args:usage to generate a formatted list of options (from OPTS), |
---|
252 | ;; suitable for embedding into help text. |
---|
253 | (define (usage) |
---|
254 | (print "Usage: " (car (argv)) " [options...] commands ") |
---|
255 | (newline) |
---|
256 | (print "Where command can be one of the following: ") |
---|
257 | (newline) |
---|
258 | ((lambda (lst) |
---|
259 | (let ((print-line (lambda (x) (cat (space-to 5) (car x) (space-to 30) (cadr x))))) |
---|
260 | (fmt #t (pad-char #\space (fmt-join print-line lst nl))) |
---|
261 | (newline))) |
---|
262 | `(("gallery" "Create an image gallery (default if no command given)") |
---|
263 | ("cdimage" "Create a CD image containing the image slides") |
---|
264 | ("thumbs" "Create image thumbnails (implicit when gallery is also given)") |
---|
265 | ("sort" "Sort images by EXIF date or file creation date") |
---|
266 | ("clean" "Clean generated files") |
---|
267 | )) |
---|
268 | (newline) |
---|
269 | (print "The following options are recognized: ") |
---|
270 | (newline) |
---|
271 | (print (parameterize ((args:indent 5)) (args:usage opts))) |
---|
272 | (exit 1)) |
---|
273 | |
---|
274 | |
---|
275 | ;; Process arguments and collate options and arguments into OPTIONS |
---|
276 | ;; alist, and operands (filenames) into OPERANDS. You can handle |
---|
277 | ;; options as they are processed, or afterwards. |
---|
278 | (define args (command-line-arguments)) |
---|
279 | |
---|
280 | (set!-values (options operands) (args:parse args opts)) |
---|
281 | |
---|
282 | |
---|
283 | (define v:quiet 0) |
---|
284 | (define v:info 1) |
---|
285 | (define v:debug 2) |
---|
286 | |
---|
287 | (define (done . rest) |
---|
288 | (let-optionals rest ((indicator "done!")) |
---|
289 | (if (= opt_verbose v:info) |
---|
290 | (begin |
---|
291 | (display indicator) |
---|
292 | (newline))))) |
---|
293 | |
---|
294 | (define (progress . rest) |
---|
295 | (let-optionals rest ((indicator ".")) |
---|
296 | (if (= opt_verbose v:info) |
---|
297 | (display indicator)))) |
---|
298 | |
---|
299 | (define (message x . rest) |
---|
300 | (if (positive? opt_verbose) |
---|
301 | (let loop ((port (open-output-string)) (objs (cons x rest))) |
---|
302 | (if (null? objs) |
---|
303 | (begin |
---|
304 | (newline port) |
---|
305 | (print-error-message (get-output-string port) |
---|
306 | (current-output-port) "SIGMA")) |
---|
307 | (begin (display (car objs) port) |
---|
308 | (display " " port) |
---|
309 | (loop port (cdr objs))))))) |
---|
310 | |
---|
311 | |
---|
312 | (define sigma-find-files |
---|
313 | (let ([glob glob] |
---|
314 | [string-match string-match] |
---|
315 | [make-pathname make-pathname] |
---|
316 | [directory? directory?] ) |
---|
317 | (lambda (dir pred . action-id-limit) |
---|
318 | (let-optionals action-id-limit |
---|
319 | ([action (lambda (x y) (cons x y))] ; we want cons inlined |
---|
320 | [id '()] |
---|
321 | [limit #f] ) |
---|
322 | (##sys#check-string dir 'sigma-find-files) |
---|
323 | (let* ([depth 0] |
---|
324 | [lproc |
---|
325 | (cond [(not limit) (lambda _ #t)] |
---|
326 | [(fixnum? limit) (lambda _ (fx< depth limit))] |
---|
327 | [else limit] ) ] |
---|
328 | [pproc |
---|
329 | (if (or (string? pred) (regexp? pred)) |
---|
330 | (lambda (x) |
---|
331 | (string-match pred x)) |
---|
332 | pred) ] ) |
---|
333 | (let loop ([fs (glob (make-pathname dir "*"))] |
---|
334 | [r id] ) |
---|
335 | (if (null? fs) r |
---|
336 | (let ([f (##sys#slot fs 0)] |
---|
337 | [rest (##sys#slot fs 1)] ) |
---|
338 | (cond [(directory? f) |
---|
339 | (cond [(member (pathname-file f) '("." "..")) (loop rest r)] |
---|
340 | [(lproc f) |
---|
341 | (loop rest |
---|
342 | (fluid-let ([depth (fx+ depth 1)]) |
---|
343 | (loop (glob (make-pathname f "*")) |
---|
344 | (if (pproc f) (action f r) r)) ) ) ] |
---|
345 | [else (loop rest (if (pproc f) (action f r) r))] ) ] |
---|
346 | [(pproc f) (loop rest (action f r))] |
---|
347 | [else (loop rest r)] ) ) ) ) ) ) ) ) ) |
---|
348 | |
---|
349 | |
---|
350 | (define (run:execute explist) |
---|
351 | (define (smooth lst) |
---|
352 | (let ((slst (map ->string lst))) |
---|
353 | (string-intersperse (cons (car slst) (cdr slst)) " "))) |
---|
354 | (for-each (lambda (cmd) |
---|
355 | (if (>= opt_verbose 2) (printf " ~A~%~!" cmd)) |
---|
356 | (system (->string cmd))) |
---|
357 | (map smooth explist))) |
---|
358 | |
---|
359 | (define (run:execute* explist) |
---|
360 | (define (smooth lst) |
---|
361 | (let ((slst (map ->string lst))) |
---|
362 | (string-intersperse (cons (car slst) (cdr slst)) " "))) |
---|
363 | (for-each (lambda (cmd) |
---|
364 | (if (>= opt_verbose 2) (printf " ~A~%~!" cmd)) |
---|
365 | (system* "~a" cmd)) |
---|
366 | (map smooth explist))) |
---|
367 | |
---|
368 | (define-macro (run . explist) |
---|
369 | `(run:execute* (list ,@(map (lambda (x) (list 'quasiquote x)) explist)))) |
---|
370 | |
---|
371 | (define-macro (run- . explist) |
---|
372 | `(run:execute (list ,@(map (lambda (x) (list 'quasiquote x)) explist)))) |
---|
373 | |
---|
374 | |
---|
375 | (define (ipipe:execute lam cmd) |
---|
376 | (define (smooth lst) |
---|
377 | (let ((slst (map ->string lst))) |
---|
378 | (string-intersperse (cons (car slst) (cdr slst)) " "))) |
---|
379 | ((lambda (cmd) |
---|
380 | (if (>= opt_verbose 2) (printf " ~A~%~!" cmd)) |
---|
381 | (with-input-from-pipe (sprintf "~a" cmd) lam)) |
---|
382 | (smooth cmd))) |
---|
383 | |
---|
384 | (define-macro (ipipe lam . explist) |
---|
385 | `(ipipe:execute ,lam ,@(map (lambda (x) (list 'quasiquote x)) explist))) |
---|
386 | |
---|
387 | |
---|
388 | |
---|
389 | (define nl (list->string (list #\newline))) |
---|
390 | |
---|
391 | (define (generate-HTML Content) |
---|
392 | |
---|
393 | (define (make-navbar head-parms) |
---|
394 | (let ((links (lookup-def 'Links head-parms '()))) |
---|
395 | (and (pair? links) |
---|
396 | `(div (@ (class "navbar")) |
---|
397 | (ul . ,(map (lambda (x) |
---|
398 | (match x ((name val) |
---|
399 | `(li (a (@ (href ,val)) ,name))))) links)))))) |
---|
400 | |
---|
401 | |
---|
402 | (define (make-header head-parms) |
---|
403 | `(head |
---|
404 | ,nl (title ,(lookup-def 'title head-parms)) |
---|
405 | ,nl (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8"))) |
---|
406 | ,nl (meta (@ (http-equiv "Content-Style-Type") (content "text/css"))) |
---|
407 | ,nl (meta (@ (http-equiv "Generator") (content "http://www.call-with-current-continuation.org/eggs/sigma.html"))) |
---|
408 | ,nl ,(let ((style (lookup-def 'Style head-parms))) |
---|
409 | (if style `(link (@ (rel "stylesheet") (type "text/css") (href ,style))) '())) |
---|
410 | ,nl |
---|
411 | ,(zip |
---|
412 | (map |
---|
413 | (lambda (key) |
---|
414 | (let ((val (lookup-def key head-parms ))) |
---|
415 | (and val |
---|
416 | `(meta (@ (name ,(symbol->string key)) (content ,val)))))) |
---|
417 | '(description Author keywords Date-yyyymmdd)) |
---|
418 | (circular-list nl)) |
---|
419 | ,nl)) |
---|
420 | |
---|
421 | (define (make-footer head-parms) |
---|
422 | `((div (@ (id "footer")) |
---|
423 | (h3 "Created on " |
---|
424 | ,(let* ((date-revised (car (lookup-def 'Date-yyyymmdd head-parms))) |
---|
425 | (year (string->number (string-copy date-revised 0 4))) |
---|
426 | (month (string->number (string-copy date-revised 4 6))) |
---|
427 | (day (string->number (string-copy date-revised 6 8))) |
---|
428 | (month-name |
---|
429 | (vector-ref |
---|
430 | '#("January" "February" "March" "April" "May" "June" |
---|
431 | "July" "August" "September" "October" "November" |
---|
432 | "December") |
---|
433 | (- month 1)))) |
---|
434 | (list month-name " " day ", " year))) |
---|
435 | ,(let ((links (lookup-def 'Links head-parms '()))) |
---|
436 | (and (pair? links) |
---|
437 | (let ((home (lookup-def 'home links))) |
---|
438 | (and home |
---|
439 | `(p "This site's top page is " |
---|
440 | (a (@ (href ,home)) (strong ,home))))))) |
---|
441 | (div (address ,(lookup-def 'Author head-parms))) |
---|
442 | (p (font (@ (size "-2")) "Image gallery generated by SIGMA."))))) |
---|
443 | |
---|
444 | |
---|
445 | (let* |
---|
446 | ;; Universal transformation rules. Work for every HTML, |
---|
447 | ;; present and future |
---|
448 | ((universal-conversion-rules |
---|
449 | `((@ |
---|
450 | ((*default* ;; local override for attributes |
---|
451 | . ,(lambda (attr-key . value) (enattr attr-key value)))) |
---|
452 | . ,(lambda (trigger . value) (cons '@ value))) |
---|
453 | (*default* . |
---|
454 | ,(let ((with-nl ;; Block-level HTML elements: |
---|
455 | ;; We insert a NL before them. |
---|
456 | ;; No NL is inserted before or after an |
---|
457 | ;; inline element. |
---|
458 | '(br ;; BR is technically inline, but we |
---|
459 | ;; treat it as block |
---|
460 | p div hr |
---|
461 | h1 h2 h3 h3 h5 h6 |
---|
462 | dl ul ol li dt dd pre |
---|
463 | table tr th td |
---|
464 | center blockquote form |
---|
465 | address body thead tfoot tbody col colgroup))) |
---|
466 | (lambda (tag . elems) |
---|
467 | (let ((nl? (and (memq tag with-nl) #\newline))) |
---|
468 | (if (and (pair? elems) (pair? (car elems)) |
---|
469 | (eq? '@ (caar elems))) |
---|
470 | (list nl? #\< tag (cdar elems) #\> |
---|
471 | (and (pair? (cdr elems)) |
---|
472 | (list (cdr elems) "</" tag #\> nl?))) |
---|
473 | (list nl? #\< tag #\> |
---|
474 | (and (pair? elems) (list elems "</" tag #\> nl?)) |
---|
475 | )))))) |
---|
476 | (*text* . ,(lambda (trigger str) |
---|
477 | (if (string? str) (string->goodHTML str) str))) |
---|
478 | (n_ ;; a non-breaking space |
---|
479 | . ,(lambda (tag . elems) |
---|
480 | (list " " elems))))) |
---|
481 | |
---|
482 | ;; Transformation rules to drop out everything but the |
---|
483 | ;; 'Header' node |
---|
484 | (search-Header-rules |
---|
485 | `((Header *preorder* |
---|
486 | . ,(lambda (tag . elems) (cons tag elems))) |
---|
487 | (*default* |
---|
488 | . ,(lambda (attr-key . elems) |
---|
489 | (let loop ((elems elems)) |
---|
490 | (cond |
---|
491 | ((null? elems) '()) |
---|
492 | ((not (pair? (car elems))) (loop (cdr elems))) |
---|
493 | ((eq? 'Header (caar elems)) (car elems)) |
---|
494 | (else (loop (cdr elems))))))) |
---|
495 | (*text* . ,(lambda (trigger str) '())))) |
---|
496 | ) |
---|
497 | |
---|
498 | (let ((header-parms (lookup-def 'Header (list (post-order Content search-Header-rules))))) |
---|
499 | (SRV:send-reply |
---|
500 | (pre-post-order Content |
---|
501 | `( |
---|
502 | ,@universal-conversion-rules |
---|
503 | |
---|
504 | (html:begin |
---|
505 | . ,(lambda (tag . elems) |
---|
506 | (let ((embedded? (lookup-def 'Embedded header-parms))) |
---|
507 | (if embedded? elems |
---|
508 | (list |
---|
509 | "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"" |
---|
510 | nl |
---|
511 | "\"http://www.w3.org/TR/html4/loose.dtd\">" nl |
---|
512 | "<html>" nl |
---|
513 | elems |
---|
514 | "</html>" nl))))) |
---|
515 | |
---|
516 | (Header |
---|
517 | *macro* |
---|
518 | . ,(lambda (tag . headers) |
---|
519 | (let ((embedded? (lookup-def 'Embedded header-parms))) |
---|
520 | (if embedded? (list) (make-header headers))))) |
---|
521 | |
---|
522 | (navbar ; Find the Header in the Content |
---|
523 | . ,(lambda (tag) ; and create the navigation bar |
---|
524 | (let ((header-parms |
---|
525 | (lookup-def 'Header |
---|
526 | (list (post-order Content |
---|
527 | search-Header-rules)) |
---|
528 | ))) |
---|
529 | (post-order (make-navbar header-parms) |
---|
530 | universal-conversion-rules)))) |
---|
531 | |
---|
532 | (body |
---|
533 | . ,(lambda (tag . elems) |
---|
534 | (list "<body>" nl elems "</body>"))) |
---|
535 | |
---|
536 | (footer ;; Find the Header in the Content |
---|
537 | . ,(lambda (tag) ;; and create the footer of the page |
---|
538 | (post-order (make-footer header-parms) |
---|
539 | universal-conversion-rules))) |
---|
540 | |
---|
541 | (gallery-title *macro* ;; Find the Header in the Content |
---|
542 | . ,(lambda (tag) ;; and create the page title rule |
---|
543 | `(div (@ (id "header")) |
---|
544 | (h1 ,(lookup-def 'Gallery-Title header-parms))))) |
---|
545 | |
---|
546 | (slide-title *macro* ;; Find the Header in the Content |
---|
547 | . ,(lambda (tag) ;; and create the page title rule |
---|
548 | `(div (@ (id "header")) |
---|
549 | (h1 ,(lookup-def 'Slide-Title header-parms))))) |
---|
550 | |
---|
551 | (slide-caption *macro* |
---|
552 | . ,(lambda (tag) |
---|
553 | `(p ,(lookup-def 'Slide-Caption header-parms)))) |
---|
554 | |
---|
555 | (slide-url *macro* |
---|
556 | . ,(lambda (tag) |
---|
557 | (lookup-def 'Slide-URL header-parms))) |
---|
558 | |
---|
559 | (image-url *macro* |
---|
560 | . ,(lambda (tag) |
---|
561 | (lookup-def 'Image-URL header-parms))) |
---|
562 | |
---|
563 | (image-thumbs *macro* |
---|
564 | . ,(lambda (tag . alist) |
---|
565 | (let ((thumbs (lookup-def 'Thumbs header-parms))) |
---|
566 | (or (and thumbs `(div (@ . ,alist) ,thumbs)) |
---|
567 | (list))))) |
---|
568 | |
---|
569 | (gallery-subfolders *macro* |
---|
570 | . ,(lambda (tag . alist) |
---|
571 | (let ((subfolders (lookup-def 'Subfolders header-parms))) |
---|
572 | (or (and subfolders |
---|
573 | `(div (@ . ,alist) (h1 "Subfolders") ,subfolders)) |
---|
574 | (list))))) |
---|
575 | |
---|
576 | (url *macro* . ,(lambda (tag href . contents) |
---|
577 | `(a (@ (href ,href)) |
---|
578 | ,(if (pair? contents) |
---|
579 | contents |
---|
580 | href)))) |
---|
581 | |
---|
582 | |
---|
583 | (Section ;; (Section level "content ...") |
---|
584 | *macro* |
---|
585 | . ,(lambda (tag level head-word . elems) |
---|
586 | `((br) (n_) (a (@ (name ,head-word)) (n_)) |
---|
587 | (,(string->symbol (s+ "h" (number->string level))) |
---|
588 | ,head-word ,elems)))) |
---|
589 | |
---|
590 | (Section* ;; (Section* level "content ...") |
---|
591 | *macro* |
---|
592 | . ,(lambda (tag level head-word . elems) |
---|
593 | `((br) (n_) (a (@ (name ,head-word)) (n_)) |
---|
594 | (,(string->symbol (s+ "h" (number->string level))) |
---|
595 | ,head-word ,elems)))) |
---|
596 | |
---|
597 | |
---|
598 | (TOC ;; Re-scan the Content for "Section" tags and generate |
---|
599 | . ,(lambda (tag) ;; the Table of contents |
---|
600 | (let ((sections |
---|
601 | (pre-post-order Content |
---|
602 | `((Section ;; (Section level "content ...") |
---|
603 | ((*text* . ,(lambda (tag str) str))) |
---|
604 | . ,(lambda (tag level head-word . elems) |
---|
605 | (list "<li><a href=\"#" head-word |
---|
606 | "\">" head-word elems "</a>" nl ))) |
---|
607 | (*default* |
---|
608 | . ,(lambda (tag . elems) elems)) |
---|
609 | |
---|
610 | (*text* . ,(lambda (trigger str) (list))))))) |
---|
611 | ;(write sections ##stderr) |
---|
612 | (list "<div id=\"toc\">" |
---|
613 | "<h3>In this page:</h3> " |
---|
614 | "<ul>" |
---|
615 | sections |
---|
616 | "</ul></div>" nl)))) |
---|
617 | |
---|
618 | |
---|
619 | )))))) |
---|
620 | |
---|
621 | |
---|
622 | ;; remove the automatically generated files from the target directory |
---|
623 | (define (clean-targetdir path) |
---|
624 | (let ((pat (s+ path dirsep "*.html"))) |
---|
625 | (run (rm -f ,pat)))) |
---|
626 | |
---|
627 | ;; load up list of image files from the given directory |
---|
628 | (define (read-imagedir path . rest) |
---|
629 | (let-optionals rest ((sort-order 'l)) |
---|
630 | (let ((jpgpat "(.*\\.[jJ][pP][eE]?[gG]$)") |
---|
631 | (pngpat "(.*\\.[pP][nN][gG]$)") |
---|
632 | (gifpat "(.*\\.[gG][iI][fF]$)") |
---|
633 | (thumbpat (string-substitute "." "\\." thumbprefix)) |
---|
634 | (slidepat (string-substitute "." "\\." slideprefix))) |
---|
635 | (let ((pat (s+ jpgpat "|" pngpat "|" gifpat)) |
---|
636 | (expat (regexp (s+ ".*((" thumbpat ")|(" slidepat ")).*")))) |
---|
637 | (let ((flst (sigma-find-files path pat |
---|
638 | (lambda (x ax) (if (string-match expat x) ax |
---|
639 | (cons (pathname-strip-directory x) ax))) |
---|
640 | (list) 0))) |
---|
641 | (sort flst string<?)))))) |
---|
642 | |
---|
643 | (define (read-subdirs path) |
---|
644 | (sigma-find-files |
---|
645 | path (lambda (x) |
---|
646 | (let ((canx (canonical-path x)) |
---|
647 | (cant (and opt_t (canonical-path opt_t)))) |
---|
648 | (and (directory? x) (or (not cant) (not (string=? cant canx)))))) |
---|
649 | (lambda (x y) (let ((lst (string-split x dirsep))) |
---|
650 | (cons (if (absolute-pathname? x) (cons dirsep lst) lst) y))) (list) 0)) |
---|
651 | |
---|
652 | |
---|
653 | ;; locate and copy (if necessary) a SIGMA template file |
---|
654 | (define (locate-and-copy-template SIGMA-DIR target-dir file-name) |
---|
655 | (if (file-exists? (s+ target-dir dirsep file-name)) |
---|
656 | (message "Found " file-name " file.") |
---|
657 | (begin |
---|
658 | (message "No " file-name " file; getting a copy from " SIGMA-DIR ".") |
---|
659 | (if (directory? SIGMA-DIR) |
---|
660 | (if (file-exists? (s+ SIGMA-DIR dirsep file-name)) |
---|
661 | (run (cp -f ,(fpesc SIGMA-DIR file-name) ,(fpesc target-dir file-name))) |
---|
662 | (sigma:error (s+ SIGMA-DIR dirsep file-name) |
---|
663 | " cannot be read or does not exist.")) |
---|
664 | (sigma:error SIGMA-DIR " cannot be read or does not exist. "))))) |
---|
665 | |
---|
666 | |
---|
667 | (define (read-or-create-captions captionpath flst subdirs . rest) |
---|
668 | (let-optionals rest ((fname-as-caption? #f)) |
---|
669 | (if (and (file-exists? captionpath) |
---|
670 | (file-read-access? captionpath)) |
---|
671 | (with-input-from-file captionpath |
---|
672 | (lambda () |
---|
673 | (let loop ((captions (list)) (subdirs (list))) |
---|
674 | (let ((line (read-line))) |
---|
675 | (if (eof-object? line) |
---|
676 | (values (reverse captions) (reverse subdirs)) |
---|
677 | (let ((sexp (with-input-from-string line read))) |
---|
678 | (let* ((subdir? (match sexp (('subdir . _) #t) (else #f))) |
---|
679 | (captions (if (or subdir? (eof-object? sexp)) |
---|
680 | captions (cons sexp captions))) |
---|
681 | (subdirs (if subdir? (cons (cdr sexp) subdirs) subdirs))) |
---|
682 | (loop captions subdirs)))))))) |
---|
683 | (if (and (null? flst) (null? subdirs)) |
---|
684 | (values #f #f) |
---|
685 | (begin |
---|
686 | ;; create caption-file file if it doesn't exist |
---|
687 | (message "Creating file " captionpath ": ") |
---|
688 | (with-output-to-file captionpath |
---|
689 | (lambda () |
---|
690 | (print "; This is SIGMA " caption-file " file, first generated " |
---|
691 | (time->string (seconds->local-time (current-seconds))) |
---|
692 | ".") |
---|
693 | (print "; The captions must be in S-expression format and may include SXML tags. ") |
---|
694 | (print "; ") |
---|
695 | (print "; Each caption entry can be in one of two forms: ") |
---|
696 | (print "; ") |
---|
697 | (print "; 1. (fname caption [option1 option2 ...]) ") |
---|
698 | (print "; The first element is the image file name, and the second element is the caption. ") |
---|
699 | (print "; The file name and the caption are required. They can be followed by any number of ") |
---|
700 | (print "; options keywords. The only option keyword currently recognized is hl, which ") |
---|
701 | (print "; indicates that the slide should be included on the optional highlights page. ") |
---|
702 | (print "; ") |
---|
703 | (print "; 2. (subdir name caption) ") |
---|
704 | (print "; Entries of this form be used to specify captions for subfolders. ") |
---|
705 | (print "; ") |
---|
706 | (print "; To add any comments to this file or to exclude any images from the slide ") |
---|
707 | (print "; show, add a ; sign at the beginning of their respective lines. ") |
---|
708 | (print "; You may also change the order of images in your slide show at this time.") |
---|
709 | (let loop ((flst flst)) |
---|
710 | (if (not (null? flst)) |
---|
711 | (begin |
---|
712 | (write (list (car flst) (if fname-as-caption? (car flst) ""))) |
---|
713 | (print) |
---|
714 | (loop (cdr flst))))) |
---|
715 | (if subdirs |
---|
716 | (let loop ((subdirs subdirs)) |
---|
717 | (if (not (null? subdirs)) |
---|
718 | (let ((subdir (car subdirs))) |
---|
719 | (write (list 'subdir (first subdir) (second subdir) |
---|
720 | (if fname-as-caption? (first subdir) ""))) |
---|
721 | (print) |
---|
722 | (loop (cdr subdirs)))))))) |
---|
723 | (message "Now edit the " captionpath " file to your liking and rerun sigma -c.") |
---|
724 | (values #f #f)))))) |
---|
725 | |
---|
726 | ;; read EXIF image date or inode change time for the file |
---|
727 | (define (image-date path) |
---|
728 | (let ((date (ipipe read-line (exif ,(fpesc path) |\|| grep Date |\|| grep orig |\|| cut -f2 -d |\\\||)))) |
---|
729 | (if (or (eof-object? date) (string-null? date)) |
---|
730 | (let* ((s (file-change-time path)) |
---|
731 | (ti (seconds->local-time s))) |
---|
732 | (s+ (number->string (+ 1900 (vector-ref ti 5))) ":" |
---|
733 | (number->string (+ 1 (vector-ref ti 4))) ":" |
---|
734 | (number->string (vector-ref ti 3)) " " |
---|
735 | (number->string (vector-ref ti 2)) ":" |
---|
736 | (number->string (vector-ref ti 1)) ":" |
---|
737 | (number->string (vector-ref ti 0)))) |
---|
738 | (let loop ((str date)) |
---|
739 | (let ((str1 (string-chomp str " "))) |
---|
740 | (if (string=? str str1) str |
---|
741 | (loop str1))))))) |
---|
742 | |
---|
743 | ;; return x dim, y dim, rounded kb for image |
---|
744 | (define (image-size path) |
---|
745 | (let ((kb (vector-ref (file-stat path) 5))) |
---|
746 | (let ((dim (ipipe (lambda () (let ((line (read-line))) |
---|
747 | ((lambda (geom) |
---|
748 | (and (list? geom) (not (null? geom)) |
---|
749 | (map string->number (string-split (car geom) "x")))) |
---|
750 | (string-split line "+")))) |
---|
751 | (identify -ping -verbose ,(fpesc path) |\|| grep "Geometry:" |\|| cut -d":" -f2 )))) |
---|
752 | (list (car dim) (cadr dim) kb)))) |
---|
753 | |
---|
754 | |
---|
755 | ;; determine image file sizes |
---|
756 | (define (read-image-sizes image-dir flst) |
---|
757 | (message "Determining image sizes: ") |
---|
758 | (let loop ((flst flst) (sz (list))) |
---|
759 | (if (null? flst) |
---|
760 | (begin |
---|
761 | (done) |
---|
762 | (reverse sz)) |
---|
763 | (let ((path (s+ image-dir dirsep (car flst)))) |
---|
764 | (let ((dims (image-size path))) |
---|
765 | (progress) |
---|
766 | (loop (cdr flst) (cons dims sz))))))) |
---|
767 | |
---|
768 | |
---|
769 | (define (sort-images image-dir target-dir flst) |
---|
770 | (let ((order (inexact->exact (ceiling (log10 (length flst)))))) |
---|
771 | (message "Reading image dates: ") |
---|
772 | (let ((olst |
---|
773 | (let loop ((flst flst) (olst (list))) |
---|
774 | (if (null? flst) olst |
---|
775 | (let ((path (s+ image-dir dirsep (car flst)))) |
---|
776 | (if (not (and (file-exists? path) (file-read-access? path))) |
---|
777 | (sigma:error 'sort-images ": cannot open " path)) |
---|
778 | (let ((date (image-date path))) |
---|
779 | (progress) |
---|
780 | (loop (cdr flst) (merge (list (cons (car flst) date)) olst |
---|
781 | (lambda (x y) (string<=? (cdr x) (cdr y))))))))))) |
---|
782 | (done) |
---|
783 | (message "Sorting images by date: ") |
---|
784 | (let* ((op (if (string=? image-dir target-dir) 'mv 'cp)) |
---|
785 | (temp-dir-name (s+ image-dir dirsep "sigma-tmp.XXXXXX")) |
---|
786 | (temp-dir (mkdtemp temp-dir-name))) |
---|
787 | (if (not temp-dir) |
---|
788 | (sigma:error 'sort-image ": unable to create temporary directory " temp-dir-name)) |
---|
789 | (for-each (lambda (f) |
---|
790 | (let ((fpath (s+ image-dir dirsep f)) |
---|
791 | (rpath (s+ temp-dir dirsep f))) |
---|
792 | (run (,op ,(fpesc fpath) ,(fpesc rpath))) |
---|
793 | (progress))) |
---|
794 | flst) |
---|
795 | (let ((i+nlst (fold (lambda (fp i+nlst) |
---|
796 | (let ((fpath (s+ temp-dir dirsep (car fp))) |
---|
797 | (ext (pathname-extension (car fp)))) |
---|
798 | (match i+nlst |
---|
799 | ((i . nlst) |
---|
800 | (let* ((width (if (positive? order) order 1)) |
---|
801 | (nfile (s+ (fmt #f (pad-char #\0 (fit/left width i))) "." ext)) |
---|
802 | (npath (s+ target-dir dirsep nfile))) |
---|
803 | (run (mv ,(fpesc fpath) ,(fpesc npath))) |
---|
804 | (progress) |
---|
805 | (cons (+ 1 i) (cons nfile nlst))))))) |
---|
806 | (cons 0 (list)) olst))) |
---|
807 | (run (rm -rf ,temp-dir)) |
---|
808 | (done) |
---|
809 | (reverse (cdr i+nlst))))))) |
---|
810 | |
---|
811 | (define (make-thumbs image-dir target-dir flst y . rest) |
---|
812 | (let-optionals rest ((xy #f) (force-regen? #f) (convert-options "")) |
---|
813 | (message "Creating thumbnails: ") |
---|
814 | (let ((source-dir (if (string=? image-dir target-dir) image-dir target-dir))) |
---|
815 | (let loop ((flst flst)) |
---|
816 | (if (not (null? flst)) |
---|
817 | (let ((image-path (s+ source-dir dirsep (car flst)))) |
---|
818 | (if (not (and (file-exists? image-path) (file-read-access? image-path))) |
---|
819 | (sigma:error 'make-thumbs ": cannot open " image-path)) |
---|
820 | (let ((thumb-path (s+ target-dir dirsep thumbprefix (car flst)))) |
---|
821 | (if (or (not (file-exists? thumb-path)) force-regen? |
---|
822 | (> (vector-ref (file-stat image-path) 9) |
---|
823 | (vector-ref (file-stat thumb-path) 9))) |
---|
824 | (run (convert ,convert-options -scale |
---|
825 | ,(if xy (let ((xy (number->string xy))) |
---|
826 | (s+ xy "x" xy)) |
---|
827 | (s+ "x" (number->string y))) |
---|
828 | ,(fpesc image-path) ,(fpesc thumb-path)))) |
---|
829 | (progress) |
---|
830 | (loop (cdr flst)))))) |
---|
831 | (done)))) |
---|
832 | |
---|
833 | ;; copy images to target-dir, if necessary |
---|
834 | (define (copy-images image-dir target-dir flst) |
---|
835 | (if (not (string=? image-dir target-dir)) |
---|
836 | (begin |
---|
837 | (message "Copying images to target directory: ") |
---|
838 | (let loop ((flst flst)) |
---|
839 | (if (not (null? flst)) |
---|
840 | (let ((image-path (s+ image-dir dirsep (car flst))) |
---|
841 | (target-path (s+ target-dir dirsep (car flst)))) |
---|
842 | (if (not (and (file-exists? image-path) (file-read-access? image-path))) |
---|
843 | (sigma:error 'copy-images ": cannot open " image-path)) |
---|
844 | (if (not (file-exists? target-path)) |
---|
845 | (run (cp -f ,(fpesc image-path) ,(fpesc target-path)))) |
---|
846 | (progress) |
---|
847 | (loop (cdr flst))) |
---|
848 | (done)))))) |
---|
849 | |
---|
850 | ;; scale down images if the --yslide <n> option was given |
---|
851 | (define (scale-images image-dir target-dir flst yslide . rest) |
---|
852 | (let-optionals rest ((force-regen? #f) (convert-options "")) |
---|
853 | (let ((source-dir (if (string=? image-dir target-dir) image-dir target-dir))) |
---|
854 | (message "Scaling down big slides: ") |
---|
855 | (let loop ((flst flst)) |
---|
856 | (if (not (null? flst)) |
---|
857 | (let ((image-path (s+ source-dir dirsep (car flst)))) |
---|
858 | (if (not (and (file-exists? image-path) (file-read-access? image-path))) |
---|
859 | (sigma:error 'scale-images ": cannot open " image-path)) |
---|
860 | (let ((slide-path (s+ target-dir dirsep slideprefix (car flst)))) |
---|
861 | (if (or (not (file-exists? slide-path)) force-regen?) |
---|
862 | (let ((y (cadr (image-size image-path)))) |
---|
863 | (if (and (positive? yslide) (> y yslide)) ;; only scale down, never up. |
---|
864 | (run (convert ,convert-options |
---|
865 | -scale ,(s+ "x" (number->string yslide)) |
---|
866 | ,(fpesc image-path) ,(fpesc slide-path))) |
---|
867 | (run (ln ,(fpesc image-path) ,(fpesc slide-path)))))) |
---|
868 | (progress) |
---|
869 | (loop (cdr flst)))))) |
---|
870 | (done)))) |
---|
871 | |
---|
872 | |
---|
873 | (define (filter-subfolders target-dir target-dir-depth lst) |
---|
874 | (filter-map (lambda (d) |
---|
875 | (let ((thumbpat (regexp (s+ thumbprefix "*"))) |
---|
876 | (absolute? (string=? dirsep (car d)))) |
---|
877 | ;; only allow subfolders that contain thumbnails |
---|
878 | (let* ((dd (drop (if absolute? (cdr d) d) target-dir-depth)) |
---|
879 | (subflst (directory (string-intersperse (cons target-dir dd) dirsep) #t)) |
---|
880 | (subthumbs (filter (lambda (x) (string-match thumbpat x)) subflst))) |
---|
881 | (and (pair? subthumbs) |
---|
882 | (list (string-intersperse dd dirsep) (car subthumbs)))))) |
---|
883 | lst)) |
---|
884 | |
---|
885 | |
---|
886 | ;; create the individual slide show files |
---|
887 | (define (make-slides image-dir target-dir slidetmpl index |
---|
888 | gallery-title flst captions slst |
---|
889 | caption-as-title? omit-image-count? yslide author) |
---|
890 | (message "Creating individual slides: ") |
---|
891 | (let loop ((lst (zip flst captions slst)) (prev index) (counter 0)) |
---|
892 | (if (not (null? lst)) |
---|
893 | (match (car lst) |
---|
894 | ((imagename caption slidename) |
---|
895 | (let ((title (let ((title (if caption-as-title? |
---|
896 | ;; use image caption for the HTML slide title |
---|
897 | caption |
---|
898 | ;; otherwise use the image name with stripped suffix |
---|
899 | (pathname-strip-extension imagename)))) |
---|
900 | (if omit-image-count? title |
---|
901 | (list title " (" (number->string counter) ")")))) |
---|
902 | (slide-url (uri-encode |
---|
903 | (if yslide |
---|
904 | (s+ slideprefix imagename) |
---|
905 | imagename))) |
---|
906 | (image-url (uri-encode imagename)) |
---|
907 | (date (let ((v (seconds->local-time (current-seconds))) |
---|
908 | (num->str (lambda (i w) (fmt #f (pad-char #\0 (fit/left w i)))))) |
---|
909 | (let ((year (num->str (+ 1900 (vector-ref v 5)) 4)) |
---|
910 | (month (num->str (+ 1 (vector-ref v 4)) 2)) |
---|
911 | (day (num->str (vector-ref v 3) 2))) |
---|
912 | (s+ year month day)))) |
---|
913 | (links `((contents ,index) |
---|
914 | (prev ,prev) |
---|
915 | (next ,(if (null? (cdr lst)) "" (third (cadr lst))))))) |
---|
916 | (with-output-to-file (s+ target-dir dirsep slidename) |
---|
917 | (lambda () |
---|
918 | (let* ((header `(Header (Date-yyyymmdd ,date) |
---|
919 | (Style ,css-tmpl-file) |
---|
920 | (Gallery-Title ,gallery-title) |
---|
921 | (Slide-Title ,title) |
---|
922 | (Slide-Caption ,caption) |
---|
923 | (Slide-URL ,slide-url) |
---|
924 | (Image-URL ,image-url) |
---|
925 | (Author ,author) |
---|
926 | (Links . ,links))) |
---|
927 | (content |
---|
928 | (pre-post-order |
---|
929 | slidetmpl |
---|
930 | `((html:begin . ,(lambda (tag . elems) |
---|
931 | (if (not (lookup-def 'Header elems)) |
---|
932 | `(html:begin . ,(cons header elems)) |
---|
933 | `(html:begin . ,elems)))) |
---|
934 | (Header . ,(lambda (tag . elems) |
---|
935 | (if (null? elems) header |
---|
936 | `(Header . ,(append (cdr header) elems))))) |
---|
937 | (*default* . ,(lambda (tag . elems) `(,tag . ,elems))))))) |
---|
938 | (generate-HTML content)))) |
---|
939 | (progress) |
---|
940 | (loop (cdr lst) slidename (+ 1 counter))))))) |
---|
941 | (done)) |
---|
942 | |
---|
943 | |
---|
944 | |
---|
945 | ;; create the index files with all the thumbnails and optional subgalleries |
---|
946 | (define (make-index target-dir index-tmpl-file flst slst captions szlst |
---|
947 | nfiles max-thumbs html-index html-ext gallery-title author |
---|
948 | subfolders . rest) |
---|
949 | (let-optionals rest ((up #f) (mlinks (list))) |
---|
950 | (let ((index-tmpl-path (s+ target-dir dirsep index-tmpl-file)) |
---|
951 | (npages (inexact->exact (ceiling (/ nfiles max-thumbs))))) |
---|
952 | (let ((indextmpl (with-input-from-file index-tmpl-path read))) |
---|
953 | (let loop ((i 0) (flst flst) (slst slst) (captions captions) (szlst szlst)) |
---|
954 | (if (not (null? flst)) |
---|
955 | (let ((nthumbs (min (length flst) max-thumbs)) |
---|
956 | (index-path (s+ target-dir dirsep html-index |
---|
957 | (if (positive? i) (number->string i) "") |
---|
958 | "." html-ext))) |
---|
959 | (message "Creating " index-path " file: ") |
---|
960 | (let ((date (let ((v (seconds->local-time (current-seconds))) |
---|
961 | (num->str (lambda (i w) (fmt #f (pad-char #\0 (fit/left w i)))))) |
---|
962 | (let ((year (num->str (+ 1900 (vector-ref v 5)) 4)) |
---|
963 | (month (num->str (+ 1 (vector-ref v 4)) 2)) |
---|
964 | (day (num->str (vector-ref v 3) 2))) |
---|
965 | (s+ year month day)))) |
---|
966 | (image-thumbs |
---|
967 | (map (lambda (fname sname caption sz) |
---|
968 | (let ((thumbname (s+ thumbprefix fname))) |
---|
969 | `(div (@ (class "thumb")) |
---|
970 | (a (@ (href ,(uri-encode sname))) |
---|
971 | (img (@ (src ,(uri-encode thumbname)))) ,nl) |
---|
972 | (div (@ (class "thumb-caption")) |
---|
973 | ,(cond (opt_u `(p (@ (size "-2")) ,caption)) |
---|
974 | (opt_U `(p (@ (size "-2")) ,sname)) |
---|
975 | (else "")) |
---|
976 | ,(cond (opt_a `(p (@ (size "-2")) |
---|
977 | ,(first sz) "x" ,(second sz) (br) |
---|
978 | "(" ,(quotient (third sz) 1024) " KB" ")")) |
---|
979 | (opt_ad `(p (@ (size "-2")) ,(first sz) "x" ,(second sz))) |
---|
980 | (opt_as `(p (@ (size "-2")) ,(quotient (third sz) 1024) " KB")) |
---|
981 | (else "")))))) |
---|
982 | (take flst nthumbs) (take slst nthumbs) (take captions nthumbs) |
---|
983 | (take szlst nthumbs))) |
---|
984 | (links (append |
---|
985 | (if up (let ((up-link (if (boolean? up) |
---|
986 | (s+ ".." dirsep html-index "." html-ext) |
---|
987 | up))) |
---|
988 | (list (list "Up" up-link))) |
---|
989 | (list)) |
---|
990 | mlinks |
---|
991 | (if (> npages 1) |
---|
992 | (list-tabulate |
---|
993 | npages (lambda (i) (list (string->symbol (number->string i)) |
---|
994 | (s+ html-index (if (positive? i) (number->string i) "") |
---|
995 | "." html-ext)))) |
---|
996 | (list)))) |
---|
997 | (subfolders (map (lambda (sub) |
---|
998 | (let ((index-path (s+ (first sub) dirsep html-index "." html-ext)) |
---|
999 | (thumb-path (s+ (first sub) dirsep (uri-encode (second sub)))) |
---|
1000 | (caption (if (string-null? (third sub)) (first sub) (third sub)))) |
---|
1001 | `(div (@ (class "thumb")) |
---|
1002 | (a (@ (href ,index-path)) |
---|
1003 | (img (@ (src ,thumb-path))) ,nl) |
---|
1004 | (div (@ (class "thumb-caption")) |
---|
1005 | (p ,caption))))) |
---|
1006 | subfolders))) |
---|
1007 | (with-output-to-file index-path |
---|
1008 | (lambda () |
---|
1009 | (let* ((header `(Header (Date-yyyymmdd ,date) |
---|
1010 | (Style ,css-tmpl-file) |
---|
1011 | (Gallery-Title ,gallery-title) |
---|
1012 | (Thumbs ,image-thumbs) |
---|
1013 | (Author ,author) |
---|
1014 | (Links . ,links) |
---|
1015 | ,@(if (null? subfolders) `() |
---|
1016 | `((Subfolders . ,subfolders))))) |
---|
1017 | (content |
---|
1018 | (pre-post-order |
---|
1019 | indextmpl |
---|
1020 | `((html:begin . ,(lambda (tag . elems) |
---|
1021 | (if (not (lookup-def 'Header elems)) |
---|
1022 | `(html:begin . ,(cons header elems)) |
---|
1023 | `(html:begin . ,elems)))) |
---|
1024 | (Header . ,(lambda (tag . elems) |
---|
1025 | (if (null? elems) header |
---|
1026 | `(Header ,(append (cdr header) elems))))) |
---|
1027 | (*default* . ,(lambda (tag . elems) `(,tag . ,elems))))))) |
---|
1028 | (generate-HTML content)))) |
---|
1029 | (done) |
---|
1030 | (loop (+ 1 i) (drop flst nthumbs) (drop slst nthumbs) (drop captions nthumbs) |
---|
1031 | (drop szlst nthumbs)))))))))) |
---|
1032 | |
---|
1033 | |
---|
1034 | ;; create an index file that only contains subgalleries |
---|
1035 | (define (make-toplevel-index target-dir index-tmpl-file html-index html-ext gallery-title author |
---|
1036 | subfolders . rest) |
---|
1037 | (let-optionals rest ((up #f) (home #f)) |
---|
1038 | (let ((index-tmpl-path (s+ target-dir dirsep index-tmpl-file))) |
---|
1039 | (let ((indextmpl (with-input-from-file index-tmpl-path read))) |
---|
1040 | (let ((index-path (s+ target-dir dirsep html-index "." html-ext))) |
---|
1041 | (message "Creating " index-path " file: ") |
---|
1042 | (let ((date (let ((v (seconds->local-time (current-seconds))) |
---|
1043 | (num->str (lambda (i w) (fmt #f (pad-char #\0 (fit/left w i)))))) |
---|
1044 | (let ((year (num->str (+ 1900 (vector-ref v 5)) 4)) |
---|
1045 | (month (num->str (+ 1 (vector-ref v 4)) 2)) |
---|
1046 | (day (num->str (vector-ref v 3) 2))) |
---|
1047 | (s+ year month day)))) |
---|
1048 | (links (append |
---|
1049 | (if up (let ((up-link (if (boolean? up) |
---|
1050 | (s+ ".." dirsep html-index "." html-ext) |
---|
1051 | up))) |
---|
1052 | (list (list "Up" up-link))) |
---|
1053 | (list)) |
---|
1054 | (if home (list (list "Home" home)) (list)))) |
---|
1055 | (subfolders (map (lambda (sub) |
---|
1056 | (let ((index-path (s+ (first sub) dirsep html-index "." html-ext)) |
---|
1057 | (thumb-path (s+ (first sub) dirsep (uri-encode (second sub)))) |
---|
1058 | (caption (if (string-null? (third sub)) (first sub) (third sub)))) |
---|
1059 | `(div (@ (class "thumb")) |
---|
1060 | (a (@ (href ,index-path)) |
---|
1061 | (img (@ (src ,thumb-path))) ,nl) |
---|
1062 | (div (@ (class "thumb-caption")) |
---|
1063 | (p ,caption))))) |
---|
1064 | subfolders))) |
---|
1065 | (with-output-to-file index-path |
---|
1066 | (lambda () |
---|
1067 | (let* ((header `(Header (Date-yyyymmdd ,date) |
---|
1068 | (Style ,css-tmpl-file) |
---|
1069 | (Gallery-Title ,gallery-title) |
---|
1070 | (Author ,author) |
---|
1071 | (Links . ,links) |
---|
1072 | ,@(if (null? subfolders) `() |
---|
1073 | `((Subfolders . ,subfolders))))) |
---|
1074 | (content |
---|
1075 | (pre-post-order |
---|
1076 | indextmpl |
---|
1077 | `((html:begin . ,(lambda (tag . elems) |
---|
1078 | (if (not (lookup-def 'Header elems)) |
---|
1079 | `(html:begin . ,(cons header elems)) |
---|
1080 | `(html:begin . ,elems)))) |
---|
1081 | (Header . ,(lambda (tag . elems) |
---|
1082 | (if (null? elems) header |
---|
1083 | `(Header ,(append (cdr header) elems))))) |
---|
1084 | (*default* . ,(lambda (tag . elems) `(,tag . ,elems))))))) |
---|
1085 | (generate-HTML content)))) |
---|
1086 | (done))))))) |
---|
1087 | |
---|
1088 | |
---|
1089 | (define (main-make-gallery SIGMA-DIR index image-dir target-dir commands . rest) |
---|
1090 | (let-optionals rest ((subdirs (list)) (up #f) (toplevel? #f) (slide-dir #f)) |
---|
1091 | (if (commands 'clean?) |
---|
1092 | (let ((pat (s+ ".*/(" thumbprefix ".*|" slideprefix ".*|" css-tmpl-file "|" |
---|
1093 | index-tmpl-file "|" slide-tmpl-file "|.*\\.html|" caption-file ")"))) |
---|
1094 | (let ((flst (sigma-find-files target-dir pat (lambda (x ax) (delete-file x) (cons x ax)) (list) 0))) |
---|
1095 | (message "deleted files: " flst)))) |
---|
1096 | (let ((flst (read-imagedir image-dir))) |
---|
1097 | ;; make sure there are some image files or subdirectories in the given directory |
---|
1098 | (if (and (null? flst) (null? subdirs)) |
---|
1099 | (sigma:error "cannot find any image files or subdirectories in directory " image-dir)) |
---|
1100 | ;; make sure target dir exists |
---|
1101 | (if (not (file-exists? target-dir)) |
---|
1102 | (create-directory target-dir)) |
---|
1103 | (let ((captionpath (s+ target-dir dirsep caption-file)) |
---|
1104 | (target-dir-depth (length (string-split target-dir dirsep)))) |
---|
1105 | (let ((subfolders (filter-subfolders target-dir target-dir-depth subdirs)) |
---|
1106 | ;; count the image files and sort them if requested by the user |
---|
1107 | (flst (if (and (commands 'sort?) (pair? flst)) |
---|
1108 | (sort-images image-dir target-dir flst) flst))) |
---|
1109 | ;; read in files specified in the .captions file |
---|
1110 | (let-values (((flst+captions subfolders) |
---|
1111 | (if (or opt_c opt_C) (read-or-create-captions captionpath flst subfolders opt_C) |
---|
1112 | (values (map (lambda (x) (if (list? x) (append x (list "")) (list x ""))) flst) |
---|
1113 | (map (lambda (x) (if (list? x) (append x (list "")) (list x ""))) subfolders))))) |
---|
1114 | (let ((nfiles (or (and flst+captions (length flst)) 0))) |
---|
1115 | (cond ((and (zero? nfiles) toplevel? subfolders) |
---|
1116 | ;; Create a top-level index file that only contains links to subgalleries |
---|
1117 | (begin |
---|
1118 | ;; locate and copy the index template file, if necessary |
---|
1119 | (locate-and-copy-template SIGMA-DIR target-dir index-tmpl-file) |
---|
1120 | ;; locate and copy the CSS file, if necessary |
---|
1121 | (locate-and-copy-template SIGMA-DIR target-dir css-tmpl-file) |
---|
1122 | ;; create the index files with all the thumbnails |
---|
1123 | (make-toplevel-index target-dir index-tmpl-file |
---|
1124 | opt_html-index opt_html-ext opt_g opt_author subfolders up))) |
---|
1125 | (flst+captions |
---|
1126 | (begin |
---|
1127 | (if (commands 'gallery?) |
---|
1128 | (begin |
---|
1129 | (message "Found " nfiles " image files in directory: " image-dir) |
---|
1130 | (if (< nfiles 1) |
---|
1131 | (sigma:error " please select more files for your gallery!")))) |
---|
1132 | (if flst+captions |
---|
1133 | (let-values (((flst captions) (unzip2 flst+captions)) |
---|
1134 | ((hflst hcaptions) (unzip2 (filter (lambda (x) (member 'hl x)) flst+captions)))) |
---|
1135 | ;; copy images to target dir, if necessary |
---|
1136 | (if (not (commands 'sort?)) (copy-images image-dir target-dir flst)) |
---|
1137 | ;; generate thumbnails |
---|
1138 | (if (commands 'thumbs?) |
---|
1139 | (make-thumbs image-dir target-dir flst opt_y opt_xy opt_f opt_con)) |
---|
1140 | ;; if slide-dir is true (e.g. when making a CD image), |
---|
1141 | ;; copy the slides to slide-dir |
---|
1142 | (if slide-dir |
---|
1143 | (let ((snum (length (directory slide-dir)))) |
---|
1144 | (message "Copying slide images to CD image dir (" slide-dir "): ") |
---|
1145 | (fold (lambda (f i) |
---|
1146 | (let ((ext (pathname-extension f)) |
---|
1147 | (is (fmt #f (pad-char #\0 (fit/left 5 i))))) |
---|
1148 | (let ((fpath (s+ target-dir dirsep (if opt_yslide (s+ slideprefix f) f))) |
---|
1149 | (rpath (s+ slide-dir dirsep is "." ext ))) |
---|
1150 | (run (cp ,(fpesc fpath) ,(fpesc rpath))) |
---|
1151 | (progress) |
---|
1152 | (+ 1 i)))) |
---|
1153 | snum flst) |
---|
1154 | (done))) |
---|
1155 | (if (commands 'gallery?) |
---|
1156 | (begin |
---|
1157 | ;; scale down images |
---|
1158 | (if opt_yslide |
---|
1159 | (scale-images image-dir target-dir flst opt_yslide opt_f opt_con)) |
---|
1160 | (let ((szlst (read-image-sizes target-dir flst)) |
---|
1161 | (hszlst (and opt_hls (read-image-sizes target-dir hflst))) |
---|
1162 | (slst (if opt_in ;; use image file names for slide html file names |
---|
1163 | (map (lambda (n) (pathname-replace-extension n opt_html-ext)) flst) |
---|
1164 | (map (lambda (n) (s+ n "." opt_html-ext)) |
---|
1165 | (list-tabulate nfiles number->string)))) |
---|
1166 | (hslst (if opt_in |
---|
1167 | (map (lambda (n) |
---|
1168 | (s+ "hl" (pathname-replace-extension n opt_html-ext))) |
---|
1169 | hflst) |
---|
1170 | (map (lambda (n) (s+ "hl" n "." opt_html-ext)) |
---|
1171 | (list-tabulate (length hflst) number->string))))) |
---|
1172 | (clean-targetdir target-dir) |
---|
1173 | ;; locate and copy the slide template file, if necessary |
---|
1174 | (locate-and-copy-template SIGMA-DIR target-dir slide-tmpl-file) |
---|
1175 | (let ((slide-tmpl-path (s+ target-dir dirsep slide-tmpl-file))) |
---|
1176 | (let ((slidetmpl (with-input-from-file slide-tmpl-path read)) |
---|
1177 | (hindex (s+ opt_html-hindex "." opt_html-ext)) |
---|
1178 | (htitle (list "Highlights of " '(br) opt_g))) |
---|
1179 | ;; create the individual slide show files |
---|
1180 | (make-slides image-dir target-dir slidetmpl |
---|
1181 | (if (and opt_hls-main (not (null? hflst))) hindex index) |
---|
1182 | opt_g flst captions slst opt_k opt_x opt_yslide opt_author) |
---|
1183 | |
---|
1184 | (if (and opt_hls (not (null? hflst))) |
---|
1185 | ;; create the slide show files for the highlight images |
---|
1186 | (make-slides image-dir target-dir slidetmpl (if opt_hls-main index hindex) |
---|
1187 | htitle hflst hcaptions hslst opt_k opt_x opt_yslide opt_author)) |
---|
1188 | ;; locate and copy the index template file, if necessary |
---|
1189 | (locate-and-copy-template SIGMA-DIR target-dir index-tmpl-file) |
---|
1190 | ;; locate and copy the CSS file, if necessary |
---|
1191 | (locate-and-copy-template SIGMA-DIR target-dir css-tmpl-file) |
---|
1192 | (cond ((and opt_hls-main (not (null? hflst))) |
---|
1193 | (let ((up-url (s+ ".." dirsep opt_html-index "." opt_html-ext))) |
---|
1194 | ;; create the index files with all the thumbnails |
---|
1195 | (make-index target-dir index-tmpl-file flst slst captions szlst |
---|
1196 | nfiles opt_n opt_html-hindex opt_html-ext opt_g opt_author |
---|
1197 | subfolders (and up up-url) |
---|
1198 | `(("Highlights" |
---|
1199 | ,(s+ opt_html-index "." opt_html-ext)))) |
---|
1200 | (make-index target-dir index-tmpl-file hflst hslst hcaptions hszlst |
---|
1201 | (length hflst) opt_n opt_html-index opt_html-ext |
---|
1202 | htitle opt_author subfolders (and up up-url) |
---|
1203 | `(("All images" |
---|
1204 | ,(s+ opt_html-hindex "." opt_html-ext)))))) |
---|
1205 | ((and opt_hls (not (null? hflst))) |
---|
1206 | (let ((up-url (s+ ".." dirsep opt_html-index "." opt_html-ext))) |
---|
1207 | ;; create the index files with all the thumbnails |
---|
1208 | (make-index target-dir index-tmpl-file flst slst captions szlst |
---|
1209 | nfiles opt_n opt_html-index opt_html-ext opt_g opt_author |
---|
1210 | subfolders (and up up-url) |
---|
1211 | `(("Highlights" |
---|
1212 | ,(s+ opt_html-hindex "." opt_html-ext)))) |
---|
1213 | (make-index target-dir index-tmpl-file hflst hslst hcaptions hszlst |
---|
1214 | (length hflst) opt_n opt_html-hindex opt_html-ext |
---|
1215 | htitle opt_author subfolders (and up up-url) |
---|
1216 | `(("All images" |
---|
1217 | ,(s+ opt_html-index "." opt_html-ext)))))) |
---|
1218 | (else |
---|
1219 | (make-index target-dir index-tmpl-file flst slst captions szlst |
---|
1220 | nfiles opt_n opt_html-index opt_html-ext opt_g opt_author |
---|
1221 | subfolders up ))) |
---|
1222 | ;; if --www was invoked make all images world-readable at the end |
---|
1223 | (if opt_www |
---|
1224 | (begin |
---|
1225 | (message "Making all gallery files world-readable for WWW publishing...") |
---|
1226 | (run (chmod a+r ,(s+ (fpesc target-dir) dirsep css-tmpl-file))) |
---|
1227 | (run (chmod a+r ,(s+ (fpesc target-dir) dirsep "*." opt_html-ext))) |
---|
1228 | (run- (chmod a+r ,(s+ (fpesc target-dir) dirsep thumbprefix "*.*"))) |
---|
1229 | (run- (chmod a+r ,(s+ (fpesc target-dir) dirsep slideprefix "*.*"))) |
---|
1230 | (for-each (lambda (x) (run (chmod a+r ,(fpesc target-dir x)))) flst) |
---|
1231 | (done)))))))))))))))))))) |
---|
1232 | |
---|
1233 | |
---|
1234 | (define (blocks->MB blocks) (quotient (* 2 blocks) 1024)) |
---|
1235 | |
---|
1236 | (define-constant *blocks-in-700MB* 359846) |
---|
1237 | (define-constant *blocks-in-650MB* 332800) |
---|
1238 | |
---|
1239 | (define (estimate-filesystem-size dirs) |
---|
1240 | (let* ((blocks (ipipe (lambda () (let ((line (read-line))) (string->number line))) |
---|
1241 | (mkisofs -r -print-size -quiet ,@dirs))) |
---|
1242 | (size-MB (blocks->MB blocks))) |
---|
1243 | (if (zero? size-MB) |
---|
1244 | (message "CD image size is estimated to be " (* 2 blocks) " KB. " ) |
---|
1245 | (message "CD image size is estimated to be " size-MB " MB. " )) |
---|
1246 | (if (<= size *blocks-in-650MB*) |
---|
1247 | (let ((remaining (- *blocks-in-650MB* size))) |
---|
1248 | (message "it will fit in a 650 MB (70 min) disk, leaving " |
---|
1249 | (blocks->MB remaining) |
---|
1250 | " MB (" remaining " blocks) unused. ") |
---|
1251 | 'cd650) |
---|
1252 | (let ((remaining (- *blocks-in-700MB* size)) |
---|
1253 | (excess (- size *blocks-in-650MB*))) |
---|
1254 | (cond ((> size *blocks-in-700MB*) |
---|
1255 | (message "it will not fit in a 700 MB (80 min) disk, for " |
---|
1256 | (blocks->MB (abs remaining)) |
---|
1257 | " MB (" (abs remaining) " blocks) too much. ") |
---|
1258 | #f) |
---|
1259 | (else |
---|
1260 | (begin |
---|
1261 | (message "it will not fit in a 650 MB (70 min) disk for " |
---|
1262 | (blocks->MB excess) |
---|
1263 | " MB (" excess " blocks), ") |
---|
1264 | (message "but it will fit in a 700 MB (80 min) disk leaving " |
---|
1265 | (blocks->MB remaining) |
---|
1266 | " MB (" remaining " blocks) unused. ") |
---|
1267 | 'cd700))))))) |
---|
1268 | |
---|
1269 | |
---|
1270 | ;; Make up a reasonable volume title from the directory names |
---|
1271 | (define (make-up-volume-title dirs) |
---|
1272 | (string-intersperse (map (lambda (d) (pathname-file d)) dirs) " ")) |
---|
1273 | |
---|
1274 | (define (create-iso-image dirs . rest) |
---|
1275 | (if (estimate-filesystem-size dirs) |
---|
1276 | (let-optionals rest |
---|
1277 | ((title (make-up-volume-title dirs)) |
---|
1278 | (output-path (s+ opt_cd-dir dirsep (or opt_gcd opt_cd-file) ".iso")) |
---|
1279 | (preparer opt_author) |
---|
1280 | (publisher opt_author)) |
---|
1281 | (run (mkisofs -r -V ,(s+ "\"" title "\"") -p ,(s+ "\"" preparer "\"") |
---|
1282 | -P ,(s+ "\"" publisher "\"") -o ,(fpesc output-path) ,@dirs)) |
---|
1283 | output-path))) |
---|
1284 | |
---|
1285 | |
---|
1286 | |
---|
1287 | (define valid-commands '(clean sort thumbs gallery cdimage)) |
---|
1288 | |
---|
1289 | (define (make-command-selector commands) |
---|
1290 | (let ((clean? (member 'clean commands)) |
---|
1291 | (sort? (member 'sort commands)) |
---|
1292 | (thumbs? (or (member 'gallery commands) (member 'thumbs commands))) |
---|
1293 | (gallery? (member 'gallery commands)) |
---|
1294 | (cdimage? (member 'cdimage commands))) |
---|
1295 | (and (or clean? sort? thumbs? gallery? cdimage?) |
---|
1296 | (lambda (selector) |
---|
1297 | (case selector |
---|
1298 | ((cdimage?) cdimage?) |
---|
1299 | ((clean?) clean?) |
---|
1300 | ((sort?) sort?) |
---|
1301 | ((thumbs?) thumbs?) |
---|
1302 | ((gallery?) gallery?)))))) |
---|
1303 | |
---|
1304 | |
---|
1305 | (define (main options operands) |
---|
1306 | (let* (;; Determine what commands were given to the program, if |
---|
1307 | ;; any |
---|
1308 | (commands (make-command-selector |
---|
1309 | (filter-map (lambda (x) (let ((s (string->symbol x))) |
---|
1310 | (and (member s valid-commands) s))) |
---|
1311 | operands))) |
---|
1312 | (commands (or commands (make-command-selector '(gallery)))) |
---|
1313 | ;; Strip any unnecessary slashes from the end of the given |
---|
1314 | ;; opt_d and opt_t directories |
---|
1315 | (image-dir (let loop ((opt_d (string-chomp opt_d dirsep))) |
---|
1316 | (let ((opt_d1 (string-chomp opt_d dirsep))) |
---|
1317 | (if (string=? opt_d1 opt_d) opt_d |
---|
1318 | (loop opt_d1))))) |
---|
1319 | (target-dir (or (and opt_t |
---|
1320 | (let loop ((opt_t (string-chomp opt_t dirsep))) |
---|
1321 | (let ((opt_t1 (string-chomp opt_t dirsep))) |
---|
1322 | (if (string=? opt_t1 opt_t) opt_t |
---|
1323 | (loop opt_t))))) |
---|
1324 | image-dir))) |
---|
1325 | |
---|
1326 | ;; sanity checks |
---|
1327 | (if (and opt_g opt_gcd) |
---|
1328 | (sigma:error "please specify only one of the -g and --gcd options")) |
---|
1329 | (if (and opt_y opt_xy) |
---|
1330 | (sigma:error "please specify only one of the -y and --xy options")) |
---|
1331 | (if (or (negative? opt_y) (and opt_xy (negative? opt_xy))) |
---|
1332 | (sigma:error "please enter non-negative thumbnail dimensions" )) |
---|
1333 | (if (and opt_yslide (negative? opt_yslide)) |
---|
1334 | (sigma:error "please enter non-negative maximum slide height" )) |
---|
1335 | |
---|
1336 | (let (;; construct the name of the main index file |
---|
1337 | (index (s+ opt_html-index "." opt_html-ext)) |
---|
1338 | ;; let users store their templates in a $HOME/.sigma directory, if it exists, |
---|
1339 | ;; instead of the site-wide /usr/share/sigma |
---|
1340 | (SIGMA-DIR (if (directory? local-sigma-dir) local-sigma-dir SIGMA-DIR)) |
---|
1341 | ;; makes a directory to store slides for a CD image |
---|
1342 | (slide-dir (and (commands 'cdimage?) |
---|
1343 | (let ((temp-dir-name (s+ image-dir dirsep ".sigma-cdimage.XXXXXX")) |
---|
1344 | (temp-dir (mkdtemp temp-dir-name ))) |
---|
1345 | (if (not temp-dir) |
---|
1346 | (sigma:error 'main ": unable to create temporary directory " temp-dir-name)) |
---|
1347 | temp-dir)))) |
---|
1348 | (if opt_R |
---|
1349 | (let* ((image-dir-depth (length (string-split image-dir dirsep))) |
---|
1350 | (make-gallery |
---|
1351 | (lambda (lev d . rest) |
---|
1352 | (let-optionals rest ((subdirs (list))) |
---|
1353 | (let* ((absolute? (string=? dirsep (car d))) |
---|
1354 | (image-dir (if absolute? |
---|
1355 | (s+ (car d) (string-intersperse (cdr d) dirsep)) |
---|
1356 | (string-intersperse d dirsep))) |
---|
1357 | (target-dir (string-intersperse |
---|
1358 | (cons target-dir (drop (if absolute? (cdr d) d) image-dir-depth)) |
---|
1359 | dirsep))) |
---|
1360 | (main-make-gallery SIGMA-DIR index image-dir target-dir commands |
---|
1361 | subdirs (or (positive? lev) opt_up) opt_top |
---|
1362 | slide-dir)))))) |
---|
1363 | ;; make sure target dir exists |
---|
1364 | (if (not (file-exists? target-dir)) |
---|
1365 | (create-directory target-dir)) |
---|
1366 | (let recur ((level 0) |
---|
1367 | (dir image-dir) |
---|
1368 | (dirlst (read-subdirs image-dir)) |
---|
1369 | (null-handler (lambda (level dir) (sigma:error "no subdirectories found in " dir)))) |
---|
1370 | (if (null? dirlst) |
---|
1371 | (null-handler level dir) |
---|
1372 | (for-each |
---|
1373 | (lambda (d) |
---|
1374 | (let ((sd (string-intersperse d dirsep))) |
---|
1375 | (let ((subdirs (read-subdirs sd))) |
---|
1376 | (recur (+ 1 level) d subdirs make-gallery)))) |
---|
1377 | dirlst))) |
---|
1378 | (main-make-gallery SIGMA-DIR index image-dir target-dir commands |
---|
1379 | (read-subdirs target-dir) opt_up opt_top slide-dir)) |
---|
1380 | (main-make-gallery SIGMA-DIR index image-dir target-dir commands (list) opt_up #f slide-dir)) |
---|
1381 | (if (commands 'cdimage?) |
---|
1382 | (begin |
---|
1383 | (message "Creating CD image " (s+ opt_cd-dir dirsep (or opt_gcd opt_cd-file) ".iso") ": ") |
---|
1384 | (create-iso-image (list slide-dir) opt_g) |
---|
1385 | (done))) |
---|
1386 | (if slide-dir (run (rm -rf ,slide-dir))) |
---|
1387 | ))) |
---|
1388 | |
---|
1389 | |
---|
1390 | |
---|
1391 | (main options operands) |
---|
1392 | |
---|