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