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

remove obsolte build support

Browse Source 
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 2014-07-29 10:58:09 +01:00
parent 0d25969ff0
commit 6621e48b86
27 changed files with 1 additions and 7970 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2329
pkgs/plt-services/meta/build/build
View File

File diff suppressed because it is too large Load Diff

525
pkgs/plt-services/meta/build/bundle
View File

@ -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)))

128
pkgs/plt-services/meta/build/current-build-status.cgi
View File

@ -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"

BIN
pkgs/plt-services/meta/build/dmg/128x128-arrow.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 4.9 KiB

194
pkgs/plt-services/meta/build/dmg/disk-image-background.rkt
View File

@ -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))

88
pkgs/plt-services/meta/build/dmg/run
View File

@ -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

2
pkgs/plt-services/meta/build/info.rkt
View File

@ -1,2 +0,0 @@
#lang info
(define compile-omit-paths 'all)

200
pkgs/plt-services/meta/build/make-patch
View File

@ -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)

311
pkgs/plt-services/meta/build/nsis/installer.nsi
View File

@ -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
pkgs/plt-services/meta/build/sitemap/AUTHORS
View File

@ -1 +0,0 @@
opensource@google.com

37
pkgs/plt-services/meta/build/sitemap/COPYING
View File

@ -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

65
pkgs/plt-services/meta/build/sitemap/ChangeLog
View File

@ -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.

10
pkgs/plt-services/meta/build/sitemap/PKG-INFO
View File

@ -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

25
pkgs/plt-services/meta/build/sitemap/README
View File

@ -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.

164
pkgs/plt-services/meta/build/sitemap/example_config.xml
View File

@ -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>

21
pkgs/plt-services/meta/build/sitemap/example_urllist.txt
View File

@ -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

16
pkgs/plt-services/meta/build/sitemap/plt-pre.xml
View File

@ -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>

12
pkgs/plt-services/meta/build/sitemap/setup.py
View File

@ -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/',
)

2205
pkgs/plt-services/meta/build/sitemap/sitemap_gen.py
View File

File diff suppressed because it is too large Load Diff

765
pkgs/plt-services/meta/build/sitemap/test_sitemap_gen.py
View File

@ -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/&#252;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()

80
pkgs/plt-services/meta/build/test-drracket.rkt
View File

@ -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)

61
pkgs/plt-services/meta/build/unix-installer/check-install-paths
View File

@ -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)

109
pkgs/plt-services/meta/build/unix-installer/paths-configure-snapshot
View File

@ -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}"

47
pkgs/plt-services/meta/build/unix-installer/test-expand-path-var
View File

@ -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."

466
pkgs/plt-services/meta/build/unix-installer/test-installer
View File

@ -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")

107
pkgs/plt-services/meta/build/versionpatch
View File

@ -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
pkgs/plt-services/meta/info.rkt
View File

@ -3,8 +3,7 @@
(define name "Infrastructure code")
(define compile-omit-paths '("images/taking-screenshots/racket-widget.scm"))
(define test-omit-paths
'("build"
"check-dists.rkt"
'("check-dists.rkt"
"drdr"
"drdr2"
"images/mkheart.rkt"