Rewrite install code in '#%kernel to avoid startup time.
This commit is contained in:
Sam Tobin-Hochstadt
Matthew Flatt
parent
c979e690a5
commit
4ea306ed61
98
src/download-libs.rkt
Normal file
98
src/download-libs.rkt
Normal file
|
|
@ -0,0 +1,98 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/tcp)
|
||||
(provide do-download)
|
||||
|
||||
(define url-host "download.racket-lang.org")
|
||||
(define url-path "/libs/4/")
|
||||
(define url-base (string-append "http://" url-host url-path))
|
||||
(define architecture #f) ;; set in `do-download'
|
||||
|
||||
|
||||
(define (delete-path path)
|
||||
(cond [(directory-exists? path)
|
||||
(parameterize ([current-directory path])
|
||||
(for-each delete-path (directory-list)))
|
||||
(delete-directory path)]
|
||||
[(or (file-exists? path) (link-exists? path)) (delete-file path)]))
|
||||
|
||||
(define (purify-port port)
|
||||
(let ([m (regexp-match-peek-positions #rx#"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)"
|
||||
port)])
|
||||
(if m (read-bytes (cdar m) port) "")))
|
||||
|
||||
(define (copy-port src dest)
|
||||
(let ([s (make-bytes 4096)])
|
||||
(let loop ()
|
||||
(let ([c (read-bytes-avail! s src)])
|
||||
(cond [(number? c)
|
||||
(let loop ([start 0])
|
||||
(unless (= start c)
|
||||
(let ([c2 (write-bytes-avail s dest start c)])
|
||||
(loop (+ start c2)))))
|
||||
(loop)]
|
||||
;; Must be EOF
|
||||
[else (void)])))))
|
||||
|
||||
(define (download* file target)
|
||||
(define src (format "~a~a/~a" url-path architecture file))
|
||||
(define-values [i o] (tcp-connect url-host 80))
|
||||
(fprintf o "GET ~a HTTP/1.0\r\nHost: ~a\r\n\r\n" src url-host)
|
||||
(flush-output o) (tcp-abandon-port o)
|
||||
(purify-port i)
|
||||
(call-with-output-file target #:exists 'truncate/replace
|
||||
(λ (out) (copy-port i out))))
|
||||
|
||||
(define (download file size)
|
||||
(define tmp (format "~a.download" file))
|
||||
(let loop ([n 0])
|
||||
(when (> n 0) (printf " retry #~a," n) (flush-output))
|
||||
(define thd (thread (λ () (download* file tmp))))
|
||||
(unless (sync/timeout (+ 10 (* 5 n)) thd)
|
||||
(kill-thread thd)
|
||||
(when (> n 3) (raise-user-error 'download "could not retrieve ~a" file))
|
||||
(when (zero? n) (printf " timeout,"))
|
||||
(loop (add1 n))))
|
||||
(rename-file-or-directory tmp file #t)
|
||||
(define sz (file-size file))
|
||||
(unless (= size sz)
|
||||
(eprintf "\n")
|
||||
(raise-user-error 'get-libs
|
||||
"size of ~a is ~a; doesn't match expected size ~a"
|
||||
file sz size)))
|
||||
|
||||
|
||||
(define (unpack-tgz tgz)
|
||||
(printf " unpacking...") (flush-output)
|
||||
(define-values [p pout pin perr]
|
||||
(subprocess
|
||||
(current-output-port) (current-input-port) (current-error-port)
|
||||
(find-executable-path "tar") "zxf" tgz))
|
||||
(subprocess-wait p)
|
||||
(delete-file tgz))
|
||||
|
||||
(define (install file)
|
||||
(cond [(regexp-match? #rx"[.]tgz" file) (unpack-tgz file)]
|
||||
[else (eprintf "\n")
|
||||
(raise-user-error 'get-libs "don't know how to install file: ~a"
|
||||
file)]))
|
||||
|
||||
|
||||
(define (do-download needed really-needed arch)
|
||||
(set! architecture arch)
|
||||
(printf ">> Downloading files from\n>> ~a~a\n" url-base architecture)
|
||||
(printf ">> If you don't want automatic download, download each file\n")
|
||||
(printf ">> yourself from there to\n")
|
||||
(printf ">> ~a\n" (path->complete-path (current-directory)))
|
||||
(for ([file+size (in-list needed)])
|
||||
(define file (car file+size))
|
||||
(define size (cadr file+size))
|
||||
(printf " ~a" file)
|
||||
(if (member file+size really-needed)
|
||||
(begin (printf " downloading...") (flush-output)
|
||||
(download file size)
|
||||
(when (pair? (cddr file+size))
|
||||
(delete-path (caddr file+size))
|
||||
(install file))
|
||||
(printf " done.\n"))
|
||||
(printf " already exists.\n"))))
|
||||
457
src/get-libs.rkt
457
src/get-libs.rkt
|
|
@ -1,252 +1,207 @@
|
|||
#lang racket/base
|
||||
;; This program avoids is written in #%kernel and
|
||||
;; dynamic-requires the real downloading,
|
||||
;; because it is loaded without using bytecode.
|
||||
(module get-libs '#%kernel
|
||||
(#%require '#%paramz (for-syntax '#%kernel))
|
||||
(#%provide all-files+sizes)
|
||||
|
||||
(define-values (all-files+sizes)
|
||||
;; alist mapping package to
|
||||
;; alist mapping architecture to
|
||||
;; a list of entries, each has filename and size
|
||||
;; and optionally a path that it would install to and the installed size
|
||||
(list
|
||||
;; Core Libraries
|
||||
'[core
|
||||
[win32/i386
|
||||
["iconv.dll" 892928]
|
||||
["libeay32.dll" 1089536]
|
||||
["ssleay32.dll" 237568]]
|
||||
[win32/x86_64
|
||||
["libiconv-2.dll" 1378028]
|
||||
["libeay32.dll" 1410560]
|
||||
["ssleay32.dll" 247808]]]
|
||||
;; GUI Libraries
|
||||
[list
|
||||
'gui
|
||||
'[i386-macosx
|
||||
["libcairo.2.dylib" 803196]
|
||||
["libintl.8.dylib" 57604]
|
||||
["libgio-2.0.0.dylib" 736720]
|
||||
["libjpeg.62.dylib" 412024]
|
||||
["libglib-2.0.0.dylib" 1009572]
|
||||
["libpango-1.0.0.dylib" 345476]
|
||||
["libgmodule-2.0.0.dylib" 18836]
|
||||
["libpangocairo-1.0.0.dylib" 83612]
|
||||
["libgobject-2.0.0.dylib" 284384]
|
||||
["libpixman-1.0.dylib" 526564]
|
||||
["libgthread-2.0.0.dylib" 24368]
|
||||
["libpng14.14.dylib" 182732]
|
||||
["PSMTabBarControl.tgz" 94103 "PSMTabBarControl.framework" 251764]]
|
||||
'[x86_64-macosx
|
||||
["libcairo.2.dylib" 919840]
|
||||
["libintl.8.dylib" 61016]
|
||||
["libgio-2.0.0.dylib" 897624]
|
||||
["libjpeg.62.dylib" 153360]
|
||||
["libglib-2.0.0.dylib" 1162256]
|
||||
["libpango-1.0.0.dylib" 394768]
|
||||
["libgmodule-2.0.0.dylib" 19832]
|
||||
["libpangocairo-1.0.0.dylib" 94952]
|
||||
["libgobject-2.0.0.dylib" 344024]
|
||||
["libpixman-1.0.dylib" 577128]
|
||||
["libgthread-2.0.0.dylib" 21728]
|
||||
["libpng14.14.dylib" 192224]
|
||||
["PSMTabBarControl.tgz" 107267 "PSMTabBarControl.framework" 316528]]
|
||||
'[ppc-macosx
|
||||
["libcairo.2.dylib" 2716096]
|
||||
["libintl.8.dylib" 133156]
|
||||
["libgio-2.0.0.dylib" 936176]
|
||||
["libjpeg.62.dylib" 209688]
|
||||
["libglib-2.0.0.dylib" 1242368]
|
||||
["libpango-1.0.0.dylib" 761292]
|
||||
["libgmodule-2.0.0.dylib" 19872]
|
||||
["libpangocairo-1.0.0.dylib" 199440]
|
||||
["libgobject-2.0.0.dylib" 352728]
|
||||
["libpixman-1.0.dylib" 1366816]
|
||||
["libgthread-2.0.0.dylib" 25416]
|
||||
["libpng14.14.dylib" 505920]
|
||||
["PSMTabBarControl.tgz" 96039 "PSMTabBarControl.framework" 229501]]
|
||||
(append
|
||||
'[win32/i386
|
||||
["libjpeg-7.dll" 233192]
|
||||
["libcairo-2.dll" 921369]
|
||||
["libpango-1.0-0.dll" 336626]
|
||||
["libexpat-1.dll" 143096]
|
||||
["libpng14-14.dll" 219305]
|
||||
["zlib1.dll" 55808]
|
||||
["freetype6.dll" 535264]
|
||||
["libfontconfig-1.dll" 279059]
|
||||
["libglib-2.0-0.dll" 1110713]
|
||||
["libgobject-2.0-0.dll" 316586]
|
||||
["libgmodule-2.0-0.dll" 31692]
|
||||
["libpangocairo-1.0-0.dll" 94625]
|
||||
["libpangowin32-1.0-0.dll" 102210]
|
||||
["libpangoft2-1.0-0.dll" 679322]]
|
||||
(if (getenv "PLT_WIN_GTK")
|
||||
'(["libatk-1.0-0.dll" 153763]
|
||||
["libgtk-win32-2.0-0.dll" 4740156]
|
||||
["libgdk-win32-2.0-0.dll" 827670]
|
||||
["libgdk_pixbuf-2.0-0.dll" 252150]
|
||||
["libgio-2.0-0.dll" 669318]
|
||||
["libwimp.dll" 69632]
|
||||
["gtkrc" 1181])
|
||||
'()))
|
||||
'[win32/x86_64
|
||||
["libjpeg-8.dll" 214016]
|
||||
["libcairo-2.dll" 1266147]
|
||||
["libpango-1.0-0.dll" 423199]
|
||||
["libexpat-1.dll" 263006]
|
||||
["libpng14-14.dll" 272473]
|
||||
["zlib1.dll" 191825]
|
||||
["libfreetype-6.dll" 633649]
|
||||
["libintl-8.dll" 240862]
|
||||
["libfontconfig-1.dll" 339943]
|
||||
["libglib-2.0-0.dll" 1267577]
|
||||
["libgobject-2.0-0.dll" 425888]
|
||||
["libgmodule-2.0-0.dll" 119538]
|
||||
["libgthread-2.0-0.dll" 126615]
|
||||
["libpangocairo-1.0-0.dll" 185168]
|
||||
["libpangowin32-1.0-0.dll" 192656]
|
||||
["libpangoft2-1.0-0.dll" 1188615]]]
|
||||
;; Database libraries
|
||||
'[db
|
||||
[win32/i386
|
||||
["sqlite3.dll" 570947]]
|
||||
[win32/x86_64
|
||||
["sqlite3.dll" 617472]]]))
|
||||
|
||||
(define-values [package dest-dir]
|
||||
(let-values ([(args) (vector->list (current-command-line-arguments))])
|
||||
(let-values
|
||||
([(package) (if (null? args) (error 'get-libs) (car args))])
|
||||
(let-values ([(dd)
|
||||
(if (null? (cdr args)) (current-directory) (cadr args))])
|
||||
(values (string->symbol package) dd)))))
|
||||
|
||||
(define-values (unixize)
|
||||
(lambda (p)
|
||||
(let-values ([(base name dir?) (split-path p)])
|
||||
(if (path? base)
|
||||
(string-append (unixize base) "/" (path->string name))
|
||||
(path->string name)))))
|
||||
|
||||
(define-values (architecture)
|
||||
(string->symbol (unixize (system-library-subpath #f))))
|
||||
|
||||
(define-values (needed-files+sizes)
|
||||
(lambda ()
|
||||
(define-values (l) (assq package all-files+sizes))
|
||||
(define-values (files+sizes)
|
||||
(cdr (if l
|
||||
l
|
||||
(error 'get-libs "bad package: ~s, expecting one of ~s"
|
||||
package (map car all-files+sizes)))))
|
||||
(define-values (arch) (assq architecture files+sizes))
|
||||
(if arch
|
||||
(cdr arch)
|
||||
'())))
|
||||
|
||||
(define-values (directory-size)
|
||||
(lambda (dir)
|
||||
(define-values (loop)
|
||||
(lambda (l)
|
||||
(if (null? l)
|
||||
0
|
||||
(+ (path-size (build-path dir (car l))) (loop (cdr l))))))
|
||||
(loop (directory-list dir))))
|
||||
|
||||
(define-values (path-size)
|
||||
(lambda (path)
|
||||
(if (file-exists? path) (file-size path)
|
||||
(if (directory-exists? path)
|
||||
(directory-size path)
|
||||
0))))
|
||||
|
||||
(define-values (got-path?) ; approximate, using size
|
||||
(case-lambda [(path size unpacked-path unpacked-size)
|
||||
(got-path? unpacked-path unpacked-size)]
|
||||
[(path size)
|
||||
(equal? size (path-size path))]))
|
||||
|
||||
|
||||
;; not provided by #%kernel
|
||||
(define-values (filter)
|
||||
(lambda (f l)
|
||||
(if (null? l)
|
||||
l
|
||||
(if (f (car l))
|
||||
(cons (car l) (filter f (cdr l)))
|
||||
(filter f (cdr l))))))
|
||||
|
||||
(define-syntaxes (here-dir)
|
||||
(λ (stx)
|
||||
(define-values (base name dir?) (split-path (syntax-source stx)))
|
||||
(datum->syntax (quote-syntax 'here) base)))
|
||||
|
||||
(require racket/cmdline racket/tcp)
|
||||
|
||||
;; This program avoids racket/port and net/url, because it is loaded
|
||||
;; without using bytecode.
|
||||
|
||||
(define url-host "download.racket-lang.org")
|
||||
(define url-path "/libs/4/")
|
||||
(define url-base (string-append "http://" url-host url-path))
|
||||
|
||||
(provide all-files+sizes)
|
||||
(define all-files+sizes
|
||||
;; alist mapping package to
|
||||
;; alist mapping architecture to
|
||||
;; a list of entries, each has filename and size
|
||||
;; and optionally a path that it would install to and the installed size
|
||||
`(;; Core Libraries
|
||||
[core
|
||||
[win32/i386
|
||||
["iconv.dll" 892928]
|
||||
["libeay32.dll" 1089536]
|
||||
["ssleay32.dll" 237568]]
|
||||
[win32/x86_64
|
||||
["libiconv-2.dll" 1378028]
|
||||
["libeay32.dll" 1410560]
|
||||
["ssleay32.dll" 247808]]]
|
||||
;; GUI Libraries
|
||||
[gui
|
||||
[i386-macosx
|
||||
["libcairo.2.dylib" 803196]
|
||||
["libintl.8.dylib" 57604]
|
||||
["libgio-2.0.0.dylib" 736720]
|
||||
["libjpeg.62.dylib" 412024]
|
||||
["libglib-2.0.0.dylib" 1009572]
|
||||
["libpango-1.0.0.dylib" 345476]
|
||||
["libgmodule-2.0.0.dylib" 18836]
|
||||
["libpangocairo-1.0.0.dylib" 83612]
|
||||
["libgobject-2.0.0.dylib" 284384]
|
||||
["libpixman-1.0.dylib" 526564]
|
||||
["libgthread-2.0.0.dylib" 24368]
|
||||
["libpng14.14.dylib" 182732]
|
||||
["PSMTabBarControl.tgz" 94103 "PSMTabBarControl.framework" 251764]]
|
||||
[x86_64-macosx
|
||||
["libcairo.2.dylib" 919840]
|
||||
["libintl.8.dylib" 61016]
|
||||
["libgio-2.0.0.dylib" 897624]
|
||||
["libjpeg.62.dylib" 153360]
|
||||
["libglib-2.0.0.dylib" 1162256]
|
||||
["libpango-1.0.0.dylib" 394768]
|
||||
["libgmodule-2.0.0.dylib" 19832]
|
||||
["libpangocairo-1.0.0.dylib" 94952]
|
||||
["libgobject-2.0.0.dylib" 344024]
|
||||
["libpixman-1.0.dylib" 577128]
|
||||
["libgthread-2.0.0.dylib" 21728]
|
||||
["libpng14.14.dylib" 192224]
|
||||
["PSMTabBarControl.tgz" 107267 "PSMTabBarControl.framework" 316528]]
|
||||
[ppc-macosx
|
||||
["libcairo.2.dylib" 2716096]
|
||||
["libintl.8.dylib" 133156]
|
||||
["libgio-2.0.0.dylib" 936176]
|
||||
["libjpeg.62.dylib" 209688]
|
||||
["libglib-2.0.0.dylib" 1242368]
|
||||
["libpango-1.0.0.dylib" 761292]
|
||||
["libgmodule-2.0.0.dylib" 19872]
|
||||
["libpangocairo-1.0.0.dylib" 199440]
|
||||
["libgobject-2.0.0.dylib" 352728]
|
||||
["libpixman-1.0.dylib" 1366816]
|
||||
["libgthread-2.0.0.dylib" 25416]
|
||||
["libpng14.14.dylib" 505920]
|
||||
["PSMTabBarControl.tgz" 96039 "PSMTabBarControl.framework" 229501]]
|
||||
[win32/i386
|
||||
["libjpeg-7.dll" 233192]
|
||||
["libcairo-2.dll" 921369]
|
||||
["libpango-1.0-0.dll" 336626]
|
||||
["libexpat-1.dll" 143096]
|
||||
["libpng14-14.dll" 219305]
|
||||
["zlib1.dll" 55808]
|
||||
["freetype6.dll" 535264]
|
||||
["libfontconfig-1.dll" 279059]
|
||||
["libglib-2.0-0.dll" 1110713]
|
||||
["libgobject-2.0-0.dll" 316586]
|
||||
["libgmodule-2.0-0.dll" 31692]
|
||||
["libpangocairo-1.0-0.dll" 94625]
|
||||
["libpangowin32-1.0-0.dll" 102210]
|
||||
["libpangoft2-1.0-0.dll" 679322]
|
||||
,@(if (getenv "PLT_WIN_GTK")
|
||||
'(["libatk-1.0-0.dll" 153763]
|
||||
["libgtk-win32-2.0-0.dll" 4740156]
|
||||
["libgdk-win32-2.0-0.dll" 827670]
|
||||
["libgdk_pixbuf-2.0-0.dll" 252150]
|
||||
["libgio-2.0-0.dll" 669318]
|
||||
["libwimp.dll" 69632]
|
||||
["gtkrc" 1181])
|
||||
'())]
|
||||
[win32/x86_64
|
||||
["libjpeg-8.dll" 214016]
|
||||
["libcairo-2.dll" 1266147]
|
||||
["libpango-1.0-0.dll" 423199]
|
||||
["libexpat-1.dll" 263006]
|
||||
["libpng14-14.dll" 272473]
|
||||
["zlib1.dll" 191825]
|
||||
["libfreetype-6.dll" 633649]
|
||||
["libintl-8.dll" 240862]
|
||||
["libfontconfig-1.dll" 339943]
|
||||
["libglib-2.0-0.dll" 1267577]
|
||||
["libgobject-2.0-0.dll" 425888]
|
||||
["libgmodule-2.0-0.dll" 119538]
|
||||
["libgthread-2.0-0.dll" 126615]
|
||||
["libpangocairo-1.0-0.dll" 185168]
|
||||
["libpangowin32-1.0-0.dll" 192656]
|
||||
["libpangoft2-1.0-0.dll" 1188615]]]
|
||||
;; Database libraries
|
||||
[db
|
||||
[win32/i386
|
||||
["sqlite3.dll" 570947]]
|
||||
[win32/x86_64
|
||||
["sqlite3.dll" 617472]]]))
|
||||
|
||||
(define-values [package dest-dir]
|
||||
(command-line #:args [package [dest-dir (current-directory)]]
|
||||
(values (string->symbol package) dest-dir)))
|
||||
|
||||
(define (unixize p)
|
||||
(let-values ([(base name dir?) (split-path p)])
|
||||
(if (path? base)
|
||||
(string-append (unixize base) "/" (path->string name))
|
||||
(path->string name))))
|
||||
|
||||
(define architecture (string->symbol (unixize (system-library-subpath #f))))
|
||||
|
||||
(define (needed-files+sizes)
|
||||
(let ([files+sizes
|
||||
(cdr (or (assq package all-files+sizes)
|
||||
(error 'get-libs "bad package: ~s, expecting one of ~s"
|
||||
package (map car all-files+sizes))))])
|
||||
(cond [(assq architecture files+sizes) => cdr]
|
||||
[else '()])))
|
||||
|
||||
(define (purify-port port)
|
||||
(let ([m (regexp-match-peek-positions #rx#"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)"
|
||||
port)])
|
||||
(if m (read-bytes (cdar m) port) "")))
|
||||
|
||||
(define (copy-port src dest)
|
||||
(let ([s (make-bytes 4096)])
|
||||
(let loop ()
|
||||
(let ([c (read-bytes-avail! s src)])
|
||||
(cond [(number? c)
|
||||
(let loop ([start 0])
|
||||
(unless (= start c)
|
||||
(let ([c2 (write-bytes-avail s dest start c)])
|
||||
(loop (+ start c2)))))
|
||||
(loop)]
|
||||
;; Must be EOF
|
||||
[else (void)])))))
|
||||
|
||||
(define (download* file target)
|
||||
(define src (format "~a~a/~a" url-path architecture file))
|
||||
(define-values [i o] (tcp-connect url-host 80))
|
||||
(fprintf o "GET ~a HTTP/1.0\r\nHost: ~a\r\n\r\n" src url-host)
|
||||
(flush-output o) (tcp-abandon-port o)
|
||||
(purify-port i)
|
||||
(call-with-output-file target #:exists 'truncate/replace
|
||||
(λ (out) (copy-port i out))))
|
||||
|
||||
(define (download file size)
|
||||
(define tmp (format "~a.download" file))
|
||||
(let loop ([n 0])
|
||||
(when (> n 0) (printf " retry #~a," n) (flush-output))
|
||||
(define thd (thread (λ () (download* file tmp))))
|
||||
(unless (sync/timeout (+ 10 (* 5 n)) thd)
|
||||
(kill-thread thd)
|
||||
(when (> n 3) (raise-user-error 'download "could not retrieve ~a" file))
|
||||
(when (zero? n) (printf " timeout,"))
|
||||
(loop (add1 n))))
|
||||
(rename-file-or-directory tmp file #t)
|
||||
(define sz (file-size file))
|
||||
(unless (= size sz)
|
||||
(eprintf "\n")
|
||||
(raise-user-error 'get-libs
|
||||
"size of ~a is ~a; doesn't match expected size ~a"
|
||||
file sz size)))
|
||||
|
||||
(define (unpack-tgz tgz)
|
||||
(printf " unpacking...") (flush-output)
|
||||
(define-values [p pout pin perr]
|
||||
(subprocess
|
||||
(current-output-port) (current-input-port) (current-error-port)
|
||||
(find-executable-path "tar") "zxf" tgz))
|
||||
(subprocess-wait p)
|
||||
(delete-file tgz))
|
||||
|
||||
(define (install file)
|
||||
(cond [(regexp-match? #rx"[.]tgz" file) (unpack-tgz file)]
|
||||
[else (eprintf "\n")
|
||||
(raise-user-error 'get-libs "don't know how to install file: ~a"
|
||||
file)]))
|
||||
|
||||
(define (delete-path path)
|
||||
(cond [(directory-exists? path)
|
||||
(parameterize ([current-directory path])
|
||||
(for-each delete-path (directory-list)))
|
||||
(delete-directory path)]
|
||||
[(or (file-exists? path) (link-exists? path)) (delete-file path)]))
|
||||
|
||||
(define (directory-size dir)
|
||||
(parameterize ([current-directory dir])
|
||||
(for/fold ([sum 0]) ([path (in-list (directory-list))])
|
||||
(+ sum (path-size path)))))
|
||||
|
||||
(define (path-size path)
|
||||
(cond [(file-exists? path) (file-size path)]
|
||||
[(directory-exists? path) (directory-size path)]
|
||||
[else 0]))
|
||||
|
||||
(define got-path? ; approximate, using size
|
||||
(case-lambda [(path size unpacked-path unpacked-size)
|
||||
(got-path? unpacked-path unpacked-size)]
|
||||
[(path size)
|
||||
(equal? size (path-size path))]))
|
||||
|
||||
(unless (eq? package 'nothing)
|
||||
(unless (directory-exists? dest-dir) (make-directory dest-dir))
|
||||
(parameterize ([current-directory dest-dir])
|
||||
(define needed (needed-files+sizes))
|
||||
(define really-needed (filter (λ (n) (not (apply got-path? n))) needed))
|
||||
(printf (if (null? needed)
|
||||
">> No ~a libraries to download for ~a\n"
|
||||
">> Getting ~a libraries for ~a\n")
|
||||
package architecture)
|
||||
(cond
|
||||
[(null? needed) (void)]
|
||||
[(null? really-needed)
|
||||
(printf ">> All files present, no downloads needed.\n")]
|
||||
[else
|
||||
(printf ">> Downloading files from\n>> ~a~a\n" url-base architecture)
|
||||
(printf ">> If you don't want automatic download, download each file\n")
|
||||
(printf ">> yourself from there to\n")
|
||||
(printf ">> ~a\n" (path->complete-path (current-directory)))
|
||||
(for ([file+size (in-list needed)])
|
||||
(define file (car file+size))
|
||||
(define size (cadr file+size))
|
||||
(printf " ~a" file)
|
||||
(if (member file+size really-needed)
|
||||
(begin (printf " downloading...") (flush-output)
|
||||
(download file size)
|
||||
(when (pair? (cddr file+size))
|
||||
(delete-path (caddr file+size))
|
||||
(install file))
|
||||
(printf " done.\n"))
|
||||
(printf " already exists.\n")))])))
|
||||
(if (eq? package 'nothing)
|
||||
(void)
|
||||
(begin
|
||||
(if (directory-exists? dest-dir) (void) (make-directory dest-dir))
|
||||
(with-continuation-mark parameterization-key
|
||||
(extend-parameterization
|
||||
(continuation-mark-set-first #f parameterization-key)
|
||||
current-directory dest-dir)
|
||||
(let-values ()
|
||||
(define-values (needed) (needed-files+sizes))
|
||||
(define-values (really-needed)
|
||||
(filter (λ (n) (not (apply got-path? n))) needed))
|
||||
(printf (if (null? needed)
|
||||
">> No ~a libraries to download for ~a\n"
|
||||
">> Getting ~a libraries for ~a\n")
|
||||
package architecture)
|
||||
(if (null? needed)
|
||||
(void)
|
||||
(if (null? really-needed)
|
||||
(printf ">> All files present, no downloads needed.\n")
|
||||
((dynamic-require (build-path here-dir "download-libs.rkt") 'do-download)
|
||||
needed really-needed architecture))))))))
|
||||
|
|
@ -2,23 +2,24 @@
|
|||
;; This module is executed by the install process to update
|
||||
;; the embedded path to "collects" in an executable.
|
||||
|
||||
(module collects-path mzscheme
|
||||
|
||||
(define label "coLLECTs dIRECTORy:")
|
||||
|
||||
(let ([dest (vector-ref (current-command-line-arguments) 0)]
|
||||
[path (vector-ref (current-command-line-arguments) 1)])
|
||||
;; written in #%kernel because it's loaded with -c (ie, no compiled files)
|
||||
(module collects-path '#%kernel
|
||||
(define-values (label) #rx#"coLLECTs dIRECTORy:")
|
||||
|
||||
(let-values ([(dest) (vector-ref (current-command-line-arguments) 0)]
|
||||
[(path) (vector-ref (current-command-line-arguments) 1)])
|
||||
(let-values ([(i o) (open-input-output-file dest 'update)])
|
||||
(let ([m (regexp-match-positions label i)]
|
||||
[path (if (string? path)
|
||||
(string->path path)
|
||||
path)])
|
||||
(unless m
|
||||
(error 'set-collects-path
|
||||
"cannot find collection-path label in executable file"))
|
||||
(file-position o (cdar m))
|
||||
(write-bytes (path->bytes path) o)
|
||||
(write-byte 0 o)
|
||||
(write-byte 0 o)
|
||||
(close-input-port i)
|
||||
(close-output-port o)))))
|
||||
(let-values ([(m) (regexp-match-positions label i)]
|
||||
[(path) (if (string? path)
|
||||
(string->path path)
|
||||
path)])
|
||||
(if m
|
||||
(void)
|
||||
(error 'set-collects-path
|
||||
"cannot find collection-path label in executable file"))
|
||||
(file-position o (cdar m))
|
||||
(write-bytes (path->bytes path) o)
|
||||
(write-byte 0 o)
|
||||
(write-byte 0 o)
|
||||
(close-input-port i)
|
||||
(close-output-port o)))))
|
||||
|
|
|
|||
|
|
@ -5,59 +5,73 @@
|
|||
;; 2. The location of the src/mzscheme directory,
|
||||
;; 3. The location of mzconfig.
|
||||
|
||||
#lang scheme/base
|
||||
;; written in #%kernel because it's loaded with -c (ie, no compiled files)
|
||||
|
||||
(define-values (incdir mzsrcdir mzconfdir)
|
||||
(let ([args (vector->list (current-command-line-arguments))])
|
||||
(define (dir path) (normal-case-path (simplify-path (cleanse-path path))))
|
||||
(unless (= 3 (length args)) (error 'mkincludes "bad arguments"))
|
||||
(apply values (map dir args))))
|
||||
|
||||
(printf "Making ~a\n" incdir)
|
||||
|
||||
(define ((change-regexp from to) src dst)
|
||||
(call-with-input-file src
|
||||
(lambda (src)
|
||||
(call-with-output-file dst
|
||||
(lambda (dst)
|
||||
(when (regexp-match from src 0 #f dst)
|
||||
(display to dst)
|
||||
(regexp-match "$" src 0 #f dst))))))
|
||||
(void))
|
||||
|
||||
(define (copy-if-newer basedir source-path [base #f] [copy copy-file])
|
||||
(define source (build-path basedir source-path))
|
||||
(define target
|
||||
(build-path incdir
|
||||
(or base
|
||||
(let-values ([(_1 name _2) (split-path source)]) name))))
|
||||
(define source-t (file-or-directory-modify-seconds source))
|
||||
(define target-t (and (file-exists? target)
|
||||
(file-or-directory-modify-seconds target)))
|
||||
(cond
|
||||
[(not target-t) (copy source target)]
|
||||
[(< target-t source-t) (delete-file target) (copy source target)]))
|
||||
|
||||
(unless (directory-exists? incdir) (make-directory incdir))
|
||||
(copy-if-newer mzconfdir "mzconfig.h")
|
||||
(copy-if-newer mzsrcdir "sconfig.h")
|
||||
(copy-if-newer mzsrcdir "uconfig.h")
|
||||
(copy-if-newer mzsrcdir "include/escheme.h")
|
||||
(copy-if-newer mzsrcdir "include/scheme.h" #f
|
||||
(change-regexp "/[*]III[*]/"
|
||||
"#define INCLUDE_WITHOUT_PATHS"))
|
||||
(copy-if-newer mzsrcdir "include/schthread.h")
|
||||
(copy-if-newer mzsrcdir "src/schemef.h")
|
||||
(copy-if-newer mzsrcdir "src/schvers.h")
|
||||
(copy-if-newer mzsrcdir "src/stypes.h")
|
||||
(copy-if-newer mzsrcdir "src/schemex.h")
|
||||
(copy-if-newer mzsrcdir "src/schemexm.h")
|
||||
(copy-if-newer mzsrcdir "src/schexn.h")
|
||||
(copy-if-newer mzsrcdir "include/ext.exp")
|
||||
(copy-if-newer mzsrcdir "include/mzscheme.exp")
|
||||
(copy-if-newer mzsrcdir "include/mzscheme3m.exp")
|
||||
(copy-if-newer mzsrcdir "gc2/gc2.h" "schemegc2.h")
|
||||
(copy-if-newer mzsrcdir "gc2/gc2.h" "schemegc2.h")
|
||||
(copy-if-newer mzsrcdir "gc2/gc2_obj.h" "schgc2obj.h")
|
||||
|
||||
(printf "Done.\n")
|
||||
(module mkincludes '#%kernel
|
||||
(#%require '#%utils)
|
||||
|
||||
(define-values (incdir mzsrcdir mzconfdir)
|
||||
(let-values ([(args) (vector->list (current-command-line-arguments))])
|
||||
(define-values (dir) (lambda (path) (normal-case-path (simplify-path (cleanse-path path)))))
|
||||
(if (= 3 (length args)) (void) (error 'mkincludes "bad arguments"))
|
||||
(apply values (map dir args))))
|
||||
|
||||
(printf "Making ~a\n" incdir)
|
||||
|
||||
(define-values (change-regexp)
|
||||
(lambda (from to)
|
||||
(lambda (src dst)
|
||||
(call-with-input-file src
|
||||
(lambda (src)
|
||||
(call-with-output-file dst
|
||||
(lambda (dst)
|
||||
(if (regexp-match from src 0 #f dst)
|
||||
(begin (display to dst)
|
||||
(regexp-match "$" src 0 #f dst))
|
||||
(void))))))
|
||||
(void))))
|
||||
|
||||
(define-values (copy-if-newer)
|
||||
(case-lambda
|
||||
[(basedir source-path) (copy-if-newer basedir source-path #f copy-file)]
|
||||
[(basedir source-path base) (copy-if-newer basedir source-path base copy-file)]
|
||||
[(basedir source-path base copy)
|
||||
(define-values (source) (build-path basedir source-path))
|
||||
(define-values (target)
|
||||
(build-path incdir
|
||||
(if base
|
||||
base
|
||||
(let-values ([(_1 name _2) (split-path source)]) name))))
|
||||
(define-values (source-t) (file-or-directory-modify-seconds source))
|
||||
(define-values (target-t) (if (file-exists? target)
|
||||
(file-or-directory-modify-seconds target)
|
||||
#f))
|
||||
(if (not target-t)
|
||||
(copy source target)
|
||||
(if (< target-t source-t)
|
||||
(begin (delete-file target) (copy source target))
|
||||
(void)))]))
|
||||
|
||||
(if (directory-exists? incdir) (void) (make-directory incdir))
|
||||
(copy-if-newer mzconfdir "mzconfig.h")
|
||||
(copy-if-newer mzsrcdir "sconfig.h")
|
||||
(copy-if-newer mzsrcdir "uconfig.h")
|
||||
(copy-if-newer mzsrcdir "include/escheme.h")
|
||||
(copy-if-newer mzsrcdir "include/scheme.h" #f
|
||||
(change-regexp "/[*]III[*]/"
|
||||
"#define INCLUDE_WITHOUT_PATHS"))
|
||||
(copy-if-newer mzsrcdir "include/schthread.h")
|
||||
(copy-if-newer mzsrcdir "src/schemef.h")
|
||||
(copy-if-newer mzsrcdir "src/schvers.h")
|
||||
(copy-if-newer mzsrcdir "src/stypes.h")
|
||||
(copy-if-newer mzsrcdir "src/schemex.h")
|
||||
(copy-if-newer mzsrcdir "src/schemexm.h")
|
||||
(copy-if-newer mzsrcdir "src/schexn.h")
|
||||
(copy-if-newer mzsrcdir "include/ext.exp")
|
||||
(copy-if-newer mzsrcdir "include/mzscheme.exp")
|
||||
(copy-if-newer mzsrcdir "include/mzscheme3m.exp")
|
||||
(copy-if-newer mzsrcdir "gc2/gc2.h" "schemegc2.h")
|
||||
(copy-if-newer mzsrcdir "gc2/gc2.h" "schemegc2.h")
|
||||
(copy-if-newer mzsrcdir "gc2/gc2_obj.h" "schgc2obj.h")
|
||||
|
||||
(printf "Done.\n"))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user