1#lang racket/base
2(require racket/set
3         setup/collection-name
4         setup/matching-platform
5         setup/getinfo
6         "../path.rkt"
7         "params.rkt"
8         "metadata.rkt"
9         "get-info.rkt")
10
11(provide pkg-directory->additional-installs
12         directory->additional-installs
13         get-additional-installed)
14
15(define (pkg-directory->additional-installs dir pkg-name
16                                            #:namespace [metadata-ns (make-metadata-namespace)]
17                                            #:system-type [sys-type #f]
18                                            #:system-library-subpath [sys-lib-subpath #f])
19  (set->list (directory->additional-installs dir pkg-name metadata-ns
20                                             #:system-type sys-type
21                                             #:system-library-subpath sys-lib-subpath)))
22
23(define (directory->additional-installs dir pkg-name metadata-ns
24                                        #:system-type [sys-type #f]
25                                        #:system-library-subpath [sys-lib-subpath #f])
26  (define single-collect
27    (pkg-single-collection dir #:name pkg-name #:namespace metadata-ns))
28  ;; In this loop `omits` is a set of paths built on `dir`, and `prefix+rxes`
29  ;; is a set of regular expressions to continue using as we recur down;
30  ;; each regular expression is matched relative to the directory where it was
31  ;; introduced, so we have to build up a prefix to use with each regexp
32  (let loop ([s (set)] [f-rel dir] [wrt #f] [top? #t] [omits (set)] [prefix+rxs '()])
33    (define f (if wrt (build-path wrt f-rel) f-rel))
34    (cond
35      [(and (directory-exists? f)
36            (let ([sf (simplify-path f)])
37              (and (not (set-member? omits sf))
38                   (not (for/or ([prefix+rx (in-list prefix+rxs)])
39                          (define prefix (car prefix+rx))
40                          (regexp-match? (cdr prefix+rx) (if (eq? prefix 'same)
41                                                             f-rel
42                                                             (build-path prefix f-rel))))))))
43       (define i (get-pkg-info f metadata-ns))
44       (define omit-paths (if i
45                              (i 'compile-omit-paths (lambda () null))
46                              null))
47       (cond
48         [(eq? omit-paths 'all)
49          s]
50         [else
51          (define omit-files (if i
52                                 (i 'compile-omit-files (lambda () null))
53                                 null))
54          (define new-s
55            (if (and i (or single-collect (not top?)))
56                (set-union (extract-additional-installs i sys-type sys-lib-subpath)
57                           s)
58                s))
59          (define new-omits
60            (set-union omits
61                       (for/set ([i (in-list (append omit-paths omit-files))]
62                                 #:unless (regexp? i))
63                         (simplify-path (build-path f i)))))
64          (define new-prefix+rxs
65            (append (for/list ([i (in-list (append omit-paths omit-files))]
66                               #:when (regexp? i))
67                      (cons 'same i))
68                    ;; add to prefix for rxs accumulated so far
69                    (for/list ([prefix+rx (in-list prefix+rxs)])
70                      (define prefix (car prefix+rx))
71                      (cons (if (eq? prefix 'same)
72                                f-rel
73                                (build-path prefix f-rel))
74                            (cdr prefix+rx)))))
75          (for/fold ([s new-s]) ([sub-f (directory-list f)])
76            (loop s sub-f f #f new-omits new-prefix+rxs))])]
77      [else s])))
78
79(define (extract-additional-installs i sys-type sys-lib-subpath)
80  (define (extract-documents i)
81    (let ([s (i 'scribblings (lambda () null))])
82      (for/set ([doc (in-list (if (list? s) s null))]
83                #:when (and (list? doc)
84                            (pair? doc)
85                            (path-string? (car doc))
86                            (or ((length doc) . < . 2)
87                                (list? (cadr doc)))
88                            (or ((length doc) . < . 4)
89                                (collection-name-element? (list-ref doc 3)))))
90        (define flags (if ((length doc) . < . 2)
91                          null
92                          (cadr doc)))
93        (cond
94         [(member 'main-doc-root flags) '(main-doc-root . "root")]
95         [(member 'user-doc-root flags) '(user-doc-root . "root")]
96         [else
97          (cons 'doc
98                (string-foldcase
99                 (if ((length doc) . < . 4)
100                     (let-values ([(base name dir?) (split-path (car doc))])
101                       (path->string (path-replace-extension name #"")))
102                     (list-ref doc 3))))]))))
103  (define (extract-paths i tag keys)
104    (define (get k)
105      (define l (i k (lambda () null)))
106      (if (and (list? l) (andmap path-string? l))
107          l
108          null))
109    (list->set (map (lambda (v) (cons tag
110                                      (let-values ([(base name dir?) (split-path v)])
111                                        ;; Normalize case, because some platforms
112                                        ;; have case-insensitive filesystems:
113                                        (string-foldcase (path->string name)))))
114                    (apply
115                     append
116                     (for/list ([k (in-list keys)])
117                       (get k))))))
118  (define (extract-launchers i)
119    (extract-paths i 'exe '(racket-launcher-names
120                            mzscheme-launcher-names
121                            gracket-launcher-names
122                            mred-launcher-names)))
123  (define (extract-foreign-libs i)
124    (extract-paths i 'lib '(copy-foreign-libs
125                            move-foreign-libs)))
126  (define (extract-shared-files i)
127    (extract-paths i 'share '(copy-shared-files
128                              move-shared-files)))
129  (define (extract-man-pages i)
130    (extract-paths i 'man '(copy-man-pages
131                            move-man-pages)))
132  (define (this-platform? i)
133    (define v (i 'install-platform (lambda () #rx"")))
134    (or (not (platform-spec? v))
135        (matching-platform? v
136                            #:cross? #t
137                            #:system-type sys-type
138                            #:system-library-subpath sys-lib-subpath)))
139  (set-union (extract-documents i)
140             (extract-launchers i)
141             (if (this-platform? i)
142                 (set-union
143                  (extract-foreign-libs i)
144                  (extract-shared-files i)
145                  (extract-man-pages i))
146                 (set))))
147
148(define (get-additional-installed kind skip-ht-keys ai-cache metadata-ns path-pkg-cache)
149  (or (unbox ai-cache)
150      (let ()
151        (define skip-pkgs (list->set (hash-keys skip-ht-keys)))
152        (define dirs (find-relevant-directories '(scribblings
153                                                  racket-launcher-names
154                                                  mzscheme-launcher-names
155                                                  gracket-launcher-names
156                                                  mred-launcher-names
157                                                  copy-foreign-libs
158                                                  move-foreign-libs
159                                                  copy-shared-files
160                                                  move-shared-files
161                                                  copy-man-pages
162                                                  move-man-pages)
163                                                (if (eq? 'user (current-pkg-scope))
164                                                    'all-available
165                                                    'no-user)))
166        (define s (for/fold ([s (set)]) ([dir (in-list dirs)])
167                    (cond
168                     [(set-member? skip-pkgs (path->pkg dir #:cache path-pkg-cache))
169                      s]
170                     [else
171                      (define i (get-pkg-info dir metadata-ns))
172                      (if i
173                          (set-union s (extract-additional-installs i #f #f))
174                          s)])))
175        (set-box! ai-cache s)
176        s)))
177
178