103 lines
4.1 KiB
Racket
103 lines
4.1 KiB
Racket
#lang scheme/base
|
|
(require scheme/cmdline
|
|
raco/command-name
|
|
setup/unpack
|
|
racket/file
|
|
racket/port
|
|
racket/match
|
|
racket/string
|
|
racket/pretty)
|
|
|
|
(define verbose (make-parameter #f))
|
|
|
|
(define just-show? (make-parameter #f))
|
|
(define replace? (make-parameter #f))
|
|
(define show-config? (make-parameter #f))
|
|
|
|
(define mzc-symbol (string->symbol (short-program+command-name)))
|
|
|
|
(define files
|
|
(command-line
|
|
#:program (short-program+command-name)
|
|
#:once-each
|
|
[("-l" "--list") "just list archive content"
|
|
(just-show? #t)]
|
|
[("-c" "--config") "show archive configuration"
|
|
(show-config? #t)]
|
|
[("-f" "--force") "replace existing files when unpacking"
|
|
(replace? #t)]
|
|
#:args archive
|
|
archive))
|
|
|
|
(define (desc->path dir)
|
|
(if (path? dir)
|
|
dir
|
|
(apply build-path
|
|
(symbol->string (car dir))
|
|
(cdr dir))))
|
|
|
|
(for ([filename (in-list files)])
|
|
(fold-plt-archive filename
|
|
(lambda (config a)
|
|
(when (show-config?)
|
|
(match config
|
|
[`(lambda (request failure)
|
|
(case request
|
|
((name) ,name)
|
|
((unpacker) (quote mzscheme))
|
|
((requires) (quote ,reqs))
|
|
((conflicts) (quote ,conflicts))
|
|
((plt-relative?) ,plt-rel?)
|
|
((plt-home-relative?) ,plt-home-rel?)
|
|
((test-plt-dirs) ,test-plt-dirs)
|
|
(else (failure))))
|
|
(printf "config:\n")
|
|
(printf " name: ~s\n" name)
|
|
(printf " requires:\n")
|
|
(for ([c (in-list reqs)])
|
|
(printf " ~s ~s\n" (string-join (car c) "/") (cadr c)))
|
|
(printf " conflicts:\n")
|
|
(for ([c (in-list conflicts)])
|
|
(printf " ~s\n" (string-join c "/")))
|
|
(cond
|
|
[plt-home-rel? (printf " unpack to main installation\n")]
|
|
[plt-rel? (printf " unpack to user add-ons\n")]
|
|
[else (printf " unpack locally\n")])]
|
|
[else
|
|
(printf "config function:\n")
|
|
(pretty-write config)]))
|
|
a)
|
|
(lambda (setup i a)
|
|
(when (show-config?)
|
|
(match setup
|
|
[`(unit (import main-collects-parent-dir mzuntar) (export) (mzuntar void) (quote ,c))
|
|
(printf "setup collections:\n")
|
|
(for ([c (in-list c)])
|
|
(printf " ~s\n" (string-join c "/")))]
|
|
[else
|
|
(printf "setup unit:\n")
|
|
(pretty-write setup)]))
|
|
a)
|
|
(lambda (dir a)
|
|
(unless (eq? dir 'same)
|
|
(if (just-show?)
|
|
(printf "~a\n" (path->directory-path (desc->path dir)))
|
|
(make-directory* (desc->path dir))))
|
|
a)
|
|
(lambda (file i kind a)
|
|
(if (just-show?)
|
|
(printf "~a~a\n" (desc->path file)
|
|
(if (eq? kind 'file-replace)
|
|
" [replace]"
|
|
""))
|
|
(call-with-output-file*
|
|
(desc->path file)
|
|
#:exists (if (or (eq? kind 'file-replace)
|
|
(replace?))
|
|
'truncate/replace
|
|
'error)
|
|
(lambda (o)
|
|
(copy-port i o))))
|
|
a)
|
|
(void)))
|