remove obsolte build support
Much of the old build support turned into "distro-build" for package-based builds, and the "build" directory hasn't been used for a year or so.
This commit is contained in:
Matthew Flatt
parent
0d25969ff0
commit
6621e48b86
File diff suppressed because it is too large
Load Diff
|
|
@ -1,525 +0,0 @@
|
||||||
#!/bin/env racket
|
|
||||||
;; -*- scheme -*-
|
|
||||||
|
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/cmdline racket/runtime-path racket/match racket/promise
|
|
||||||
racket/list ; for use in specs too
|
|
||||||
racket/string
|
|
||||||
racket/file (only-in racket/system system)
|
|
||||||
(except-in compatibility/mlist mappend)
|
|
||||||
meta/checker (prefix-in dist: meta/dist-specs) meta/specs)
|
|
||||||
|
|
||||||
(define (/-ify x)
|
|
||||||
(regexp-replace #rx"/?$" (if (path? x) (path->string x) x) "/"))
|
|
||||||
(define home/ (/-ify (expand-user-path "~scheme")))
|
|
||||||
(define binaries/ (/-ify (build-path home/ "binaries")))
|
|
||||||
(define target/ (/-ify (build-path home/ "pre-installers")))
|
|
||||||
(define racket/ (/-ify (or (getenv "PLTHOME")
|
|
||||||
(error 'bundle "PLTHOME is not defined"))))
|
|
||||||
(define racket-base/ (/-ify (simplify-path (build-path racket/ 'up) #f)))
|
|
||||||
(define racket/-name (let-values ([(base name dir?) (split-path racket/)])
|
|
||||||
(path-element->string name)))
|
|
||||||
|
|
||||||
(define cd current-directory)
|
|
||||||
|
|
||||||
(define *readme-file*
|
|
||||||
(build-path racket/ "README"))
|
|
||||||
(define *info-domain-file*
|
|
||||||
(build-path racket/ "collects" "info-domain" "compiled" "cache.rktd"))
|
|
||||||
|
|
||||||
(define *readme-cache* #f)
|
|
||||||
(define *info-domain-cache* #f)
|
|
||||||
|
|
||||||
(define-runtime-path *spec-file* "distribution-specs")
|
|
||||||
|
|
||||||
(define *verify?* #t)
|
|
||||||
(define *btgz?* #t)
|
|
||||||
(define *pack?* #t)
|
|
||||||
(define *release?* #f)
|
|
||||||
(define *verbose?* 'yes) ; #t, #f, or else -- show stderr stuff but not stdout
|
|
||||||
|
|
||||||
;;; ===========================================================================
|
|
||||||
;;; Utilities etc
|
|
||||||
|
|
||||||
(define concat string-append)
|
|
||||||
|
|
||||||
(define (sort* l)
|
|
||||||
(sort l string<?))
|
|
||||||
|
|
||||||
(define (dir-list . args)
|
|
||||||
(sort* (map path->string (apply directory-list args))))
|
|
||||||
|
|
||||||
(define (dprintf fmt . args)
|
|
||||||
(when *verbose?*
|
|
||||||
(apply fprintf (current-error-port) fmt args)
|
|
||||||
(flush-output (current-error-port))))
|
|
||||||
|
|
||||||
;;; ===========================================================================
|
|
||||||
;;; Tree utilities
|
|
||||||
|
|
||||||
;; path -> tree
|
|
||||||
;; Same as get-tree, but lists the contents of a tgz file via tar.
|
|
||||||
(define (get-tgz-tree tgz)
|
|
||||||
(define base (regexp-replace #rx"/$" (path->string (cd)) ""))
|
|
||||||
(define tgz-name
|
|
||||||
(regexp-replace #rx"^.*/" (if (path? tgz) (path->string tgz) tgz) ""))
|
|
||||||
(define (tree+rest paths curdir)
|
|
||||||
(define cur-rx (regexp (concat "^" (regexp-quote curdir))))
|
|
||||||
(define m
|
|
||||||
(let ([m (and (pair? paths)
|
|
||||||
(regexp-match-positions cur-rx (car paths)))])
|
|
||||||
(and m (regexp-match-positions #rx"/.*/" (car paths) (cdar m)))))
|
|
||||||
(if m
|
|
||||||
;; we have too many "/"s => need to reconstruct a fake intermediate dir
|
|
||||||
(tree+rest (cons (substring (car paths) 0 (add1 (caar m))) paths) curdir)
|
|
||||||
(let loop ([paths paths] [contents '()])
|
|
||||||
(when (pair? paths)
|
|
||||||
(prop-set! (car paths) 'tgz tgz-name)
|
|
||||||
(prop-set! (car paths) 'base base)
|
|
||||||
(prop-set!
|
|
||||||
(car paths) 'name
|
|
||||||
(cond [(regexp-match #rx"^(?:.*/)?([^/]+)/?$" (car paths)) => cadr]
|
|
||||||
[else (error 'get-tgz-tree
|
|
||||||
"bad path name: ~s" (car paths))])))
|
|
||||||
(if (and (pair? paths) (regexp-match? cur-rx (car paths)))
|
|
||||||
;; still in the same subtree
|
|
||||||
(if (regexp-match? #rx"/$" (car paths))
|
|
||||||
;; new directory
|
|
||||||
(let-values ([(tree rest) (tree+rest (cdr paths) (car paths))])
|
|
||||||
(loop rest (cons tree contents)))
|
|
||||||
;; new file
|
|
||||||
(loop (cdr paths) (cons (car paths) contents)))
|
|
||||||
;; in a new subtree
|
|
||||||
(values (cons curdir (reverse contents)) paths)))))
|
|
||||||
(define-values (p pout pin perr)
|
|
||||||
(subprocess #f /dev/null-in (current-error-port) /tar "tzf" tgz))
|
|
||||||
(parameterize ([current-input-port pout])
|
|
||||||
(let loop ([lines '()])
|
|
||||||
(let ([line (read-line)])
|
|
||||||
(if (eof-object? line)
|
|
||||||
(let ([paths (sort* (reverse lines))])
|
|
||||||
(subprocess-wait p)
|
|
||||||
(unless (eq? 0 (subprocess-status p))
|
|
||||||
(error 'get-tgz-tree "`tar' failed."))
|
|
||||||
(let-values ([(tree rest) (tree+rest paths "")])
|
|
||||||
(if (null? rest)
|
|
||||||
(cdr tree)
|
|
||||||
(error 'get-tgz-tree "something bad happened (~s...)"
|
|
||||||
(car paths)))))
|
|
||||||
(loop (cons line lines)))))))
|
|
||||||
|
|
||||||
;;; ===========================================================================
|
|
||||||
;;; Start working
|
|
||||||
|
|
||||||
(register-macros!)
|
|
||||||
|
|
||||||
(define *platforms* #f)
|
|
||||||
(define *bin-types* #f)
|
|
||||||
(define *src-types* #f)
|
|
||||||
(define *platform-tree-lists* #f)
|
|
||||||
(define /pax #f)
|
|
||||||
(define /tar #f)
|
|
||||||
(define /fakeroot #f)
|
|
||||||
(define /dev/null-out #f)
|
|
||||||
(define /dev/null-in #f)
|
|
||||||
|
|
||||||
(define (process-command-line)
|
|
||||||
(command-line
|
|
||||||
#:multi
|
|
||||||
["+d" "Verify dependencies (default)" (set! *verify?* #t)]
|
|
||||||
["-d" "Don't verify dependencies" (set! *verify?* #f)]
|
|
||||||
["+v" "Verbose mode (on stdout)" (set! *verbose?* #t)]
|
|
||||||
["-v" "Normal output (only stderr) (default)" (set! *verbose?* 'yes)]
|
|
||||||
["-q" "Quiet mode" (set! *verbose?* #f)]
|
|
||||||
["+b" "Create binary tgzs (default)" (set! *btgz?* #t)]
|
|
||||||
["-b" "Skip binary tgzs, re-use binary trees" (set! *btgz?* #f)]
|
|
||||||
["+p" "Pack distributions (default)" (set! *pack?* #t)]
|
|
||||||
["-p" "Skip packing" (set! *pack?* #f)]
|
|
||||||
["++release" "Build for a release" (set! *release?* #t)]
|
|
||||||
["-o" dest "Destination directory" (set! target/ (/-ify dest))]
|
|
||||||
["--text" "Stands for -d +v -b -p -r (useful for debugging)"
|
|
||||||
(set!-values (*verify?* *verbose?* *btgz?* *pack?*) (values #f #t #f #f))])
|
|
||||||
(current-verbose-port (and *verbose?* current-error-port)))
|
|
||||||
|
|
||||||
;; specs can have `lambda' expressions to evaluate, do it in this context
|
|
||||||
(define-namespace-anchor bundle-specs)
|
|
||||||
|
|
||||||
(define (read-spec-file file [param *specs*])
|
|
||||||
(process-specs
|
|
||||||
(with-input-from-file file
|
|
||||||
(lambda ()
|
|
||||||
(let loop ([xs '()])
|
|
||||||
(let ([x (read)])
|
|
||||||
(if (eof-object? x) (reverse xs) (loop (cons x xs)))))))
|
|
||||||
param))
|
|
||||||
|
|
||||||
(define (read-specs)
|
|
||||||
(current-namespace (namespace-anchor->namespace bundle-specs))
|
|
||||||
(dprintf "Reading specs...")
|
|
||||||
(dist:register-specs!)
|
|
||||||
(dprintf " done.\n"))
|
|
||||||
|
|
||||||
(define (input-tgz-name? f)
|
|
||||||
(let ([f (if (path? f) (path->string f) f)])
|
|
||||||
;; names of tgzs that are not the generated binary ones
|
|
||||||
(and (regexp-match? #rx"\\.tgz$" f)
|
|
||||||
(not (regexp-match? #rx"-binaries\\.tgz$" f)))))
|
|
||||||
|
|
||||||
(define (initialize)
|
|
||||||
(when *release?* (*environment* (cons 'release (*environment*))))
|
|
||||||
(define (find-exe name)
|
|
||||||
(path->string
|
|
||||||
(or (find-executable-path name #f)
|
|
||||||
(error (format "error: couldn't find a `~a' executable" name)))))
|
|
||||||
(set! /pax (find-exe "pax"))
|
|
||||||
(set! /tar (find-exe "gtar"))
|
|
||||||
(set! /fakeroot (find-exe "fakeroot"))
|
|
||||||
(set! /dev/null-out (open-output-file "/dev/null" #:exists 'append))
|
|
||||||
(set! /dev/null-in (open-input-file "/dev/null"))
|
|
||||||
(unless (directory-exists? target/) (make-directory target/))
|
|
||||||
(let ([d (ormap (lambda (x) (and (not (directory-exists? x)) x))
|
|
||||||
(list home/ racket/ binaries/ target/))])
|
|
||||||
(when d (error 'bundle "directory not found: ~a" d)))
|
|
||||||
(set! *platforms*
|
|
||||||
(parameterize ([cd binaries/])
|
|
||||||
(filter (lambda (x)
|
|
||||||
(and (not (regexp-match? #rx"^[.]" x))
|
|
||||||
(directory-exists? x)))
|
|
||||||
(dir-list))))
|
|
||||||
(set! *bin-types* (map string->symbol *platforms*))
|
|
||||||
(set! *src-types*
|
|
||||||
(let loop ([bins *bin-types*] [r '()])
|
|
||||||
(if (null? bins)
|
|
||||||
(reverse r)
|
|
||||||
(let* ([bin (car bins)] [src (get-tag bin)])
|
|
||||||
(cond
|
|
||||||
[(not src) (error 'binaries "no type assigned to `~.s'" bin)]
|
|
||||||
[(not (= 1 (length src)))
|
|
||||||
(error 'binaries "bad type assignment for `~.s': ~.s" bin src)]
|
|
||||||
[else (loop (cdr bins)
|
|
||||||
(if (memq (car src) r) r (cons (car src) r)))])))))
|
|
||||||
(dprintf "Scanning full tgzs")
|
|
||||||
(set! *platform-tree-lists*
|
|
||||||
(parameterize ([cd binaries/])
|
|
||||||
(map (lambda (platform)
|
|
||||||
(dprintf ".")
|
|
||||||
(parameterize ([cd platform])
|
|
||||||
;; if no btgz *and* "racket" already created then use
|
|
||||||
;; get-tree (useful when debugging stuff so re-use pre made
|
|
||||||
;; ones) should work the same with an old tree
|
|
||||||
(if (and (directory-exists? "racket") (not *btgz?*))
|
|
||||||
(filtered-map
|
|
||||||
(lambda (x) ; only directories contain stuff we need
|
|
||||||
(and (directory-exists? x) (get-tree x "racket")))
|
|
||||||
(dir-list))
|
|
||||||
(let ([trees (filtered-map
|
|
||||||
(lambda (x)
|
|
||||||
(and (file-exists? x) (input-tgz-name? x)
|
|
||||||
(get-tgz-tree x)))
|
|
||||||
(dir-list))])
|
|
||||||
(tag (list (string->symbol platform))
|
|
||||||
(map (lambda (tree) (tree-filter 'binaries tree))
|
|
||||||
(apply append trees)))))))
|
|
||||||
*platforms*)))
|
|
||||||
(dprintf " done.\n")
|
|
||||||
(for-each (lambda (platform trees)
|
|
||||||
(when (null? trees)
|
|
||||||
(error 'binaries "no binaries found for ~s" platform)))
|
|
||||||
*platforms* *platform-tree-lists*)
|
|
||||||
;; Get the racket tree, remove junk and binary stuff
|
|
||||||
(set-racket-tree! racket/ racket-base/ racket/-name *platform-tree-lists*)
|
|
||||||
(set-bin-files-delayed-lists!
|
|
||||||
(delay (map (lambda (trees)
|
|
||||||
(sort* (mappend tree-flatten (add-trees trees))))
|
|
||||||
*platform-tree-lists*))))
|
|
||||||
|
|
||||||
(define (make-info-domain trees)
|
|
||||||
(unless (= 1 (length trees))
|
|
||||||
(error 'make-info-domain "got zero or multiple trees: ~e" trees))
|
|
||||||
(let* ([collects (or (tree-filter "/racket/collects/" (car trees))
|
|
||||||
(error 'make-info-domain "got no collects in tree"))]
|
|
||||||
[info (filter (lambda (x)
|
|
||||||
(define p (car x))
|
|
||||||
(unless (and (list? p)
|
|
||||||
((length p) . >= . 2)
|
|
||||||
(eq? 'info (car p))
|
|
||||||
(andmap bytes? (cdr p)))
|
|
||||||
(error 'bundle "unexpected path form in cache.rktd: ~e" p))
|
|
||||||
(let ([x (string-join (map bytes->string/utf-8 (cdr p)) "/")])
|
|
||||||
(pair? (tree-filter (concat "/racket/collects/" x)
|
|
||||||
collects))))
|
|
||||||
*info-domain-cache*)])
|
|
||||||
(lambda () (write info) (newline))))
|
|
||||||
|
|
||||||
(define readme-skeleton
|
|
||||||
(delay (let ([m (regexp-match #rx"^(.*?\n====+\n)\n*(.*)$" *readme-cache*)])
|
|
||||||
;; title, rest (without generic source reference)
|
|
||||||
(if m
|
|
||||||
(list (cadr m)
|
|
||||||
(regexp-replace #rx"Instructions for building[^\n]*\n\n"
|
|
||||||
(caddr m)
|
|
||||||
""))
|
|
||||||
(error 'readme-skeleton "unexpected toplevel README")))))
|
|
||||||
(define (make-readme)
|
|
||||||
(for-each
|
|
||||||
;; convert to CRLF on Windows
|
|
||||||
(if (memq 'win (*environment*))
|
|
||||||
(lambda (x) (display (regexp-replace* #rx"\r?\n" x "\r\n")))
|
|
||||||
display)
|
|
||||||
`(,(car (force readme-skeleton))
|
|
||||||
"\n"
|
|
||||||
,@(expand-spec 'readme-header)
|
|
||||||
"\n"
|
|
||||||
,(cadr (force readme-skeleton)))))
|
|
||||||
|
|
||||||
(define (create-binaries platform trees)
|
|
||||||
(parameterize ([cd (build-path binaries/ platform)])
|
|
||||||
(let ([full-tgz (concat "racket-"platform"-full.tgz")]
|
|
||||||
[bin-tgz (concat "racket-"platform"-binaries.tgz")]
|
|
||||||
[all-tgzs (filter input-tgz-name?
|
|
||||||
(map path->string (directory-list)))])
|
|
||||||
(unless (and (directory-exists? "racket") (not *btgz?*))
|
|
||||||
(dprintf "Unpacking binaries in ~s ~a\n" platform all-tgzs)
|
|
||||||
;; even if a "racket" directory exists, we just overwrite the same
|
|
||||||
;; stuff
|
|
||||||
(unless (member full-tgz all-tgzs)
|
|
||||||
(error 'create-binaries "~a/~a not found" (cd) full-tgz))
|
|
||||||
(for ([tgz all-tgzs]) (unpack tgz trees)))
|
|
||||||
(when *btgz?*
|
|
||||||
(dprintf "Creating ~s\n" bin-tgz)
|
|
||||||
(when (file-exists? bin-tgz) (delete-file bin-tgz))
|
|
||||||
(let-values ([(p pout pin perr)
|
|
||||||
(subprocess
|
|
||||||
(current-output-port) /dev/null-in (current-error-port)
|
|
||||||
/fakeroot "--"
|
|
||||||
;; see below for flag explanations
|
|
||||||
/pax "-w" "-x" "ustar" "-z" "-f" bin-tgz
|
|
||||||
;; only pack the racket dir (only exception is Libraries
|
|
||||||
;; on OSX, but that has its own dir)
|
|
||||||
"racket")])
|
|
||||||
(subprocess-wait p))))))
|
|
||||||
|
|
||||||
(define (pack archive trees prefix)
|
|
||||||
;; `pax' is used to create the tgz archives -- the main reasons for using it
|
|
||||||
;; is the fact that it can generate portable "ustar" tar files, and that it
|
|
||||||
;; is flexible enough to allow replacing file names, so we can collect files
|
|
||||||
;; from different directories and make them all appear in a single one in the
|
|
||||||
;; resulting archive.
|
|
||||||
(when (eq? #t *verbose?*) (printf "~a:\n" archive))
|
|
||||||
(cond [*pack?*
|
|
||||||
(dprintf " packing...")
|
|
||||||
(when (file-exists? archive) (delete-file archive))
|
|
||||||
(let*-values ([(output) (if (eq? #t *verbose?*)
|
|
||||||
(current-output-port) /dev/null-out)]
|
|
||||||
[(p pout pin perr)
|
|
||||||
;; Note: pax prints converted paths on stderr, so
|
|
||||||
;; silence it too unless verbose. Use only for
|
|
||||||
;; debugging.
|
|
||||||
(subprocess
|
|
||||||
output #f output
|
|
||||||
/fakeroot "--"
|
|
||||||
/pax
|
|
||||||
"-w" ; write
|
|
||||||
"-x" "ustar" ; create a POSIX ustar format
|
|
||||||
"-z" ; gzip the archive
|
|
||||||
"-d" ; dont go down directories implicitly
|
|
||||||
"-s" (format ",^~a,,p" prefix) ; delete base paths
|
|
||||||
"-f" archive ; pack to this file
|
|
||||||
)])
|
|
||||||
(parameterize ([current-output-port pin])
|
|
||||||
(for ([t trees]) (print-tree t 'full)))
|
|
||||||
(close-output-port pin)
|
|
||||||
(subprocess-wait p)
|
|
||||||
(unless (eq? 0 (subprocess-status p))
|
|
||||||
(error 'pack "`pax' failed.")))]
|
|
||||||
[(eq? #t *verbose?*) (for ([t trees]) (print-tree t))])
|
|
||||||
(when (eq? #t *verbose?*) (newline))
|
|
||||||
(flush-output))
|
|
||||||
|
|
||||||
(define (unpack archive trees)
|
|
||||||
;; unpack using tar (doesn't look like there's a way to unpack according to
|
|
||||||
;; files from stdin with pax, and it uses gnu format with @LongLinks).
|
|
||||||
(let-values
|
|
||||||
([(p pout pin perr)
|
|
||||||
(subprocess
|
|
||||||
(current-output-port) #f (current-error-port) /tar
|
|
||||||
"x" ; extract
|
|
||||||
"-z" ; gunzip the archive
|
|
||||||
"-p" ; preserve permissions
|
|
||||||
"--files-from=-" ; read files from stdin
|
|
||||||
"-f" archive ; unpack this file
|
|
||||||
)]
|
|
||||||
[(trees)
|
|
||||||
(map (lambda (t)
|
|
||||||
(tree-filter
|
|
||||||
(lambda (t)
|
|
||||||
;; Problem: if this returns #t/#f only, then the sources can
|
|
||||||
;; come from multiple tgz since each file will be identified
|
|
||||||
;; by itself. But if this is done, then no empty directories
|
|
||||||
;; will be included (see `tree-filter' comment) and this will
|
|
||||||
;; later be a problem (to have an empty dir in the tree but
|
|
||||||
;; not on disk) -- so return '+ and as soon as a root is
|
|
||||||
;; identified with the tgz, all of it will be used.
|
|
||||||
(and
|
|
||||||
(equal? archive
|
|
||||||
(prop-get (tree-path t) 'tgz
|
|
||||||
(lambda ()
|
|
||||||
(error 'unpack
|
|
||||||
"no `tgz' property for ~e" t))))
|
|
||||||
'+))
|
|
||||||
t))
|
|
||||||
trees)])
|
|
||||||
(parameterize ([current-output-port pin])
|
|
||||||
(for ([t trees]) (print-tree t 'only-files)))
|
|
||||||
(close-output-port pin)
|
|
||||||
(subprocess-wait p)
|
|
||||||
(unless (eq? 0 (subprocess-status p)) (error 'unpack "`tar' failed."))))
|
|
||||||
|
|
||||||
;; This code implements the binary filtering of 3m/cgc files, see
|
|
||||||
;; `binary-keep/throw-templates' in "distribution-specs.ss".
|
|
||||||
;; Careful when editing!
|
|
||||||
(define (filter-bintree tree)
|
|
||||||
(define (get-pattern spec)
|
|
||||||
(let ([rx (expand-spec spec)])
|
|
||||||
(if (and (pair? rx) (null? (cdr rx)) (string? (car rx)))
|
|
||||||
(car rx)
|
|
||||||
(error 'filter-bintree "bad value for ~.s: ~e" spec rx))))
|
|
||||||
(define keep-pattern (get-pattern 'binary-keep))
|
|
||||||
(define throw-pattern (get-pattern 'binary-throw))
|
|
||||||
(define keep-rx (regexpify-spec (string-append "*" keep-pattern "*")))
|
|
||||||
(define throw-rx (regexpify-spec (string-append "*" throw-pattern "*")))
|
|
||||||
(define templates
|
|
||||||
(let ([ts (expand-spec 'binary-keep/throw-templates)])
|
|
||||||
(for ([t ts])
|
|
||||||
(unless (and (string? t)
|
|
||||||
;; verify that it has exactly one "<...!...>" pattern
|
|
||||||
(regexp-match? #rx"^[^<!>]*<[^<!>]*![^<!>]*>[^<!>]*$" t))
|
|
||||||
(error 'filter-bintree "bad keep/throw template: ~e" t)))
|
|
||||||
ts))
|
|
||||||
(define (make-matcher x) ; matchers return match-positions or #f
|
|
||||||
(let ([rxs (map (lambda (t)
|
|
||||||
(let* ([x (regexp-replace #rx"!" t x)]
|
|
||||||
[x (object-name (regexpify-spec x #t))]
|
|
||||||
[x (regexp-replace #rx"<(.*)>" x "(\\1)")])
|
|
||||||
(regexp x)))
|
|
||||||
templates)])
|
|
||||||
(lambda (p) (ormap (lambda (rx) (regexp-match-positions rx p)) rxs))))
|
|
||||||
(define (rassoc x l)
|
|
||||||
(and (pair? l) (if (equal? x (cdar l)) (car l) (rassoc x (cdr l)))))
|
|
||||||
(define keep? (make-matcher keep-pattern))
|
|
||||||
(define throw? (make-matcher throw-pattern))
|
|
||||||
(define existing-paths (tree-flatten tree))
|
|
||||||
;; The two `*-paths' values are association lists: ((<path> . <plain>) ...)
|
|
||||||
;; both sides are unique in each list, the lhs is always an existing path
|
|
||||||
(define (find-paths pred? mode rx)
|
|
||||||
(define res '())
|
|
||||||
(let loop ([t tree])
|
|
||||||
(let ([p (tree-path t)])
|
|
||||||
(cond [(pred? p)
|
|
||||||
=> (lambda (m)
|
|
||||||
(let ([plain (string-append (substring p 0 (caadr m))
|
|
||||||
(substring p (cdadr m)))])
|
|
||||||
(when (rassoc plain res)
|
|
||||||
(error 'filter-bintree
|
|
||||||
"two ~s templates have the same plain: ~e -> ~e"
|
|
||||||
mode p plain))
|
|
||||||
(set! res `((,p . ,plain) ,@res)))
|
|
||||||
#t)]
|
|
||||||
[(regexp-match? rx p)
|
|
||||||
;; other matches are not allowed, unless on a directory where
|
|
||||||
;; all files are selected
|
|
||||||
(when (or (not (pair? t))
|
|
||||||
(memq #f (map loop (cdr t))))
|
|
||||||
(error 'filter-bintree
|
|
||||||
"~s path uncovered by patterns: ~e" mode p))
|
|
||||||
#t]
|
|
||||||
[(pair? t) (not (memq #f (map loop (cdr t))))]
|
|
||||||
[else #f])))
|
|
||||||
res)
|
|
||||||
(define keep-paths (find-paths keep? 'keep keep-rx))
|
|
||||||
(define throw-paths (find-paths throw? 'throw throw-rx))
|
|
||||||
(for ([k keep-paths])
|
|
||||||
(when (assoc (car k) throw-paths)
|
|
||||||
(error 'filter-bintree
|
|
||||||
"a path matched both keep and throw patterns: ~s" (car k))))
|
|
||||||
(let* ([ps (map cdr keep-paths)]
|
|
||||||
[ps (append ps (remove* ps (map cdr throw-paths)))]
|
|
||||||
[scan (lambda (f paths)
|
|
||||||
(map (lambda (p) (cond [(f p paths) => car] [else #f])) ps))]
|
|
||||||
[plain (scan member existing-paths)]
|
|
||||||
[keep (scan rassoc keep-paths)]
|
|
||||||
[throw (scan rassoc throw-paths)])
|
|
||||||
(define del
|
|
||||||
(map (lambda (p k t)
|
|
||||||
(cond
|
|
||||||
[(and p k t) (error 'filter-bintree "got keep+throw+plain")]
|
|
||||||
[(or k t) (or t p)]
|
|
||||||
[else (error 'filter-bintree "internal error")]))
|
|
||||||
plain keep throw))
|
|
||||||
(tree-filter `(not (or ,(lambda (t) (and (memq (tree-path t) del) '+))
|
|
||||||
binary-throw-more))
|
|
||||||
tree)))
|
|
||||||
|
|
||||||
;; This is hooked below as a `distribute!' spec macro, and invoked through
|
|
||||||
;; expand-spec.
|
|
||||||
(define (distribute!)
|
|
||||||
(define (distribute tree) (tree-filter 'distribution tree))
|
|
||||||
(let* ([features (filter string? (reverse (*environment*)))]
|
|
||||||
[name (apply concat (cdr (mappend (lambda (x) (list "-" x))
|
|
||||||
features)))]
|
|
||||||
[features (map string->symbol features)]
|
|
||||||
[bin? (memq 'bin features)]
|
|
||||||
[src? (memq 'src features)]
|
|
||||||
[full? (memq 'full features)])
|
|
||||||
(when (and bin? src?)
|
|
||||||
(error 'distribute! "bad configuration (both bin & src): ~e" features))
|
|
||||||
(unless (or bin? src?)
|
|
||||||
(error 'distribute! "bad configuration (both bin & src): ~e" features))
|
|
||||||
(for ([type (if bin? *bin-types* *src-types*)]
|
|
||||||
;; this is unused if bin? is false
|
|
||||||
[bin-trees (if bin? *platform-tree-lists* *src-types*)])
|
|
||||||
(tag (cons type features)
|
|
||||||
(let ([name (format "~a-~a.tgz" name type)])
|
|
||||||
(dprintf "Creating ~s: filtering..." name)
|
|
||||||
(let ([trees (add-trees
|
|
||||||
(cons (distribute (get-racket-tree))
|
|
||||||
(if bin?
|
|
||||||
(tag 'in-binary-tree
|
|
||||||
(map (if full?
|
|
||||||
distribute
|
|
||||||
(lambda (t)
|
|
||||||
(distribute (filter-bintree t))))
|
|
||||||
bin-trees))
|
|
||||||
'())))])
|
|
||||||
(with-output-to-file *readme-file* #:exists 'truncate make-readme)
|
|
||||||
(with-output-to-file *info-domain-file* #:exists 'truncate
|
|
||||||
(make-info-domain trees))
|
|
||||||
(pack (concat target/ name) trees
|
|
||||||
(if bin?
|
|
||||||
(format "\\(~a\\|~a~a/\\)" racket-base/ binaries/ type)
|
|
||||||
racket-base/)))
|
|
||||||
(dprintf " done.\n")))))
|
|
||||||
'())
|
|
||||||
(register-spec! 'distribute!
|
|
||||||
(lambda () (when (or *pack?* (eq? #t *verbose?*)) (distribute!))))
|
|
||||||
|
|
||||||
(register-spec! 'verify! (lambda () (when *verify?* (verify!))))
|
|
||||||
|
|
||||||
(define (read-orig-files)
|
|
||||||
(set! *readme-cache* (file->string *readme-file*))
|
|
||||||
(set! *info-domain-cache* (with-input-from-file *info-domain-file* read)))
|
|
||||||
(define (write-orig-files)
|
|
||||||
(display-to-file *readme-cache* *readme-file* #:exists 'truncate)
|
|
||||||
(with-output-to-file *info-domain-file* #:exists 'truncate
|
|
||||||
(lambda () (write *info-domain-cache*) (newline))))
|
|
||||||
|
|
||||||
(process-command-line)
|
|
||||||
(read-specs)
|
|
||||||
(initialize)
|
|
||||||
(for-each create-binaries *platforms* *platform-tree-lists*)
|
|
||||||
(dynamic-wind
|
|
||||||
(lambda () (read-orig-files))
|
|
||||||
;; Start the verification and distribution
|
|
||||||
(lambda () (expand-spec 'distributions) (void))
|
|
||||||
(lambda () (write-orig-files)))
|
|
||||||
|
|
@ -1,128 +0,0 @@
|
||||||
# these should be writable (for the web server)
|
|
||||||
cache="/tmp/racket-build-status-cache"
|
|
||||||
cachelock="$cache-lock"
|
|
||||||
requestfile="/tmp/racket-build-request"
|
|
||||||
requeststatusfile="/tmp/racket-build-request-status"
|
|
||||||
|
|
||||||
printf 'Content-type: text/plain\r\nAccess-Control-Allow-Origin: *\r\n\r\n'
|
|
||||||
|
|
||||||
if [[ "$PATH_INFO" = "/request" ]]; then
|
|
||||||
error() { echo "Error: $*"; exit 0; }
|
|
||||||
if [[ -e "$lockfile" ]]; then
|
|
||||||
if [[ -e "$statusfile" ]]; then error "a build is in progress"
|
|
||||||
else error "builds temporarily disabled"; fi
|
|
||||||
fi
|
|
||||||
request_rx='^([^&@]+@racket-lang[.]org)&([^&]+)&([0-9]+)$'
|
|
||||||
if [[ ! "$QUERY_STRING" =~ $request_rx ]]; then error "invalid request"; fi
|
|
||||||
username="${BASH_REMATCH[1]}"
|
|
||||||
branch="${BASH_REMATCH[2]}"
|
|
||||||
cookie="${BASH_REMATCH[3]}"
|
|
||||||
date="$(date +'%Y-%m-%d %H:%M')"
|
|
||||||
prevuser=""
|
|
||||||
if [[ -e "$requestfile" ]]; then
|
|
||||||
prevuser="$(cat "$requestfile" | head -1)"
|
|
||||||
rm -f "$requestfile" || error "could not remove previous request file"
|
|
||||||
rm -f "$requeststatusfile"
|
|
||||||
fi
|
|
||||||
touch "$requestfile" || error "could not create request file"
|
|
||||||
{ echo "$username"; echo "$branch"; echo "$date"; echo "$cookie"; } \
|
|
||||||
> "$requestfile"
|
|
||||||
if [[ "x$prevuser" = "x" ]]; then
|
|
||||||
echo "Request created for $username"
|
|
||||||
elif [[ "x$prevuser" = "x$username" ]]; then
|
|
||||||
echo "Request re-created for $username"
|
|
||||||
else
|
|
||||||
echo "Request created for $username, overwriting request for $prevuser"
|
|
||||||
fi
|
|
||||||
exit 0
|
|
||||||
fi
|
|
||||||
|
|
||||||
###############################################################################
|
|
||||||
# status reporting
|
|
||||||
|
|
||||||
# cache status reports (avoids excessive work during builds)
|
|
||||||
# use a lockfile as a cheap hack to time cache refreshing
|
|
||||||
if ! lockfile -r 0 -l 25 -s 0 "$cachelock" >& /dev/null \
|
|
||||||
&& [[ -e "$cache" ]]; then
|
|
||||||
cat "$cache"; exit
|
|
||||||
fi
|
|
||||||
|
|
||||||
{
|
|
||||||
|
|
||||||
check_exists() { if [[ -e "$2" ]]; then eval "$1=Y"; else eval "$1=N"; fi; }
|
|
||||||
check_exists L "$lockfile"
|
|
||||||
check_exists S "$statusfile"
|
|
||||||
check_exists SL "$statusfile_last"
|
|
||||||
check_exists R "$requestfile"
|
|
||||||
check_exists RS "$requeststatusfile"
|
|
||||||
|
|
||||||
if [[ "$L$S" = "YY" ]]; then
|
|
||||||
time_for_file() {
|
|
||||||
local t="$(($(date +"%s") - $(stat -c "%Z" "$1")))"
|
|
||||||
printf "%d:%02d:%02d" "$((t/3600))" "$(((t%3600)/60))" "$((t%60))"
|
|
||||||
}
|
|
||||||
printf '{{{LINKTO: %s}}}' "current-$(basename "$buildlogfile")"
|
|
||||||
printf 'A build is running (%s)\n' "$(time_for_file "$lockfile")"
|
|
||||||
printf 'Status: %s (%s)\n' "$(cat "$statusfile")" \
|
|
||||||
"$(time_for_file "$statusfile")"
|
|
||||||
shopt -s nullglob
|
|
||||||
if [[ "x$(echo "$bglogfile"*)" != "x" ]]; then
|
|
||||||
printf '\n%s build jobs running:\n' "$(ls "$bglogfile"* | wc -l)"
|
|
||||||
for bg in "$bglogfile"*; do
|
|
||||||
s="$(grep "^### <<< .* >>>" "$bg" | tail -1 \
|
|
||||||
| sed -e 's/([^()]* build) //' \
|
|
||||||
| sed -e 's/^### <<< \(.*\) >>>/\1/')"
|
|
||||||
printf '{{{LINKTO: %s}}}' "current-$(basename "$bg")"
|
|
||||||
if [[ "x$s" = "x" ]]; then
|
|
||||||
printf ' %s: (just starting)\n' "${bg#$bglogfile-}"
|
|
||||||
else
|
|
||||||
s="${bg#$bglogfile-}: $s"
|
|
||||||
s="$(echo "$s" \
|
|
||||||
| sed -e 's/^\(.*\): \(.*\) \[\1(\(.*\))\]$/\3(\1): \2/')"
|
|
||||||
echo " $s"
|
|
||||||
fi
|
|
||||||
done
|
|
||||||
fi
|
|
||||||
else
|
|
||||||
printf 'No build is running.\n'
|
|
||||||
if [[ "$L" = "Y" ]]; then
|
|
||||||
# lockfile exists, but no statusfile
|
|
||||||
printf '(Builds temporarily disabled.)\n'
|
|
||||||
elif [[ "$S" = "Y" ]]; then
|
|
||||||
# statusfile exists, but no lockfile
|
|
||||||
printf '(Last build crashed abnormally: status file not removed.)\n'
|
|
||||||
fi
|
|
||||||
if [[ "$R" = "Y" ]]; then
|
|
||||||
echo ""
|
|
||||||
{ read R_user; read R_branch; read R_date; } < "$requestfile"
|
|
||||||
printf 'Pending build request for %s' "$R_user"
|
|
||||||
if [[ "x$R_branch" != "xmaster" ]]; then
|
|
||||||
printf ' (%s branch)' "$R_branch"
|
|
||||||
fi
|
|
||||||
echo " made at $R_date"
|
|
||||||
if [[ "$RS" = "Y" ]]; then awk '{ print " " $0 }' < "$requeststatusfile"
|
|
||||||
else echo " The request is fresh, and was not noticed by the system."; fi
|
|
||||||
fi
|
|
||||||
if [[ "$SL" = "Y" ]]; then
|
|
||||||
echo ""
|
|
||||||
last="$(cat "$statusfile_last")"
|
|
||||||
printf '{{{LINKTO: %s}}}' "current-$(basename "$buildlogfile")"
|
|
||||||
if [[ "x$last" = "xDone ("*")" ]]; then
|
|
||||||
last="${last#Done (}"
|
|
||||||
last="${last%)}"
|
|
||||||
printf 'Last build successfully ended at %s\n' "$last"
|
|
||||||
elif [[ "x$last" = "x("*" build) Done ("*")" ]]; then
|
|
||||||
last="${last#(}"
|
|
||||||
build="${last% build) Done*}"
|
|
||||||
last="${last#*) Done (}"
|
|
||||||
last="${last%)}"
|
|
||||||
printf 'Last %s build successfully ended at %s\n' "$build" "$last"
|
|
||||||
else
|
|
||||||
printf 'Last build was unsuccessful (%s)\n' "$last"
|
|
||||||
fi
|
|
||||||
fi
|
|
||||||
fi
|
|
||||||
|
|
||||||
} > "$cache.$$" 2>&1
|
|
||||||
mv "$cache.$$" "$cache"
|
|
||||||
cat "$cache"
|
|
||||||
Binary file not shown.
|
Before Width: | Height: | Size: 4.9 KiB |
|
|
@ -1,194 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require slideshow racket/gui/base racket/runtime-path)
|
|
||||||
|
|
||||||
(provide plt-title-background
|
|
||||||
make-plt-title-background
|
|
||||||
plt-red-color
|
|
||||||
plt-blue-color
|
|
||||||
plt-background-color
|
|
||||||
plt-lambda-color
|
|
||||||
plt-pen-color
|
|
||||||
plt-pen-style)
|
|
||||||
|
|
||||||
(define plt-red-color (make-object color% 242 183 183))
|
|
||||||
(define plt-blue-color (make-object color% 183 202 242))
|
|
||||||
(define plt-background-color (make-object color% 209 220 248))
|
|
||||||
(define plt-lambda-color (send the-color-database find-color "white"))
|
|
||||||
(define plt-pen-color "black")
|
|
||||||
(define plt-pen-style 'transparent)
|
|
||||||
|
|
||||||
(define (with-dc-settings dc thunk)
|
|
||||||
(define alpha (send dc get-alpha))
|
|
||||||
(define smoothing (send dc get-smoothing))
|
|
||||||
(define pen (send dc get-pen))
|
|
||||||
(define brush (send dc get-brush))
|
|
||||||
(thunk)
|
|
||||||
(send* dc (set-alpha alpha)
|
|
||||||
(set-smoothing smoothing)
|
|
||||||
(set-pen pen)
|
|
||||||
(set-brush brush)))
|
|
||||||
|
|
||||||
(define (make-plt-title-background
|
|
||||||
red-color blue-color background-color lambda-color pen-color pen-style
|
|
||||||
#:clip? [clip? #t] #:edge-cleanup-pen [edge-cleanup-pen #f])
|
|
||||||
(define-syntax-rule (make-path cmd ...)
|
|
||||||
(let ([p (new dc-path%)]) (send* p cmd ...) p))
|
|
||||||
(define left-lambda-path
|
|
||||||
(make-path (move-to 153 44)
|
|
||||||
(line-to 161.5 60)
|
|
||||||
(curve-to 202.5 49 230 42 245 61)
|
|
||||||
(curve-to 280.06 105.41 287.5 141 296.5 186)
|
|
||||||
(curve-to 301.12 209.08 299.11 223.38 293.96 244)
|
|
||||||
(curve-to 281.34 294.54 259.18 331.61 233.5 375)
|
|
||||||
(curve-to 198.21 434.63 164.68 505.6 125.5 564)
|
|
||||||
(line-to 135 572)))
|
|
||||||
(define left-logo-path
|
|
||||||
(make-path (append left-lambda-path)
|
|
||||||
(arc 0 0 630 630 (* 235/360 2 pi) (* 121/360 2 pi) #f)))
|
|
||||||
(define bottom-lambda-path
|
|
||||||
(make-path (move-to 135 572)
|
|
||||||
(line-to 188.5 564)
|
|
||||||
(curve-to 208.5 517 230.91 465.21 251 420)
|
|
||||||
(curve-to 267 384 278.5 348 296.5 312)
|
|
||||||
(curve-to 301.01 302.98 318 258 329 274)
|
|
||||||
(curve-to 338.89 288.39 351 314 358 332)
|
|
||||||
(curve-to 377.28 381.58 395.57 429.61 414 477)
|
|
||||||
(curve-to 428 513 436.5 540 449.5 573)
|
|
||||||
(line-to 465 580)
|
|
||||||
(line-to 529 545)))
|
|
||||||
(define bottom-logo-path
|
|
||||||
(make-path (append bottom-lambda-path)
|
|
||||||
(arc 0 0 630 630 (* 314/360 2 pi) (* 235/360 2 pi) #f)))
|
|
||||||
(define right-lambda-path
|
|
||||||
(make-path (move-to 153 44)
|
|
||||||
(curve-to 192.21 30.69 233.21 14.23 275 20)
|
|
||||||
(curve-to 328.6 27.4 350.23 103.08 364 151)
|
|
||||||
(curve-to 378.75 202.32 400.5 244 418 294)
|
|
||||||
(curve-to 446.56 375.6 494.5 456 530.5 537)
|
|
||||||
(line-to 529 545)))
|
|
||||||
(define right-logo-path
|
|
||||||
(make-path (append right-lambda-path)
|
|
||||||
(arc 0 0 630 630 (* 314/360 2 pi) (* 121/360 2 pi) #t)))
|
|
||||||
(define lambda-path ;; the lambda by itself (no circle)
|
|
||||||
(let ([p (new dc-path%)])
|
|
||||||
(send p append left-lambda-path)
|
|
||||||
(send p append bottom-lambda-path)
|
|
||||||
(let ([t (make-object dc-path%)])
|
|
||||||
(send t append right-lambda-path)
|
|
||||||
(send t reverse)
|
|
||||||
(send p append t))
|
|
||||||
(send p close)
|
|
||||||
p))
|
|
||||||
|
|
||||||
;; (define lambda-path
|
|
||||||
;; (make-path (append left-lambda-path)
|
|
||||||
;; (append bottom-lambda-path)
|
|
||||||
;; (append right-lambda-path)))
|
|
||||||
|
|
||||||
;; This function draws the paths with suitable colors:
|
|
||||||
(define (paint-plt dc dx dy)
|
|
||||||
(send dc set-smoothing 'aligned)
|
|
||||||
(define old-pen (send dc get-pen))
|
|
||||||
(define old-brush (send dc get-brush))
|
|
||||||
(define old-clip (send dc get-clipping-region))
|
|
||||||
(send dc set-pen pen-color 0 pen-style)
|
|
||||||
(cond [(procedure? lambda-color)
|
|
||||||
(with-dc-settings dc
|
|
||||||
(λ () (lambda-color dc)
|
|
||||||
(send dc draw-path lambda-path dx dy)))]
|
|
||||||
[lambda-color
|
|
||||||
(send* dc (set-brush lambda-color 'solid)
|
|
||||||
(draw-path lambda-path dx dy))]
|
|
||||||
[else (void)])
|
|
||||||
;; Draw red regions
|
|
||||||
(cond [(is-a? red-color bitmap%)
|
|
||||||
(define rgn1 (new region% [dc dc]))
|
|
||||||
(define rgn2 (new region% [dc dc]))
|
|
||||||
(send rgn1 set-path left-logo-path dx dy #;(- dx 150) #;(- dy 20))
|
|
||||||
(send rgn2 set-path bottom-logo-path dx dy #;(- dx 150) #;(- dy 20))
|
|
||||||
(send rgn2 union rgn1)
|
|
||||||
(send dc set-clipping-region rgn2)
|
|
||||||
;; the left and top values of the bounding box seem to change over
|
|
||||||
;; time, so I've just put reasonable numbers below.
|
|
||||||
(let-values ([(sw sh) (send dc get-scale)])
|
|
||||||
(send* dc (set-scale 1 1)
|
|
||||||
(draw-bitmap red-color 220 100)
|
|
||||||
(set-scale sw sh)))
|
|
||||||
(send dc set-clipping-region old-clip)
|
|
||||||
(cleanup-edges left-logo-path dc dx dy)
|
|
||||||
(cleanup-edges bottom-logo-path dc dx dy)]
|
|
||||||
[(procedure? red-color)
|
|
||||||
(with-dc-settings dc
|
|
||||||
(λ () (red-color dc)
|
|
||||||
(send* dc (draw-path left-logo-path dx dy)
|
|
||||||
(draw-path bottom-logo-path dx dy))))]
|
|
||||||
[else (send* dc (set-brush red-color 'solid)
|
|
||||||
(draw-path left-logo-path dx dy)
|
|
||||||
(draw-path bottom-logo-path dx dy))])
|
|
||||||
;; Draw blue region
|
|
||||||
(cond [(is-a? blue-color bitmap%)
|
|
||||||
(define rgn (new region% [dc dc]))
|
|
||||||
(send rgn set-path right-logo-path dx dy #;(- dx 150) #;(- dy 20))
|
|
||||||
(send dc set-clipping-region rgn)
|
|
||||||
;; the left and top values of the bounding box seem to change over
|
|
||||||
;; time, so I've just put reasonable numbers below.
|
|
||||||
(let-values ([(sw sh) (send dc get-scale)])
|
|
||||||
(send* dc (set-scale 1 1)
|
|
||||||
(draw-bitmap blue-color 430 50)
|
|
||||||
(set-scale sw sh)))
|
|
||||||
(send dc set-clipping-region old-clip)
|
|
||||||
(cleanup-edges right-logo-path dc dx dy)]
|
|
||||||
[(procedure? blue-color)
|
|
||||||
(with-dc-settings dc
|
|
||||||
(λ () (blue-color dc)
|
|
||||||
(send dc draw-path right-logo-path dx dy)))]
|
|
||||||
[else (send* dc (set-brush blue-color 'solid)
|
|
||||||
(draw-path right-logo-path dx dy))])
|
|
||||||
(send* dc (set-pen old-pen)
|
|
||||||
(set-brush old-brush)
|
|
||||||
(set-clipping-region old-clip)))
|
|
||||||
(define (cleanup-edges path dc dx dy)
|
|
||||||
(when edge-cleanup-pen
|
|
||||||
(define pen (send dc get-pen))
|
|
||||||
(define brush (send dc get-brush))
|
|
||||||
(define alpha (send dc get-alpha))
|
|
||||||
(send* dc (set-pen edge-cleanup-pen)
|
|
||||||
(set-brush "black" 'transparent)
|
|
||||||
(set-alpha .8)
|
|
||||||
(draw-path path dx dy)
|
|
||||||
(set-pen pen)
|
|
||||||
(set-brush brush)
|
|
||||||
(set-alpha alpha))))
|
|
||||||
(define image (pin-over
|
|
||||||
(if background-color
|
|
||||||
(colorize (filled-rectangle client-w client-h)
|
|
||||||
background-color)
|
|
||||||
(blank client-w client-h))
|
|
||||||
320 50
|
|
||||||
(scale (dc paint-plt 630 630 0 0) 12/10)))
|
|
||||||
(if clip? (clip image) image))
|
|
||||||
|
|
||||||
(define plt-title-background
|
|
||||||
(make-plt-title-background plt-red-color
|
|
||||||
plt-blue-color
|
|
||||||
plt-background-color
|
|
||||||
plt-lambda-color
|
|
||||||
plt-pen-color
|
|
||||||
plt-pen-style))
|
|
||||||
|
|
||||||
(define-runtime-path arrow.png "128x128-arrow.png")
|
|
||||||
(define blue-arrow (read-bitmap arrow.png))
|
|
||||||
|
|
||||||
(define result.png "racket-rising.png")
|
|
||||||
|
|
||||||
(define size 1)
|
|
||||||
(define bmp (make-bitmap (round (* 1024 size 2/3)) (* 768 size 1/2)))
|
|
||||||
(define bdc (make-object bitmap-dc% bmp))
|
|
||||||
(draw-pict (scale plt-title-background size) bdc -100 0)
|
|
||||||
(void (send bdc draw-bitmap
|
|
||||||
blue-arrow
|
|
||||||
(/ (- (send bmp get-width) (send blue-arrow get-width)) 2)
|
|
||||||
(/ (- (send bmp get-height) (send blue-arrow get-height)) 2)))
|
|
||||||
(when (send bmp save-file result.png 'png)
|
|
||||||
(printf "wrote ~a\n" result.png))
|
|
||||||
|
|
@ -1,88 +0,0 @@
|
||||||
#!/bin/sh
|
|
||||||
|
|
||||||
# This is a very simple job server which can be used to run commands in
|
|
||||||
# a different context. For example, for things that need to run from
|
|
||||||
# inside an OSX session rather than in the ssh-ed context.
|
|
||||||
|
|
||||||
here="$(cd $(dirname "$0"); pwd)"
|
|
||||||
pidfile="$here/pid"
|
|
||||||
|
|
||||||
unset LD_LIBRARY_PATH
|
|
||||||
|
|
||||||
###############################################################################
|
|
||||||
server() {
|
|
||||||
case "$serverstatus" in
|
|
||||||
( running ) echo "Server already running" 1>&2; exit 1 ;;
|
|
||||||
( stopped ) ;;
|
|
||||||
( dead ) echo "Cleaning up after dead server" 1>&2; rm -f "$pidfile" ;;
|
|
||||||
( * ) echo "Unknown server status" 1>&2; exit 1 ;;
|
|
||||||
esac
|
|
||||||
echo "Server started, pid=$$"
|
|
||||||
echo "$$" > "$pidfile"
|
|
||||||
trap cleanup 0 3 9 15
|
|
||||||
while true; do
|
|
||||||
cd "$here"
|
|
||||||
jobs="$(find * -name "*.job")"
|
|
||||||
if [[ "$jobs" = "" ]]; then sleep 2; continue; fi
|
|
||||||
echo "$jobs" | \
|
|
||||||
while read job; do
|
|
||||||
n="${job%.job}"
|
|
||||||
echo "Running job #$n..."
|
|
||||||
cd "$HOME"
|
|
||||||
. "$here/$job" > "$here/$n.out" 2>&1
|
|
||||||
echo "$?" > "$here/$n.ret"
|
|
||||||
cd "$here"
|
|
||||||
echo "Done"
|
|
||||||
rm -f "$here/$job"
|
|
||||||
done
|
|
||||||
done
|
|
||||||
}
|
|
||||||
|
|
||||||
cleanup() { rm -f "$pidfile"; }
|
|
||||||
|
|
||||||
###############################################################################
|
|
||||||
client() {
|
|
||||||
case "$serverstatus" in
|
|
||||||
( running ) ;;
|
|
||||||
( stopped ) echo "No server running" 1>&2; exit 1 ;;
|
|
||||||
( dead ) echo "Server died" 1>&2; exit 1 ;;
|
|
||||||
( * ) echo "Unknown server status" 1>&2; exit 1 ;;
|
|
||||||
esac
|
|
||||||
c="0"
|
|
||||||
if [[ -e "$here/counter" ]]; then c="$(cat "$here/counter")"; fi
|
|
||||||
c=$(( (c+1) % 10000 ))
|
|
||||||
echo "$c" > "$here/counter"
|
|
||||||
c="$here/$c"
|
|
||||||
echo "cd \"$(pwd)\"" > "$c.tmp"
|
|
||||||
if [[ "x$1" = "x-" ]]; then cat; else echo "$@"; fi >> "$c.tmp"
|
|
||||||
mv "$c.tmp" "$c.job"
|
|
||||||
while [[ -e "$c.job" ]]; do sleep 1; done
|
|
||||||
cat "$c.out"; rm -f "$c.out"
|
|
||||||
stat="$(cat "$c.ret")"; rm -f "$c.ret"
|
|
||||||
exit "$stat"
|
|
||||||
}
|
|
||||||
|
|
||||||
###############################################################################
|
|
||||||
status() {
|
|
||||||
echo "$serverstatus"
|
|
||||||
}
|
|
||||||
|
|
||||||
if [[ ! -e "$pidfile" ]]; then serverstatus="stopped"
|
|
||||||
else
|
|
||||||
pid="$(cat "$pidfile")"
|
|
||||||
if ps -p "$pid" | grep -q "$pid"; then serverstatus="running"
|
|
||||||
else serverstatus="dead"; fi
|
|
||||||
fi
|
|
||||||
|
|
||||||
###############################################################################
|
|
||||||
|
|
||||||
case "x$1" in
|
|
||||||
( "x--help" ) echo "--start: start server"
|
|
||||||
echo "--status: find the status of the running server, if any"
|
|
||||||
echo "Anything else, run it on the server; use \`-' to read"
|
|
||||||
echo " shell code from stdin"
|
|
||||||
exit ;;
|
|
||||||
( "x--start" ) shift; server "$@" ;;
|
|
||||||
( "x--status" ) shift; status "$@" ;;
|
|
||||||
( * ) client "$@" ;;
|
|
||||||
esac
|
|
||||||
|
|
@ -1,2 +0,0 @@
|
||||||
#lang info
|
|
||||||
(define compile-omit-paths 'all)
|
|
||||||
|
|
@ -1,200 +0,0 @@
|
||||||
#!/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)
|
|
||||||
|
|
@ -1,311 +0,0 @@
|
||||||
!include "MUI2.nsh"
|
|
||||||
!include "WinVer.nsh"
|
|
||||||
!include "nsDialogs.nsh"
|
|
||||||
|
|
||||||
;; ==================== Configuration
|
|
||||||
|
|
||||||
;; The following should define:
|
|
||||||
;; RKTVersion, RKTVersionLong, RKTHumanName, RKTShortName,
|
|
||||||
;; RKTStartName, RKTDirName, RKTRegName, RKTProgFiles,
|
|
||||||
;; RKTLaunchProgram
|
|
||||||
|
|
||||||
!include racket-defs.nsh
|
|
||||||
|
|
||||||
Name "${RKTHumanName}"
|
|
||||||
OutFile "installer.exe"
|
|
||||||
|
|
||||||
BrandingText "${RKTHumanName}"
|
|
||||||
BGGradient 4040A0 101020
|
|
||||||
|
|
||||||
SetCompressor /SOLID "LZMA"
|
|
||||||
|
|
||||||
InstallDir "${RKTProgFiles}\${RKTDirName}"
|
|
||||||
!ifndef SimpleInstaller
|
|
||||||
InstallDirRegKey HKLM "Software\${RKTRegName}" ""
|
|
||||||
!endif
|
|
||||||
!define MUI_STARTMENUPAGE_DEFAULTFOLDER "${RKTStartName}"
|
|
||||||
!define MUI_ICON "installer.ico"
|
|
||||||
!define MUI_UNICON "uninstaller.ico"
|
|
||||||
!define MUI_HEADERIMAGE
|
|
||||||
!define MUI_HEADERIMAGE_BITMAP "header.bmp"
|
|
||||||
!define MUI_HEADERIMAGE_BITMAP_RTL "header-r.bmp"
|
|
||||||
!define MUI_HEADERIMAGE_RIGHT
|
|
||||||
|
|
||||||
!define MUI_WELCOMEFINISHPAGE_BITMAP "welcome.bmp"
|
|
||||||
!define MUI_UNWELCOMEFINISHPAGE_BITMAP "welcome.bmp"
|
|
||||||
|
|
||||||
!define MUI_WELCOMEPAGE_TITLE "${RKTHumanName} Setup"
|
|
||||||
!define MUI_UNWELCOMEPAGE_TITLE "${RKTHumanName} Uninstall"
|
|
||||||
!ifdef SimpleInstaller
|
|
||||||
!define MUI_WELCOMEPAGE_TEXT "This is a simple installer for ${RKTShortName}.$\r$\n$\r$\nIt will only create the Racket folder. To uninstall, simply remove the folder.$\r$\n$\r$\n$_CLICK"
|
|
||||||
!else
|
|
||||||
!define MUI_WELCOMEPAGE_TEXT "This wizard will guide you through the installation of ${RKTShortName}.$\r$\n$\r$\nPlease close any running Racket applications so the installer can update the relevant system files.$\r$\n$\r$\n$_CLICK"
|
|
||||||
!endif
|
|
||||||
!define MUI_UNWELCOMEPAGE_TEXT "This wizard will guide you through the removal of ${RKTShortName}.$\r$\n$\r$\nBefore starting, make sure no Racket applications are running.$\r$\n$\r$\n$_CLICK"
|
|
||||||
|
|
||||||
!define MUI_FINISHPAGE_TITLE "${RKTHumanName}"
|
|
||||||
!ifdef SimpleInstaller
|
|
||||||
!define MUI_FINISHPAGE_RUN
|
|
||||||
!define MUI_FINISHPAGE_RUN_FUNCTION OpenInstDir
|
|
||||||
Function OpenInstDir
|
|
||||||
ExecShell "" "$INSTDIR"
|
|
||||||
FunctionEnd
|
|
||||||
!define MUI_FINISHPAGE_RUN_TEXT "Open the installation folder"
|
|
||||||
!else
|
|
||||||
!define MUI_FINISHPAGE_RUN "$INSTDIR\${RKTLaunchProgram}.exe"
|
|
||||||
!define MUI_FINISHPAGE_RUN_TEXT "Run ${RKTLaunchProgram}"
|
|
||||||
!endif
|
|
||||||
!define MUI_FINISHPAGE_LINK "Visit the Racket web site"
|
|
||||||
!define MUI_FINISHPAGE_LINK_LOCATION "http://racket-lang.org/"
|
|
||||||
|
|
||||||
; !define MUI_UNFINISHPAGE_NOAUTOCLOSE ; to allow users see what was erased
|
|
||||||
|
|
||||||
!define MUI_STARTMENUPAGE_REGISTRY_ROOT "HKLM"
|
|
||||||
!define MUI_STARTMENUPAGE_REGISTRY_KEY "Software\${RKTRegName}"
|
|
||||||
!define MUI_STARTMENUPAGE_REGISTRY_VALUENAME "Start Menu Folder"
|
|
||||||
|
|
||||||
; Doesn't work on some non-xp machines
|
|
||||||
; !define MUI_INSTFILESPAGE_PROGRESSBAR colored
|
|
||||||
|
|
||||||
VIProductVersion "${RKTVersionLong}"
|
|
||||||
VIAddVersionKey "ProductName" "Racket"
|
|
||||||
VIAddVersionKey "Comments" "This is the Racket language, see http://racket-lang.org/."
|
|
||||||
VIAddVersionKey "CompanyName" "PLT Design Inc."
|
|
||||||
VIAddVersionKey "LegalCopyright" "© PLT Design Inc."
|
|
||||||
VIAddVersionKey "FileDescription" "Racket Installer"
|
|
||||||
VIAddVersionKey "FileVersion" "${RKTVersion}"
|
|
||||||
|
|
||||||
;; ==================== Variables
|
|
||||||
|
|
||||||
!ifndef SimpleInstaller
|
|
||||||
Var MUI_TEMP
|
|
||||||
Var STARTMENU_FOLDER
|
|
||||||
!endif
|
|
||||||
|
|
||||||
;; ==================== Interface
|
|
||||||
|
|
||||||
!define MUI_ABORTWARNING
|
|
||||||
|
|
||||||
; Install
|
|
||||||
!insertmacro MUI_PAGE_WELCOME
|
|
||||||
!define MUI_PAGE_CUSTOMFUNCTION_LEAVE myTestInstDir
|
|
||||||
!insertmacro MUI_PAGE_DIRECTORY
|
|
||||||
!ifndef SimpleInstaller
|
|
||||||
!insertmacro MUI_PAGE_STARTMENU Application $STARTMENU_FOLDER
|
|
||||||
!endif
|
|
||||||
!insertmacro MUI_PAGE_INSTFILES
|
|
||||||
|
|
||||||
; Uncheck and hide the "run" checkbox on vista, since it will run with
|
|
||||||
; elevated permissions (see also ../nsis-vista-note.txt)
|
|
||||||
!define MUI_PAGE_CUSTOMFUNCTION_SHOW DisableRunCheckBoxIfOnVista
|
|
||||||
!insertmacro MUI_PAGE_FINISH
|
|
||||||
Function DisableRunCheckBoxIfOnVista
|
|
||||||
${If} ${AtLeastWinVista}
|
|
||||||
; use EnableWindow instead of ShowWindow to just disable it
|
|
||||||
ShowWindow $mui.FinishPage.Run 0
|
|
||||||
${NSD_Uncheck} $mui.FinishPage.Run
|
|
||||||
${EndIf}
|
|
||||||
FunctionEnd
|
|
||||||
|
|
||||||
!ifndef SimpleInstaller
|
|
||||||
; Uninstall
|
|
||||||
!define MUI_WELCOMEPAGE_TITLE "${MUI_UNWELCOMEPAGE_TITLE}"
|
|
||||||
!define MUI_WELCOMEPAGE_TEXT "${MUI_UNWELCOMEPAGE_TEXT}"
|
|
||||||
; !insertmacro MUI_UNPAGE_WELCOME
|
|
||||||
!insertmacro MUI_UNPAGE_CONFIRM
|
|
||||||
!insertmacro MUI_UNPAGE_INSTFILES
|
|
||||||
; !insertmacro MUI_UNPAGE_FINISH
|
|
||||||
!endif
|
|
||||||
|
|
||||||
!ifndef SimpleInstaller
|
|
||||||
!define MUI_CUSTOMFUNCTION_UNGUIINIT un.myGUIInit
|
|
||||||
!endif
|
|
||||||
|
|
||||||
!insertmacro MUI_LANGUAGE "English"
|
|
||||||
|
|
||||||
!ifndef SimpleInstaller
|
|
||||||
!define UNINSTEXE "$INSTDIR\Uninstall.exe"
|
|
||||||
!endif
|
|
||||||
|
|
||||||
;; ==================== Installer
|
|
||||||
|
|
||||||
!ifdef SimpleInstaller
|
|
||||||
Function myTestInstDir
|
|
||||||
IfFileExists "$INSTDIR\*.*" +1 inst_dir_exists
|
|
||||||
MessageBox MB_YESNO "The directory '$INSTDIR' already exists, continue?" /SD IDYES IDYES inst_dir_exists
|
|
||||||
Abort
|
|
||||||
inst_dir_exists:
|
|
||||||
FunctionEnd
|
|
||||||
!else
|
|
||||||
Function myTestInstDir
|
|
||||||
; The assumption is that users might have all kinds of ways to get a Racket
|
|
||||||
; tree, plus, they might have an old wise-based installation, so it is better
|
|
||||||
; to rely on files rather than test registry keys. Note: no version check.
|
|
||||||
; if any of these exist, then we assume it's an old installation
|
|
||||||
IfFileExists "$INSTDIR\Racket.exe" racket_is_installed
|
|
||||||
IfFileExists "$INSTDIR\${RKTLaunchProgram}.exe" racket_is_installed
|
|
||||||
IfFileExists "$INSTDIR\collects" racket_is_installed
|
|
||||||
Goto racket_is_not_installed
|
|
||||||
racket_is_installed:
|
|
||||||
IfFileExists "${UNINSTEXE}" we_have_uninstall
|
|
||||||
MessageBox MB_YESNO "It appears that there is an existing Racket installation in '$INSTDIR', but no Uninstaller was found.$\r$\nContinue anyway (not recommended)?" /SD IDYES IDYES maybe_remove_tree
|
|
||||||
Abort
|
|
||||||
we_have_uninstall:
|
|
||||||
MessageBox MB_YESNO "It appears that there is an existing Racket installation in '$INSTDIR'.$\r$\nDo you want to uninstall it first (recommended)?" /SD IDNO IDNO maybe_remove_tree
|
|
||||||
HideWindow
|
|
||||||
ClearErrors
|
|
||||||
ExecWait '"${UNINSTEXE}" _?=$INSTDIR'
|
|
||||||
IfErrors uninstaller_problematic
|
|
||||||
IfFileExists "$INSTDIR\Racket.exe" uninstaller_problematic
|
|
||||||
IfFileExists "$INSTDIR\GRacket.exe" uninstaller_problematic
|
|
||||||
BringToFront
|
|
||||||
Goto racket_is_not_installed
|
|
||||||
uninstaller_problematic:
|
|
||||||
MessageBox MB_YESNO "Errors in uninstallation!$\r$\nDo you want to quit and sort things out now (highly recommended)?" /SD IDNO IDNO maybe_remove_tree
|
|
||||||
Quit
|
|
||||||
maybe_remove_tree:
|
|
||||||
MessageBox MB_YESNO "Since you insist, do you want to simply remove the previous directory now?$\r$\n(It is really better if you sort this out manually.)" /SD IDYES IDNO racket_is_not_installed
|
|
||||||
RMDir /r $INSTDIR
|
|
||||||
racket_is_not_installed:
|
|
||||||
FunctionEnd
|
|
||||||
!endif
|
|
||||||
|
|
||||||
Section ""
|
|
||||||
SetShellVarContext all
|
|
||||||
|
|
||||||
SetDetailsPrint both
|
|
||||||
DetailPrint "Installing Racket..."
|
|
||||||
SetDetailsPrint listonly
|
|
||||||
SetOutPath "$INSTDIR"
|
|
||||||
File /a /r "racket\*.*"
|
|
||||||
!ifndef SimpleInstaller
|
|
||||||
WriteUninstaller "${UNINSTEXE}" ; Create uninstaller
|
|
||||||
!endif
|
|
||||||
|
|
||||||
!ifndef SimpleInstaller
|
|
||||||
SetDetailsPrint both
|
|
||||||
DetailPrint "Creating Shortcuts..."
|
|
||||||
SetDetailsPrint listonly
|
|
||||||
!insertmacro MUI_STARTMENU_WRITE_BEGIN Application
|
|
||||||
SetOutPath "$INSTDIR" ; Make installed links run in INSTDIR
|
|
||||||
CreateDirectory "$SMPROGRAMS\$STARTMENU_FOLDER"
|
|
||||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\DrRacket.lnk" "$INSTDIR\DrRacket.exe"
|
|
||||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\Racket Documentation.lnk" "$INSTDIR\Racket Documentation.exe"
|
|
||||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\GRacket.lnk" "$INSTDIR\GRacket.exe"
|
|
||||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\Racket.lnk" "$INSTDIR\Racket.exe"
|
|
||||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\Racket Folder.lnk" "$INSTDIR"
|
|
||||||
CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\Uninstall.lnk" "${UNINSTEXE}"
|
|
||||||
!insertmacro MUI_STARTMENU_WRITE_END
|
|
||||||
|
|
||||||
SetDetailsPrint both
|
|
||||||
DetailPrint "Setting Registry Keys..."
|
|
||||||
SetDetailsPrint listonly
|
|
||||||
WriteRegStr HKLM "Software\${RKTRegName}" "" "$INSTDIR" ; Save folder location
|
|
||||||
WriteRegStr HKCR ".rkt" "" "Racket.Document"
|
|
||||||
WriteRegStr HKCR ".rktl" "" "Racket.Document"
|
|
||||||
WriteRegStr HKCR ".rktd" "" "Racket.Document"
|
|
||||||
WriteRegStr HKCR ".ss" "" "Racket.Document"
|
|
||||||
WriteRegStr HKCR ".scm" "" "Racket.Document"
|
|
||||||
WriteRegStr HKCR ".scrbl" "" "Racket.Document"
|
|
||||||
WriteRegStr HKCR "Racket.Document" "" "Racket Document"
|
|
||||||
WriteRegStr HKCR "Racket.Document\DefaultIcon" "" "$INSTDIR\collects\icons\schemedoc.ico"
|
|
||||||
WriteRegStr HKCR "Racket.Document\shell\open\command" "" '"$INSTDIR\DrRacket.exe" "%1"'
|
|
||||||
; Example, in case we want some things like this in the future
|
|
||||||
; WriteRegStr HKCR "Racket.Document\shell\racket" "" "Run with Racket"
|
|
||||||
; WriteRegStr HKCR "Racket.Document\shell\racket\command" "" '"$INSTDIR\Racket.exe" "-r" "%1"'
|
|
||||||
WriteRegStr HKCR ".plt" "" "Racket Setup.Document"
|
|
||||||
WriteRegStr HKCR "Racket Setup.Document" "" "Racket Package"
|
|
||||||
WriteRegStr HKCR "Racket Setup.Document\DefaultIcon" "" "$INSTDIR\collects\icons\schemedoc.ico"
|
|
||||||
WriteRegStr HKCR "Racket Setup.Document\shell\open\command" "" '"$INSTDIR\raco.exe" setup -p "%1"'
|
|
||||||
|
|
||||||
WriteRegExpandStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "UninstallString" '"${UNINSTEXE}"'
|
|
||||||
WriteRegExpandStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "InstallLocation" "$INSTDIR"
|
|
||||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "DisplayName" "${RKTHumanName}"
|
|
||||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "DisplayIcon" "$INSTDIR\DrRacket.exe,0"
|
|
||||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "DisplayVersion" "${RKTVersion}"
|
|
||||||
; used to also have "VersionMajor" & "VersionMinor" but looks like it's not needed
|
|
||||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "HelpLink" "http://racket-lang.org/"
|
|
||||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "URLInfoAbout" "http://racket-lang.org/"
|
|
||||||
WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "Publisher" "PLT Design Inc."
|
|
||||||
WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "NoModify" "1"
|
|
||||||
WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "NoRepair" "1"
|
|
||||||
!endif
|
|
||||||
|
|
||||||
SetDetailsPrint both
|
|
||||||
DetailPrint "Installation complete."
|
|
||||||
SectionEnd
|
|
||||||
|
|
||||||
;; ==================== Uninstaller
|
|
||||||
|
|
||||||
!ifndef SimpleInstaller
|
|
||||||
|
|
||||||
Function un.myGUIInit
|
|
||||||
; if any of these exist, then we're fine
|
|
||||||
IfFileExists "$INSTDIR\Racket.exe" racket_is_installed_un
|
|
||||||
IfFileExists "$INSTDIR\lib\GRacket.exe" racket_is_installed_un
|
|
||||||
IfFileExists "$INSTDIR\DrRacket.exe" racket_is_installed_un
|
|
||||||
IfFileExists "$INSTDIR\lib\collects" racket_is_installed_un
|
|
||||||
MessageBox MB_YESNO "It does not appear that Racket is installed in '$INSTDIR'.$\r$\nContinue anyway (not recommended)?" /SD IDYES IDYES racket_is_installed_un
|
|
||||||
Abort "Uninstall aborted by user"
|
|
||||||
racket_is_installed_un:
|
|
||||||
FunctionEnd
|
|
||||||
|
|
||||||
Section "Uninstall"
|
|
||||||
SetShellVarContext all
|
|
||||||
|
|
||||||
SetDetailsPrint both
|
|
||||||
DetailPrint "Removing the Racket installation..."
|
|
||||||
SetDetailsPrint listonly
|
|
||||||
Delete "$INSTDIR\*.exe"
|
|
||||||
Delete "$INSTDIR\README*.*"
|
|
||||||
RMDir /r "$INSTDIR\collects"
|
|
||||||
RMDir /r "$INSTDIR\include"
|
|
||||||
RMDir /r "$INSTDIR\lib"
|
|
||||||
RMDir /r "$INSTDIR\doc"
|
|
||||||
;; these exist in Racket-Full installations
|
|
||||||
RMDir /r "$INSTDIR\man"
|
|
||||||
RMDir /r "$INSTDIR\src"
|
|
||||||
Delete "${UNINSTEXE}"
|
|
||||||
RMDir "$INSTDIR"
|
|
||||||
;; if the directory is opened, it will take some time to remove
|
|
||||||
Sleep 1000
|
|
||||||
IfErrors +1 uninstall_inst_dir_ok
|
|
||||||
MessageBox MB_YESNO "The Racket installation at '$INSTDIR' was not completely removed.$\r$\nForce deletion?$\r$\n(Make sure no Racket applications are running.)" /SD IDYES IDNO uninstall_inst_dir_ok
|
|
||||||
RMDir /r "$INSTDIR"
|
|
||||||
IfErrors +1 uninstall_inst_dir_ok
|
|
||||||
MessageBox MB_OK "Forced deletion did not work either, you will need to clean up '$INSTDIR' manually." /SD IDOK
|
|
||||||
uninstall_inst_dir_ok:
|
|
||||||
|
|
||||||
SetDetailsPrint both
|
|
||||||
DetailPrint "Removing Shortcuts..."
|
|
||||||
SetDetailsPrint listonly
|
|
||||||
!insertmacro MUI_STARTMENU_GETFOLDER Application $MUI_TEMP
|
|
||||||
Delete "$SMPROGRAMS\$MUI_TEMP\*.lnk"
|
|
||||||
;; Delete empty start menu parent diretories
|
|
||||||
StrCpy $MUI_TEMP "$SMPROGRAMS\$MUI_TEMP"
|
|
||||||
startMenuDeleteLoop:
|
|
||||||
RMDir $MUI_TEMP
|
|
||||||
GetFullPathName $MUI_TEMP "$MUI_TEMP\.."
|
|
||||||
IfErrors startMenuDeleteLoopDone
|
|
||||||
StrCmp $MUI_TEMP $SMPROGRAMS startMenuDeleteLoopDone startMenuDeleteLoop
|
|
||||||
startMenuDeleteLoopDone:
|
|
||||||
|
|
||||||
SetDetailsPrint both
|
|
||||||
DetailPrint "Removing Registry Keys..."
|
|
||||||
SetDetailsPrint listonly
|
|
||||||
DeleteRegKey /ifempty HKLM "Software\${RKTRegName}\Start Menu Folder"
|
|
||||||
DeleteRegKey /ifempty HKLM "Software\${RKTRegName}"
|
|
||||||
DeleteRegKey HKCR ".rkt"
|
|
||||||
DeleteRegKey HKCR ".rktl"
|
|
||||||
DeleteRegKey HKCR ".rktd"
|
|
||||||
DeleteRegKey HKCR ".ss"
|
|
||||||
DeleteRegKey HKCR ".scm"
|
|
||||||
DeleteRegKey HKCR ".scrbl"
|
|
||||||
DeleteRegKey HKCR "Racket.Document"
|
|
||||||
DeleteRegKey HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}"
|
|
||||||
|
|
||||||
SetDetailsPrint both
|
|
||||||
DetailPrint "Uninstallation complete."
|
|
||||||
SectionEnd
|
|
||||||
|
|
||||||
!endif
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
opensource@google.com
|
|
||||||
|
|
@ -1,37 +0,0 @@
|
||||||
Copyright (c) 2004, 2005, Google Inc.
|
|
||||||
All rights reserved.
|
|
||||||
|
|
||||||
Redistribution and use in source and binary forms, with or without
|
|
||||||
modification, are permitted provided that the following conditions
|
|
||||||
are met:
|
|
||||||
|
|
||||||
* Redistributions of source code must retain the above copyright
|
|
||||||
notice, this list of conditions and the following disclaimer.
|
|
||||||
|
|
||||||
* Redistributions in binary form must reproduce the above
|
|
||||||
copyright notice, this list of conditions and the following
|
|
||||||
disclaimer in the documentation and/or other materials provided
|
|
||||||
with the distribution.
|
|
||||||
|
|
||||||
* Neither the name of Google Inc. nor the names of its contributors
|
|
||||||
may be used to endorse or promote products derived from this
|
|
||||||
software without specific prior written permission.
|
|
||||||
|
|
||||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
|
||||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
|
||||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
|
||||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
|
||||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
|
||||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
|
||||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
|
||||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
|
||||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
||||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
|
||||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
|
|
||||||
|
|
||||||
The sitemap_gen.py script is written in Python 2.2 and released to the open
|
|
||||||
source community for continuous improvements under the BSD 2.0 new license,
|
|
||||||
which can be found at:
|
|
||||||
|
|
||||||
http://www.opensource.org/licenses/bsd-license.php
|
|
||||||
|
|
@ -1,65 +0,0 @@
|
||||||
Wed Jun 01 01:00:00 2005 Google Inc. <opensource@google.com>
|
|
||||||
|
|
||||||
* sitemap_gen: initial release:
|
|
||||||
This directory contains Python utilities for creating
|
|
||||||
Sitemaps.
|
|
||||||
|
|
||||||
Mon Jun 13 01:00:00 2005 Google Inc. <opensource@google.com>
|
|
||||||
|
|
||||||
* sitemap_gen.py: v1.1
|
|
||||||
|
|
||||||
[BIG]
|
|
||||||
Not blow up when dealing with international character encodings.
|
|
||||||
|
|
||||||
[MODERATE]
|
|
||||||
Fix platform and Python version issues. In some versions of 2.2
|
|
||||||
and certain platforms, True was not defined. Gak!
|
|
||||||
|
|
||||||
Tue Jul 12 01:00:00 2005 Google Inc. <opensource@google.com>
|
|
||||||
|
|
||||||
* sitemap_gen.py: v1.2
|
|
||||||
|
|
||||||
[MODERATE]
|
|
||||||
Default_file option added to directory walking
|
|
||||||
Support for Extended Logfile Format (IIS's log format)
|
|
||||||
Allow wildcards in the "path" attribute on accesslog and urllist
|
|
||||||
input methods.
|
|
||||||
Running on Python 1.5 should exit cleanly with an error message
|
|
||||||
Stricter processing of configuration files
|
|
||||||
|
|
||||||
[SMALL]
|
|
||||||
XML files written in "text" mode, so linefeeds are correct
|
|
||||||
One more Unicode issue fixed: Sitemap filenames with non-ascii
|
|
||||||
characters had still been problematic
|
|
||||||
In directory walking, the root URL of the walk now gets included
|
|
||||||
In directory walking, URLs to directories now have a "/" appended
|
|
||||||
URLs to files we recognize as our own script's Sitemap output files
|
|
||||||
are suppressed.
|
|
||||||
'suppress_search_engine_notify="0"' now does what you would expect
|
|
||||||
Default priority on URLs is now 0.5 instead of 1.0
|
|
||||||
Priority values written by default to only 4 decimal places
|
|
||||||
URLs to Sitemap files in the Sitemap index file are now encoded
|
|
||||||
according to the user's default_encoding, instead of forcing to UTF-8
|
|
||||||
|
|
||||||
Mon Aug 01 01:00:00 2005 Google Inc. <opensource@google.com>
|
|
||||||
|
|
||||||
* sitemap_gen.py: v1.3
|
|
||||||
|
|
||||||
[BIG]
|
|
||||||
<sitemap ... /> input method added.
|
|
||||||
|
|
||||||
[MODERATE]
|
|
||||||
Use proper IDNA encoding on international domain names. This is
|
|
||||||
only available on Python2.3 or higher.
|
|
||||||
|
|
||||||
[SMALL]
|
|
||||||
Fixed Windows bug where directory walking would generate bad URLs on
|
|
||||||
2+ deep subdirectories
|
|
||||||
|
|
||||||
Wed Nov 03 01:00:00 2005 Google Inc. <opensource@google.com>
|
|
||||||
|
|
||||||
* sitemap_gen.py: v1.4
|
|
||||||
|
|
||||||
[SMALL]
|
|
||||||
Fixed bug where writing a gzipped sitemap would store the server's
|
|
||||||
file path in the archive.
|
|
||||||
|
|
@ -1,10 +0,0 @@
|
||||||
Metadata-Version: 1.0
|
|
||||||
Name: sitemap_gen
|
|
||||||
Version: 1.4
|
|
||||||
Summary: Sitemap Generator
|
|
||||||
Home-page: http://sourceforge.net/projects/goog-sitemapgen/
|
|
||||||
Author: Google Inc.
|
|
||||||
Author-email: opensource@google.com
|
|
||||||
License: BSD
|
|
||||||
Description: UNKNOWN
|
|
||||||
Platform: UNKNOWN
|
|
||||||
|
|
@ -1,25 +0,0 @@
|
||||||
sitemap_gen.py
|
|
||||||
|
|
||||||
Version 1.4
|
|
||||||
|
|
||||||
The sitemap_gen.py script analyzes your web server and generates one or more
|
|
||||||
Sitemap files. These files are XML listings of content you make available on
|
|
||||||
your web server. The files can be directly submitted to search engines as
|
|
||||||
hints for the search engine web crawlers as they index your web site. This
|
|
||||||
can result in better coverage of your web content in search engine indices,
|
|
||||||
and less of your bandwidth spent doing it.
|
|
||||||
|
|
||||||
The sitemap_gen.py script is written in Python and released to the open
|
|
||||||
source community for continuous improvements under the BSD 2.0 new license,
|
|
||||||
which can be found at:
|
|
||||||
|
|
||||||
http://www.opensource.org/licenses/bsd-license.php
|
|
||||||
|
|
||||||
The original release notes for the script, including a walk-through for
|
|
||||||
webmasters on how to use it, can be found at the following site:
|
|
||||||
|
|
||||||
http://www.google.com/webmasters/sitemaps/sitemap-generator.html
|
|
||||||
|
|
||||||
The minimum Python version required is Python 2.2. However, if URLs on
|
|
||||||
your site involve any non-ASCII characters, we strongly recommend
|
|
||||||
Python 2.3 or later, as it better handles encoding issues.
|
|
||||||
|
|
@ -1,164 +0,0 @@
|
||||||
<?xml version="1.0" encoding="UTF-8"?>
|
|
||||||
<!--
|
|
||||||
sitemap_gen.py example configuration script
|
|
||||||
|
|
||||||
This file specifies a set of sample input parameters for the
|
|
||||||
sitemap_gen.py client.
|
|
||||||
|
|
||||||
You should copy this file into "config.xml" and modify it for
|
|
||||||
your server.
|
|
||||||
|
|
||||||
|
|
||||||
********************************************************* -->
|
|
||||||
|
|
||||||
|
|
||||||
<!-- ** MODIFY **
|
|
||||||
The "site" node describes your basic web site.
|
|
||||||
|
|
||||||
Required attributes:
|
|
||||||
base_url - the top-level URL of the site being mapped
|
|
||||||
store_into - the webserver path to the desired output file.
|
|
||||||
This should end in '.xml' or '.xml.gz'
|
|
||||||
(the script will create this file)
|
|
||||||
|
|
||||||
Optional attributes:
|
|
||||||
verbose - an integer from 0 (quiet) to 3 (noisy) for
|
|
||||||
how much diagnostic output the script gives
|
|
||||||
suppress_search_engine_notify="1"
|
|
||||||
- disables notifying search engines about the new map
|
|
||||||
(same as the "testing" command-line argument.)
|
|
||||||
default_encoding
|
|
||||||
- names a character encoding to use for URLs and
|
|
||||||
file paths. (Example: "UTF-8")
|
|
||||||
-->
|
|
||||||
<site
|
|
||||||
base_url="http://www.example.com/"
|
|
||||||
store_into="/var/www/docroot/sitemap.xml.gz"
|
|
||||||
verbose="1"
|
|
||||||
>
|
|
||||||
|
|
||||||
<!-- ********************************************************
|
|
||||||
INPUTS
|
|
||||||
|
|
||||||
All the various nodes in this section control where the script
|
|
||||||
looks to find URLs.
|
|
||||||
|
|
||||||
MODIFY or DELETE these entries as appropriate for your server.
|
|
||||||
********************************************************* -->
|
|
||||||
|
|
||||||
<!-- ** MODIFY or DELETE **
|
|
||||||
"url" nodes specify individual URLs to include in the map.
|
|
||||||
|
|
||||||
Required attributes:
|
|
||||||
href - the URL
|
|
||||||
|
|
||||||
Optional attributes:
|
|
||||||
lastmod - timestamp of last modification (ISO8601 format)
|
|
||||||
changefreq - how often content at this URL is usually updated
|
|
||||||
priority - value 0.0 to 1.0 of relative importance in your site
|
|
||||||
-->
|
|
||||||
<url href="http://www.example.com/stats?q=name" />
|
|
||||||
<url
|
|
||||||
href="http://www.example.com/stats?q=age"
|
|
||||||
lastmod="2004-11-14T01:00:00-07:00"
|
|
||||||
changefreq="yearly"
|
|
||||||
priority="0.3"
|
|
||||||
/>
|
|
||||||
|
|
||||||
|
|
||||||
<!-- ** MODIFY or DELETE **
|
|
||||||
"urllist" nodes name text files with lists of URLs.
|
|
||||||
An example file "example_urllist.txt" is provided.
|
|
||||||
|
|
||||||
Required attributes:
|
|
||||||
path - path to the file
|
|
||||||
|
|
||||||
Optional attributes:
|
|
||||||
encoding - encoding of the file if not US-ASCII
|
|
||||||
-->
|
|
||||||
<urllist path="example_urllist.txt" encoding="UTF-8" />
|
|
||||||
|
|
||||||
|
|
||||||
<!-- ** MODIFY or DELETE **
|
|
||||||
"directory" nodes tell the script to walk the file system
|
|
||||||
and include all files and directories in the Sitemap.
|
|
||||||
|
|
||||||
Required attributes:
|
|
||||||
path - path to begin walking from
|
|
||||||
url - URL equivalent of that path
|
|
||||||
|
|
||||||
Optional attributes:
|
|
||||||
default_file - name of the index or default file for directory URLs
|
|
||||||
-->
|
|
||||||
<directory path="/var/www/icons" url="http://www.example.com/images/" />
|
|
||||||
<directory
|
|
||||||
path="/var/www/docroot"
|
|
||||||
url="http://www.example.com/"
|
|
||||||
default_file="index.html"
|
|
||||||
/>
|
|
||||||
|
|
||||||
|
|
||||||
<!-- ** MODIFY or DELETE **
|
|
||||||
"accesslog" nodes tell the script to scan webserver log files to
|
|
||||||
extract URLs on your site. Both Common Logfile Format (Apache's default
|
|
||||||
logfile) and Extended Logfile Format (IIS's default logfile) can be read.
|
|
||||||
|
|
||||||
Required attributes:
|
|
||||||
path - path to the file
|
|
||||||
|
|
||||||
Optional attributes:
|
|
||||||
encoding - encoding of the file if not US-ASCII
|
|
||||||
-->
|
|
||||||
<accesslog path="/etc/httpd/logs/access.log" encoding="UTF-8" />
|
|
||||||
<accesslog path="/etc/httpd/logs/access.log.0" encoding="UTF-8" />
|
|
||||||
<accesslog path="/etc/httpd/logs/access.log.1.gz" encoding="UTF-8" />
|
|
||||||
|
|
||||||
|
|
||||||
<!-- ** MODIFY or DELETE **
|
|
||||||
"sitemap" nodes tell the script to scan other Sitemap files. This can
|
|
||||||
be useful to aggregate the results of multiple runs of this script into
|
|
||||||
a single Sitemap.
|
|
||||||
|
|
||||||
Required attributes:
|
|
||||||
path - path to the file
|
|
||||||
-->
|
|
||||||
<sitemap path="/var/www/docroot/subpath/sitemap.xml" />
|
|
||||||
|
|
||||||
|
|
||||||
<!-- ********************************************************
|
|
||||||
FILTERS
|
|
||||||
|
|
||||||
Filters specify wild-card patterns that the script compares
|
|
||||||
against all URLs it finds. Filters can be used to exclude
|
|
||||||
certain URLs from your Sitemap, for instance if you have
|
|
||||||
hidden content that you hope the search engines don't find.
|
|
||||||
|
|
||||||
Filters can be either type="wildcard", which means standard
|
|
||||||
path wildcards (* and ?) are used to compare against URLs,
|
|
||||||
or type="regexp", which means regular expressions are used
|
|
||||||
to compare.
|
|
||||||
|
|
||||||
Filters are applied in the order specified in this file.
|
|
||||||
|
|
||||||
An action="drop" filter causes exclusion of matching URLs.
|
|
||||||
An action="pass" filter causes inclusion of matching URLs,
|
|
||||||
shortcutting any other later filters that might also match.
|
|
||||||
If no filter at all matches a URL, the URL will be included.
|
|
||||||
Together you can build up fairly complex rules.
|
|
||||||
|
|
||||||
The default action is "drop".
|
|
||||||
The default type is "wildcard".
|
|
||||||
|
|
||||||
You can MODIFY or DELETE these entries as appropriate for
|
|
||||||
your site. However, unlike above, the example entries in
|
|
||||||
this section are not contrived and may be useful to you as
|
|
||||||
they are.
|
|
||||||
********************************************************* -->
|
|
||||||
|
|
||||||
<!-- Exclude URLs that end with a '~' (IE: emacs backup files) -->
|
|
||||||
<filter action="drop" type="wildcard" pattern="*~" />
|
|
||||||
|
|
||||||
<!-- Exclude URLs within UNIX-style hidden files or directories -->
|
|
||||||
<filter action="drop" type="regexp" pattern="/\.[^/]*" />
|
|
||||||
|
|
||||||
</site>
|
|
||||||
|
|
@ -1,21 +0,0 @@
|
||||||
# To add a list of URLs, make a space-delimited text file. The first
|
|
||||||
# column contains the URL; then you can specify various optional
|
|
||||||
# attributes in the form key=value:
|
|
||||||
#
|
|
||||||
# lastmod = modification time in ISO8601 (YYYY-MM-DDThh:mm:ss+00:00)
|
|
||||||
# changefreq = 'always' | 'hourly' | 'daily' | 'weekly' | 'monthly' |
|
|
||||||
# 'yearly' | 'never'
|
|
||||||
# priority = priority of the page relative to other pages on the same site;
|
|
||||||
# a number between 0.0 and 1.0, where 0.0 is the lowest priority
|
|
||||||
# and 1.0 is the highest priority
|
|
||||||
#
|
|
||||||
# Note that all URLs must be part of the site, and therefore must begin with
|
|
||||||
# the base_url (e.g., 'http://www.example.com/') as specified in config.xml.
|
|
||||||
#
|
|
||||||
# Any line beginning with a # is a comment.
|
|
||||||
#
|
|
||||||
# Example contents of the file:
|
|
||||||
#
|
|
||||||
# http://www.example.com/foo/bar
|
|
||||||
# http://www.example.com/foo/xxx.pdf lastmod=2003-12-31T14:05:06+00:00
|
|
||||||
# http://www.example.com/foo/yyy?x=12&y=23 changefreq=weekly priority=0.3
|
|
||||||
|
|
@ -1,16 +0,0 @@
|
||||||
<?xml version="1.0" encoding="UTF-8"?>
|
|
||||||
<site base_url="http://pre.plt-scheme.org/"
|
|
||||||
store_into="/home/scheme/html/sitemap.xml.gz"
|
|
||||||
verbose="1">
|
|
||||||
<directory path="/home/scheme/html/"
|
|
||||||
url="http://pre.plt-scheme.org/"
|
|
||||||
default_file="index.html" />
|
|
||||||
<!-- Exclude URLs that end with a '~' (IE: emacs backup files) -->
|
|
||||||
<filter action="drop" type="wildcard" pattern="*~" />
|
|
||||||
<!-- Exclude URLs within UNIX-style hidden files or directories -->
|
|
||||||
<filter action="drop" type="regexp" pattern="/\.[^/]*" />
|
|
||||||
<!-- Exclude .plt files -->
|
|
||||||
<filter action="drop" type="wildcard" pattern="*.plt" />
|
|
||||||
<!-- Exclude possible nested trees -->
|
|
||||||
<filter action="drop" type="regexp" pattern="^http://[^/]*/[0-9]+" />
|
|
||||||
</site>
|
|
||||||
|
|
@ -1,12 +0,0 @@
|
||||||
#!/usr/bin/env python
|
|
||||||
|
|
||||||
from distutils.core import setup
|
|
||||||
|
|
||||||
setup(name='sitemap_gen',
|
|
||||||
version='1.4',
|
|
||||||
description='Sitemap Generator',
|
|
||||||
license='BSD',
|
|
||||||
author='Google Inc.',
|
|
||||||
author_email='opensource@google.com',
|
|
||||||
url='http://sourceforge.net/projects/goog-sitemapgen/',
|
|
||||||
)
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,765 +0,0 @@
|
||||||
#!/usr/bin/env python
|
|
||||||
#
|
|
||||||
# Copyright (c) 2004, 2005 Google Inc.
|
|
||||||
# All rights reserved.
|
|
||||||
#
|
|
||||||
# Redistribution and use in source and binary forms, with or without
|
|
||||||
# modification, are permitted provided that the following conditions
|
|
||||||
# are met:
|
|
||||||
#
|
|
||||||
# * Redistributions of source code must retain the above copyright
|
|
||||||
# notice, this list of conditions and the following disclaimer.
|
|
||||||
#
|
|
||||||
# * Redistributions in binary form must reproduce the above copyright
|
|
||||||
# notice, this list of conditions and the following disclaimer in
|
|
||||||
# the documentation and/or other materials provided with the
|
|
||||||
# distribution.
|
|
||||||
#
|
|
||||||
# * Neither the name of Google nor the names of its contributors may
|
|
||||||
# be used to endorse or promote products derived from this software
|
|
||||||
# without specific prior written permission.
|
|
||||||
#
|
|
||||||
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
|
||||||
# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
|
||||||
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
|
|
||||||
# FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
|
||||||
# COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
|
||||||
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
|
|
||||||
# BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
|
||||||
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
|
||||||
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
|
||||||
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
|
||||||
# ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
# POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
#
|
|
||||||
#
|
|
||||||
# The sitemap_gen.py script is written in Python 2.2 and released to
|
|
||||||
# the open source community for continuous improvements under the BSD
|
|
||||||
# 2.0 new license, which can be found at:
|
|
||||||
#
|
|
||||||
# http://www.opensource.org/licenses/bsd-license.php
|
|
||||||
#
|
|
||||||
|
|
||||||
"""Unit tests for sitemap_gen.py, a script for generating sitemaps
|
|
||||||
for a web server.
|
|
||||||
"""
|
|
||||||
|
|
||||||
# Please be careful that all syntax used in this file can be parsed on
|
|
||||||
# Python 1.5 -- this version check is not evaluated until after the
|
|
||||||
# entire file has been parsed.
|
|
||||||
import sys
|
|
||||||
if sys.hexversion < 0x02020000:
|
|
||||||
print 'This script requires Python 2.2 or later.'
|
|
||||||
print 'Currently run with version: %s' % sys.version
|
|
||||||
sys.exit(1)
|
|
||||||
|
|
||||||
import binascii
|
|
||||||
import fnmatch
|
|
||||||
import gzip
|
|
||||||
import os
|
|
||||||
import tempfile
|
|
||||||
import unittest
|
|
||||||
import xml.dom.minidom
|
|
||||||
import sitemap_gen
|
|
||||||
|
|
||||||
# True and False were introduced in Python2.2.2
|
|
||||||
try:
|
|
||||||
testTrue=True
|
|
||||||
del testTrue
|
|
||||||
except NameError:
|
|
||||||
True=1
|
|
||||||
False=0
|
|
||||||
|
|
||||||
|
|
||||||
class URLCounter(object):
|
|
||||||
"""Counts returned URLs, determines how many valid v. invalid we get.
|
|
||||||
This is a helper for consuming what the many Input* objects produce."""
|
|
||||||
def __init__(self, root, print_invalid, expected):
|
|
||||||
"""Input:
|
|
||||||
root :: root URL for calling the URL's own Validate()
|
|
||||||
print_invalid :: print to output all invalid URLs
|
|
||||||
expected :: sequence of wildcard filters to validate against
|
|
||||||
"""
|
|
||||||
self._root = root
|
|
||||||
self._print = print_invalid
|
|
||||||
self._expected = expected
|
|
||||||
self._valid = 0
|
|
||||||
self._invalid = 0
|
|
||||||
#end def __init__
|
|
||||||
|
|
||||||
def Reset(self):
|
|
||||||
"""Reset our counts without harming the validity filters."""
|
|
||||||
self._valid = 0
|
|
||||||
self._invalid = 0
|
|
||||||
#end def Reset
|
|
||||||
|
|
||||||
def Valid(self):
|
|
||||||
"""Returns number of valid URLs."""
|
|
||||||
return self._valid
|
|
||||||
#end def Valid
|
|
||||||
|
|
||||||
def Invalid(self):
|
|
||||||
"""Returns number of invalid URLs."""
|
|
||||||
return self._invalid
|
|
||||||
#end def Valid
|
|
||||||
|
|
||||||
def Count(self, url, allow_fragment):
|
|
||||||
"""The 'please consume this URL' function called by the URL producer."""
|
|
||||||
valid = True
|
|
||||||
if valid:
|
|
||||||
valid = url.Validate(self._root, allow_fragment)
|
|
||||||
if valid:
|
|
||||||
for filter in self._expected:
|
|
||||||
valid = fnmatch.fnmatchcase(url.loc, filter)
|
|
||||||
if valid:
|
|
||||||
break
|
|
||||||
if valid:
|
|
||||||
self._valid = self._valid + 1
|
|
||||||
else:
|
|
||||||
if self._print:
|
|
||||||
url.Log(prefix='URLCounter', level=0)
|
|
||||||
self._invalid = self._invalid + 1
|
|
||||||
#end def Count
|
|
||||||
#end class URLCounter
|
|
||||||
|
|
||||||
|
|
||||||
class TestSiteMap(unittest.TestCase):
|
|
||||||
"""Tests the sitemap_gen application."""
|
|
||||||
|
|
||||||
def testTimestampISO8601(self):
|
|
||||||
""" Checks whether the TimestampISO8601 function works. """
|
|
||||||
self.assertEqual(sitemap_gen.TimestampISO8601(23),
|
|
||||||
'1970-01-01T00:00:23Z')
|
|
||||||
self.assertEqual(sitemap_gen.TimestampISO8601(549876543),
|
|
||||||
'1987-06-05T07:29:03Z')
|
|
||||||
#end def testTimestampISO8601
|
|
||||||
|
|
||||||
def testExpandPathAttribute(self):
|
|
||||||
""" Verifies our path globbing function works. """
|
|
||||||
temppath = tempfile.mktemp()
|
|
||||||
tempwild = tempfile.tempdir
|
|
||||||
if tempwild:
|
|
||||||
tempwild = tempwild + os.sep
|
|
||||||
tempwild = tempwild + '*'
|
|
||||||
try:
|
|
||||||
open(temppath, 'w').close()
|
|
||||||
|
|
||||||
dict1 = {}
|
|
||||||
dict2 = {'alpha' : 'beta', 'path' : 'DoesNotExist987654321.xyz'}
|
|
||||||
dict3 = {'alpha' : 'beta', 'path' : tempwild}
|
|
||||||
|
|
||||||
res1 = sitemap_gen.ExpandPathAttribute(dict1, 'path')
|
|
||||||
res2 = sitemap_gen.ExpandPathAttribute(dict2, 'path')
|
|
||||||
res3 = sitemap_gen.ExpandPathAttribute(dict3, 'path')
|
|
||||||
|
|
||||||
self.assertEqual(len(res1), 1)
|
|
||||||
self.assertEqual(res1[0], dict1)
|
|
||||||
|
|
||||||
self.assertEqual(len(res2), 1)
|
|
||||||
self.assertEqual(res2[0], dict2)
|
|
||||||
|
|
||||||
self.assert_(len(res3) >= 1)
|
|
||||||
anymatch = False
|
|
||||||
for res in res3:
|
|
||||||
path = res['path']
|
|
||||||
if path.find(temppath) >= 0:
|
|
||||||
anymatch = True
|
|
||||||
self.assertEqual(res['alpha'], 'beta')
|
|
||||||
self.assert_(anymatch)
|
|
||||||
|
|
||||||
finally:
|
|
||||||
os.unlink(temppath)
|
|
||||||
#end def testExpandPathAttribute
|
|
||||||
|
|
||||||
def testEncoder(self):
|
|
||||||
""" Tests minimal functionality of the learning Unicode codec """
|
|
||||||
ENC_UTF8 = 'UTF-8'
|
|
||||||
ENC_LATIN1 = 'ISO-8859-1'
|
|
||||||
ENC_CYRILLIC = 'ISO-8859-5'
|
|
||||||
|
|
||||||
STR1_LATIN1 = 'has an ' + binascii.a2b_hex('FC') + 'mlat'
|
|
||||||
STR1_UTF8 = 'has an ' + binascii.a2b_hex('C3BC') + 'mlat'
|
|
||||||
STR1_UCS2 = 'has an ' + unichr(252) + 'mlat'
|
|
||||||
|
|
||||||
STR2_LATIN1 = 'DRAGON' + binascii.a2b_hex('A7') + '!'
|
|
||||||
STR2_CYRILLIC = 'DRAGON' + binascii.a2b_hex('FD') + '!'
|
|
||||||
STR2_UCS2 = 'DRAGON' + unichr(167) + '!'
|
|
||||||
|
|
||||||
# Spawn our own encoder instance so we don't abuse the module one.
|
|
||||||
encoder = sitemap_gen.Encoder()
|
|
||||||
|
|
||||||
# Convert Latin-1 to UTF-8, by way of Unicode
|
|
||||||
encoder.SetUserEncoding(ENC_LATIN1)
|
|
||||||
self.assertEqual(encoder.WidenText(STR1_LATIN1, None), STR1_UCS2)
|
|
||||||
self.assertEqual(encoder.NarrowText(STR1_UCS2, ENC_UTF8), STR1_UTF8)
|
|
||||||
|
|
||||||
# Test learning. STR1 has no Cyrillic equivalent, STR2 just changes.
|
|
||||||
encoder.SetUserEncoding(None)
|
|
||||||
encoder._learned = []
|
|
||||||
self.assertEqual(encoder.WidenText(STR2_CYRILLIC, ENC_CYRILLIC), STR2_UCS2)
|
|
||||||
self.assertEqual(encoder.WidenText(STR2_CYRILLIC, None), STR2_UCS2)
|
|
||||||
self.assertEqual(encoder.NarrowText(STR1_UCS2, None), STR1_UTF8)
|
|
||||||
self.assert_(not encoder._learned)
|
|
||||||
self.assertEqual(encoder.NarrowText(STR1_UCS2, ENC_LATIN1), STR1_LATIN1)
|
|
||||||
self.assertEqual(encoder.NarrowText(STR1_UCS2, None), STR1_LATIN1)
|
|
||||||
self.assertEqual(encoder.NarrowText(STR2_UCS2, None), STR2_LATIN1)
|
|
||||||
#end def testEncoder
|
|
||||||
|
|
||||||
def testURL(self):
|
|
||||||
""" Vigorously tests our URL attribute processing. """
|
|
||||||
|
|
||||||
# Test the IsAbsolute method
|
|
||||||
self.assert_(sitemap_gen.URL.IsAbsolute('http://a.b.c/d/e.txt?f=g#h'))
|
|
||||||
self.assert_(sitemap_gen.URL.IsAbsolute('http://a.b.c'))
|
|
||||||
self.assert_(not sitemap_gen.URL.IsAbsolute('http:///d/e.txt?f=g#h'))
|
|
||||||
self.assert_(not sitemap_gen.URL.IsAbsolute('http:a.b.c/d/e.txt?f=g#h'))
|
|
||||||
self.assert_(not sitemap_gen.URL.IsAbsolute('a.b.c/d/e.txt?f=g#h'))
|
|
||||||
self.assert_(not sitemap_gen.URL.IsAbsolute('/d/e.txt?f=g#h'))
|
|
||||||
|
|
||||||
# Canonicalize our base URL
|
|
||||||
BASE_R = 'http://www.example.com/f' + binascii.a2b_hex('F6F6') + '/'
|
|
||||||
BASE_C = 'http://www.example.com/f%F6%F6/'
|
|
||||||
sitemap_gen.encoder.SetUserEncoding('ISO-8859-1')
|
|
||||||
self.assertEqual(sitemap_gen.URL.Canonicalize(BASE_R), BASE_C)
|
|
||||||
|
|
||||||
# Test how canonicalization handles pre-quoted values
|
|
||||||
self.assertEqual(sitemap_gen.URL.Canonicalize(
|
|
||||||
'http://www.example.com/my%25thing'),
|
|
||||||
'http://www.example.com/my%25thing')
|
|
||||||
self.assertEqual(sitemap_gen.URL.Canonicalize(
|
|
||||||
'http://www.example.com/my%thing'),
|
|
||||||
'http://www.example.com/my%25thing')
|
|
||||||
|
|
||||||
# Test IDNA encoding
|
|
||||||
# The generator can only do the "right thing" on Python 2.3 or higher
|
|
||||||
warn = sitemap_gen.output.num_warns
|
|
||||||
if sys.hexversion >= 0x02030000:
|
|
||||||
self.assertEqual(sitemap_gen.URL.Canonicalize(
|
|
||||||
'http://www.' + unichr(252) + 'mlat.com/' + unichr(252) + 'mlat.txt'),
|
|
||||||
'http://www.xn--mlat-zra.com/%FCmlat.txt')
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn)
|
|
||||||
else:
|
|
||||||
self.assertEqual(sitemap_gen.URL.Canonicalize(
|
|
||||||
'http://www.' + unichr(252) + 'mlat.com/' + unichr(252) + 'mlat.txt'),
|
|
||||||
'http://www.%FCmlat.com/%FCmlat.txt')
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn + 2)
|
|
||||||
|
|
||||||
# All valid data
|
|
||||||
warn = sitemap_gen.output.num_warns
|
|
||||||
url1 = sitemap_gen.URL()
|
|
||||||
url1.TrySetAttribute('loc', BASE_R + 'bar.html')
|
|
||||||
url1.TrySetAttribute('lastmod', '1987-06-05T07:29:03Z')
|
|
||||||
url1.TrySetAttribute('changefreq', 'daily')
|
|
||||||
url1.TrySetAttribute('priority', '0.3')
|
|
||||||
self.assert_(url1.Validate(BASE_C, True))
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn)
|
|
||||||
|
|
||||||
# Valid ref, all else invalid
|
|
||||||
warn = sitemap_gen.output.num_warns
|
|
||||||
url2 = sitemap_gen.URL()
|
|
||||||
url2.TrySetAttribute('loc', BASE_C + 'bar.html')
|
|
||||||
url2.TrySetAttribute('lastmod', 'June 1, 2005')
|
|
||||||
url2.TrySetAttribute('changefreq', 'every second')
|
|
||||||
url2.TrySetAttribute('priority', 'infinite')
|
|
||||||
url2.TrySetAttribute('badattr', 'Nope!')
|
|
||||||
self.assert_(url2.Validate(BASE_C, True))
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn + 4)
|
|
||||||
|
|
||||||
# Two URLs with same ref should compare equal
|
|
||||||
self.assertEqual(url1, url2)
|
|
||||||
|
|
||||||
# A ref not based
|
|
||||||
warn = sitemap_gen.output.num_warns
|
|
||||||
url3 = sitemap_gen.URL()
|
|
||||||
url3.TrySetAttribute('loc', 'http://www.example.com/bar/foo.html')
|
|
||||||
self.assert_(not url3.Validate(BASE_C, True))
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn + 1)
|
|
||||||
|
|
||||||
# A fragmentary URL
|
|
||||||
warn = sitemap_gen.output.num_warns
|
|
||||||
url4 = sitemap_gen.URL()
|
|
||||||
url4.TrySetAttribute('loc', '/foo.html')
|
|
||||||
self.assert_(not url4.Validate(BASE_C, False))
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn + 1)
|
|
||||||
url4.TrySetAttribute('loc', '/xyzzy/foo.html')
|
|
||||||
self.assert_(url4.Validate('http://www.example.com/', True))
|
|
||||||
self.assertEqual(url4.loc, 'http://www.example.com/xyzzy/foo.html')
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn + 1)
|
|
||||||
|
|
||||||
# Test a whole sequence of good and bad timestamp values
|
|
||||||
timestamps_good = [
|
|
||||||
'2001',
|
|
||||||
'2001-01',
|
|
||||||
'2001-01-02',
|
|
||||||
'2001-01-03T01:02Z',
|
|
||||||
'2001-01-03T01:02:03Z',
|
|
||||||
'2001-01-03T01:02:03.0123Z',
|
|
||||||
'2001-01-03T01:02+00:00',
|
|
||||||
'2001-01-03T01:02:03-99:99',
|
|
||||||
'2001-01-03T01:02:03.0123+88:88',
|
|
||||||
]
|
|
||||||
timestamps_bad = [
|
|
||||||
'2001:01:03T01:02Z',
|
|
||||||
'2001-01-03T01:02:03.Z',
|
|
||||||
'a2001-01-06T01:02:05-99:99',
|
|
||||||
'2001-01-06T01:02:05-99:99Z',
|
|
||||||
'2001-1-6T01:02:05-99:99',
|
|
||||||
'xyzzy',
|
|
||||||
'2001-01-03T01:02:03.1.2Z',
|
|
||||||
]
|
|
||||||
warn = sitemap_gen.output.num_warns
|
|
||||||
url3.TrySetAttribute('loc', BASE_C + 'foo.html')
|
|
||||||
for ts in timestamps_good:
|
|
||||||
url3.TrySetAttribute('lastmod', ts)
|
|
||||||
self.assert_(url3.Validate(BASE_C, True))
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn)
|
|
||||||
for ts in timestamps_bad:
|
|
||||||
url3.TrySetAttribute('lastmod', ts)
|
|
||||||
self.assert_(url3.Validate(BASE_C, True))
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn + len(timestamps_bad))
|
|
||||||
#end def testURL
|
|
||||||
|
|
||||||
def testFilter(self):
|
|
||||||
""" Test the filtering object """
|
|
||||||
url1 = sitemap_gen.URL()
|
|
||||||
url2 = sitemap_gen.URL()
|
|
||||||
url1.TrySetAttribute('loc', 'http://www.example.com/foo/bar.html')
|
|
||||||
url2.TrySetAttribute('loc', 'http://www.example.com/bar/foo.html')
|
|
||||||
url1.Validate('http://www.example.com', True)
|
|
||||||
url2.Validate('http://www.example.com', True)
|
|
||||||
|
|
||||||
# Arguments
|
|
||||||
error = sitemap_gen.output.num_errors
|
|
||||||
args_bad = [
|
|
||||||
{},
|
|
||||||
{'pattern' : '*', 'type' : 'unknown'},
|
|
||||||
{'pattern' : '*', 'type' : 'wildcard', 'action' : 'look pretty'},
|
|
||||||
{'pattern' : '*', 'type' : 'regexp'},
|
|
||||||
]
|
|
||||||
error = sitemap_gen.output.num_errors
|
|
||||||
for args in args_bad:
|
|
||||||
sitemap_gen.Filter(args)
|
|
||||||
self.assertEqual(sitemap_gen.output.num_errors, error + len(args_bad))
|
|
||||||
|
|
||||||
# Wildcard
|
|
||||||
filt_w = sitemap_gen.Filter({'pattern' : '*/foo/*', 'type' : 'wildcard' })
|
|
||||||
self.assertEqual(filt_w.Apply(url1), False)
|
|
||||||
self.assertEqual(filt_w.Apply(url2), None)
|
|
||||||
|
|
||||||
# Regexp
|
|
||||||
filt_r = sitemap_gen.Filter({'pattern' : '/bar/[^/]+$', 'type' : 'REGEXP',
|
|
||||||
'action' : 'PASS'})
|
|
||||||
self.assertEqual(filt_r.Apply(url1), None)
|
|
||||||
self.assertEqual(filt_r.Apply(url2), True)
|
|
||||||
#end def testFilter
|
|
||||||
|
|
||||||
def Count(self, url, allow_fragment):
|
|
||||||
if url.Validate('http://www.example.com/', allow_fragment):
|
|
||||||
self.valid_urls = self.valid_urls + 1
|
|
||||||
else:
|
|
||||||
self.invalid_urls = self.invalid_urls + 1
|
|
||||||
#end def Count
|
|
||||||
valid_urls = 0
|
|
||||||
invalid_urls = 0
|
|
||||||
|
|
||||||
def testInputURL(self):
|
|
||||||
""" Test one of the Input mechanisms: InputURL """
|
|
||||||
|
|
||||||
# Feed a couple URLs. Make sure we get an error on extra attributes.
|
|
||||||
self.valid_urls = 0
|
|
||||||
self.invalid_urls = 0
|
|
||||||
error = sitemap_gen.output.num_errors
|
|
||||||
warn = sitemap_gen.output.num_warns
|
|
||||||
generator1 = sitemap_gen.InputURL({'href' : 'http://www.example.com/1',
|
|
||||||
'priority' : '0.3',
|
|
||||||
'lastmod' : '2004-11-14T01:00-07:00',
|
|
||||||
'changefreq' : 'hourly',
|
|
||||||
'unknownInURL' : 'attribute'})
|
|
||||||
generator2 = sitemap_gen.InputURL({'href' : 'http://www.example.com/2',
|
|
||||||
'priority' : '0.3',
|
|
||||||
'lastmod' : '2004-11-14T01:00-07:00',
|
|
||||||
'changefreq' : 'hourly'})
|
|
||||||
generator1.ProduceURLs(self.Count)
|
|
||||||
generator2.ProduceURLs(self.Count)
|
|
||||||
self.assertEqual(self.valid_urls, 1)
|
|
||||||
self.assertEqual(self.invalid_urls, 0)
|
|
||||||
self.assertEqual(sitemap_gen.output.num_errors, error + 1)
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn)
|
|
||||||
#end def testInputURL
|
|
||||||
|
|
||||||
def testInputURLList(self):
|
|
||||||
""" Test one of the Input mechanisms: InputURLList """
|
|
||||||
path = tempfile.mktemp()
|
|
||||||
file = open(path, 'w')
|
|
||||||
|
|
||||||
try:
|
|
||||||
# Create a temp file we can read
|
|
||||||
testText = """
|
|
||||||
http://www.example.com/foo/bar unknownInURLList=attribute
|
|
||||||
http://www.example.com/foo/xxx.pdf lastmod=2003-12-31T14:05:06+00:00
|
|
||||||
http://www.example.com/foo/yyy?x=12&y=23 changefreq=weekly priority=0.3
|
|
||||||
"""
|
|
||||||
file.write(testText)
|
|
||||||
file.close()
|
|
||||||
|
|
||||||
# Feed in the data. Make sure we get a warning on the bad attribute.
|
|
||||||
self.valid_urls = 0
|
|
||||||
self.invalid_urls = 0
|
|
||||||
warn = sitemap_gen.output.num_warns
|
|
||||||
generator = sitemap_gen.InputURLList({'path' : path})
|
|
||||||
generator.ProduceURLs(self.Count)
|
|
||||||
self.assertEqual(self.valid_urls, 3)
|
|
||||||
self.assertEqual(self.invalid_urls, 0)
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn + 1)
|
|
||||||
|
|
||||||
finally:
|
|
||||||
os.unlink(path)
|
|
||||||
#end def testInputURLList
|
|
||||||
|
|
||||||
def testInputDirectory(self):
|
|
||||||
"""Test one of the Input mechanisms: InputDirectory.
|
|
||||||
I've seen a subtle path-bug appear when going into sub-sub-directories
|
|
||||||
that didn't under just sub-directories. So we go to the trouble to
|
|
||||||
make a whole little directory tree to read.
|
|
||||||
"""
|
|
||||||
counter = URLCounter('http://www.example.com/', True, (
|
|
||||||
'http://www.example.com/',
|
|
||||||
'http://www.example.com/one.html',
|
|
||||||
'http://www.example.com/two.html',
|
|
||||||
'http://www.example.com/xyzzy/',
|
|
||||||
'http://www.example.com/xyzzy/thr.html',
|
|
||||||
'http://www.example.com/xyzzy/zyxxy/',
|
|
||||||
'http://www.example.com/xyzzy/zyxxy/fiv.html',
|
|
||||||
))
|
|
||||||
path = tempfile.mktemp()
|
|
||||||
subpath = os.path.join(path, 'xyzzy')
|
|
||||||
subsubpath = os.path.join(subpath, 'zyxxy')
|
|
||||||
|
|
||||||
try:
|
|
||||||
# Create some dummy empty files
|
|
||||||
os.mkdir(path)
|
|
||||||
os.mkdir(subpath)
|
|
||||||
os.mkdir(subsubpath)
|
|
||||||
path_one = os.path.join(path, 'one.html')
|
|
||||||
path_two = os.path.join(path, 'two.html')
|
|
||||||
path_thr = os.path.join(subpath, 'thr.html')
|
|
||||||
path_for = os.path.join(subpath, 'default.html')
|
|
||||||
path_fiv = os.path.join(subsubpath, 'fiv.html')
|
|
||||||
open(path_one, 'w').close()
|
|
||||||
open(path_two, 'w').close()
|
|
||||||
open(path_thr, 'w').close()
|
|
||||||
open(path_for, 'w').close()
|
|
||||||
open(path_fiv, 'w').close()
|
|
||||||
|
|
||||||
# Feed in the data. There should be no warnings.
|
|
||||||
warn = sitemap_gen.output.num_warns
|
|
||||||
generator = sitemap_gen.InputDirectory({'path' : path,
|
|
||||||
'url' : 'http://www.example.com/', 'default_file' : 'default.html'},
|
|
||||||
'http://www.example.com/')
|
|
||||||
generator.ProduceURLs(counter.Count)
|
|
||||||
self.assertEqual(counter.Valid(), 7)
|
|
||||||
self.assertEqual(counter.Invalid(), 0)
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn)
|
|
||||||
|
|
||||||
finally:
|
|
||||||
os.unlink(path_one)
|
|
||||||
os.unlink(path_two)
|
|
||||||
os.unlink(path_thr)
|
|
||||||
os.unlink(path_for)
|
|
||||||
os.unlink(path_fiv)
|
|
||||||
os.rmdir(subsubpath)
|
|
||||||
os.rmdir(subpath)
|
|
||||||
os.rmdir(path)
|
|
||||||
#end def testInputDirectory
|
|
||||||
|
|
||||||
def testInputAccessLogCLF(self):
|
|
||||||
""" Test one of the Input mechanisms: InputAccessLog (Common logfile) """
|
|
||||||
path = tempfile.mktemp()
|
|
||||||
file = open(path, 'w')
|
|
||||||
|
|
||||||
try:
|
|
||||||
# Create a temp file we can read
|
|
||||||
testText = '''
|
|
||||||
msnbot.msn.com - - [15/May/2005:07:46:50 -0700] "GET /~guest/main/ HTTP/1.0" 200 5670
|
|
||||||
221.216.237.71 - - [15/May/2005:07:59:25 -0700] "GET /~guest/bookmark/ HTTP/1.1" 200 39195
|
|
||||||
221.216.237.71 - - [15/May/2005:07:59:27 -0700] "GET /favicon.ico HTTP/1.1" 404 217
|
|
||||||
c-67-161-121-105.hsd1.wa.comcast.net - - [15/May/2005:11:17:23 -0700] "GET /picts/top.jpg HTTP/1.1" 200 10044
|
|
||||||
cpe-65-24-155-46.columbus.res.rr.com - - [16/May/2005:22:53:07 -0700] "HEAD http://www.example.com/~guest HTTP/1.1" 200 0
|
|
||||||
'''
|
|
||||||
file.write(testText)
|
|
||||||
file.close()
|
|
||||||
|
|
||||||
# Feed in the data
|
|
||||||
self.valid_urls = 0
|
|
||||||
self.invalid_urls = 0
|
|
||||||
warn = sitemap_gen.output.num_warns
|
|
||||||
generator = sitemap_gen.InputAccessLog({'path' : path})
|
|
||||||
generator.ProduceURLs(self.Count)
|
|
||||||
self.assertEqual(self.valid_urls, 4)
|
|
||||||
self.assertEqual(self.invalid_urls, 0)
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn)
|
|
||||||
|
|
||||||
finally:
|
|
||||||
os.unlink(path)
|
|
||||||
#end def testInputAccessLogCLF
|
|
||||||
|
|
||||||
def testInputAccessLogELF(self):
|
|
||||||
""" Test one of the Input mechanisms: InputAccessLog (Extended logfile) """
|
|
||||||
path = tempfile.mktemp()
|
|
||||||
file = open(path, 'w')
|
|
||||||
|
|
||||||
try:
|
|
||||||
# Create a temp file we can read
|
|
||||||
testText = '''
|
|
||||||
#Software: Microsoft Internet Information Services 6.0
|
|
||||||
#Version: 1.0
|
|
||||||
#Date: 2004-03-22 09:20:36
|
|
||||||
#Fields: date time s-ip cs-method cs-uri-stem cs-uri-query s-port cs-username c-ip cs(User-Agent) sc-status sc-substatus sc-w
|
|
||||||
in32-status
|
|
||||||
2004-03-22 09:20:36 192.168.0.58 GET /Default.htm - 80 - 4.5.11.3 Mozilla/4.0+(compatible;+MSIE+5.5;+Windows+98) 200 0 64
|
|
||||||
2004-03-22 09:22:58 192.168.0.58 GET /Default.htm - 80 - 24.87.160.82 Mozilla/4.0+(compatible;+MSIE+5.5;+Windows+98) 200 0 6
|
|
||||||
4
|
|
||||||
'''
|
|
||||||
file.write(testText)
|
|
||||||
file.close()
|
|
||||||
|
|
||||||
# Feed in the data
|
|
||||||
self.valid_urls = 0
|
|
||||||
self.invalid_urls = 0
|
|
||||||
warn = sitemap_gen.output.num_warns
|
|
||||||
generator = sitemap_gen.InputAccessLog({'path' : path})
|
|
||||||
generator.ProduceURLs(self.Count)
|
|
||||||
self.assertEqual(self.valid_urls, 2)
|
|
||||||
self.assertEqual(self.invalid_urls, 0)
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn)
|
|
||||||
|
|
||||||
finally:
|
|
||||||
os.unlink(path)
|
|
||||||
#end def testInputAccessLogELF
|
|
||||||
|
|
||||||
def testInputSitemap(self):
|
|
||||||
""" Test one of the Input mechanisms: InputSitemap """
|
|
||||||
path1 = tempfile.mktemp('.xml')
|
|
||||||
path2 = tempfile.mktemp('.xml')
|
|
||||||
path3 = tempfile.mktemp('.xml')
|
|
||||||
path4 = tempfile.mktemp('.xml')
|
|
||||||
file1 = None
|
|
||||||
file2 = None
|
|
||||||
file3 = None
|
|
||||||
file4 = None
|
|
||||||
|
|
||||||
index = '''<?xml version="1.0" encoding="UTF-8"?>
|
|
||||||
<sitemapindex
|
|
||||||
xmlns="http://www.google.com/schemas/sitemap/0.84"
|
|
||||||
xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
|
|
||||||
xsi:schemaLocation="http://www.google.com/schemas/sitemap/0.84
|
|
||||||
http://www.google.com/schemas/sitemap/0.84/siteindex.xsd">
|
|
||||||
<sitemap>
|
|
||||||
<loc>http://www.example.com/path/to/%(PATH2)s</loc>
|
|
||||||
<lastmod>2005-07-15T17:41:22Z</lastmod>
|
|
||||||
</sitemap>
|
|
||||||
<sitemap>
|
|
||||||
<loc>http://www.example.com/path/to/%(PATH3)s</loc>
|
|
||||||
<lastmod>2005-07-15T17:41:22Z</lastmod>
|
|
||||||
</sitemap>
|
|
||||||
</sitemapindex>
|
|
||||||
'''
|
|
||||||
content1 = '''<?xml version="1.0" encoding="UTF-8"?>
|
|
||||||
<urlset
|
|
||||||
xmlns="http://www.google.com/schemas/sitemap/0.84"
|
|
||||||
xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
|
|
||||||
xsi:schemaLocation="http://www.google.com/schemas/sitemap/0.84
|
|
||||||
http://www.google.com/schemas/sitemap/0.84/sitemap.xsd">
|
|
||||||
<url>
|
|
||||||
<loc>http://www.example.com/another/path/to/samplefile1.html</loc>
|
|
||||||
<lastmod>2005-07-13T00:00:12Z</lastmod>
|
|
||||||
<priority>0.5000</priority>
|
|
||||||
</url>
|
|
||||||
<url>
|
|
||||||
<loc>http://www.example.com/another/path/to/samplefile2.html</loc>
|
|
||||||
<lastmod>2004-11-16T20:22:06Z</lastmod>
|
|
||||||
<priority>0.5000</priority>
|
|
||||||
</url>
|
|
||||||
</urlset>
|
|
||||||
'''
|
|
||||||
content2 = '''<?xml version="1.0" encoding="UTF-8"?>
|
|
||||||
<urlset
|
|
||||||
xmlns="http://www.google.com/schemas/sitemap/0.84"
|
|
||||||
xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
|
|
||||||
xsi:schemaLocation="http://www.google.com/schemas/sitemap/0.84
|
|
||||||
http://www.google.com/schemas/sitemap/0.84/sitemap.xsd">
|
|
||||||
<url badSitemapAttr="Hello, World!">
|
|
||||||
<loc>http://www.example.com/another/path/to/samplefile3.html</loc>
|
|
||||||
<lastmod>2005-07-13T00:00:12Z</lastmod>
|
|
||||||
<priority>0.5000</priority>
|
|
||||||
</url>
|
|
||||||
<url>
|
|
||||||
<loc>http://www.example.com/another/path/to/samplefile4.html</loc>
|
|
||||||
<lastmod>2004-11-16T20:22:06Z</lastmod>
|
|
||||||
<priority>0.5000</priority>
|
|
||||||
</url>
|
|
||||||
</urlset>
|
|
||||||
'''
|
|
||||||
# This index is invalid because it points to another index file.
|
|
||||||
badindex = '''<?xml version="1.0" encoding="UTF-8"?>
|
|
||||||
<sitemapindex
|
|
||||||
xmlns="http://www.google.com/schemas/sitemap/0.84"
|
|
||||||
xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
|
|
||||||
xsi:schemaLocation="http://www.google.com/schemas/sitemap/0.84
|
|
||||||
http://www.google.com/schemas/sitemap/0.84/siteindex.xsd">
|
|
||||||
<sitemap>
|
|
||||||
<loc>http://www.example.com/path/to/%(PATH2)s</loc>
|
|
||||||
<lastmod>2005-07-15T17:41:22Z</lastmod>
|
|
||||||
</sitemap>
|
|
||||||
<sitemap>
|
|
||||||
<loc>http://www.example.com/path/to/%(PATH1)s</loc>
|
|
||||||
<lastmod>2005-07-15T17:41:22Z</lastmod>
|
|
||||||
</sitemap>
|
|
||||||
</sitemapindex>
|
|
||||||
'''
|
|
||||||
|
|
||||||
# Make a nice complicated set of two index files and two sitemaps.
|
|
||||||
try:
|
|
||||||
file1 = open(path1, 'wt')
|
|
||||||
file2 = open(path2, 'wt')
|
|
||||||
file3 = open(path3, 'wt')
|
|
||||||
file4 = open(path4, 'wt')
|
|
||||||
file1.write(index % {
|
|
||||||
'PATH1' : os.path.basename(path1),
|
|
||||||
'PATH2' : os.path.basename(path2),
|
|
||||||
'PATH3' : os.path.basename(path3)})
|
|
||||||
file2.write(content1)
|
|
||||||
file3.write(content2)
|
|
||||||
file4.write(badindex % {
|
|
||||||
'PATH1' : os.path.basename(path1),
|
|
||||||
'PATH2' : os.path.basename(path2),
|
|
||||||
'PATH3' : os.path.basename(path3)})
|
|
||||||
file1.close()
|
|
||||||
file1 = None
|
|
||||||
file2.close()
|
|
||||||
file2 = None
|
|
||||||
file3.close()
|
|
||||||
file3 = None
|
|
||||||
file4.close()
|
|
||||||
file4 = None
|
|
||||||
|
|
||||||
# Feed in the good data. Make sure we get warned on the bad attribute.
|
|
||||||
self.valid_urls = 0
|
|
||||||
self.invalid_urls = 0
|
|
||||||
warn = sitemap_gen.output.num_warns
|
|
||||||
generator = sitemap_gen.InputSitemap({'path' : path1})
|
|
||||||
generator.ProduceURLs(self.Count)
|
|
||||||
self.assertEqual(self.valid_urls, 4)
|
|
||||||
self.assertEqual(self.invalid_urls, 0)
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn + 1)
|
|
||||||
|
|
||||||
# Feed in the bad data. Should error once on the bad index and once
|
|
||||||
# because it aborts processing the XML.
|
|
||||||
self.valid_urls = 0
|
|
||||||
self.invalid_urls = 0
|
|
||||||
errors = sitemap_gen.output.num_errors
|
|
||||||
generator = sitemap_gen.InputSitemap({'path' : path4})
|
|
||||||
generator.ProduceURLs(self.Count)
|
|
||||||
self.assertEqual(self.valid_urls, 2)
|
|
||||||
self.assertEqual(self.invalid_urls, 0)
|
|
||||||
self.assertEqual(sitemap_gen.output.num_errors, errors + 2)
|
|
||||||
|
|
||||||
finally:
|
|
||||||
if file1 is not None:
|
|
||||||
file1.close()
|
|
||||||
if file2 is not None:
|
|
||||||
file2.close()
|
|
||||||
if file3 is not None:
|
|
||||||
file3.close()
|
|
||||||
if os.path.exists(path1):
|
|
||||||
os.unlink(path1)
|
|
||||||
if os.path.exists(path2):
|
|
||||||
os.unlink(path2)
|
|
||||||
if os.path.exists(path3):
|
|
||||||
os.unlink(path3)
|
|
||||||
#end def testInputSitemap
|
|
||||||
|
|
||||||
def testFilePathGenerator(self):
|
|
||||||
""" Test our iteration of filenames """
|
|
||||||
gen1 = sitemap_gen.FilePathGenerator()
|
|
||||||
gen2 = sitemap_gen.FilePathGenerator()
|
|
||||||
gen3 = sitemap_gen.FilePathGenerator()
|
|
||||||
self.assert_(gen1.Preload('/tmp/bar/foo.xml'))
|
|
||||||
self.assert_(gen2.Preload('foo.xml.gz'))
|
|
||||||
self.assert_(gen3.Preload('/foo.gz'))
|
|
||||||
self.assert_(not gen1.is_gzip)
|
|
||||||
self.assert_( gen2.is_gzip)
|
|
||||||
self.assert_( gen3.is_gzip)
|
|
||||||
self.assertEqual(gen1.GeneratePath(0),
|
|
||||||
os.path.normpath('/tmp/bar/foo.xml'))
|
|
||||||
self.assertEqual(gen2.GeneratePath(1),'foo1.xml.gz')
|
|
||||||
self.assertEqual(gen1.GeneratePath('_index.xml'),
|
|
||||||
os.path.normpath('/tmp/bar/foo_index.xml'))
|
|
||||||
self.assertEqual(gen1.GenerateURL('_index.xml', 'http://www.example.com/'),
|
|
||||||
'http://www.example.com/foo_index.xml')
|
|
||||||
self.assertEqual(gen1.GenerateURL(2, 'http://www.example.com/'),
|
|
||||||
'http://www.example.com/foo2.xml')
|
|
||||||
self.assertEqual(gen2.GenerateWildURL('http://www.example.com/'),
|
|
||||||
'http://www.example.com/foo*.xml.gz')
|
|
||||||
#end def testFilePathGenerator
|
|
||||||
|
|
||||||
def testSitemap(self):
|
|
||||||
"""Test a basic config of the overall sitemap class."""
|
|
||||||
path1 = tempfile.mktemp()
|
|
||||||
path2 = tempfile.mktemp(".xml.gz")
|
|
||||||
file = open(path1, 'w')
|
|
||||||
|
|
||||||
try:
|
|
||||||
# Create a temp file we can read
|
|
||||||
testText = '''<?xml version="1.0" encoding="UTF-8"?>
|
|
||||||
<site
|
|
||||||
base_url="http://www.example.com/"
|
|
||||||
store_into="%(OUTPUTFILENAME)s"
|
|
||||||
default_encoding="UTF-8"
|
|
||||||
verbose="3"
|
|
||||||
>
|
|
||||||
<url href="http://www.example.com/.htaccess" />
|
|
||||||
<url href="http://www.example.com/foo/bar.html" />
|
|
||||||
<url href="http://www.example.com/foo/bar.gif" />
|
|
||||||
<url href="http://www.example.com/foo/bar.html" />
|
|
||||||
<url href="http://www.example.com/percent%%%%percent.html" />
|
|
||||||
<url href="http://www.example.com/ümlat.html" />
|
|
||||||
<filter action="drop" type="regexp" pattern="/\.[^/]*$" />
|
|
||||||
</site>
|
|
||||||
'''
|
|
||||||
file.write(testText % {'OUTPUTFILENAME' : path2})
|
|
||||||
file.close()
|
|
||||||
|
|
||||||
# Bring up the engine
|
|
||||||
warn = sitemap_gen.output.num_warns
|
|
||||||
error = sitemap_gen.output.num_errors
|
|
||||||
sitemap = sitemap_gen.CreateSitemapFromFile(path1, True)
|
|
||||||
self.assert_(sitemap)
|
|
||||||
sitemap.Generate()
|
|
||||||
self.assertEqual(sitemap_gen.output.num_warns, warn)
|
|
||||||
self.assertEqual(sitemap_gen.output.num_errors, error)
|
|
||||||
|
|
||||||
# Verify we got readable XML out of it
|
|
||||||
file = gzip.open(path2, mode='rb')
|
|
||||||
result = file.read()
|
|
||||||
file.close()
|
|
||||||
dom = xml.dom.minidom.parseString(result)
|
|
||||||
self.assertEqual(len(dom.getElementsByTagName('url')), 4)
|
|
||||||
self.assert_(result.find('http://www.example.com/foo/bar.html') > 0)
|
|
||||||
self.assert_(result.find('http://www.example.com/foo/bar.gif') > 0)
|
|
||||||
self.assert_(result.find('%25%25') > 0)
|
|
||||||
self.assert_(result.find('%C3%BC') > 0)
|
|
||||||
finally:
|
|
||||||
if os.path.exists(path2):
|
|
||||||
os.unlink(path2)
|
|
||||||
os.unlink(path1)
|
|
||||||
#end def testSitemap
|
|
||||||
|
|
||||||
#end class TestSiteMap
|
|
||||||
|
|
||||||
#
|
|
||||||
# __main__
|
|
||||||
#
|
|
||||||
|
|
||||||
if __name__ == '__main__':
|
|
||||||
unittest.main()
|
|
||||||
|
|
@ -1,80 +0,0 @@
|
||||||
#!/bin/sh
|
|
||||||
#| -*- scheme -*-
|
|
||||||
exec "$PLTHOME/bin/gracket" "$0"
|
|
||||||
|#
|
|
||||||
|
|
||||||
#lang racket/gui
|
|
||||||
|
|
||||||
;; save the original error port to send messages
|
|
||||||
(define stderr (current-error-port))
|
|
||||||
(define (die fmt . args)
|
|
||||||
(apply fprintf stderr fmt args)
|
|
||||||
(newline stderr)
|
|
||||||
(exit 1))
|
|
||||||
|
|
||||||
(define (cleanup)
|
|
||||||
(when (directory-exists? (find-system-path 'pref-dir))
|
|
||||||
(delete-directory/files (find-system-path 'pref-dir))))
|
|
||||||
|
|
||||||
(define (my-handler e)
|
|
||||||
(cleanup)
|
|
||||||
(die "uncaught exception: ~a\n" (if (exn? e) (exn-message e) e)))
|
|
||||||
|
|
||||||
(define-values (in out) (make-pipe))
|
|
||||||
((compose void thread)
|
|
||||||
(lambda ()
|
|
||||||
(let* ([bytes (make-bytes 1000)]
|
|
||||||
[len/eof (sync (read-bytes-avail!-evt bytes in))])
|
|
||||||
(die "text printed to stdout/stderr:\n~a\n"
|
|
||||||
(if (eof-object? len/eof) len/eof (subbytes bytes 0 len/eof))))))
|
|
||||||
|
|
||||||
(uncaught-exception-handler my-handler)
|
|
||||||
(current-output-port out)
|
|
||||||
(current-error-port out)
|
|
||||||
|
|
||||||
;; must create eventspace after setting parameters, so its thread
|
|
||||||
;; inherits the new settings
|
|
||||||
(define es (make-eventspace))
|
|
||||||
|
|
||||||
(current-eventspace es)
|
|
||||||
(void (thread (lambda () (sleep 120) (die "timeout!"))))
|
|
||||||
|
|
||||||
;; make sure the preferences are such that we don't get the welcome screen
|
|
||||||
(cleanup)
|
|
||||||
(make-directory (find-system-path 'pref-dir))
|
|
||||||
(with-output-to-file (find-system-path 'pref-file) #:exists 'truncate
|
|
||||||
(lambda ()
|
|
||||||
(printf "~s\n" `((plt:framework-prefs
|
|
||||||
((drracket:last-version ,(version))
|
|
||||||
(drracket:last-language english)))))))
|
|
||||||
|
|
||||||
;; start drracket, get interface for testing its windows
|
|
||||||
(define <%> #f)
|
|
||||||
(queue-callback (lambda ()
|
|
||||||
(dynamic-require 'drracket #f)
|
|
||||||
(set! <%> (dynamic-require 'drracket/tool-lib
|
|
||||||
'drracket:unit:frame<%>))))
|
|
||||||
|
|
||||||
(define (is-drracket-frame? win) (and <%> (is-a? win <%>)))
|
|
||||||
|
|
||||||
;; wait for the drracket window to appear
|
|
||||||
(define (window-title w) (send w get-label))
|
|
||||||
(let loop ()
|
|
||||||
(sleep 1/100)
|
|
||||||
(let ([wins (get-top-level-windows)])
|
|
||||||
(cond
|
|
||||||
;; wait to have windows
|
|
||||||
[(null? wins) (loop)]
|
|
||||||
;; that are all drracket frames
|
|
||||||
[(not (andmap is-drracket-frame? wins)) (loop)]
|
|
||||||
[(pair? (cdr wins))
|
|
||||||
(die "too many windows popped up: ~s" (map window-title wins))]
|
|
||||||
[(regexp-match #rx"^Untitled( - DrRacket)?$" (window-title (car wins)))
|
|
||||||
(fprintf stderr "got a good window: ~a\n" (window-title (car wins)))]
|
|
||||||
[else (die "bad window popped up: ~s" (window-title (car wins)))])))
|
|
||||||
|
|
||||||
;; handle some events
|
|
||||||
(let loop ([n 20]) (unless (zero? n) (yield) (loop (sub1 n))))
|
|
||||||
|
|
||||||
;; queue a low priority callback to exit sucessfully
|
|
||||||
(queue-callback (lambda () (cleanup) (exit 0)) #f)
|
|
||||||
|
|
@ -1,61 +0,0 @@
|
||||||
#!/bin/sh
|
|
||||||
#| -*- scheme -*-
|
|
||||||
tmp="/tmp/path-compare-$$"
|
|
||||||
if [ -x "$PLTHOME/bin/racket" ]; then
|
|
||||||
"$PLTHOME/bin/racket" -r "$0" "$@"
|
|
||||||
else
|
|
||||||
"racket" -r "$0" "$@"
|
|
||||||
fi > "$tmp" || exit 1
|
|
||||||
cd "`dirname \"$0\"`"
|
|
||||||
if diff "paths-configure-snapshot" "$tmp"; then
|
|
||||||
echo "PATHS OK"; rm "$tmp"; exit 0
|
|
||||||
else echo "*** PATHS DATA MISMATCH (see $tmp) ***"; exit 1
|
|
||||||
fi
|
|
||||||
|#
|
|
||||||
|
|
||||||
;; Extract path information from the configure script, so it can be compared
|
|
||||||
;; to a snapshot and generate an error each time things change
|
|
||||||
|
|
||||||
(define configure-path
|
|
||||||
(simplify-path
|
|
||||||
(build-path
|
|
||||||
;; (find-executable-path
|
|
||||||
;; (find-system-path 'exec-file) (find-system-path 'collects-dir) #t)
|
|
||||||
(find-system-path 'exec-file)
|
|
||||||
'up 'up "src" "configure")))
|
|
||||||
(unless (file-exists? configure-path)
|
|
||||||
(error "Cannot find `configure':" configure-path))
|
|
||||||
|
|
||||||
(define current-match (make-parameter #f))
|
|
||||||
(define (match? . bytess)
|
|
||||||
(cond [(regexp-match (byte-regexp (apply bytes-append bytess))
|
|
||||||
(current-input-port))
|
|
||||||
=> (lambda (m) (current-match (car m)) #t)]
|
|
||||||
[else #f]))
|
|
||||||
(define (show-match)
|
|
||||||
(write-bytes (current-match)))
|
|
||||||
|
|
||||||
(with-input-from-file configure-path
|
|
||||||
(lambda ()
|
|
||||||
(if (match? #"\n# Installation directory options.\n"
|
|
||||||
#"(?:#[^\n]*\n)+"
|
|
||||||
#"(?:[a-z]+=[^\n]+\n)+"
|
|
||||||
#"\n")
|
|
||||||
(show-match)
|
|
||||||
(error "Did not find first block"))
|
|
||||||
(if (match? #"\n#+ Install targets #+\n\n"
|
|
||||||
#"unixstyle=no\n"
|
|
||||||
#"if (?:[^\n]+\n)+fi\n\n"
|
|
||||||
#"MAKE_COPYTREE=no\n"
|
|
||||||
#"if [^\n]+\n"
|
|
||||||
#"(?: +[^\n]+\n)+"
|
|
||||||
#"else\n"
|
|
||||||
#"(?: +[^\n]+\n)+"
|
|
||||||
#"fi\n\n")
|
|
||||||
(show-match)
|
|
||||||
(error "Did not find second block"))
|
|
||||||
(if (match? #"\n +echo \">>> Installation targets:\"\n"
|
|
||||||
#"(?: +echo [^\n]+\n)+")
|
|
||||||
(show-match)
|
|
||||||
(error "Did not find third block"))))
|
|
||||||
(exit)
|
|
||||||
|
|
@ -1,109 +0,0 @@
|
||||||
|
|
||||||
# Installation directory options.
|
|
||||||
# These are left unexpanded so users can "make install exec_prefix=/foo"
|
|
||||||
# and all the variables that are supposed to be based on exec_prefix
|
|
||||||
# by default will actually change.
|
|
||||||
# Use braces instead of parens because sh, perl, etc. also accept them.
|
|
||||||
# (The list follows the same order as the GNU Coding Standards.)
|
|
||||||
bindir='${exec_prefix}/bin'
|
|
||||||
sbindir='${exec_prefix}/sbin'
|
|
||||||
libexecdir='${exec_prefix}/libexec'
|
|
||||||
datarootdir='${prefix}/share'
|
|
||||||
datadir='${datarootdir}'
|
|
||||||
sysconfdir='${prefix}/etc'
|
|
||||||
sharedstatedir='${prefix}/com'
|
|
||||||
localstatedir='${prefix}/var'
|
|
||||||
includedir='${prefix}/include'
|
|
||||||
oldincludedir='/usr/include'
|
|
||||||
docdir='${datarootdir}/doc/${PACKAGE}'
|
|
||||||
infodir='${datarootdir}/info'
|
|
||||||
htmldir='${docdir}'
|
|
||||||
dvidir='${docdir}'
|
|
||||||
pdfdir='${docdir}'
|
|
||||||
psdir='${docdir}'
|
|
||||||
libdir='${exec_prefix}/lib'
|
|
||||||
localedir='${datarootdir}/locale'
|
|
||||||
mandir='${datarootdir}/man'
|
|
||||||
|
|
||||||
|
|
||||||
############## Install targets ################
|
|
||||||
|
|
||||||
unixstyle=no
|
|
||||||
if test "${prefix}" != "NONE" ; then
|
|
||||||
if test "${enable_origtree}" != "yes" ; then
|
|
||||||
unixstyle=yes
|
|
||||||
fi
|
|
||||||
fi
|
|
||||||
if test "${exec_prefix}" != "NONE" ; then
|
|
||||||
unixstyle=yes
|
|
||||||
fi
|
|
||||||
if test "${bindir}" != '${exec_prefix}/bin' ; then
|
|
||||||
unixstyle=yes
|
|
||||||
fi
|
|
||||||
if test "${datadir}" != '${prefix}/share' ; then
|
|
||||||
# Newer autoconf uses datarootdir:
|
|
||||||
if test "${datadir}" = '${datarootdir}' ; then
|
|
||||||
if test "${datarootdir}" != '${prefix}/share' ; then
|
|
||||||
unixstyle=yes
|
|
||||||
fi
|
|
||||||
else
|
|
||||||
unixstyle=yes
|
|
||||||
fi
|
|
||||||
fi
|
|
||||||
if test "${libdir}" != '${exec_prefix}/lib' ; then
|
|
||||||
unixstyle=yes
|
|
||||||
fi
|
|
||||||
if test "${includedir}" != '${prefix}/include' ; then
|
|
||||||
unixstyle=yes
|
|
||||||
fi
|
|
||||||
if test "${mandir}" != '${prefix}/man' ; then
|
|
||||||
if test "${mandir}" = '${datarootdir}/man' ; then
|
|
||||||
if test "${datarootdir}" != '${prefix}/share' ; then
|
|
||||||
unixstyle=yes
|
|
||||||
fi
|
|
||||||
else
|
|
||||||
unixstyle=yes
|
|
||||||
fi
|
|
||||||
fi
|
|
||||||
|
|
||||||
MAKE_COPYTREE=no
|
|
||||||
if test "${unixstyle}" = "no" ; then
|
|
||||||
if test "${prefix}" = "NONE" ; then
|
|
||||||
inplacebuild=yes
|
|
||||||
prefix=`cd "${srcdir}/.." && pwd`
|
|
||||||
else
|
|
||||||
MAKE_COPYTREE=copytree
|
|
||||||
fi
|
|
||||||
bindir='${prefix}/bin'
|
|
||||||
libpltdir='${prefix}/lib'
|
|
||||||
collectsdir='${prefix}/collects'
|
|
||||||
includepltdir='${prefix}/include'
|
|
||||||
docdir='${prefix}/doc'
|
|
||||||
mandir='${prefix}/man'
|
|
||||||
COLLECTS_PATH="../collects"
|
|
||||||
INSTALL_ORIG_TREE=yes
|
|
||||||
else
|
|
||||||
if test "${prefix}" = "NONE" ; then
|
|
||||||
# Set prefix explicitly so we can use it during configure
|
|
||||||
prefix="${ac_default_prefix}"
|
|
||||||
fi
|
|
||||||
libpltdir="${libdir}/racket"
|
|
||||||
collectsdir="${libdir}/racket/collects"
|
|
||||||
includepltdir="${includedir}/racket"
|
|
||||||
docdir="${datadir}/doc/racket"
|
|
||||||
MAKE_COPYTREE=copytree
|
|
||||||
COLLECTS_PATH='${collectsdir}'
|
|
||||||
INSTALL_ORIG_TREE=no
|
|
||||||
fi
|
|
||||||
|
|
||||||
|
|
||||||
echo ">>> Installation targets:"
|
|
||||||
echo " executables : ${bindir}/..."
|
|
||||||
echo " Racket code : ${collectsdir}/..."
|
|
||||||
echo " core docs : ${docdir}/..."
|
|
||||||
echo " C libraries : ${libdir}/..."
|
|
||||||
echo " C headers : ${includepltdir}/..."
|
|
||||||
echo " extra C objs : ${libpltdir}/..."
|
|
||||||
echo " man pages : ${mandir}/..."
|
|
||||||
echo " where prefix = ${prefix}"
|
|
||||||
echo " and datarootdir = ${datarootdir}"
|
|
||||||
|
|
@ -1,47 +0,0 @@
|
||||||
#!/bin/sh
|
|
||||||
|
|
||||||
awk -- '
|
|
||||||
/^expand_path_var()/ { showing = 1; }
|
|
||||||
{ if (showing) print; }
|
|
||||||
/^}/ { showing = 0; }
|
|
||||||
' "`dirname \"$0\"/`/installer-header" > "/tmp/test-$$"
|
|
||||||
. "/tmp/test-$$"
|
|
||||||
rm "/tmp/test-$$"
|
|
||||||
|
|
||||||
test() {
|
|
||||||
foo="$1"
|
|
||||||
expand_path_var foo
|
|
||||||
if [ ! "x$foo" = "x$2" ]; then
|
|
||||||
echo "fail: $1 -> $foo; expected $2" 1>&2
|
|
||||||
exit 1
|
|
||||||
fi
|
|
||||||
}
|
|
||||||
|
|
||||||
test 'blah' "blah"
|
|
||||||
test 'blah blah' "blah blah"
|
|
||||||
test 'blah blah' "blah blah"
|
|
||||||
test 'blah=blah' "blah=blah"
|
|
||||||
test 'x=1 y=2 z=3' "x=1 y=2 z=3"
|
|
||||||
test '$HOME' "$HOME"
|
|
||||||
test '$HOME/foo' "$HOME/foo"
|
|
||||||
test '$HOME/ foo' "$HOME/ foo"
|
|
||||||
test '$HOME / foo' "$HOME / foo"
|
|
||||||
test '~' "$HOME"
|
|
||||||
test '~/' "$HOME/"
|
|
||||||
test '~/x' "$HOME/x"
|
|
||||||
test '~/x/y' "$HOME/x/y"
|
|
||||||
test '~/x /y' "$HOME/x /y"
|
|
||||||
test '~/ x / y ' "$HOME/ x / y "
|
|
||||||
test '~/ ' "$HOME/ "
|
|
||||||
test '~ ' "~ "
|
|
||||||
test '~eli' "$HOME"
|
|
||||||
test '~eli ' "~eli "
|
|
||||||
test '~e li' "~e li"
|
|
||||||
test '~ eli' "~ eli"
|
|
||||||
test '~eli /x' "~eli /x"
|
|
||||||
test '~root/x' "/root/x"
|
|
||||||
test '~bleh' "~bleh"
|
|
||||||
test '~bleh ' "~bleh "
|
|
||||||
test '~/x y' "$HOME/x y"
|
|
||||||
test '~/x;pwd' "$HOME/x;pwd"
|
|
||||||
echo "All tests passed."
|
|
||||||
|
|
@ -1,466 +0,0 @@
|
||||||
#!/bin/sh
|
|
||||||
#| -*- scheme -*-
|
|
||||||
exec racket "$0" "$@"
|
|
||||||
|#
|
|
||||||
|
|
||||||
#lang at-exp racket/base
|
|
||||||
|
|
||||||
(require racket/list racket/file racket/match racket/system)
|
|
||||||
|
|
||||||
(define (err fmt . args)
|
|
||||||
(raise-user-error (format "Error: ~a" (apply format fmt args))))
|
|
||||||
|
|
||||||
(define testdir "/tmp/racket-installer-test")
|
|
||||||
(define installer
|
|
||||||
(match (current-command-line-arguments)
|
|
||||||
[(vector installer) installer]
|
|
||||||
[(vector _ ...) (err "usage: test-installer <installer-file-name>")]))
|
|
||||||
|
|
||||||
(define (exe name [just-path? #f])
|
|
||||||
(define path (or (find-executable-path name)
|
|
||||||
(err "no `~a' executable found" name)))
|
|
||||||
(λ args (unless (apply system* path args)
|
|
||||||
(err "`~a' signaled an error" name))))
|
|
||||||
|
|
||||||
(define expect-exe (exe "expect"))
|
|
||||||
(define sync-exe (exe "sync"))
|
|
||||||
|
|
||||||
(unless (file-exists? installer) (err "missing installer at: ~a" installer))
|
|
||||||
(when (directory-exists? testdir) (err "test directory exists: ~a" testdir))
|
|
||||||
(make-directory testdir)
|
|
||||||
(current-directory testdir)
|
|
||||||
;; plain interaction, identifiable prompts, safe-for-play home
|
|
||||||
(void (putenv "TERM" "dumb") (putenv "PS1" "sh> ") (putenv "HOME" testdir))
|
|
||||||
|
|
||||||
(define (transcript)
|
|
||||||
;; the test transcript text:
|
|
||||||
;; - text is matched against the process output (anchored)
|
|
||||||
;; - `i' is for user input to send
|
|
||||||
;; - `r' is for a regexp
|
|
||||||
;; - `s' is a nested list to be spliced in
|
|
||||||
;; - `N' is short for @r{(?:-?[0-9.]+)?}
|
|
||||||
;; - `...' makes the next match unanchored (so it's similar to a non-greedy
|
|
||||||
;; ".*" regexp)
|
|
||||||
(define (i . xs) `(i . ,xs))
|
|
||||||
(define (r . xs) `(r . ,xs))
|
|
||||||
(define (s . xs) `(s . ,xs))
|
|
||||||
(define break 'break)
|
|
||||||
(define N @r{(?:-?[0-9.]+)?})
|
|
||||||
(define ... '...)
|
|
||||||
(define not-recommended
|
|
||||||
(let ([s (string-append
|
|
||||||
"*** This is a nightly build: such a unix-style distribution"
|
|
||||||
" is *not*\n"
|
|
||||||
"*** recommended because it cannot be used to install multiple"
|
|
||||||
" versions.\n")])
|
|
||||||
(format "(?:~a)?" (regexp-quote s))))
|
|
||||||
@list{
|
|
||||||
@; the first few puzzling interactions are testing that we generate the
|
|
||||||
@; right expect code -- which requires regexp and $-quoting.
|
|
||||||
sh> @i{echo "blah"}
|
|
||||||
blah
|
|
||||||
sh> @i{echo 'blah'}
|
|
||||||
blah
|
|
||||||
sh> @i{x=123}
|
|
||||||
sh> @i{echo "][@"}{"blah*$x*"}
|
|
||||||
][@"}{"blah*123*
|
|
||||||
sh> @i{echo '[]{}blah*$x*'}
|
|
||||||
[]{}blah*$x*
|
|
||||||
sh> @i{pwd}
|
|
||||||
@testdir
|
|
||||||
@; utilities
|
|
||||||
sh> @i{LS() { ls --width=72 -mF "$@"@""@";" }}
|
|
||||||
@; proper testing begins here
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
This program will extract and install Racket v@|N|.
|
|
||||||
@||
|
|
||||||
Note: the required diskspace for this installation is @|N|M.
|
|
||||||
@||
|
|
||||||
Do you want a Unix-style distribution?
|
|
||||||
In this distribution mode files go into different directories according
|
|
||||||
to Unix conventions. A "racket-uninstall" script will be generated
|
|
||||||
to be used when you want to remove the installation. If you say 'no',
|
|
||||||
the whole Racket directory is kept in a single installation directory
|
|
||||||
(movable and erasable), possibly with external links into it -- this is
|
|
||||||
often more convenient, especially if you want to install multiple
|
|
||||||
versions or keep it in your home directory.
|
|
||||||
@r{@not-recommended}@;
|
|
||||||
Enter yes/no (default: no) > @i{bleh}
|
|
||||||
Enter yes/no (default: no) > @i{foo}
|
|
||||||
Enter yes/no (default: no) > @i{}
|
|
||||||
@||
|
|
||||||
Where do you want to install the "racket@N" directory tree?
|
|
||||||
1 - /usr/racket@N [default]
|
|
||||||
2 - /usr/local/racket@N
|
|
||||||
3 - ~/racket@N (@|testdir|/racket@N)
|
|
||||||
4 - ./racket@N (here)
|
|
||||||
Or enter a different "racket" directory to install in.
|
|
||||||
> @i{4}
|
|
||||||
@||
|
|
||||||
Checking the integrity of the binary archive... ok.
|
|
||||||
Unpacking into "@|testdir|/racket@N" (Ctrl+C to abort)...
|
|
||||||
Done.
|
|
||||||
@||
|
|
||||||
If you want to install new system links within the "bin" and
|
|
||||||
"man" subdirectories of a common directory prefix (for example,
|
|
||||||
"/usr/local") then enter the prefix of an existing directory
|
|
||||||
that you want to use. This might overwrite existing symlinks,
|
|
||||||
but not files.
|
|
||||||
(default: skip links) > @i{}
|
|
||||||
@||
|
|
||||||
Installation complete.
|
|
||||||
sh> @i{LS}
|
|
||||||
racket@|N|/
|
|
||||||
sh> @i{LS racket*}
|
|
||||||
README, bin/, collects/, doc/, include/, lib/, man/
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{No}
|
|
||||||
@...
|
|
||||||
> @i{.}
|
|
||||||
@||
|
|
||||||
Checking the integrity of the binary archive... ok.
|
|
||||||
"@|testdir|/racket@N" exists, delete? @i{n}
|
|
||||||
Aborting installation.
|
|
||||||
sh> @i{LS racket*}
|
|
||||||
README, bin/, collects/, doc/, include/, lib/, man/
|
|
||||||
sh> @i{chmod 000 racket*}
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{No}
|
|
||||||
@...
|
|
||||||
> @i{./}
|
|
||||||
@||
|
|
||||||
Checking the integrity of the binary archive... ok.
|
|
||||||
"@|testdir|/racket@N" exists, delete? @i{y}
|
|
||||||
Deleting old "@|testdir|/racket@N"... @;
|
|
||||||
/usr/bin/rm: cannot remove ‘@|testdir|/racket@|N|’: @;
|
|
||||||
Permission denied
|
|
||||||
Error: could not delete "@|testdir|/racket@N".
|
|
||||||
sh> @i{chmod 755 racket*}
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{No}
|
|
||||||
@...
|
|
||||||
> @i{.}
|
|
||||||
@||
|
|
||||||
Checking the integrity of the binary archive... ok.
|
|
||||||
"@|testdir|/racket@N" exists, delete? @i{y}
|
|
||||||
Deleting old "@|testdir|/racket@N"... done.
|
|
||||||
@...
|
|
||||||
(default: skip links) > @i{.}
|
|
||||||
"@|testdir|/bin" does not exist, skipping.
|
|
||||||
"@|testdir|/share/man/man1" does not exist, skipping.
|
|
||||||
@||
|
|
||||||
Installation complete.
|
|
||||||
sh> @i{mkdir bin}
|
|
||||||
sh> @i{touch R bin/gracket}
|
|
||||||
sh> @i{export TGT=R}
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{}
|
|
||||||
@...
|
|
||||||
> @i{$TGT}
|
|
||||||
@||
|
|
||||||
Checking the integrity of the binary archive... ok.
|
|
||||||
"R" exists (as a file), delete? @i{y}
|
|
||||||
Deleting old "R"... done.
|
|
||||||
Unpacking into "@|testdir|/R" (Ctrl+C to abort)...
|
|
||||||
Done.
|
|
||||||
@...
|
|
||||||
(default: skip links) > @i{.}
|
|
||||||
Installing links in "@|testdir|/bin"...
|
|
||||||
drracket, gracket skipped (non-link exists), gracket-text, mred, @;
|
|
||||||
mred-text, mzc, mzpp, mzscheme, mztext, pdf-slatex, plt-games, @;
|
|
||||||
plt-help, plt-r5rs, plt-r6rs, plt-web-server, racket, raco, scribble, @;
|
|
||||||
setup-plt, slatex, slideshow, swindle
|
|
||||||
done.
|
|
||||||
"@|testdir|/share/man/man1" does not exist, skipping.
|
|
||||||
@||
|
|
||||||
Installation complete.
|
|
||||||
sh> @i{LS .}
|
|
||||||
R/, bin/, racket@|N|/
|
|
||||||
sh> @i{LS R}
|
|
||||||
README, bin/, collects/, doc/, include/, lib/, man/
|
|
||||||
sh> @i{LS bin}
|
|
||||||
@s|{drracket@, gracket, gracket-text@, mred@, mred-text@, mzc@, mzpp@,
|
|
||||||
mzscheme@, mztext@, pdf-slatex@, plt-games@, plt-help@, plt-r5rs@,
|
|
||||||
plt-r6rs@, plt-web-server@, racket@, raco@, scribble@, setup-plt@,
|
|
||||||
slatex@, slideshow@, swindle@}|
|
|
||||||
sh> @i{LS -l bin/ra*}
|
|
||||||
lrwxrwxrwx. @... bin/racket -> @|testdir|/R/bin/racket*
|
|
||||||
lrwxrwxrwx. @... bin/raco -> @|testdir|/R/bin/raco*
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{}
|
|
||||||
@...
|
|
||||||
> @i{$TGT`echo 1`}
|
|
||||||
@||
|
|
||||||
Checking the integrity of the binary archive... ok.
|
|
||||||
Unpacking into "@|testdir|/R1" (Ctrl+C to abort)...
|
|
||||||
@break
|
|
||||||
@; HACK! BAD TEST!
|
|
||||||
@; This test fails sometimes, when `tar' happens to be the first to break,
|
|
||||||
@; leading to an unpacking error followed by the file cleanup followed by
|
|
||||||
@; the "aborting" errors and no cleanup (since it's already done). The
|
|
||||||
@; test can be modified to try either pattern but it'd be better to find
|
|
||||||
@; a way to make the output more predictable -- somehow kill the tar
|
|
||||||
@; process before it errors, and more generally, make it kill any child
|
|
||||||
@; processes.
|
|
||||||
Error: Aborting...
|
|
||||||
(Removing installation files in @|testdir|/R1)
|
|
||||||
sh> @i{LS}
|
|
||||||
R/, bin/, racket@|N|/
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{}
|
|
||||||
@...
|
|
||||||
> @i{mmm}
|
|
||||||
@...
|
|
||||||
Unpacking into "@|testdir|/mmm" (Ctrl+C to abort)...
|
|
||||||
Done.
|
|
||||||
@...
|
|
||||||
(default: skip links) > @break
|
|
||||||
Error: Aborting...
|
|
||||||
sh> @i{LS}
|
|
||||||
R/, bin/, mmm/, racket@|N|/
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{}
|
|
||||||
@...
|
|
||||||
> @i{`pwd`}
|
|
||||||
@...
|
|
||||||
"@testdir" is where you ran the installer from, delete? @i{y}
|
|
||||||
Deleting old "@testdir"... done.
|
|
||||||
*** Note: your original directory was deleted, so you will need
|
|
||||||
*** to 'cd' back into it when the installer is done, otherwise
|
|
||||||
*** it will look like you have an empty directory.
|
|
||||||
Unpacking into "@testdir" (Ctrl+C to abort)...
|
|
||||||
Done.
|
|
||||||
@...
|
|
||||||
(default: skip links) > @i{/usr/local}
|
|
||||||
"/usr/local" is not writable, skipping links.
|
|
||||||
@||
|
|
||||||
Installation complete.
|
|
||||||
sh> @i{LS}
|
|
||||||
sh> @i{cd /}
|
|
||||||
sh> @i{cd @testdir}
|
|
||||||
sh> @i{LS}
|
|
||||||
README, bin/, collects/, doc/, include/, lib/, man/
|
|
||||||
sh> @i{rm -rf [a-zR]*}
|
|
||||||
sh> @i{LS}
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Do you want a Unix-style distribution?
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{bleh}
|
|
||||||
Enter yes/no (default: no) > @i{yes}
|
|
||||||
@||
|
|
||||||
Where do you want to base your installation of Racket v@|N|?
|
|
||||||
(If you've done such an installation in the past, either
|
|
||||||
enter the same directory, or run 'racket-uninstall' manually.)
|
|
||||||
1 - /usr/... [default]
|
|
||||||
2 - /usr/local/...
|
|
||||||
3 - ~/... (@|testdir|/...)
|
|
||||||
4 - ./... (here)
|
|
||||||
Or enter a different directory prefix to install in.
|
|
||||||
> @i{}
|
|
||||||
Error: The entered base directory is not writable: /usr
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{y}
|
|
||||||
@...
|
|
||||||
> @i{2}
|
|
||||||
Error: The entered base directory is not writable: /usr/local
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{y}
|
|
||||||
@...
|
|
||||||
> @i{3}
|
|
||||||
@||
|
|
||||||
Target Directories:
|
|
||||||
[e] Executables @|testdir|/bin (will be created)
|
|
||||||
[r] Racket Code @|testdir|/lib/racket@|N|/collects (will be created)
|
|
||||||
[d] Core Docs @|testdir|/share/racket@|N|/doc (will be created)
|
|
||||||
[l] C Libraries @|testdir|/lib (will be created)
|
|
||||||
[h] C headers @|testdir|/include/racket@|N| (will be created)
|
|
||||||
[o] Extra C Objs @|testdir|/lib/racket@|N| (will be created)
|
|
||||||
[m] Man Pages @|testdir|/share/man (will be created)
|
|
||||||
Enter a letter to change an entry, or enter to continue.
|
|
||||||
> @i{z}
|
|
||||||
> @i{Q}
|
|
||||||
> @i{}
|
|
||||||
@||
|
|
||||||
Checking the integrity of the binary archive... ok.
|
|
||||||
Unpacking into "@|testdir|/racket@|N|-tmp-install" (Ctrl+C to abort)...
|
|
||||||
Done.
|
|
||||||
Moving bin -> @|testdir|/bin
|
|
||||||
Moving collects -> @|testdir|/lib/racket@|N|/collects
|
|
||||||
Moving doc -> @|testdir|/share/racket@|N|/doc
|
|
||||||
Moving include -> @|testdir|/include/racket@|N|
|
|
||||||
Moving lib -> @|testdir|/lib/racket@|N|
|
|
||||||
Moving man -> @|testdir|/share/man
|
|
||||||
Moving README -> @|testdir|/share/racket@|N|/doc/README
|
|
||||||
Writing uninstaller at: @|testdir|/bin/racket-uninstall...
|
|
||||||
Rewriting configuration file at: @|testdir|/lib/racket@|N|/@;
|
|
||||||
collects/config/config.rkt...
|
|
||||||
Recompiling to @|testdir|/lib/racket@|N|/@;
|
|
||||||
collects/config/compiled/config_rkt.zo...
|
|
||||||
@||
|
|
||||||
Installation complete.
|
|
||||||
sh> @i{LS}
|
|
||||||
bin/, include/, lib/, share/
|
|
||||||
sh> @i{LS bin}
|
|
||||||
drracket*, gracket*, gracket-text*, mred*, mred-text*, mzc*, mzpp*,
|
|
||||||
mzscheme*, mztext*, pdf-slatex*, plt-games*, plt-help*, plt-r5rs*,
|
|
||||||
plt-r6rs*, plt-web-server*, racket*, racket-uninstall*, raco*,
|
|
||||||
scribble*, setup-plt*, slatex*, slideshow*, swindle*
|
|
||||||
sh> @i{LS include && LS lib && LS share}
|
|
||||||
racket@|N|/
|
|
||||||
racket@|N|/
|
|
||||||
man/, racket@|N|/
|
|
||||||
sh> @i{LS include/r*}
|
|
||||||
escheme.h, ext.exp, mzconfig.h, mzscheme3m.exp, scheme.h, schemef.h,
|
|
||||||
schemegc2.h, schemex.h, schemexm.h, schexn.h, schgc2obj.h, schthread.h,
|
|
||||||
schvers.h, sconfig.h, stypes.h, uconfig.h
|
|
||||||
sh> @i{LS lib/r*}
|
|
||||||
buildinfo, collects/, mzdyn3m.o, starter*
|
|
||||||
sh> @i{LS share/r* && LS share/r*/doc}
|
|
||||||
doc/
|
|
||||||
README, @|...|xrepl/
|
|
||||||
sh> @i{LS share/man && LS share/man/man1}
|
|
||||||
man1/
|
|
||||||
drracket.1, gracket.1, mred.1, mzc.1, mzscheme.1, plt-help.1, racket.1,
|
|
||||||
raco.1, setup-plt.1
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{y}
|
|
||||||
@...
|
|
||||||
> @i{meh}
|
|
||||||
Base directory does not exist: meh
|
|
||||||
should I create it? (default: yes) @i{n}
|
|
||||||
Aborting installation.
|
|
||||||
sh> @i{touch m}
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{y}
|
|
||||||
@...
|
|
||||||
> @i{4}
|
|
||||||
@||
|
|
||||||
Target Directories:
|
|
||||||
[e] Executables @|testdir|/bin (exists)
|
|
||||||
[r] Racket Code @|testdir|/lib/racket@|N|/collects (exists)
|
|
||||||
[d] Core Docs @|testdir|/share/racket@|N|/doc (exists)
|
|
||||||
[l] C Libraries @|testdir|/lib (exists)
|
|
||||||
[h] C headers @|testdir|/include/racket@|N| (exists)
|
|
||||||
[o] Extra C Objs @|testdir|/lib/racket@|N| (exists)
|
|
||||||
[m] Man Pages @|testdir|/share/man (exists)
|
|
||||||
Enter a letter to change an entry, or enter to continue.
|
|
||||||
> @i{m}
|
|
||||||
New directory (absolute or relative to @testdir): @i{m}
|
|
||||||
@||
|
|
||||||
Target Directories:
|
|
||||||
[e] Executables @|testdir|/bin (exists)
|
|
||||||
[r] Racket Code @|testdir|/lib/racket@|N|/collects (exists)
|
|
||||||
[d] Core Docs @|testdir|/share/racket@|N|/doc (exists)
|
|
||||||
[l] C Libraries @|testdir|/lib (exists)
|
|
||||||
[h] C headers @|testdir|/include/racket@|N| (exists)
|
|
||||||
[o] Extra C Objs @|testdir|/lib/racket@|N| (exists)
|
|
||||||
[m] Man Pages @|testdir|/m (error: not a directory!)
|
|
||||||
Enter a letter to change an entry, or enter to continue.
|
|
||||||
> @i{}
|
|
||||||
*** Please fix erroneous paths to proceed
|
|
||||||
@...
|
|
||||||
Enter a letter to change an entry, or enter to continue.
|
|
||||||
> @i{m}
|
|
||||||
New directory (absolute or relative to @testdir): @i{man}
|
|
||||||
@||
|
|
||||||
Target Directories:
|
|
||||||
[e] Executables @|testdir|/bin (exists)
|
|
||||||
[r] Racket Code @|testdir|/lib/racket@|N|/collects (exists)
|
|
||||||
[d] Core Docs @|testdir|/share/racket@|N|/doc (exists)
|
|
||||||
[l] C Libraries @|testdir|/lib (exists)
|
|
||||||
[h] C headers @|testdir|/include/racket@|N| (exists)
|
|
||||||
[o] Extra C Objs @|testdir|/lib/racket@|N| (exists)
|
|
||||||
[m] Man Pages @|testdir|/man (will be created)
|
|
||||||
Enter a letter to change an entry, or enter to continue.
|
|
||||||
> @i{}
|
|
||||||
@||
|
|
||||||
A previous Racket uninstaller is found at
|
|
||||||
"@|testdir|/bin/racket-uninstall",
|
|
||||||
should I run it? (default: yes) @i{}
|
|
||||||
running uninstaller... done.
|
|
||||||
@||
|
|
||||||
Checking the integrity of the binary archive... ok.
|
|
||||||
@...
|
|
||||||
Installation complete.
|
|
||||||
sh> @i{LS}
|
|
||||||
bin/, include/, lib/, m, man/, share/
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{y}
|
|
||||||
@...
|
|
||||||
> @i{4}
|
|
||||||
@...
|
|
||||||
> @i{}
|
|
||||||
@||
|
|
||||||
A previous Racket uninstaller is found at
|
|
||||||
"@|testdir|/bin/racket-uninstall",
|
|
||||||
should I run it? (default: yes) @i{n}
|
|
||||||
Aborting installation.
|
|
||||||
sh> @i{rm -rf share}
|
|
||||||
sh> @i{sh @installer}
|
|
||||||
@...
|
|
||||||
Enter yes/no (default: no) > @i{y}
|
|
||||||
@...
|
|
||||||
> @i{4}
|
|
||||||
@...
|
|
||||||
[m] Man Pages @|testdir|/man (exists)
|
|
||||||
Enter a letter to change an entry, or enter to continue.
|
|
||||||
> @break
|
|
||||||
Error: Aborting...
|
|
||||||
sh> @i{LS}
|
|
||||||
bin/, include/, lib/, m, man/
|
|
||||||
sh> @i{exit}
|
|
||||||
@||})
|
|
||||||
|
|
||||||
(define (make-expect-script)
|
|
||||||
(printf "spawn sh\nproc abort {} { puts \"timeout!\\n\"; exit 1 }\n")
|
|
||||||
(printf "set timeout 60\n")
|
|
||||||
(define (tclq str)
|
|
||||||
;; tcl uses $ and [] for variable & function call interpolation, and "}{"
|
|
||||||
;; can confuse it; quote all of these
|
|
||||||
(regexp-replace* "[][{}$]" (format "~s" str) "\\\\&"))
|
|
||||||
(define (expect strs anchored?)
|
|
||||||
(unless (null? strs)
|
|
||||||
(define str (if (string? strs) strs (apply string-append strs)))
|
|
||||||
(let ([str (regexp-replace* "\r?\n" str "\r\n")])
|
|
||||||
(printf "expect {\n timeout abort\n -re ~a\n}\n"
|
|
||||||
(tclq (if anchored? (string-append "^" str) str))))))
|
|
||||||
(define (send strs)
|
|
||||||
(define str (if (string? strs) strs (apply string-append strs)))
|
|
||||||
(printf "send -- ~a\n" (tclq (string-append str "\n"))))
|
|
||||||
(let loop ([strs '()] [xs (transcript)] [anchored? #t])
|
|
||||||
(define (do-expect) (expect (reverse strs) anchored?))
|
|
||||||
(if (null? xs)
|
|
||||||
(do-expect)
|
|
||||||
(match (car xs)
|
|
||||||
['... (do-expect) (loop '() (cdr xs) #f)]
|
|
||||||
[(? string? x) (loop (cons (regexp-quote x) strs) (cdr xs) anchored?)]
|
|
||||||
[`(s . ,sxs) (loop strs (append sxs (cdr xs)) anchored?)]
|
|
||||||
[`(r . ,rxs) (loop (append (reverse rxs) strs) (cdr xs) anchored?)]
|
|
||||||
[`(i . ,inps) (do-expect) (send inps)
|
|
||||||
(loop (map regexp-quote (reverse inps)) (cdr xs) #t)]
|
|
||||||
['break (do-expect) (printf "send \"\\03\"\n")
|
|
||||||
(loop '("\\^C") (cdr xs) #t)]
|
|
||||||
[x (err "bad item in transcript: ~s" (car xs))])))
|
|
||||||
(printf "expect eof\n"))
|
|
||||||
|
|
||||||
(with-output-to-file "/tmp/racket-installer-expect-script" make-expect-script)
|
|
||||||
(sync-exe) ; we'll shuffle a lot of bytes, be prepared
|
|
||||||
(expect-exe "/tmp/racket-installer-expect-script")
|
|
||||||
|
|
||||||
(delete-directory/files testdir)
|
|
||||||
(delete-file "/tmp/racket-installer-expect-script")
|
|
||||||
|
|
||||||
(printf "\n--> All tests passed.\n")
|
|
||||||
|
|
@ -1,107 +0,0 @@
|
||||||
#!/bin/sh
|
|
||||||
#| -*- scheme -*-
|
|
||||||
exec racket -um "$0" "$@"
|
|
||||||
|#
|
|
||||||
|
|
||||||
#lang racket/base
|
|
||||||
(require version/utils racket/file)
|
|
||||||
|
|
||||||
(define (patches)
|
|
||||||
;; no grouping parens in regexps
|
|
||||||
(let* ([parts# (length (regexp-split #rx"[.]" the-version))]
|
|
||||||
[concat
|
|
||||||
(lambda xs
|
|
||||||
(apply bytes-append
|
|
||||||
(map (lambda (x) (if (string? x) (string->bytes/utf-8 x) x))
|
|
||||||
xs)))]
|
|
||||||
[commas "<1>, *<2>, *<3>, *<4>"]
|
|
||||||
[periods "<1>.<2>.<3>.<4>"]
|
|
||||||
[rc-patch (list (concat "\r\n *FILEVERSION "commas" *"
|
|
||||||
"\r\n *PRODUCTVERSION "commas" *\r\n")
|
|
||||||
(concat "\r\n *VALUE \"FileVersion\", *\""commas
|
|
||||||
"(?:\\\\0)?\"")
|
|
||||||
(concat "\r\n *VALUE \"ProductVersion\", *\""commas
|
|
||||||
"(?:\\\\0)?\""))]
|
|
||||||
[manifest-patch (list (concat "assemblyIdentity[ \r\n]+"
|
|
||||||
"version=\""periods"\"[ \r\n]"))])
|
|
||||||
`([#t ; only verify that it has the right contents
|
|
||||||
"src/racket/src/schvers.h"
|
|
||||||
,(concat "\n#define MZSCHEME_VERSION \"<1>.<2>"
|
|
||||||
(if (parts# . >= . 3) ".<3>" "")
|
|
||||||
(if (parts# . >= . 4) ".<4>" "")
|
|
||||||
"\"\n")
|
|
||||||
,@(for/list ([x+n (in-list '([X 1] [Y 2] [Z 3] [W 4]))])
|
|
||||||
(format "\n#define MZSCHEME_VERSION_~a ~a\n"
|
|
||||||
(car x+n)
|
|
||||||
(if ((cadr x+n) . > . parts#)
|
|
||||||
"0" (format "<~a>" (cadr x+n)))))]
|
|
||||||
["src/worksp/racket/racket.rc" ,@rc-patch]
|
|
||||||
["src/worksp/gracket/gracket.rc" ,@rc-patch]
|
|
||||||
["src/worksp/starters/start.rc" ,@rc-patch]
|
|
||||||
["src/worksp/racket/racket.manifest" ,@manifest-patch]
|
|
||||||
["src/worksp/gracket/gracket.manifest" ,@manifest-patch]
|
|
||||||
["src/worksp/mzcom/mzobj.rgs"
|
|
||||||
,(concat "MzCOM.MzObj."periods" = s 'MzObj Class'")
|
|
||||||
,(concat "CurVer = s 'MzCOM.MzObj."periods"'")
|
|
||||||
,(concat "ProgID = s 'MzCOM.MzObj."periods"'")]
|
|
||||||
["src/worksp/mzcom/mzcom.rc" ,@rc-patch
|
|
||||||
#"\r\n *CTEXT +\"MzCOM v. <1>.<2>\",IDC_STATIC"
|
|
||||||
#"\r\n *CTEXT +\"Racket v. <1>.<2>\",IDC_STATIC"])))
|
|
||||||
|
|
||||||
(define the-version #f)
|
|
||||||
|
|
||||||
(define getv
|
|
||||||
(let ([vlist #f])
|
|
||||||
(lambda (i)
|
|
||||||
(unless vlist
|
|
||||||
(set! vlist (map (compose string->bytes/utf-8 number->string)
|
|
||||||
(version->list the-version))))
|
|
||||||
(list-ref vlist i))))
|
|
||||||
|
|
||||||
(define (replace-pattern pattern buf err)
|
|
||||||
(let* ([rx (regexp-replace* #rx#"<[1234]>" pattern #"([0-9]+)")]
|
|
||||||
[vs (map (lambda (m)
|
|
||||||
(let* ([m (regexp-replace #rx#"^<(.+)>$" m #"\\1")]
|
|
||||||
[m (string->number (bytes->string/utf-8 m))])
|
|
||||||
(sub1 m)))
|
|
||||||
(regexp-match* #rx#"<[1234]>" pattern))]
|
|
||||||
[m (regexp-match-positions rx buf)])
|
|
||||||
(cond
|
|
||||||
[(not m) (err "pattern ~s not found" pattern)]
|
|
||||||
[(regexp-match? rx buf (cdar m))
|
|
||||||
(err "pattern ~s matches more than once" pattern)]
|
|
||||||
[else (let loop ([m (cdr m)] [i 0] [vs vs] [r '()])
|
|
||||||
(cond [(and (null? m) (null? vs))
|
|
||||||
(apply bytes-append (reverse (cons (subbytes buf i) r)))]
|
|
||||||
[(or (null? m) (null? vs)) (error "internal error")]
|
|
||||||
[else (loop (cdr m) (cdar m) (cdr vs)
|
|
||||||
(list* (getv (car vs))
|
|
||||||
(subbytes buf i (caar m))
|
|
||||||
r))]))])))
|
|
||||||
|
|
||||||
(define (do-patch file . specs)
|
|
||||||
(let* ([only-verify? (eq? file #t)]
|
|
||||||
[file (if only-verify? (car specs) file)]
|
|
||||||
[specs (if only-verify? (cdr specs) specs)]
|
|
||||||
[_ (begin (printf " ~a..." file) (flush-output))]
|
|
||||||
[contents (file->bytes file)]
|
|
||||||
[buf contents]
|
|
||||||
[err (lambda (fmt . args)
|
|
||||||
(error 'versionpatch "~a, in ~s"
|
|
||||||
(apply format fmt args) file))])
|
|
||||||
(for ([spec (in-list specs)]) (set! buf (replace-pattern spec buf err)))
|
|
||||||
(if (equal? buf contents)
|
|
||||||
(printf (if only-verify? " verified.\n" " no change.\n"))
|
|
||||||
(begin (printf " modified.\n")
|
|
||||||
(if only-verify?
|
|
||||||
(error 'versionpatch
|
|
||||||
"this file is expected to have a correct version")
|
|
||||||
(with-output-to-file file (lambda () (write-bytes buf))
|
|
||||||
#:exists 'truncate))))))
|
|
||||||
|
|
||||||
(provide main)
|
|
||||||
(define (main ver)
|
|
||||||
(set! the-version ver)
|
|
||||||
;; (printf "Patching files for ~a...\n" ver)
|
|
||||||
(for ([p (in-list (patches))]) (apply do-patch p))
|
|
||||||
(printf "Done.\n"))
|
|
||||||
|
|
@ -3,8 +3,7 @@
|
||||||
(define name "Infrastructure code")
|
(define name "Infrastructure code")
|
||||||
(define compile-omit-paths '("images/taking-screenshots/racket-widget.scm"))
|
(define compile-omit-paths '("images/taking-screenshots/racket-widget.scm"))
|
||||||
(define test-omit-paths
|
(define test-omit-paths
|
||||||
'("build"
|
'("check-dists.rkt"
|
||||||
"check-dists.rkt"
|
|
||||||
"drdr"
|
"drdr"
|
||||||
"drdr2"
|
"drdr2"
|
||||||
"images/mkheart.rkt"
|
"images/mkheart.rkt"
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user