1#lang scheme/base
2(require scheme/cmdline
3         raco/command-name
4         setup/pack
5         setup/getinfo
6         compiler/distribute)
7
8(define verbose (make-parameter #f))
9
10(define collection? (make-parameter #f))
11
12(define default-plt-name "archive")
13
14(define plt-name (make-parameter default-plt-name))
15(define plt-files-replace (make-parameter #f))
16(define plt-files-plt-relative? (make-parameter #f))
17(define plt-files-plt-home-relative? (make-parameter #f))
18(define plt-force-install-dir? (make-parameter #f))
19(define plt-setup-collections (make-parameter null))
20(define plt-include-compiled (make-parameter #f))
21
22(define mzc-symbol (string->symbol (short-program+command-name)))
23
24(define-values (plt-output source-files)
25  (command-line
26   #:program (short-program+command-name)
27   #:once-each
28   [("--collect") "<path>s specify collections instead of files/dirs"
29    (collection? #t)]
30   [("--plt-name") name "Set the printed <name> describing the archive"
31    (plt-name name)]
32   [("--replace") "Files in archive replace existing files when unpacked"
33    (plt-files-replace #t)]
34   [("--at-plt") "Files/dirs in archive are relative to user's add-ons directory"
35    (plt-files-plt-relative? #t)]
36   #:once-any
37   [("--all-users") "Files/dirs in archive go to PLT installation if writable"
38    (plt-files-plt-home-relative? #t)]
39   [("--force-all-users") "Files/dirs forced to PLT installation"
40    (plt-files-plt-home-relative? #t) (plt-force-install-dir? #t)]
41   #:once-each
42   [("--include-compiled") "Include \"compiled\" subdirectories in the archive"
43    (plt-include-compiled #t)]
44   #:multi
45   [("++setup") collect "Setup <collect> after the archive is unpacked"
46    (plt-setup-collections (append (plt-setup-collections) (list collect)))]
47   #:once-each
48   [("-v") "Verbose mode"
49    (verbose #t)]
50   #:args (dest-file . path)
51   (values dest-file path)))
52
53(if (not (collection?))
54    ;; Files and directories
55    (begin
56      (for ([fd source-files])
57        (unless (relative-path? fd)
58          (error mzc-symbol
59                 "file/directory is not relative to the current directory: \"~a\""
60                 fd)))
61      (pack-plt plt-output
62                (plt-name)
63                source-files
64                #:collections (map list (plt-setup-collections))
65                #:file-mode (if (plt-files-replace) 'file-replace 'file)
66                #:plt-relative? (or (plt-files-plt-relative?)
67                                    (plt-files-plt-home-relative?))
68                #:at-plt-home? (plt-files-plt-home-relative?)
69                #:test-plt-dirs (if (or (plt-force-install-dir?)
70                                        (not (plt-files-plt-home-relative?)))
71                                    #f
72                                    '("collects" "doc" "include" "lib"))
73                #:requires
74                null)
75      (when (verbose)
76        (printf " [output to \"~a\"]\n" plt-output)))
77    ;; Collection
78    (begin
79      (pack-collections-plt
80       plt-output
81       (if (eq? default-plt-name (plt-name)) #f (plt-name))
82       (map (lambda (sf)
83              (let loop ([sf sf])
84                (let ([m (regexp-match "^([^/]*)/(.*)$" sf)])
85                  (if m (cons (cadr m) (loop (caddr m))) (list sf)))))
86            source-files)
87       #:replace? (plt-files-replace)
88       #:extra-setup-collections (map list (plt-setup-collections))
89       #:file-filter (if (plt-include-compiled)
90                         (lambda (path)
91                           (or (regexp-match #rx#"compiled$" (path->bytes path))
92                               (std-filter path)))
93                         std-filter)
94       #:at-plt-home? (plt-files-plt-home-relative?)
95       #:test-plt-collects? (not (plt-force-install-dir?)))
96      (when (verbose)
97        (printf " [output to \"~a\"]\n" plt-output))))
98
99(module test racket/base)
100