201 lines
8.1 KiB
Scheme
Executable File
201 lines
8.1 KiB
Scheme
Executable File
#!/bin/sh
|
|
#| -*- scheme -*-
|
|
exec racket "$0"
|
|
|
|
Instructions:
|
|
|
|
* Create a copy of a distributed PLT tree, change all files that need to change
|
|
for the patch. If this is not a first patch, then begin this process with a
|
|
tree that has the previous patch applied. (Patch numbers should go from 1
|
|
up.)
|
|
|
|
I do this:
|
|
cd ...git-repo...
|
|
git checkout -b patch <PREV-VER-OR-PATCH> patched
|
|
git cherry-pick fix-sha1s...
|
|
... more merges as needed ...
|
|
And at the end don't forget to drop a new tag for the patched result.
|
|
|
|
* Make sure that "collects/version/patchlevel.ss" contains the new patch
|
|
number, and add comments about this patch, with a list of files that are
|
|
modified. (This is good for the next step, when doing additional patches.)
|
|
|
|
* In the code below,
|
|
- set `plt-version' to the version you're patching (base version, the code
|
|
will expect `(version)' to return an equal value).
|
|
- set `plt-base' to the location of the patched PLT tree on your system.
|
|
- put the list of files in the `files' definition. Each patch should also
|
|
have all preceding patches in it, which means that if you're patching an
|
|
already-patched tree, then you should add more files. (This is why it is
|
|
good to keep track of the modified files.) Note that
|
|
"collects/version/patchlevel.ss" must be included in this list, and that
|
|
the file does have the correct patchlevel number (there is currently no way
|
|
to check whether the patchlevel makes sense).
|
|
|
|
* Note that the patch is a collection with the same name ("plt-patch" below).
|
|
This means that installing a patch is a process that first overwrites any
|
|
preexisting patch collections. This is fine, because patches are linear and
|
|
cumulative. The worst that can happen is that someone downloads a patch
|
|
older than what's installed -- in that case the PLT tree already has the
|
|
higher patch level, and when the collection's installer is doing its work it
|
|
will simply be skipped (a successful patch installation happens only once,
|
|
and is later skipped when setup-plt is re-run).
|
|
|
|
* Test, put in "iplt/web/download/patches/", publish new html, announce.
|
|
|
|
* Commit the patched tree as a new tag.
|
|
|
|
|#
|
|
|
|
#lang mzscheme
|
|
|
|
;; ============================================================================
|
|
;; customization (items marked with `[*]' should be edited for all patches)
|
|
|
|
;; [*] which PLT version is this patch for?
|
|
(define plt-version "370")
|
|
|
|
;; [*] location of a patched PLT tree
|
|
(define plt-base "~/patched")
|
|
|
|
;; [*] patched files in this tree (including previously patched files, if any)
|
|
(define files '("collects/version/patchlevel.ss"
|
|
"collects/drscheme/private/module-language.ss"
|
|
"collects/framework/private/scheme.ss"
|
|
"collects/slideshow/tool.ss"
|
|
"collects/lang/htdp-langs.ss"
|
|
"collects/drscheme/private/unit.ss"))
|
|
|
|
;; message to show after the last `Done' (#f => no extra text)
|
|
(define exit-message "please restart DrScheme")
|
|
|
|
;; template for the output archive file
|
|
(define patchfile-template "/tmp/plt-patch-v~ap~a.plt")
|
|
|
|
;; template for archive name
|
|
(define name-template "PLT Scheme v~ap~a patch")
|
|
|
|
;; patchlevel file in the PLT tree (must be included in `files' above)
|
|
(define patchlevel-file "collects/version/patchlevel.ss")
|
|
|
|
;; ============================================================================
|
|
;; code folows
|
|
|
|
(require (lib "list.ss") (lib "pack.ss" "setup"))
|
|
|
|
;; move patchlevel file to the end
|
|
(unless (member patchlevel-file files)
|
|
(error 'make-patch
|
|
"missing patchlevel file (~a) in the list of files" patchlevel-file))
|
|
(set! files (append (remove patchlevel-file files) (list patchlevel-file)))
|
|
|
|
(unless (absolute-path? plt-base)
|
|
(error 'make-patch "plt-base is not an absolute path: ~a" plt-base))
|
|
|
|
(define patchlevel
|
|
;; use `dynamic-require' -- not `require' since the patch can be built by a
|
|
;; different PLT installation
|
|
(dynamic-require (build-path plt-base patchlevel-file) 'patchlevel))
|
|
(define archive-name (format name-template plt-version patchlevel))
|
|
(define archive-filename (format patchfile-template plt-version patchlevel))
|
|
|
|
(define unpacker-body
|
|
`((define me ,(format "v~ap~a-patch" plt-version patchlevel))
|
|
(define (error* fmt . args)
|
|
(error (string-append "ERROR applying "me": " (apply format fmt args))))
|
|
(define (message fmt . args)
|
|
(printf "*** ~a: ~a\n" me (apply format fmt args)))
|
|
(define collects-dir (find-collects-dir))
|
|
(cond
|
|
[(not (equal? ,plt-version (version)))
|
|
(error* "bad version number; this patch is for version ~a, you have ~a"
|
|
',plt-version (version))]
|
|
[(= patchlevel ,patchlevel) (error* "Already installed")]
|
|
[(> patchlevel ,patchlevel) (error* "Newer patch installed")]
|
|
[else (message "Applying patch...")])
|
|
(mzuntar void)
|
|
(message "Patch applied successfully, recompiling...")
|
|
;; return a list of all toplevel collections to recompile
|
|
;; (define (has-info? c)
|
|
;; (file-exists? (build-path collects-dir c "info.ss")))
|
|
;; (let* ([cs (directory-list collects-dir)]
|
|
;; [cs (filter has-info? cs)]
|
|
;; [cs (map path->string cs)]
|
|
;; [cs (sort cs string<?)]
|
|
;; [cs (map list cs)])
|
|
;; cs)
|
|
;; instead of the above, invoke setup-plt directly to avoid installers
|
|
;; (otherwise, running this .plt from DrScheme on Windows complains about
|
|
;; not being able to recreate the executable)
|
|
(let ([x 0])
|
|
(parameterize ([exit-handler (lambda (n) (set! x n))])
|
|
(run-setup))
|
|
(message ,(if exit-message (format "Done, ~a." exit-message) "Done."))
|
|
(exit x))
|
|
;; everything below does not matter since we exit above
|
|
;; (but just in case, return '() so no collections to recompile)
|
|
'()))
|
|
|
|
(define run-setup
|
|
;; This code is based on setup-go
|
|
`(module run-setup mzscheme
|
|
(require (lib "unit.ss") (lib "option-sig.ss" "setup")
|
|
(lib "option-unit.ss" "setup") (lib "cm.ss"))
|
|
(define-values/invoke-unit/infer setup:option@)
|
|
;; settings
|
|
(clean #f) ; no cleaning
|
|
(make-zo #t) ; recompile zos
|
|
(call-install #f) ; no installers
|
|
(make-launchers #f) ; no launcher recreation
|
|
(make-so #f) ; no extension compilation
|
|
(verbose #f) ; be quiet
|
|
(make-verbose #f) ; be quiet
|
|
(trust-existing-zos #f) ; recompile files when needed
|
|
(pause-on-errors #f) ; no interactions
|
|
(force-unpacks #f) ; not doing any unpacking
|
|
(compile-mode #f) ; default compilation
|
|
;; not unpacking, but just in case, make it go into the PLT tree
|
|
(current-target-plt-directory-getter
|
|
(lambda (preferred main-collects-parent-dir choices)
|
|
main-collects-parent-dir))
|
|
(specific-collections '()) ; no specifics, do all collections
|
|
(archives '()) ; no archives to unpack
|
|
(specific-planet-dirs '()) ; no planet stuff
|
|
;; invoke it
|
|
(require (lib "setup-unit.ss" "setup")
|
|
(lib "option-unit.ss" "compiler")
|
|
(lib "compiler-unit.ss" "compiler")
|
|
(lib "launcher-unit.ss" "launcher")
|
|
(lib "dynext-unit.ss" "dynext"))
|
|
(provide run-setup)
|
|
(define (run-setup)
|
|
(invoke-unit (compound-unit/infer (import setup-option^) (export)
|
|
(link launcher@ dynext:compile@ dynext:link@ dynext:file@
|
|
compiler:option@ compiler@ setup@))
|
|
(import setup-option^)))))
|
|
|
|
(define unpack-unit
|
|
`(begin (require (lib "list.ss")
|
|
(lib "patchlevel.ss" "version")
|
|
(lib "dirs.ss" "setup"))
|
|
,run-setup
|
|
(require run-setup)
|
|
(unit (import main-collects-parent-dir mzuntar) (export)
|
|
,@unpacker-body)))
|
|
|
|
;; Pack up a .plt file
|
|
|
|
(current-directory plt-base)
|
|
|
|
(when (file-exists? archive-filename) (delete-file archive-filename))
|
|
|
|
(pack-plt archive-filename
|
|
archive-name
|
|
files
|
|
#:requires `((("racket") ()) (("gracket") ()))
|
|
#:file-mode 'file-replace
|
|
#:plt-relative? #t
|
|
#:at-plt-home? #t
|
|
#:unpack-unit unpack-unit)
|
|
(printf "Patch file created: ~a\n" archive-filename)
|