suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

mzscheme -> scheme

Browse Source 
svn: r16240
This commit is contained in:
Eli Barzilay 2009-10-05 04:36:22 +00:00
parent b0e8fac1f8
commit e499c32435
1 changed files with 66 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

136
collects/setup/winvers-change.ss
View File

@ -8,79 +8,75 @@
;; running MzScheme.exe on Windows -- "winvers.ss" uses a trick of making a ;; running MzScheme.exe on Windows -- "winvers.ss" uses a trick of making a
;; copy of the binary and restarting that copy for the actual change. ;; copy of the binary and restarting that copy for the actual change.
(module winvers-change mzscheme #lang scheme
(define verbose? #t) (define verbose? #t)
(define binary-extensions '("exe" "dll" "lib" "so" "def" "exp" #|"obj" "o"|#)) (define binary-extensions '("exe" "dll" "lib" "so" "def" "exp" #|"obj" "o"|#))
(define xxxs #"xxxxxxx") (define xxxs #"xxxxxxx")
(define xxxs-re (define xxxs-re
(bytes-append #"(?:lib(?:mzsch|mzgc|mred)(?:|3m))(" xxxs #")")) (bytes-append #"(?:lib(?:mzsch|mzgc|mred)(?:|3m))(" xxxs #")"))
(define renaming (regexp (format "^~a[.](?:dll|lib|exp)$" xxxs-re))) (define renaming (regexp (format "^~a[.](?:dll|lib|exp)$" xxxs-re)))
(define substitutions (define substitutions
(map (lambda (s) (byte-regexp (regexp-replace #rx#"~a" s xxxs-re))) (map (lambda (s) (byte-regexp (regexp-replace #rx#"~a" s xxxs-re)))
;; pdb not needed, but this way we can expect no ;; pdb not needed, but this way we can expect no
;; `xxxxxxx's when we finish. ;; `xxxxxxx's when we finish.
'(#"~a[.](?:dll|lib|exp|pdb)" '(#"~a[.](?:dll|lib|exp|pdb)"
#"~a_NULL_THUNK_DATA\0" #"~a_NULL_THUNK_DATA\0"
#"__IMPORT_DESCRIPTOR_~a\0" #"__IMPORT_DESCRIPTOR_~a\0"
#"__head_~a_lib\0" #"__head_~a_lib\0"
#"__~a_lib_iname\0"))) #"__~a_lib_iname\0")))
(require dynext/filename-version) (require dynext/filename-version)
(define version-bytes (string->bytes/utf-8 filename-version-part)) (define version-bytes (string->bytes/utf-8 filename-version-part))
(define (binary-file? filename) (define (binary-file? filename)
(cond [(regexp-match #rx"[.]([^.]+)$" filename) => (cond [(regexp-match #rx"[.]([^.]+)$" filename) =>
(lambda (m) (member (string-downcase (cadr m)) binary-extensions))] (lambda (m) (member (string-downcase (cadr m)) binary-extensions))]
[else #f])) [else #f]))
(define (do-file file) (define (do-file file)
(define (full-path) ; proc since `file' can change (define (full-path) ; proc since `file' can change
(build-path (current-directory) file)) (build-path (current-directory) file))
(let ([dfile (string-downcase file)]) (let ([dfile (string-downcase file)])
(cond [(regexp-match-positions renaming dfile) => (cond [(regexp-match-positions renaming dfile) =>
(lambda (m) (lambda (m)
(let ([new (string-append (substring dfile 0 (caadr m)) (let ([new (string-append (substring dfile 0 (caadr m))
filename-version-part filename-version-part
(substring dfile (cdadr m)))]) (substring dfile (cdadr m)))])
(when verbose? (printf "Renaming: ~a -> ~a\n" (full-path) new)) (when verbose? (printf "Renaming: ~a -> ~a\n" (full-path) new))
(rename-file-or-directory file new) (rename-file-or-directory file new)
(set! file new)))] (set! file new)))]
[(regexp-match-positions xxxs dfile) [(regexp-match-positions xxxs dfile)
(fprintf (current-error-port) (fprintf (current-error-port)
"Warning: ~a was not renamed!\n" (full-path))])) "Warning: ~a was not renamed!\n" (full-path))]))
(let-values ([(i o) (open-input-output-file file 'update)]) (let-values ([(i o) (open-input-output-file file 'update)])
(define print? verbose?) (define print? verbose?)
(for-each (lambda (subst) (for ([subst (in-list substitutions)])
(file-position i 0)
(let loop ([pos 0])
(cond [(regexp-match-positions subst i) =>
(lambda (m)
(when print?
(printf "Changing: ~a\n" (full-path))
(set! print? #f))
(file-position o (+ pos (caadr m)))
(write-bytes version-bytes o)
(flush-output o)
(file-position i (+ pos (cdar m)))
(loop (+ pos (cdar m))))])))
substitutions)
(file-position i 0) (file-position i 0)
(when (regexp-match-positions xxxs i) (let loop ([pos 0])
(fprintf (current-error-port) (cond [(regexp-match-positions subst i) =>
"Warning: ~a still has \"~a\"!\n" (full-path) xxxs)) (lambda (m)
(close-input-port i) (when print?
(close-output-port o))) (printf "Changing: ~a\n" (full-path))
(set! print? #f))
(file-position o (+ pos (caadr m)))
(write-bytes version-bytes o)
(flush-output o)
(file-position i (+ pos (cdar m)))
(loop (+ pos (cdar m))))])))
(file-position i 0)
(when (regexp-match-positions xxxs i)
(fprintf (current-error-port)
"Warning: ~a still has \"~a\"!\n" (full-path) xxxs))
(close-input-port i)
(close-output-port o)))
(let loop ([paths (if (zero? (vector-length (current-command-line-arguments))) (let loop ([paths (if (zero? (vector-length (current-command-line-arguments)))
'(".") '(".")
(vector->list (current-command-line-arguments)))]) (vector->list (current-command-line-arguments)))])
(for-each (lambda (path) (for ([path (in-list paths)])
(cond [(file-exists? path) (cond [(file-exists? path)
(when (binary-file? path) (do-file path))] (when (binary-file? path) (do-file path))]
[(directory-exists? path) [(directory-exists? path)
(parameterize ([current-directory path]) (parameterize ([current-directory path])
(loop (map path->string (directory-list))))])) (loop (map path->string (directory-list))))])))
paths))
)