This file is indexed.

/usr/share/racket/collects/pkg/main.rkt is in racket-common 6.7-3.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
#lang racket/base
(require racket/function
         racket/list
         racket/format
         racket/path
         racket/splicing
         raco/command-name
         setup/dirs
         net/url
         "name.rkt"
         "lib.rkt"
         "commands.rkt"
         (prefix-in setup: setup/setup)
         (for-syntax racket/base
                     syntax/strip-context))

(define (setup what no-setup? fail-fast? setup-collects jobs)
  (unless (or (eq? setup-collects 'skip)
              no-setup?
              (not (member (getenv "PLT_PKG_NOSETUP") '(#f ""))))
    (define installation? (eq? 'installation (current-pkg-scope)))
    (unless (setup:setup
             #:make-user? (not installation?)
             #:avoid-main? (not installation?)
             #:collections (and setup-collects
                                (map (lambda (s)
                                       (if (list? s) s (list s)))
                                     setup-collects))
             #:tidy? #t
             #:make-doc-index? #t
             #:jobs jobs
             #:fail-fast? fail-fast?)
      ((current-pkg-error)
       "packages ~a, although setup reported errors"
       what))))

(define ((pkg-error cmd) . args)
  (apply raise-user-error
         (string->symbol (format "~a ~a" (short-program+command-name) cmd))
         args))

;; Selects scope from `given-scope' through `user' arguments, or infers
;; a scope from `pkgs' if non-#f, and then calls `thunk'.
(define (call-with-package-scope who given-scope scope-dir installation user pkgs
                                 pkgs-type clone-type-can-be-name? given-name
                                 thunk)
  (define scope
    (case given-scope
      [(installation user) given-scope]
      [else
       (cond
        [installation 'installation]
        [user 'user]
        [(path-string? given-scope) 
         ;; This can happens when a #:scope value is given a path programmatically.
         ;; Make it easier on clients by alloing that.
         (path->complete-path given-scope)]
        [scope-dir (path->complete-path scope-dir)]
        [else
         (define default-scope (default-pkg-scope))
         (or (and pkgs
                  ;; Infer a scope from given package names:
                  (parameterize ([current-pkg-scope 'user]
                                 [current-pkg-error (pkg-error who)])
                    (with-pkg-lock/read-only
                     (define-values (pkg scope)
                       (for/fold ([prev-pkg #f] [prev-scope #f]) ([pkg (in-list pkgs)])
                         (define-values (pkg-name pkg-type/unused)
                           (cond
                            [given-name (values given-name #f)]
                            [(and (eq? pkgs-type 'clone)
                                  clone-type-can-be-name?
                                  (let-values ([(pkg-name pkg-type) 
                                                (package-source->name+type pkg #f)])
                                    (and (eq? pkg-type 'name)
                                         pkg-name)))
                             => (lambda (name)
                                  (values name #f))]
                            [else
                             (package-source->name+type pkg pkgs-type
                                                        #:must-infer-name? #t
                                                        #:complain
                                                        (lambda (s msg)
                                                          ((current-pkg-error) 
                                                           (~a "~a\n"
                                                               "  given: ~a")
                                                           msg s)))]))
                         (define scope (find-pkg-installation-scope pkg-name))
                         (cond
                          [(or (not prev-pkg) (not prev-scope)) (values pkg scope)]
                          [(not scope) (values prev-pkg prev-scope)]
                          [(equal? scope prev-scope) (values prev-pkg prev-scope)]
                          [else
                           ((current-pkg-error)
                            (~a "given packages are installed in different scopes\n"
                                "  package: ~a\n"
                                "  scope: ~a\n"
                                "  second package: ~a\n"
                                "  second scope: ~a")
                            prev-pkg
                            prev-scope
                            pkg
                            scope)])))
                     (when (and scope
                                (not (equal? scope default-scope)))
                       (printf "Inferred package scope: ~a\n" scope))
                     scope)))
             ;; No inference, so use configured default scope:
             default-scope)])]))
  (parameterize ([current-pkg-scope scope]
                 [current-pkg-error (pkg-error who)])
    (thunk)))

(define (catalog->url s)
  (cond
   [(regexp-match? #rx"^[a-zA-Z]*://" s) (string->url s)]
   [else (path->url (path->complete-path s))]))

(define (clone-to-package-name clone cmd)
  ;; Use directory name as sole package name, if possible
  (define-values (base name dir?) (split-path clone))
  (cond
   [(and (path? name)
         (let-values ([(pkg-name pkg-type) 
                       (package-source->name+type (path-element->string name) #f)])
           (eq? pkg-type 'name)))
    (define pkg (path-element->string name))
    (printf (~a "Inferred package name from given `--clone' path\n"
                "  package: ~a\n"
                "  given path: ~a\n")
            pkg
            clone)
    (list pkg)]
   [else
    ((pkg-error cmd)
     (~a "cannot extract a valid package name from the `--clone' path\n"
         "  given path: ~a")
     clone)]))

  (define-syntax (make-commands stx)
    (syntax-case stx ()
      [(_ #:scope-flags (scope-flags ...)
          #:dry-run-flags (dry-run-flags ...)
          #:job-flags (job-flags ...)
          #:trash-flags (trash-flags ...)
          #:catalog-flags (catalog-flags ...)
          #:install-type-flags (install-type-flags ...)
          #:install-dep-flags ((install-dep-flags ... (dep-desc ...)))
          #:install-dep-desc (install-dep-desc ...)
          #:install-force-flags (install-force-flags ...)
          #:install-clone-flags (install-clone-flags ...)
          #:update-deps-flags (update-deps-flags ...)
          #:install-copy-flags (install-copy-flags ...)
          #:install-copy-defns (install-copy-defns ...)
          #:install-copy-checks (install-copy-checks ...))
       (replace-context
        stx
         #`(commands
            "This tool is used for managing installed packages."
            "pkg-~a-command"
            ;; ----------------------------------------
            [install
             "Install packages"
             #:usage-help "Installs the packages specified by <pkg-source> ..., and"
                          "if no sources are specified, installs the current directory"
             #:once-each
             install-type-flags ...
             #:once-any
             [install-dep-flags ...
                                (dep-desc ... 
                                          install-dep-desc ...)]
             [#:bool auto () "Shorthand for `--deps search-auto'"]
             #:once-each
             update-deps-flags ...
             #:once-any
             install-copy-flags ...
             #:once-any
             scope-flags ...
             #:once-each
             catalog-flags ...
             [#:bool skip-installed () ("Skip a <pkg-source> if already installed")]
             [#:bool pkgs () ("Install only the specified packages, even when none are provided")]
             install-force-flags ...
             install-clone-flags ...
             dry-run-flags ...
             job-flags ...
             trash-flags ...
             [#:bool fail-fast () ("Break `raco setup' when it discovers an error")]
             #:args pkg-source
             install-copy-defns ...
             (let ([pkg-source
                    ;; Implement special rules for an empty list of package sources
                    (cond
                     [(not (null? pkg-source))
                      pkg-source]
                     [clone
                      (clone-to-package-name clone 'install)]
                     [else
                      pkg-source])])
               (call-with-package-scope
                'install
                scope scope-dir installation user #f a-type #f name
                (lambda ()
                  install-copy-checks ...
                  (when (and name (> (length pkg-source) 1))
                    ((current-pkg-error) (format "the --name flag only makes sense with a single package source")))
                  (unless (or (not name) (package-source->name name))
                    ((current-pkg-error) (format "~e is an invalid package name" name)))
                  ;; if no sources were supplied, and `--pkgs` was not
                  ;; explicitly specified, install the current directory
                  ;; as a linked directory
                  (define-values (sources a-type*)
                    (if (and (not pkgs) (null? pkg-source))
                        (begin
                          (printf "Linking current directory as a package\n")
                          (values (list (path->string (current-directory)))
                                  'link))
                        (values pkg-source a-type)))
                  (define setup-collects
                    (with-pkg-lock
                        (parameterize ([current-pkg-catalogs (and catalog
                                                                  (list (catalog->url catalog)))])
                          (pkg-install #:from-command-line? #t
                                       #:dep-behavior (or (and auto 'search-auto)
                                                          deps
                                                          (cond
                                                           [batch 'fail]                                                           
                                                           [else 'search-ask]))
                                       #:all-platforms? all-platforms
                                       #:force? force
                                       #:ignore-checksums? ignore-checksums
                                       #:strict-doc-conflicts? strict-doc-conflicts
                                       #:use-cache? (not no-cache)
                                       #:skip-installed? skip-installed
                                       #:update-deps? update-deps
                                       #:update-implies? (not ignore-implies)
                                       #:strip (or (and source 'source)
                                                   (and binary 'binary)
                                                   (and binary-lib 'binary-lib))
                                       #:force-strip? force
                                       #:multi-clone-behavior (or multi-clone 
                                                                  (if batch
                                                                      'fail
                                                                      'ask))
                                       #:pull-behavior pull
                                       #:link-dirs? link-dirs?
                                       #:dry-run? dry-run
                                       #:use-trash? (not no-trash)
                                       (for/list ([p (in-list sources)])
                                         (pkg-desc p a-type* name checksum #f
                                                   #:path (and (eq? a-type* 'clone)
                                                               (path->complete-path clone))))))))
                  (setup "installed" no-setup fail-fast setup-collects jobs))))]
            ;; ----------------------------------------
            [update
             "Update packages"
             #:once-each
             [#:bool all ("-a") ("Update all packages if no <pkg-source> is given")]
             [#:bool lookup ()
                     ("When <pkg-source> is a name, get source from a catalog instead of"
                      "  using the currently installed source; unclones or combines with `--clone'")]
             #:once-each
             install-type-flags ...
             #:once-any
             [install-dep-flags ...
                                (dep-desc ... 
                                          install-dep-desc ...)]
             [#:bool auto () "Shorthand for `--deps search-auto' plus `--update-deps'"]
             #:once-each
             update-deps-flags ...
             #:once-any
             install-copy-flags ...
             #:once-any
             scope-flags ...
             #:once-each
             catalog-flags ...
             [#:bool skip-uninstalled () ("Skip a given <pkg-source> if not installed")]
             install-force-flags ...
             install-clone-flags ...
             dry-run-flags ...
             job-flags ...
             trash-flags ...
             #:args pkg-source
             install-copy-defns ...
             (let ([pkg-source
                    ;; Implement special rules for an empty list of package sources
                    (cond
                     [(or (not (null? pkg-source))
                          all) ; --all has is own treatment of an empty list
                      pkg-source]
                     [clone
                      (clone-to-package-name clone 'update)]
                     [else
                      ;; In a package directory?
                      (define pkg (path->pkg (current-directory)))
                      (if pkg
                          (begin
                            (printf "Updating current directory's package: ~a\n"
                                    pkg)
                            (list pkg))
                          null)])])
               (call-with-package-scope
                'update
                scope scope-dir installation user pkg-source a-type #t name
                (lambda ()
                  install-copy-checks ...
                  (define clone-path (and (eq? a-type 'clone)
                                          (path->complete-path clone)))
                  (define setup-collects
                    (with-pkg-lock
                        (parameterize ([current-pkg-catalogs (and catalog
                                                                  (list (catalog->url catalog)))])
                          (pkg-update (for/list ([pkg-source (in-list pkg-source)])
                                        (cond
                                         [lookup
                                          (pkg-desc pkg-source a-type name checksum #f
                                                    #:path clone-path)]
                                         [else
                                          (define-values (pkg-name pkg-type) 
                                            (package-source->name+type pkg-source a-type))
                                          (if (eq? pkg-type 'name)
                                              pkg-name
                                              (pkg-desc pkg-source a-type name checksum #f
                                                        #:path clone-path))]))
                                      #:from-command-line? #t
                                      #:all? all
                                      #:dep-behavior (or (and auto 'search-auto)
                                                         deps
                                                         (cond
                                                          [batch 'fail]
                                                          [else 'search-ask]))
                                      #:all-platforms? all-platforms
                                      #:force? force
                                      #:ignore-checksums? ignore-checksums
                                      #:strict-doc-conflicts? strict-doc-conflicts
                                      #:use-cache? (not no-cache)
                                      #:skip-uninstalled? skip-uninstalled
                                      #:update-deps? (or update-deps auto)
                                      #:update-implies? (not ignore-implies)
                                      #:strip (or (and source 'source)
                                                  (and binary 'binary)
                                                  (and binary-lib 'binary-lib))
                                      #:force-strip? force
                                      #:lookup-for-clone? lookup
                                      #:multi-clone-behavior (or multi-clone
                                                                 (if batch
                                                                     'fail
                                                                     'ask))
                                      #:pull-behavior pull
                                      #:link-dirs? link-dirs?
                                      #:infer-clone-from-dir? (not (or link static-link copy))
                                      #:dry-run? dry-run
                                      #:use-trash? (not no-trash)))))
                  (setup "updated" no-setup #f setup-collects jobs))))]
            ;; ----------------------------------------
            [remove
             "Remove packages"
             #:once-each
             [#:bool demote () "Demote to auto-installed, instead of removing"]
             [#:bool force () "Remove even if package has dependents"]
             [#:bool auto () "Also remove auto-installed packages that have no dependents"]
             #:once-any
             scope-flags ...
             #:once-each
             dry-run-flags ...
             job-flags ...
             trash-flags ...
             #:args pkg
             (call-with-package-scope
              'remove
              scope scope-dir installation user pkg 'name #f #f
              (lambda ()
                (define setup-collects
                  (with-pkg-lock
                   (pkg-remove pkg
                               #:from-command-line? #t
                               #:demote? demote
                               #:auto? auto
                               #:force? force
                               #:dry-run? dry-run
                               #:use-trash? (not no-trash))))
                (setup "removed" no-setup #f setup-collects jobs)))]
            ;; ----------------------------------------
            [new
             "Populate a new directory with the stubs of a package"
             #:args (pkg)
             (parameterize ([current-pkg-error (pkg-error 'new)])
               (pkg-new pkg))]
            ;; ----------------------------------------
            [show
             "Show information about installed packages"
             #:usage-help
             "Set the COLUMNS environment variable to configure the output without `-l'."
             #:once-each
             [#:bool all ("-a") "Show auto-installed packages, too"]
             [#:bool long ("-l") "Show full column content"]
             [#:bool full-checksum () "Show the full checksum"]
             [#:bool rx () "Treat <pkg>s as regular expressions"]
             [#:bool dir ("-d") "Show the directory where the package is installed"]
             #:once-any
             scope-flags ...
             [(#:str vers #f) version ("-v") "Show user-specific for installation <vers>"]
             #:args pkg
             (define only-mode (case scope
                                 [(installation user) scope]
                                 [else
                                  (cond
                                   [scope-dir (path->complete-path scope-dir)]
                                   [installation 'installation]
                                   [user 'user]
                                   [else (if version 'user #f)])]))
             (define pkgs* (if (pair? pkg) pkg #f))
             (for ([mode (if only-mode
                             (list only-mode)
                             (append (let ([main (find-pkgs-dir)])
                                       (reverse
                                        (for/list ([d (get-pkgs-search-dirs)])
                                          (if (equal? d main)
                                              'installation
                                              (simple-form-path d)))))
                                     '(user)))])
               (when (or (equal? mode only-mode) (not only-mode))
                 (define prefix-line
                   (and (not only-mode)
                        (case mode
                          [(installation) "Installation-wide:"]
                          [(user) (format "User-specific for installation ~s:"
                                          (or version (get-installation-name)))]
                          [else (format "~a:" mode)])))
                 (parameterize ([current-pkg-scope mode]
                                [current-pkg-error (pkg-error 'show)]
                                [current-pkg-scope-version (or version (get-installation-name))])
                   (with-pkg-lock/read-only
                    (pkg-show (if only-mode "" " ") pkgs*
                              #:prefix-line prefix-line
                              #:auto? all
                              #:long? long
                              #:rx? rx
                              #:full-checksum? full-checksum
                              #:directory? dir)))))]
            ;; ----------------------------------------
            [migrate
             "Install packages installed for other version/name"
             #:once-each
             [install-dep-flags ...
                                (dep-desc ...
                                          "where the default is `search-auto'")]
             #:once-any
             [#:bool source () ("Strip built elements of the package before installing")]
             [#:bool binary () ("Strip source elements of the package before installing")]
             [#:bool binary-lib () ("Strip source elements and documentation before installing")]
             #:once-any
             scope-flags ...
             #:once-each
             catalog-flags ...
             install-force-flags ...
             dry-run-flags ...
             job-flags ...
             #:args (from-version)
             (call-with-package-scope
              'migrate
              scope scope-dir installation user #f #f #f #f
              (lambda ()
                (define setup-collects
                  (with-pkg-lock
                   (parameterize ([current-pkg-catalogs (and catalog
                                                             (list (catalog->url catalog)))])
                     (pkg-migrate from-version
                                  #:from-command-line? #t
                                  #:dep-behavior deps
                                  #:force? force
                                  #:all-platforms? all-platforms
                                  #:ignore-checksums? ignore-checksums
                                  #:strict-doc-conflicts? strict-doc-conflicts
                                  #:use-cache? (not no-cache)
                                  #:strip (or (and source 'source)
                                              (and binary 'binary)
                                              (and binary-lib 'binary-lib))
                                  #:force-strip? force
                                  #:dry-run? dry-run))))
                (setup "migrated" no-setup #f setup-collects jobs)))]
            ;; ----------------------------------------
            [create
             "Bundle package from a directory or installed package"
             #:once-any
             [#:bool from-dir () "Treat <directory-or-package> as a directory (the default)"]
             [#:bool from-install () "Treat <directory-or-package> as a package name"]
             #:once-any
             [(#:sym fmt [zip tgz plt] #f) format ()
              ("Select the format of the package to be created;"
               "valid <fmt>s are: zip (the default), tgz, plt")]
             [#:bool manifest () "Creates a manifest file for a directory, rather than an archive"]
             #:once-any
             [#:bool as-is () "Bundle the directory/package as-is (the default)"]
             [#:bool source () "Bundle sources only"]
             [#:bool binary () "Bundle bytecode and rendered documentation without sources"]
             [#:bool binary-lib () "Bundle bytecode without sources or documentation"]
             [#:bool built () "Bundle sources, bytecode and rendered documentation"]
             #:once-each
             [(#:str dest-dir #f) dest () "Create output files in <dest-dir>"]
             #:args (directory-or-package)
             (parameterize ([current-pkg-error (pkg-error 'create)])
               (pkg-create (if manifest 'MANIFEST (or format 'zip)) 
                           directory-or-package
                           #:from-command-line? #t
                           #:dest (and dest 
                                       (path->complete-path dest))
                           #:source (cond
                                     [from-install 'name]
                                     [else 'dir])
                           #:mode (cond
                                   [source 'source]
                                   [binary 'binary]
                                   [binary-lib 'binary-lib]
                                   [built 'built]
                                   [else 'as-is])))]
            ;; ----------------------------------------
            [config
             "View and modify the package manager's configuration"
             #:usage-help "Shows value for <key>, shows values for all <key>s if"
                          " none is given, or sets a single <key>"
                          " if --set is specified"
             #:once-any
             [#:bool set () "Set <key> to <val>s"]
             #:once-any
             scope-flags ...
             #:handlers
             (lambda (accum . key+vals)
               (call-with-package-scope
                'config
                scope scope-dir installation user #f #f #f #f
                (lambda ()
                  (if set
                      (with-pkg-lock
                       (pkg-config #t key+vals
                                   #:from-command-line? #t))
                      (with-pkg-lock/read-only
                       (pkg-config #f key+vals
                                   #:from-command-line? #t))))))
             (list "key" "val")]
            ;; ----------------------------------------
            [catalog-show
             "Show package information as reported by a catalog"
             #:once-each
             [#:bool all () "Show all packages"]
             [#:bool only-names () "Show only package names"]
             [#:bool modules () "Show implemented modules"]
             catalog-flags ...
             [(#:str vers #f) version ("-v") "Show result for Racket <vers>"]
             #:args pkg-name
             (when (and all (pair? pkg-name))
               ((pkg-error 'catalog-show) "both `--all' and package names provided"))
             (parameterize ([current-pkg-catalogs (and catalog
                                                       (list (catalog->url catalog)))]
                            [current-pkg-error (pkg-error 'catalog-show)]
                            [current-pkg-lookup-version (or version
                                                            (current-pkg-lookup-version))])
               (pkg-catalog-show pkg-name 
                                 #:all? all
                                 #:only-names? only-names
                                 #:modules? modules))]
            ;; ----------------------------------------
            [catalog-copy
             "Copy/merge package name catalogs"
             #:once-each
             [#:bool from-config () "Include currently configured catalogs last"]
             #:once-any
             [#:bool force () "Force replacement of existing file/directory"]
             [#:bool merge () "Merge to existing database"]
             #:once-each
             [#:bool override () "While merging, override existing with new"]
             [#:bool relative () "Make source paths relative when possible"]
             [(#:str vers #f) version ("-v") "Copy information suitable for Racket <vers>"]
             #:args catalog
             (parameterize ([current-pkg-error (pkg-error 'catalog-copy)])
               (when (null? catalog)
                 ((current-pkg-error) "need a destination catalog"))
               (parameterize ([current-pkg-lookup-version (or version
                                                              (current-pkg-lookup-version))])
                 (pkg-catalog-copy (drop-right catalog 1)
                                   (last catalog)
                                   #:from-config? from-config
                                   #:force? force
                                   #:merge? merge
                                   #:override? override
                                   #:relative-sources? relative)))]
            ;; ----------------------------------------
            [catalog-archive
             "Copy catalog plus packages"
             #:once-each
             [#:bool from-config () "Include currently configured catalogs last"]
             [(#:str state-database #f) state () "Read/write <state-database> as state of <dest-dir>"]
             [(#:str vers #f) version ("-v") "Copy information suitable for Racket <vers>"]
             [#:bool relative () "Make source paths relative when possible"]
             [(#:sym mode [fail skip continue] 'fail) pkg-fail ()
              ("Select handling of package-download failure;"
               "<mode>s: fail (the default), skip, continue (but with exit status of 5)")]
             #:args (dest-dir . src-catalog)
             (parameterize ([current-pkg-error (pkg-error 'catalog-archive)]
                            [current-pkg-lookup-version (or version
                                                            (current-pkg-lookup-version))])
                 (define fail-at-end? #f)
                 (pkg-catalog-archive dest-dir
                                      src-catalog
                                      #:from-config? from-config
                                      #:state-catalog state
                                      #:relative-sources? relative
                                      #:package-exn-handler (case pkg-fail
                                                              [(fail) (lambda (name exn) (raise exn))]
                                                              [(skip continue)
                                                               (lambda (name exn)
                                                                 (log-error (~a "archiving failed for package; ~a\n"
                                                                                "  package name: ~a\n"
                                                                                "  original error:\n~a")
                                                                            (if (eq? pkg-fail 'continue)
                                                                                "continuing"
                                                                                "skipping")
                                                                            name
                                                                            (regexp-replace* #rx"(?m:^)"
                                                                                             (exn-message exn)
                                                                                             "   "))
                                                                 (when (eq? pkg-fail 'continue)
                                                                   (set! fail-at-end? #t)))]))
                 (when fail-at-end?
                   (exit 5)))]
            ;; ----------------------------------------
            [archive
             "Create catalog from installed packages"
             (define exclude-list (make-parameter null))
             #:once-each
             [#:bool include-deps () "Include dependencies of specified packages"]
             #:multi
             [(#:str pkg #f) exclude () "Exclude <pkg> from new catalog"
              (exclude-list (cons pkg (exclude-list)))]
             #:once-each
             [#:bool relative () "Make source paths relative when possible"]
             #:args (dest-dir pkg . pkgs)
             (parameterize ([current-pkg-error (pkg-error 'pkgs-archive)])
               (pkg-archive-pkgs dest-dir
                                 (cons pkg pkgs)
                                 #:include-deps? include-deps
                                 #:exclude (exclude-list)
                                 #:relative-sources? relative))]
            ;; ----------------------------------------
            [empty-trash
             "Delete old package installations from the trash directory"
             #:once-any
             scope-flags ...
             #:once-each
             [#:bool list ("-l") "Show trash content without emptying"]
             #:args ()
             (call-with-package-scope
              'empty-trash
              scope scope-dir installation user #f #f #f #f
              (lambda ()
                (pkg-empty-trash #:list? list
                                 #:quiet? #f)))]))]))

  (make-commands
   #:scope-flags
   ([(#:sym scope [installation user] #f) scope ()
     ("Select package <scope>, one of"
      "  installation: for all users of the Racket installation"
      "  user: as user-specific for an installation version/name")]
    [#:bool installation ("-i") "Shorthand for `--scope installation'"]
    [#:bool user ("-u") "Shorthand for `--scope user'"]
    [(#:str dir #f) scope-dir () "Select package scope <dir>"])
   #:dry-run-flags
   ([#:bool dry-run () ("Don't actually change package installation")])
   #:job-flags
   ([#:bool no-setup () ("Don't `raco setup' after changing packages (usually a bad idea)")]
    [(#:num n #f) jobs ("-j") "Setup with <n> parallel jobs"]
    [#:bool batch () ("Disable interactive mode and all prompts")])
   #:trash-flags
   ([#:bool no-trash () ("Delete uninstalled/updated, instead of moving to a trash folder")])
   #:catalog-flags
   ([(#:str catalog #f) catalog () "Use <catalog> instead of configured catalogs"])
   #:install-type-flags
   ([(#:sym type [file dir file-url dir-url git github name] #f) type ("-t") 
     ("Specify type of <pkg-source>, instead of inferred;"
      "valid <types>s are: file, dir, file-url, dir-url, git, github, or name")]
    [(#:str name #f) name ("-n") ("Specify name of package, instead of inferred;"
                                  "makes sense only when a single <pkg-source> is given")]
    [(#:str checksum #f) checksum () ("Checksum of package, either expected or selected;"
                                      "makes sense only when a single <pkg-source> is given")])
   #:install-dep-flags
   ([(#:sym mode [fail force search-ask search-auto] #f) deps ()
     ("Specify the behavior for uninstalled dependencies, with"
      "<mode> as one of"
      "  fail: cancels if dependencies are not installed"
      "  force: continues despite missing dependencies"
      "  search-ask: looks for dependencies in the package catalogs"
      "              and asks for permission to auto-install"
      "  search-auto: like `search-ask', but does not ask for permission")])
   #:install-dep-desc
   ("where the default is `search-ask' in interactive mode, `fail' otherwise")
   #:install-force-flags
   ([#:bool all-platforms () "Follow package dependencies for all platforms"]
    [#:bool force () "Ignore conflicts"]
    [#:bool ignore-checksums () "Ignore checksums"]
    [#:bool strict-doc-conflicts () "Report doc-name conflicts, even for user scope"]
    [#:bool no-cache () "Disable download cache"])
   #:install-clone-flags
   ([(#:sym mode [fail force convert ask] #f) multi-clone ()
     ("Specify treatment of multiple clones of a repository;"
      "<mode>s: convert, ask (interactive default), fail (other default), or force")]
    [(#:sym mode [ff-only try rebase] 'ff-only) pull ()
     ("Specify `git pull' mode for repository clones;"
      "<mode>s: ff-only (the default), try, or rebase")])
   #:update-deps-flags
   ([#:bool update-deps () "For `search-ask' or `search-auto', also update dependencies"]
    [#:bool ignore-implies () "When updating, treat `implies' like other dependencies"])
   #:install-copy-flags
   ([#:bool link () ("Link a directory package source in place (default for a directory)")]
    [#:bool static-link () ("Link in place, promising collections do not change")]
    [#:bool copy () ("Treat directory sources the same as other sources")]
    [(#:str dir #f) clone () ("Clone Git and GitHub package sources to <dir> and link")]
    [#:bool source () ("Strip packages' built elements before installing; implies --copy")]
    [#:bool binary () ("Strip packages' source elements before installing; implies --copy")]
    [#:bool binary-lib () ("Strip source & documentation before installing; implies --copy")])
   #:install-copy-defns
   [(define link-dirs? (not (or copy source binary binary-lib)))
    (define link-type (or (and link 'link) 
                          (and static-link 'static-link)
                          (and (eq? type 'dir) link-dirs? 'link)
                          (and clone 'clone)))
    (define a-type (or link-type type))]
   #:install-copy-checks
   [(when (and type
               link-type
               (not (memq type
                          (case link-type
                            [(clone) '(git github)]
                            [else '(dir)]))))
      ((current-pkg-error) (format "-t/--type value must be ~a with --~a"
                                   (cond
                                    [clone "`git' or `github'"]
                                    [else "`dir'"])
                                   (cond
                                    [link "link"]
                                    [static-link "static-link"]
                                    [clone "clone"]))))])