Changeset 7316 in project


Ignore:
Timestamp:
01/09/08 00:58:42 (12 years ago)
Author:
Ivan Raikov
Message:

Added support for making CD images.

Location:
sigma/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • sigma/trunk/sigma-eggdoc.scm

    r7209 r7316  
    3636
    3737     (history
     38      (version "1.7" "Added support for CD image generation")
    3839      (version "1.6" "Bug fix in the highlights index generation")
    3940      (version "1.5" "Documentation updates")
     
    9899          (p
    99100           (symbol-table
    100             (describe "gallery"    "Create an image gallery (default if no command given)")
    101             (describe "thumbs" "Create image thumbnails (implicit when gallery is also given)")
    102             (describe "sort"   "Sort images by EXIF date or file creation date")
    103             (describe "clean"  "Clean generated files"))))
     101            (describe "gallery"   "Create an image gallery (default if no command given)")
     102            (describe "thumbs"    "Create image thumbnails (implicit when gallery is also given)")
     103            (describe "sort"      "Sort images by EXIF date or file creation date")
     104            (describe "cdimage"   "Create a CD image containing the image slides")
     105            (describe "clean"     "Clean generated files"))))
    104106
    105107      (subsection "Options"
     
    114116                (describe "-k"                 "use the image captions for the HTML slide titles")
    115117                (describe "-R"                 "recursively descend subdirectories")
     118                (describe "-t DIR"             ("place gallery files in directory DIR "
     119                                                "(will be created if it doesn't exist)"))
    116120                (describe "-u"                 "write captions under thumbnails on index page")
    117121                (describe "-U"                 "write slide names under thumbnails on index page")
     
    120124                (describe "--ad"               "like -a, but write only the image dimensions")
    121125                (describe "--as"               "like -a, but write only the file size (in kbytes)")
    122                 (describe "--yslide=N"         "scale slides to the given maximum height")
     126                (describe "--author=AUTHOR"    "specify author name (default: $USER)")
    123127                (describe "--con=OPTS"         ("options to pass to " (tt "convert")))
     128                (describe "--cd-dir=DIR"       "directory for CD image output (default: $HOME/tmp)")
     129                (describe "--cd-file=DIR"      "name of CD image file if --gcd is not specified (default: Photos)")
     130                (describe "--gcd=TITLE"        "like -g, but also sets CD image file name")
    124131                (describe "--hls"              "creates a highlights page")
    125132                (describe "--hls-main"         "creates a highlights page as the main page")
    126                 (describe "--in"               "use image file names for the HTML slide files")
    127133                (describe "--html-ext=SUFFIX"  "suffix of output HTML files (default: html)")
    128134                (describe "--html-index=NAME"  "name (without suffix) of the main thumbnail index file (default: index)")
    129135                (describe "--html-hindex=NAME" "name (without suffix) of the highlights index file (default: hindex)")
     136                (describe "--in"               "use image file names for the HTML slide files")
     137                (describe "--top"              "create index pages for directories that only contain subfolders")
     138                (describe "--tp=PREFIX"        "sets the thumbnail image prefix (default: .thumb_)")
     139                (describe "--sp=PREFIX"        "sets the slide image prefix (default: .slide_)")
     140                (describe "--up"               "create Up links even in top-level image galleries")
     141                (describe "--verbose=LEVEL"    "set verbose mode (0: quiet; 1: info; 2: debug)")
    130142                (describe "--www"              "makes all SIGMA files world-readable")
    131143                (describe "--xy=N"             "scale thumbnails to N pixels in their longer dimension")
    132                 (describe "--tp=PREFIX"        "sets the thumbnail image prefix (default: .thumb_)")
    133                 (describe "--sp=PREFIX"        "sets the slide image prefix (default: .slide_)")
    134                 (describe "--author=AUTHOR"    "specify author name (default: $USER)")
    135                 (describe "--verbose=LEVEL"    "set verbose mode (0: quiet; 1: info; 2: debug)")
    136                 (describe "--target=DIR"    "place gallery files in directory DIR (will be created if it doesn't exist)")
    137                 (describe "--top"              "create index pages for directories that only contain subfolders")
    138                 (describe "--up"               "create Up links even in top-level image galleries")
     144                (describe "--yslide=N"         "scale slides to the given maximum height")
    139145                (describe "-h, --help"         "print help"))))
    140146
     
    161167  ## height of 500 pixels
    162168
    163   sigma -a -c -u -R --yslide=500 --target=album 
     169  sigma -a -c -u -R --yslide=500 -t album 
    164170
    165171
     
    168174
    169175     (license
    170       "Copyright 2007 Ivan Raikov
     176      "Copyright 2007 Ivan Raikov.
     177
     178Based on the igal program by Eric Pop. 
     179ISO 9660 image creation code based on code by Walter C. Pelissero.
    171180
    172181This program is free software: you can redistribute it and/or modify
  • sigma/trunk/sigma.scm

    r7208 r7316  
    55;; Based on the igal program by Eric Pop.
    66;; SXML templates based on code by Oleg Kiselyov.
     7;; CD image creation code by Walter C. Pelissero.
    78;;
    89;;
     
    3738
    3839
     40(define s+ string-append)
     41
    3942(define lookup-def
    4043  (lambda (k lst . rest)
     
    4346
    4447
     48
    4549(define (fpesc dir . rest)
    4650  (if (null? rest)
    47       (string-append "\"" dir "\"")
    48       (string-append "\"" dir dirsep (apply string-append rest) "\"")))
     51      (s+ "\"" dir "\"")
     52      (s+ "\"" dir dirsep (apply s+ rest) "\"")))
    4953
    5054(foreign-declare "#include <math.h>")
     
    96100  (let ((env (current-environment)))
    97101    (let ((home (alist-ref "HOME" env string=?)))
    98       (if home (string-append home dirsep sigma-dir)
     102      (if home (s+ home dirsep sigma-dir)
    99103          sigma-dir))))
    100104
     
    111115(define opt_n      20)         ; -n maximum thumbnails per index page
    112116(define opt_R      #f)         ; -R to descend subdirectories recursively
     117(define opt_t      #f)         ; if specified, place image gallery in this directory
    113118(define opt_u      #f)         ; write captions under thumbnails on index page
    114119(define opt_U      #f)         ; write image names under thumbnails on index page
     
    134139                              ; file in directories that only contain
    135140                              ; subfolders but no images
    136 (define opt_target   #f)      ; if specified, place image gallery in this directory
    137 (define opt_up   #f)          ; if specified, generate "Up" link even for top-level image galleries
     141(define opt_up       #f)      ; if specified, generate "Up" link even for top-level image galleries
    138142(define opt_verbose  1)       ; verbose mode
    139143(define opt_xy       #f)      ; scale thumbs to n pixels in their longer dimension
    140144(define opt_www      #f)      ; makes everything world-readable
     145
     146(define opt_gcd      #f) ;; the same as -g, but also sets the
     147                         ;; name of the CD image file
     148
     149(define opt_cd-file  "Photos") ;; name of CD image file
     150(define opt_cd-dir             ;; directory for CD image output
     151  (let ((env (current-environment)))
     152    (let ((home (alist-ref "HOME" env string=?)))
     153      (if home (s+ home dirsep "tmp")
     154          (s+ dirsep "tmp")))))
    141155
    142156
     
    151165                       (set! opt_C #t))
    152166    ,(args:make-option (d)       (required: "DIR")   
    153                        (string-append "operate on files in directory DIR (default: " opt_d ")")
     167                       (s+ "operate on files in directory DIR (default: " opt_d ")")
    154168                       (set! opt_d arg))
    155169    ,(args:make-option (f)       #:none               "force thumbnail regeneration and scaled slides"
    156170                       (set! opt_f #t))
    157     ,(args:make-option (g)       (required: "TITLE")    (string-append "gallery title (default: " opt_g ")")
     171    ,(args:make-option (g)       (required: "TITLE")    (s+ "gallery title (default: " opt_g ")")
    158172                       (set! opt_g arg))
    159173    ,(args:make-option (k)       #:none               "use the image captions for the HTML slide titles"
     
    161175    ,(args:make-option (R)       #:none               "recursively descend subdirectories"
    162176                       (set! opt_R #t))
     177    ,(args:make-option (t)       (required: "DIR")
     178                       "place gallery files in directory DIR (will be created if it doesn't exist)"
     179                       (set! opt_t arg))
    163180    ,(args:make-option (u)       #:none               "write captions under thumbnails on index page"
    164181                       (set! opt_u #t))
     
    168185                       (set! opt_x #t))
    169186    ,(args:make-option (y)       (required: "N")     
    170                        (string-append "scale all thumbnails to the same height  "
     187                       (s+ "scale all thumbnails to the same height  "
    171188                                      "(default: " (number->string opt_y) ")")
    172189                       (set! opt_y (string->number arg)))
     190
    173191    ,(args:make-option (ad)       #:none              "like -a, but write only the image dimensions"
    174192                       (set! opt_ad #t))
    175193    ,(args:make-option (as)       #:none              "like -a, but write only the file size (in kbytes)"
    176194                       (set! opt_as #t))
    177     ,(args:make-option (yslide)     (required: "N")   "scale slides to the given maximum height"
    178                        (set! opt_yslide (string->number arg)))
     195    ,(args:make-option (author)    (required: "AUTHOR")  (s+ "specify author name "
     196                                                                        "(default: " opt_author ")")
     197                       (set! opt_author arg))
    179198    ,(args:make-option (con)      (required: "OPTS")  "options to pass to convert"
    180199                       (set! opt_con arg))
    181     ,(args:make-option (in)       #:none              "use image file names for the HTML slide files"
    182                        (set! opt_in #t))
     200    ,(args:make-option (cd-dir)      (required: "DIR")  (s+ "directory for CD image output (default: "
     201                                                            opt_cd-dir ")")
     202                       (set! opt_cd-dir arg))
     203    ,(args:make-option (cd-file)      (required: "DIR")  (s+ "name of CD image file if --gcd is not specified (default: "
     204                                                             opt_cd-file ")")
     205                       (set! opt_cd-file arg))
     206    ,(args:make-option (gcd)       (required: "TITLE")    (s+ "like -g, but also sets CD image file name")
     207                       (set! opt_g arg)
     208                       (set! opt_gcd arg))
    183209    ,(args:make-option (hls)       #:none             "creates a highlights page"
    184210                       (set! opt_hls #t))
     
    187213                       (set! opt_hls-main #t))
    188214    ,(args:make-option (html-ext)       (required: "SUFFIX")
    189                        (string-append "suffix of output HTML files (default: " opt_html-ext ")")
     215                       (s+ "suffix of output HTML files (default: " opt_html-ext ")")
    190216                       (set! opt_html-ext arg))
    191217    ,(args:make-option (html-index)     (required: "NAME")   
    192                        (string-append "name (without suffix) of the main thumbnail "
     218                       (s+ "name (without suffix) of the main thumbnail "
    193219                                      "index file (default: " opt_html-index ")")
    194220                       (set! opt_html-index arg))
    195221    ,(args:make-option (html-hindex)     (required: "NAME")   
    196                        (string-append "name (without suffix) of the highlights "
     222                       (s+ "name (without suffix) of the highlights "
    197223                                      "index file (default: " opt_html-hindex ")")
    198224                       (set! opt_html-hindex arg))
     225    ,(args:make-option (in)       #:none              "use image file names for the HTML slide files"
     226                       (set! opt_in #t))
     227    ,(args:make-option (sp)       (required: "PREFIX")   (s+ "sets the slide image prefix "
     228                                                                     "(default: " opt_sp ")")
     229                       (set! opt_sp arg))
     230    ,(args:make-option (top)       #:none              "create index pages for directories that only contain subfolders"
     231                       (set! opt_top #t))
     232    ,(args:make-option (tp)       (required: "PREFIX")   (s+ "sets the thumbnail image prefix "
     233                                                                     "(default: " opt_tp ")")
     234                       (set! opt_tp arg))
     235    ,(args:make-option (up)       #:none               "create Up links even in top-level image galleries"
     236                       (set! opt_up #t))
     237    ,(args:make-option (verbose)       (required: "LEVEL")
     238                       (s+ "set verbose mode (0: quiet; 1: info; 2: debug)")
     239                       (set! opt_verbose (string->number arg)))
    199240    ,(args:make-option (www)      #:none              "makes all SIGMA files world-readable"
    200241                       (set! opt_www #t))
    201242    ,(args:make-option (xy)       (required: "N")     "scale thumbnails to N pixels in their longer dimension"
    202243                       (set! opt_xy (number->string arg)))
    203     ,(args:make-option (tp)       (required: "PREFIX")   (string-append "sets the thumbnail image prefix "
    204                                                                      "(default: " opt_tp ")")
    205                        (set! opt_tp arg))
    206     ,(args:make-option (sp)       (required: "PREFIX")   (string-append "sets the slide image prefix "
    207                                                                      "(default: " opt_sp ")")
    208                        (set! opt_sp arg))
    209     ,(args:make-option (author)    (required: "AUTHOR")  (string-append "specify author name "
    210                                                                         "(default: " opt_author ")")
    211                        (set! opt_author arg))
    212     ,(args:make-option (verbose)       (required: "LEVEL")
    213                        (string-append "set verbose mode (0: quiet; 1: info; 2: debug)")
    214                        (set! opt_verbose (string->number arg)))
    215     ,(args:make-option (target)       (required: "DIR")
    216                        "place gallery files in directory DIR (will be created if it doesn't exist)"
    217                        (set! opt_target arg))
    218     ,(args:make-option (top)       #:none              "create index pages for directories that only contain subfolders"
    219                        (set! opt_top #t))
    220     ,(args:make-option (up)       #:none               "create Up links even in top-level image galleries"
    221                        (set! opt_up #t))
     244    ,(args:make-option (yslide)     (required: "N")   "scale slides to the given maximum height"
     245                       (set! opt_yslide (string->number arg)))
    222246    ,(args:make-option (h help)  #:none               "Print help"
    223247                       (usage))))
     
    236260       (newline)))
    237261   `(("gallery"  . "Create an image gallery (default if no command given)")
     262     ("cdimage"  . "Create a CD image containing the image slides")
    238263     ("thumbs"   . "Create image thumbnails (implicit when gallery is also given)")
    239264     ("sort"     . "Sort images by EXIF date or file creation date")
     
    294319           [id '()]
    295320           [limit #f] )
    296         (##sys#check-string dir 'find-files)
     321        (##sys#check-string dir 'sigma-find-files)
    297322        (let* ([depth 0]
    298323               [lproc
     
    302327               [pproc
    303328                (if (or (string? pred) (regexp? pred))
    304                     (lambda (x) (string-match pred x))
     329                    (lambda (x)
     330                      (string-match pred x))
    305331                    pred) ] )
    306332          (let loop ([fs (glob (make-pathname dir "*"))]
    307333                     [r id] )
    308             (if (null? fs)
    309                 r
     334            (if (null? fs)  r
    310335                (let ([f (##sys#slot fs 0)]
    311336                      [rest (##sys#slot fs 1)] )
     
    547572                          . ,(lambda (tag level head-word . elems)
    548573                               `((br) (n_) (a (@ (name ,head-word)) (n_))
    549                                  (,(string->symbol (string-append "h" (number->string level)))
     574                                 (,(string->symbol (s+ "h" (number->string level)))
    550575                                  ,head-word ,elems))))
    551576
     
    554579                          . ,(lambda (tag level head-word . elems)
    555580                               `((br) (n_) (a (@ (name ,head-word)) (n_))
    556                                  (,(string->symbol (string-append "h" (number->string level)))
     581                                 (,(string->symbol (s+ "h" (number->string level)))
    557582                                  ,head-word ,elems))))
    558583
     
    584609;; remove the automatically generated files from the target directory
    585610(define (clean-targetdir path)
    586   (let ((pat (string-append path dirsep "*.html")))
     611  (let ((pat (s+ path dirsep "*.html")))
    587612    (run (rm -f ,pat))))
    588613
     
    595620          (thumbpat (string-substitute "." "\\." thumbprefix))
    596621          (slidepat (string-substitute "." "\\." slideprefix)))
    597       (let ((pat   (string-append jpgpat "|" pngpat "|" gifpat))
    598             (expat (regexp (string-append ".*((" thumbpat ")|(" slidepat ")).*"))))
    599         (let ((flst (find-files path pat
    600                                 (lambda (x ax) (if (string-match expat x) ax
    601                                                   (cons (pathname-strip-directory x) ax)))
    602                                 (list) 0)))
     622      (let ((pat   (s+ jpgpat "|" pngpat "|" gifpat))
     623            (expat (regexp (s+ ".*((" thumbpat ")|(" slidepat ")).*"))))
     624        (let ((flst (sigma-find-files path pat
     625                                      (lambda (x ax) (if (string-match expat x) ax
     626                                                        (cons (pathname-strip-directory x) ax)))
     627                                      (list) 0)))
    603628          (sort flst string<?))))))
    604629
     
    611636;; locate and copy (if necessary) a SIGMA template file
    612637(define (locate-and-copy-template LIBDIR target-dir file-name)
    613   (if (file-exists? (string-append target-dir dirsep file-name))
     638  (if (file-exists? (s+ target-dir dirsep file-name))
    614639      (message "Found " file-name " file.")
    615640      (begin
    616641        (message "No " file-name " file; getting a copy from " LIBDIR ".")
    617642        (if (directory? LIBDIR)
    618             (if (file-exists? (string-append LIBDIR dirsep file-name))
     643            (if (file-exists? (s+ LIBDIR dirsep file-name))
    619644                (run (cp -f ,(fpesc LIBDIR file-name) ,(fpesc target-dir file-name)))
    620                 (sigma:error (string-append LIBDIR dirsep file-name)
     645                (sigma:error (s+ LIBDIR dirsep file-name)
    621646                             " cannot be read or does not exist."))
    622647            (sigma:error LIBDIR " cannot be read or does not exist. ")))))
     
    688713        (let* ((s  (file-change-time path))
    689714               (ti (seconds->local-time s)))
    690           (string-append (number->string (+ 1900 (vector-ref ti 5))) ":"
     715          (s+ (number->string (+ 1900 (vector-ref ti 5))) ":"
    691716                         (number->string (+ 1 (vector-ref ti 4))) ":"
    692717                         (number->string (vector-ref ti 3)) " "
     
    716741          (done)
    717742          (reverse sz))
    718         (let ((path (string-append image-dir dirsep (car flst))))
     743        (let ((path (s+ image-dir dirsep (car flst))))
    719744          (let ((dims  (image-size path)))
    720745            (progress)
     
    728753           (let loop ((flst flst) (olst (list)))
    729754             (if (null? flst) olst
    730                  (let ((path (string-append image-dir dirsep (car flst))))
     755                 (let ((path (s+ image-dir dirsep (car flst))))
    731756                   (if (not (and (file-exists? path) (file-read-access? path)))
    732757                       (sigma:error 'sort-images ": cannot open " path))
     
    738763      (message "Sorting images by date: ")
    739764      (let ((op (if (string=? image-dir target-dir) 'mv 'cp))
    740             (temp-dir (mkdtemp (string-append image-dir dirsep "sigma-tmp.XXXXXX"))))
     765            (temp-dir (mkdtemp (s+ image-dir dirsep "sigma-tmp.XXXXXX"))))
    741766        (for-each (lambda (f)
    742                     (let ((fpath (string-append image-dir dirsep f))
    743                           (rpath (string-append temp-dir dirsep  f)))
     767                    (let ((fpath (s+ image-dir dirsep f))
     768                          (rpath (s+ temp-dir dirsep  f)))
    744769                      (run (,op  ,(fpesc fpath) ,(fpesc rpath)))
    745770                      (progress)))
    746771                  flst)
    747772        (let ((i+nlst (fold (lambda (fp i+nlst)
    748                               (let ((fpath (string-append temp-dir dirsep  (car fp)))
     773                              (let ((fpath (s+ temp-dir dirsep  (car fp)))
    749774                                    (ext   (pathname-extension (car fp))))
    750775                                (match i+nlst
    751776                                       ((i . nlst)
    752777                                        (let* ((width (if (positive? order) order 1))
    753                                                (nfile (string-append (fmt #f (pad-char #\0 (fit/left width (num i))))
     778                                               (nfile (s+ (fmt #f (pad-char #\0 (fit/left width (num i))))
    754779                                                                     "." ext))
    755                                                (npath (string-append target-dir dirsep nfile)))
     780                                               (npath (s+ target-dir dirsep nfile)))
    756781                                          (run (mv  ,(fpesc fpath) ,(fpesc npath)))
    757782                                          (progress)
     
    768793     (let loop ((flst flst))
    769794       (if (not (null? flst))
    770            (let ((image-path (string-append source-dir dirsep (car flst))))
     795           (let ((image-path (s+ source-dir dirsep (car flst))))
    771796             (if (not (and (file-exists? image-path) (file-read-access? image-path)))
    772797                 (sigma:error 'make-thumbs ": cannot open " image-path))
    773              (let ((thumb-path (string-append target-dir dirsep thumbprefix (car flst))))
     798             (let ((thumb-path (s+ target-dir dirsep thumbprefix (car flst))))
    774799               (if (or (not (file-exists? thumb-path)) force-regen?
    775800                       (> (vector-ref (file-stat image-path) 9)
     
    777802                   (run (convert ,convert-options -scale
    778803                                 ,(if xy (let ((xy (number->string xy)))
    779                                            (string-append xy "x" xy))
    780                                       (string-append "x" (number->string y)))
     804                                           (s+ xy "x" xy))
     805                                      (s+ "x" (number->string y)))
    781806                                 ,(fpesc image-path) ,(fpesc thumb-path))))
    782807               (progress)
     
    791816        (let loop ((flst flst))
    792817          (if (not (null? flst))
    793           (let ((image-path  (string-append image-dir dirsep (car flst)))
    794                 (target-path (string-append target-dir dirsep (car flst))))
     818          (let ((image-path  (s+ image-dir dirsep (car flst)))
     819                (target-path (s+ target-dir dirsep (car flst))))
    795820            (if (not (and (file-exists? image-path) (file-read-access? image-path)))
    796821                (sigma:error 'copy-images ": cannot open " image-path))
     
    808833     (let loop ((flst flst))
    809834       (if (not (null? flst))
    810            (let ((image-path (string-append source-dir dirsep (car flst))))
     835           (let ((image-path (s+ source-dir dirsep (car flst))))
    811836             (if (not (and (file-exists? image-path) (file-read-access? image-path)))
    812837                 (sigma:error 'scale-images ": cannot open " image-path))
    813              (let ((slide-path (string-append target-dir dirsep slideprefix (car flst))))
     838             (let ((slide-path (s+ target-dir dirsep slideprefix (car flst))))
    814839               (if (or (not (file-exists? slide-path)) force-regen?)
    815840                   (let ((y (cadr (image-size image-path))))
    816841                     (if (and (positive? yslide) (> y yslide)) ;; only scale down, never up.
    817842                         (run (convert  ,convert-options
    818                                         -scale ,(string-append "x" (number->string yslide))
     843                                        -scale ,(s+ "x" (number->string yslide))
    819844                                        ,(fpesc image-path) ,(fpesc slide-path)))
    820845                         (run (ln ,(fpesc image-path) ,(fpesc slide-path))))))
     
    822847               (loop (cdr flst))))))
    823848     (done))))
     849
     850
     851(define (filter-subfolders target-dir target-dir-depth lst)
     852  (filter-map (lambda (d)
     853                (let ((thumbpat   (regexp (s+ thumbprefix "*")))
     854                      (absolute?  (string=? dirsep (car d))))
     855                  ;; only allow subfolders that contain thumbnails
     856                  (let* ((dd        (drop (if absolute? (cdr d) d) target-dir-depth))
     857                         (subflst   (directory (string-intersperse (cons target-dir dd) dirsep) #t))
     858                         (subthumbs (filter (lambda (x) (string-match thumbpat x)) subflst)))
     859                    (and (pair? subthumbs)
     860                         (list (string-intersperse dd dirsep) (car subthumbs))))))
     861              lst))
    824862
    825863
     
    842880                      (slide-url  (uri-encode
    843881                                   (if yslide
    844                                        (string-append slideprefix imagename)
     882                                       (s+ slideprefix imagename)
    845883                                       imagename)))
    846884                      (image-url   (uri-encode imagename))
     
    850888                                           (month (num->str (+ 1 (vector-ref v 4)) 2))
    851889                                           (day   (num->str (vector-ref v 3) 2)))
    852                                      (string-append year month day))))
     890                                     (s+ year month day))))
    853891                      (links      `((contents  ,index)
    854892                                    (prev      ,prev)
    855893                                    (next      ,(if (null? (cdr lst)) "" (third (cadr lst)))))))
    856                   (with-output-to-file (string-append target-dir dirsep slidename)
     894                  (with-output-to-file (s+ target-dir dirsep slidename)
    857895                    (lambda ()
    858896                      (let* ((header `(Header (Date-yyyymmdd    ,date)
     
    888926                    subfolders . rest)
    889927  (let-optionals rest ((up #f) (mlinks (list)))
    890    (let ((index-tmpl-path (string-append target-dir dirsep index-tmpl-file))
     928   (let ((index-tmpl-path (s+ target-dir dirsep index-tmpl-file))
    891929         (npages          (inexact->exact (ceiling (/ nfiles max-thumbs)))))
    892930     (let ((indextmpl (with-input-from-file index-tmpl-path read)))
     
    894932         (if (not (null? flst))
    895933            (let ((nthumbs     (min (length flst) max-thumbs))
    896                   (index-path  (string-append target-dir dirsep html-index
     934                  (index-path  (s+ target-dir dirsep html-index
    897935                                              (if (positive? i) (number->string i) "")
    898936                                              "." html-ext)))
     
    903941                                    (month (num->str (+ 1 (vector-ref v 4)) 2))
    904942                                    (day   (num->str (vector-ref v 3) 2)))
    905                                 (string-append year month day))))
     943                                (s+ year month day))))
    906944                    (image-thumbs
    907945                     (map (lambda (fname sname caption sz)
    908                             (let ((thumbname (string-append thumbprefix fname)))
     946                            (let ((thumbname (s+ thumbprefix fname)))
    909947                              `(div (@ (class "thumb"))
    910948                                    (a (@ (href ,(uri-encode sname)))
     
    924962                    (links (append
    925963                            (if up (let ((up-link (if (boolean? up)
    926                                                       (string-append ".." dirsep html-index "." html-ext)
     964                                                      (s+ ".." dirsep html-index "." html-ext)
    927965                                                      up)))
    928966                                     (list (list "Up" up-link)))
     
    932970                                (list-tabulate
    933971                                npages (lambda (i) (list (string->symbol (number->string i))
    934                                                          (string-append html-index
    935                                                                         (if (positive? i) (number->string i) "")
    936                                                                         "." html-ext))))
     972                                                         (s+ html-index (if (positive? i) (number->string i) "")
     973                                                             "." html-ext))))
    937974                                (list))))
    938975                    (subfolders  (map (lambda (sub)
    939                                         (let ((index-path
    940                                                (string-append (first sub) dirsep html-index "." html-ext))
    941                                               (thumb-path
    942                                                (string-append (first sub) dirsep (uri-encode (second sub))))
    943                                               (caption
    944                                                (if (string-null? (third sub)) (first sub) (third sub))))r
     976                                        (let ((index-path  (s+ (first sub) dirsep html-index "." html-ext))
     977                                              (thumb-path  (s+ (first sub) dirsep (uri-encode (second sub))))
     978                                              (caption     (if (string-null? (third sub)) (first sub) (third sub))))
    945979                                        `(div (@ (class "thumb"))
    946980                                              (a (@ (href ,index-path))
     
    9801014                             subfolders . rest)
    9811015  (let-optionals rest ((up #f) (home #f))
    982    (let ((index-tmpl-path (string-append target-dir dirsep index-tmpl-file)))
     1016   (let ((index-tmpl-path (s+ target-dir dirsep index-tmpl-file)))
    9831017     (let ((indextmpl (with-input-from-file index-tmpl-path read)))
    984        (let ((index-path  (string-append target-dir dirsep html-index "." html-ext)))
     1018       (let ((index-path  (s+ target-dir dirsep html-index "." html-ext)))
    9851019         (message "Creating " index-path " file: ")
    9861020         (let ((date   (let ((v         (seconds->local-time (current-seconds)))
     
    9891023                               (month (num->str (+ 1 (vector-ref v 4)) 2))
    9901024                               (day   (num->str (vector-ref v 3) 2)))
    991                            (string-append year month day))))
     1025                           (s+ year month day))))
    9921026               (links (append
    9931027                       (if up (let ((up-link (if (boolean? up)
    994                                                  (string-append ".." dirsep html-index "." html-ext)
     1028                                                 (s+ ".." dirsep html-index "." html-ext)
    9951029                                                 up)))
    9961030                                (list (list "Up" up-link)))
     
    9981032                       (if home (list (list "Home" home)) (list))))
    9991033               (subfolders  (map (lambda (sub)
    1000                                    (let ((index-path
    1001                                           (string-append (first sub) dirsep html-index "." html-ext))
    1002                                          (thumb-path
    1003                                           (string-append (first sub) dirsep (uri-encode (second sub))))
    1004                                          (caption
    1005                                           (if (string-null? (third sub)) (first sub) (third sub))))
     1034                                   (let ((index-path  (s+ (first sub) dirsep html-index "." html-ext))
     1035                                         (thumb-path  (s+ (first sub) dirsep (uri-encode (second sub))))
     1036                                         (caption     (if (string-null? (third sub)) (first sub) (third sub))))
    10061037                                     `(div (@ (class "thumb"))
    10071038                                           (a (@ (href ,index-path))
     
    10341065
    10351066
    1036 (define (filter-subfolders target-dir target-dir-depth lst)
    1037   (filter-map (lambda (d)
    1038                 (let ((thumbpat   (regexp (string-append thumbprefix "*")))
    1039                       (absolute?  (string=? dirsep (car d))))
    1040                   ;; only allow subfolders that contain thumbnails
    1041                   (let* ((dd        (drop (if absolute? (cdr d) d) target-dir-depth))
    1042                          (subflst   (directory (string-intersperse (cons target-dir dd) dirsep) #t))
    1043                          (subthumbs (filter (lambda (x) (string-match thumbpat x)) subflst)))
    1044                     (and (pair? subthumbs)
    1045                          (list (string-intersperse dd dirsep) (car subthumbs))))))
    1046               lst))
    1047 
    1048 
    10491067(define (main-make-gallery LIBDIR index image-dir target-dir commands . rest)
    1050   (let-optionals rest ((subdirs (list)) (up #f) (toplevel? #f))
     1068  (let-optionals rest ((subdirs (list)) (up #f) (toplevel? #f) (slide-dir #f))
    10511069   (if (commands 'clean?)
    1052        (let ((pat (string-append "(" thumbprefix ".*|" slideprefix ".*|" css-tmpl-file "|"
    1053                                 index-tmpl-file "|" slide-tmpl-file "|.*\\.html|" caption-file ")")))
    1054          (let ((flst (find-files target-dir pat (lambda (x ax) (delete-file x) (cons x ax)) (list) 0)))
     1070       (let ((pat (s+ ".*/(" thumbprefix ".*|" slideprefix ".*|" css-tmpl-file "|"
     1071                      index-tmpl-file "|" slide-tmpl-file "|.*\\.html|" caption-file ")")))
     1072         (let ((flst (sigma-find-files target-dir pat (lambda (x ax) (delete-file x) (cons x ax)) (list) 0)))
    10551073           (message "deleted files: " flst))))
    10561074   (let ((flst  (read-imagedir image-dir)))
     
    10611079     (if (not (file-exists? target-dir))
    10621080         (create-directory target-dir))
    1063      (let ((captionpath        (string-append target-dir dirsep caption-file))
     1081     (let ((captionpath        (s+ target-dir dirsep caption-file))
    10641082           (target-dir-depth   (length (string-split target-dir dirsep))))
    10651083       (let ((subfolders (filter-subfolders target-dir target-dir-depth subdirs))
     
    10981116                            (if (commands 'thumbs?)
    10991117                                (make-thumbs image-dir target-dir flst opt_y opt_xy opt_f opt_con))
     1118                            ;; if slide-dir is true (e.g. when making a CD image),
     1119                            ;; copy the slides to slide-dir
     1120                            (if slide-dir
     1121                                (let ((snum (length (directory slide-dir))))
     1122                                  (message "Copying slide images to CD image dir (" slide-dir "): ")
     1123                                  (fold (lambda (f i)
     1124                                          (let ((ext (pathname-extension f))
     1125                                                (is  (fmt #f (pad-char #\0 (fit/left 5 (num i))))))
     1126                                            (let ((fpath (s+ target-dir dirsep (if opt_yslide (s+ slideprefix f) f)))
     1127                                                  (rpath (s+ slide-dir dirsep is "." ext )))
     1128                                              (run (cp  ,(fpesc fpath) ,(fpesc rpath)))
     1129                                              (progress)
     1130                                              (+ 1 i))))
     1131                                        snum flst)
     1132                                  (done)))
    11001133                            (if (commands 'gallery?)
    11011134                                (begin
     
    11071140                                        (slst  (if opt_in  ;; use image file names for slide html file names
    11081141                                                   (map (lambda (n) (pathname-replace-extension n opt_html-ext)) flst)
    1109                                                    (map (lambda (n) (string-append n "." opt_html-ext))
     1142                                                   (map (lambda (n) (s+ n "." opt_html-ext))
    11101143                                                        (list-tabulate nfiles number->string))))
    11111144                                        (hslst  (if opt_in 
    1112                                                     (map (lambda (n) (string-append
    1113                                                                       "hl" (pathname-replace-extension n opt_html-ext)))
     1145                                                    (map (lambda (n)
     1146                                                           (s+ "hl" (pathname-replace-extension n opt_html-ext)))
    11141147                                                         hflst)
    1115                                                     (map (lambda (n) (string-append "hl" n "." opt_html-ext))
     1148                                                    (map (lambda (n) (s+ "hl" n "." opt_html-ext))
    11161149                                                         (list-tabulate (length hflst) number->string)))))
    11171150                                    (clean-targetdir target-dir)
    11181151                                    ;; locate and copy the slide template file, if necessary
    11191152                                    (locate-and-copy-template LIBDIR target-dir slide-tmpl-file)
    1120                                     (let ((slide-tmpl-path    (string-append target-dir dirsep slide-tmpl-file)))
     1153                                    (let ((slide-tmpl-path    (s+ target-dir dirsep slide-tmpl-file)))
    11211154                                      (let ((slidetmpl   (with-input-from-file slide-tmpl-path read))
    1122                                             (hindex      (string-append opt_html-hindex "." opt_html-ext))
     1155                                            (hindex      (s+ opt_html-hindex "." opt_html-ext))
    11231156                                            (htitle      (list "Highlights of " '(br) opt_g)))
    11241157                                        ;; create the individual slide show files
     
    11261159                                                     (if (and opt_hls-main (not (null? hflst))) hindex index)
    11271160                                                     opt_g flst captions slst opt_k opt_x opt_yslide opt_author)
     1161                                       
    11281162                                        (if (and opt_hls (not (null? hflst)))
    11291163                                            ;; create the slide show files for the highlight images
     
    11351169                                        (locate-and-copy-template LIBDIR target-dir css-tmpl-file)
    11361170                                        (cond ((and opt_hls-main (not (null? hflst)))
    1137                                                (let ((up-url (string-append ".." dirsep opt_html-index "." opt_html-ext)))
     1171                                               (let ((up-url (s+ ".." dirsep opt_html-index "." opt_html-ext)))
    11381172                                                 ;; create the index files with all the thumbnails
    11391173                                                 (make-index target-dir index-tmpl-file flst slst captions szlst
     
    11411175                                                             subfolders (and up up-url)
    11421176                                                             `(("Highlights"
    1143                                                                 ,(string-append opt_html-index "." opt_html-ext))))
     1177                                                                ,(s+ opt_html-index "." opt_html-ext))))
    11441178                                                 (make-index target-dir index-tmpl-file hflst hslst hcaptions hszlst
    11451179                                                             (length hflst) opt_n opt_html-index opt_html-ext
    11461180                                                             htitle opt_author subfolders (and up up-url)
    11471181                                                             `(("All images"
    1148                                                                 ,(string-append opt_html-hindex "." opt_html-ext))))))
     1182                                                                ,(s+ opt_html-hindex "." opt_html-ext))))))
    11491183                                              ((and opt_hls (not (null? hflst)))
    1150                                                (let ((up-url (string-append ".." dirsep opt_html-index "." opt_html-ext)))
     1184                                               (let ((up-url (s+ ".." dirsep opt_html-index "." opt_html-ext)))
    11511185                                                  ;; create the index files with all the thumbnails
    11521186                                                  (make-index target-dir index-tmpl-file flst slst captions szlst
     
    11541188                                                              subfolders (and up up-url)
    11551189                                                              `(("Highlights"
    1156                                                                  ,(string-append opt_html-hindex "." opt_html-ext))))
     1190                                                                 ,(s+ opt_html-hindex "." opt_html-ext))))
    11571191                                                  (make-index target-dir index-tmpl-file hflst hslst hcaptions hszlst
    11581192                                                              (length hflst) opt_n opt_html-hindex opt_html-ext
    11591193                                                              htitle opt_author subfolders (and up up-url)
    11601194                                                              `(("All images"
    1161                                                                  ,(string-append opt_html-index "." opt_html-ext))))))
     1195                                                                 ,(s+ opt_html-index "." opt_html-ext))))))
    11621196                                               (else
    11631197                                                (make-index target-dir index-tmpl-file flst slst captions szlst
     
    11691203                                              (message "Making all gallery files world-readable for WWW publishing...")
    11701204                                              (run (chmod a+r ,(fpesc target-dir css-tmpl-file)))
    1171                                               (run (chmod a+r ,(string-append target-dir dirsep "*." opt_html-ext)))
    1172                                               (run (chmod a+r ,(string-append target-dir dirsep thumbprefix "*.*")))
    1173                                               (run (chmod a+r ,(string-append target-dir dirsep slideprefix "*.*")))
     1205                                              (run (chmod a+r ,(s+ target-dir dirsep "*." opt_html-ext)))
     1206                                              (run (chmod a+r ,(s+ target-dir dirsep thumbprefix "*.*")))
     1207                                              (run (chmod a+r ,(s+ target-dir dirsep slideprefix "*.*")))
    11741208                                              (for-each (lambda (x)
    11751209                                                          (run (chmod a+r ,(fpesc target-dir x)))) flst)
     
    11771211
    11781212
    1179 (define valid-commands '(clean sort thumbs gallery))
     1213(define (blocks->MB blocks)  (quotient (* 2 blocks) 1024))
     1214     
     1215(define-constant *blocks-in-700MB* 359846)
     1216(define-constant *blocks-in-650MB* 332800)
     1217
     1218(define (estimate-filesystem-size dirs)
     1219  (let* ((blocks  (ipipe (lambda () (let ((line (read-line))) (string->number line)))
     1220                         (mkisofs -r -print-size -quiet ,@dirs)))
     1221         (size-MB (blocks->MB blocks)))
     1222    (if (zero? size-MB)
     1223        (message "CD image size is estimated to be " (* 2 blocks) " KB. " )
     1224        (message "CD image size is estimated to be " size-MB " MB. " ))
     1225    (if (<= size *blocks-in-650MB*)
     1226        (let ((remaining (- *blocks-in-650MB* size)))
     1227          (message "it will fit in a 650 MB (70 min) disk, leaving "
     1228                   (blocks->MB remaining)
     1229                   " MB (" remaining " blocks) unused. ")
     1230          'cd650)
     1231        (let ((remaining (- *blocks-in-700MB* size))
     1232              (excess    (- size *blocks-in-650MB*)))
     1233          (cond ((> size *blocks-in-700MB*)
     1234                 (message "it will not fit in a 700 MB (80 min) disk, for "
     1235                          (blocks->MB (abs remaining))
     1236                          " MB (" (abs remaining) " blocks) too much.  ")
     1237                 #f)
     1238                (else
     1239                 (begin
     1240                   (message "it will not fit in a 650 MB (70 min) disk for "
     1241                            (blocks->MB excess)
     1242                            " MB (" excess "  blocks), ")
     1243                   (message "but it will fit in a 700 MB (80 min) disk leaving "
     1244                            (blocks->MB remaining)
     1245                            " MB (" remaining " blocks) unused. ")
     1246                   'cd700)))))))
     1247
     1248
     1249;; Make up a reasonable volume title from the directory names
     1250(define (make-up-volume-title dirs)
     1251  (string-intersperse (map (lambda (d) (pathname-file d)) dirs) " "))
     1252
     1253(define (create-iso-image dirs . rest)
     1254  (if (estimate-filesystem-size dirs)
     1255      (let-optionals rest
     1256                     ((title        (make-up-volume-title dirs))
     1257                      (output-path  (s+ opt_cd-dir dirsep (or opt_gcd opt_cd-file) ".iso"))
     1258                      (preparer     opt_author)
     1259                      (publisher    opt_author))
     1260        (run (mkisofs -r -V ,(s+ "\"" title "\"") -p ,(s+ "\"" preparer "\"")
     1261                      -P ,(s+ "\"" publisher "\"") -o ,(fpesc output-path) ,@dirs))
     1262        output-path)))
     1263
     1264
     1265
     1266(define valid-commands '(clean sort thumbs gallery cdimage))
    11801267
    11811268(define (make-command-selector commands)
     
    11831270        (sort?      (member 'sort commands))
    11841271        (thumbs?    (or (member 'gallery commands) (member 'thumbs commands)))
    1185         (gallery?   (member 'gallery commands)))
    1186   (lambda (selector)
    1187     (case selector
    1188       ((clean?)    clean?)
    1189       ((sort?)     sort?)
    1190       ((thumbs?)   thumbs?)
    1191       ((gallery?)  gallery?)))))
     1272        (gallery?   (member 'gallery commands))
     1273        (cdimage?   (member 'cdimage commands)))
     1274    (and (or clean? sort? thumbs? gallery? cdimage?)
     1275         (lambda (selector)
     1276           (case selector
     1277             ((cdimage?)     cdimage?)
     1278             ((clean?)       clean?)
     1279             ((sort?)        sort?)
     1280             ((thumbs?)      thumbs?)
     1281             ((gallery?)     gallery?))))))
    11921282     
    11931283     
     
    11991289                                                 (and (member s valid-commands) s)))
    12001290                                   operands)))
    1201            (commands  (if (null? commands) '(gallery) commands))
     1291           (commands  (or commands (make-command-selector '(gallery))))
    12021292           ;; Strip any unnecessary slashes from the end of the given
    1203            ;; opt_d and opt_target directories
     1293           ;; opt_d and opt_t directories
    12041294           (image-dir  (let loop ((opt_d (string-chomp opt_d dirsep)))
    12051295                         (let ((opt_d1 (string-chomp opt_d dirsep)))
    12061296                           (if (string=? opt_d1 opt_d) opt_d
    12071297                               (loop opt_d1)))))
    1208            (target-dir  (or (and opt_target
    1209                                  (let loop ((opt_target (string-chomp opt_target dirsep)))
    1210                                    (let ((opt_target1 (string-chomp opt_target dirsep)))
    1211                                      (if (string=? opt_target1 opt_target) opt_target
    1212                                          (loop opt_target1)))))
     1298           (target-dir  (or (and opt_t
     1299                                 (let loop ((opt_t (string-chomp opt_t dirsep)))
     1300                                   (let ((opt_t1 (string-chomp opt_t dirsep)))
     1301                                     (if (string=? opt_t1 opt_t) opt_t
     1302                                         (loop opt_t)))))
    12131303                            image-dir)))
    12141304   
    12151305    ;; sanity checks
     1306    (if (and opt_g opt_gcd)
     1307        (sigma:error "please specify only one of the -g and --gcd options"))
    12161308    (if (and opt_y opt_xy)
    12171309        (sigma:error "please specify only one of the -y and --xy options"))
     
    12221314
    12231315    (let (;; construct the name of the main index file
    1224           (index  (string-append opt_html-index "." opt_html-ext))
     1316          (index  (s+ opt_html-index "." opt_html-ext))
    12251317          ;; let users store their templates in a $HOME/.sigma directory, if it exists,
    12261318          ;; instead of the site-wide /usr/share/sigma
    1227           (LIBDIR   (if (directory? local-sigma-dir) local-sigma-dir LIBDIR)))
     1319          (LIBDIR   (if (directory? local-sigma-dir) local-sigma-dir LIBDIR))
     1320          ;; makes a directory to store slides for a CD image
     1321          (slide-dir (and (commands 'cdimage?)
     1322                          (mkdtemp (s+ image-dir dirsep ".sigma-cdimage.XXXXXX")))))
    12281323      (if opt_R
    12291324          (let* ((image-dir-depth   (length (string-split image-dir dirsep)))
     
    12331328                      (let* ((absolute?    (string=? dirsep (car d)))
    12341329                             (image-dir    (if absolute?
    1235                                                (string-append (car d) (string-intersperse (cdr d) dirsep))
     1330                                               (s+ (car d) (string-intersperse (cdr d) dirsep))
    12361331                                               (string-intersperse d dirsep)))
    12371332                             (target-dir   (string-intersperse
     
    12391334                                           dirsep)))
    12401335                        (main-make-gallery LIBDIR index image-dir target-dir commands
    1241                                            subdirs (or (positive? lev) opt_up)))))))
     1336                                           subdirs (or (positive? lev) opt_up) opt_top
     1337                                           slide-dir))))))
    12421338            ;; make sure target dir exists
    12431339            (if (not (file-exists? target-dir))
     
    12561352                   dirlst)))
    12571353            (main-make-gallery LIBDIR index image-dir target-dir commands
    1258                                (read-subdirs target-dir) opt_up opt_top))
    1259           (main-make-gallery LIBDIR index image-dir target-dir commands (list) opt_up)))))
     1354                               (read-subdirs target-dir) opt_up opt_top slide-dir))
     1355          (main-make-gallery LIBDIR index image-dir target-dir commands (list) opt_up #f slide-dir))
     1356      (if (commands 'cdimage?)
     1357          (begin
     1358            (message "Creating CD image " (s+ opt_cd-dir dirsep (or opt_gcd opt_cd-file) ".iso") ": ")
     1359            (create-iso-image (list slide-dir) opt_g)
     1360            (done)))
     1361      (if slide-dir (run (rm -rf ,slide-dir)))
     1362      )))
    12601363         
    12611364
  • sigma/trunk/sigma.setup

    r7209 r7316  
    11
    2 (compile -O -d2 sigma.scm -lchicken -lm)
     2(compile -O2 sigma.scm -lchicken -lm)
    33
    44(run (csi -qbs sigma-eggdoc.scm > sigma.html))
     
    1010
    1111  ; Assoc list with properties for the program:
    12   '((version 1.6)
     12  '((version 1.7)
    1313    (documentation "sigma.html")))
    1414
Note: See TracChangeset for help on using the changeset viewer.