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

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

Go back to the start directory after a package is built.

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 (and doc (not (string-suffix? ".html" doc)))
111              (let ((html-path (s+ "html/" name ".html")))
112                (run (csi -s ,(cond ((file-exists? (s+ start "/makehtml.scm")) => identity)
113                                    (else 'makehtml.scm))
114                          ,(s+ "--extension-path=" ext-path) 
115                          ,(s+ "--wikipath=" wiki-dir) 
116                          ,(s+ "--only=" name)))
117                (run (cp ,html-path ,build-dir))))
118          (cd build-dir)
119          (run (chmod a+rx debian/rules))
120          (run (,(s+ "EGG_TREE=\"" eggdir "\"") dpkg-buildpackage -us -uc))
121          (cd start))
122        (message "No debian subdirectory found in ~a" path))))
123
124(define (main options operands)
125  (let ((opt_wikidir   (alist-ref 'wiki-dir options))
126        (opt_eggdir    (alist-ref 'egg-dir options))
127        (opt_extpath   (alist-ref 'extension-path options))
128        (opt_exclude ((lambda (x) (and x (string-split x ","))) (alist-ref 'exclude options)))
129        (opt_output-dir (alist-ref 'output-dir options)))
130    (if (not (and opt_eggdir opt_output-dir))
131        (begin
132          (error-message "Both egg directory and output directory must be specified!")
133          (usage)))
134    (message "Egg directory tree: ~a" opt_eggdir)
135    (message "Output directory tree: ~a" opt_output-dir)
136    ;; make sure target dir exists
137    (if (not (file-exists? opt_output-dir))
138        (begin
139          (message "Creating directory ~a" opt_output-dir)
140          (create-directory opt_output-dir)))
141    (let ((eggdirs (filter-map 
142                    (lambda (x) (and (not (member (pathname-strip-directory x) opt_exclude)) x))
143                    (or (and (pair? operands) (map (lambda (x) (s+ opt_eggdir dirsep (->string x))) operands))
144                        (read-subdirs opt_eggdir)))))
145      (if (null? eggdirs)
146          (message "No egg directories found in ~a" opt_eggdir)
147          (message "Found egg directories: ~a" eggdirs))
148      (for-each (lambda (x) (build-deb opt_eggdir opt_wikidir opt_output-dir opt_extpath x))
149                eggdirs))))
150
151(main options operands)
Note: See TracBrowser for help on using the repository browser.