source: project/chicken/trunk/scripts/dpkg-eggs.scm @ 9090

Last change on this file since 9090 was 9090, checked in by Ivan Raikov, 12 years ago

Some updates to the Debian egg building stuff,
so that documentation is automatically generated from the wiki.

File size: 5.6 KB
Line 
1;;
2;; Given a directory tree with egg directories, build Debian packages
3;; for all eggs that have a debian subdirectory.
4;;
5;; Usage: dpkg-eggs --eggdir=DIR --output-dir=DIR
6;;
7
8(require-extension srfi-1)
9(require-extension srfi-13)
10(require-extension posix)
11(require-extension regex)
12(require-extension utils)
13(require-extension args)
14
15(include "tools.scm")
16
17(define s+ string-append)
18
19(define opts
20  `(
21    ,(args:make-option (extension-path)       (required: "DIR")   
22                       (s+ "path to stream-wiki extensions"))
23    ,(args:make-option (wiki-dir)       (required: "DIR")   
24                       (s+ "use wiki documentation in directory DIR"))
25    ,(args:make-option (egg-dir)       (required: "DIR")   
26                       (s+ "operate on eggs in directory DIR"))
27    ,(args:make-option (output-dir)       (required: "DIR")   
28                       (s+ "place Debian packages in directory DIR (will be created if it does not exist)"))
29    ,(args:make-option (verbose)       #:none
30                       (s+ "enable verbose mode")
31                       (set! *verbose* #t))
32    ,(args:make-option (exclude)       (required: "EGGS")   
33                       (s+ "a comma separated list of eggs to exclude from building"))
34    ,(args:make-option (h help)  #:none               "Print help"
35                       (usage))
36
37    ))
38
39
40;; Use args:usage to generate a formatted list of options (from OPTS),
41;; suitable for embedding into help text.
42(define (usage)
43  (print "Usage: " (car (argv)) " options... [list of eggs to be built] ")
44  (newline)
45  (print "The following options are recognized: ")
46  (newline)
47  (print (parameterize ((args:indent 5)) (args:usage opts)))
48  (exit 1))
49
50
51;; Process arguments and collate options and arguments into OPTIONS
52;; alist, and operands (filenames) into OPERANDS.  You can handle
53;; options as they are processed, or afterwards.
54(define args    (command-line-arguments))
55(set!-values (options operands)  (args:parse args opts))
56
57(define dirsep (string ##sys#pathname-directory-separator))
58
59(define (read-subdirs path)
60  (find-files path directory? cons (list) 0))
61
62;; Compare versions of the format x.x...
63(define (version< v1 v2)
64  (let ((v1 (string-split v1 "."))
65        (v2 (string-split v2 ".")))
66    (every (lambda (s1 s2) 
67             (let ((n1 (string->number s1))
68                   (n2 (string->number s2)))
69               (cond ((and n1 n2)  (<= n1 n2))
70                     (else (string<= s1 s2)))))
71           v1 v2)))
72           
73;; Find the latest release in a given egg directory
74(define (find-latest-release path)
75  (let ((tags (s+ path dirsep "tags")))
76    (cond ((file-exists? tags) 
77           (let ((lst (filter-map (lambda (x) (and (not (string=? (pathname-strip-directory x) ".svn")) x))
78                                  (read-subdirs tags)))
79                 (cmp (lambda (x y) (version< (pathname-strip-directory x) (pathname-strip-directory y)))))
80             (if (pair? lst) (car (reverse (sort lst cmp))) path)))
81          (else path))))
82           
83;; Find the debian subdirectory in a given egg directory
84(define (find-debian-subdir path . rest)
85  (let-optionals rest ((release (find-latest-release path)))
86    (cond ((file-exists? (s+ path dirsep "trunk" dirsep "debian")) => identity)
87          ((file-exists? (s+ release dirsep "debian")) => identity)
88          (else #f))))
89           
90;; Find wiki documentation for given egg
91(define (find-wiki-doc name wikidir)
92  (cond ((file-exists? (s+ wikidir dirsep name)) => identity)
93        (else #f)))
94
95(define (build-deb eggdir wiki-dir output-dir ext-path path)
96  (let* ((name     (pathname-strip-directory path))
97         (release  (find-latest-release path))
98         (debdir   (find-debian-subdir path release)))
99    (if debdir
100        (let ((start      (cwd))
101              (build-dir  (s+ output-dir dirsep name))
102              (doc        (cond ((file-exists? (s+ release dirsep name ".html")) => identity)
103                                ((and wiki-dir (file-exists? (s+ wiki-dir dirsep name))) => identity)
104                                (else #f))))
105          (message "Release directory is ~a" release)
106          (message "debian subdirectory found in ~a" path)
107          (run (rm -rf ,build-dir))
108          (run (cp -R ,release ,build-dir))
109          (run (cp -R ,debdir ,build-dir))
110          (if (not (string-suffix? ".html" doc))
111              (run (csi -s ,(cond ((file-exists? (s+ start "/makehtml.scm")) => identity)
112                                  (else 'makehtml.scm))
113                    ,(s+ "--extension-path=" ext-path) 
114                    ,(s+ "--wikipath=" wiki-dir) 
115                    ,(s+ "--only=" name))))
116          (run (cp ,(s+ "html/" name ".html") ,build-dir))
117          (cd build-dir)
118          (run (chmod a+rx debian/rules))
119          (run (,(s+ "EGG_TREE=\"" eggdir "\"") dpkg-buildpackage -us -uc)))
120        (message "No debian subdirectory found in ~a" path))))
121
122(define (main options operands)
123  (let ((opt_wikidir   (alist-ref 'wiki-dir options))
124        (opt_eggdir    (alist-ref 'egg-dir options))
125        (opt_extpath   (alist-ref 'extension-path options))
126        (opt_exclude ((lambda (x) (and x (string-split x ","))) (alist-ref 'exclude options)))
127        (opt_output-dir (alist-ref 'output-dir options)))
128    (if (not (and opt_eggdir opt_output-dir))
129        (begin
130          (error-message "Both egg directory and output directory must be specified!")
131          (usage)))
132    (message "Egg directory tree: ~a" opt_eggdir)
133    (message "Output directory tree: ~a" opt_output-dir)
134    ;; make sure target dir exists
135    (if (not (file-exists? opt_output-dir))
136        (begin
137          (message "Creating directory ~a" opt_output-dir)
138          (create-directory opt_output-dir)))
139    (let ((eggdirs (filter-map 
140                    (lambda (x) (and (not (member (pathname-strip-directory x) opt_exclude)) x))
141                    (or (and (pair? operands) (map (lambda (x) (s+ opt_eggdir dirsep (->string x))) operands))
142                        (read-subdirs opt_eggdir)))))
143      (if (null? eggdirs)
144          (message "No egg directories found in ~a" opt_eggdir)
145          (message "Found egg directories: ~a" eggdirs))
146      (for-each (lambda (x) (build-deb opt_eggdir opt_wikidir opt_output-dir opt_extpath x))
147                eggdirs))))
148
149(main options operands)
Note: See TracBrowser for help on using the repository browser.