/usr/share/racket/pkgs/games/main.rkt is in racket-common 6.1-4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | #lang racket/gui
(require setup/getinfo
net/sendurl)
(define-struct game (file name set icon))
(define (get-game gamedir)
(define-values (base name dir?) (split-path gamedir))
(define game (path-element->string name))
(define info (with-handlers ([exn:fail? (lambda (x) #f)])
(get-info (list "games" game))))
(define main (and info (info 'game (lambda () #f))))
(define (gamefile f) (build-path gamedir f))
(and main
(make-game
(gamefile main)
(info 'name (λ () (string-titlecase (regexp-replace* #rx"-" game " "))))
(info 'game-set (λ () "Other Games"))
(info 'game-icon (λ () (gamefile (format "~a.png" game)))))))
(define (run-game game)
(define c (make-custodian))
(define run
(dynamic-wind
begin-busy-cursor
(lambda ()
(with-handlers ([exn? (lambda (e) (lambda () (raise e)))])
(let ([u (dynamic-require (game-file game) 'game@)])
(lambda () (invoke-unit u)))))
end-busy-cursor))
(parameterize* ([current-custodian c]
[current-namespace (make-gui-empty-namespace)]
[current-eventspace (make-eventspace)])
(queue-callback
(lambda ()
(exit-handler (lambda (v) (custodian-shutdown-all c)))
(with-handlers ([exn? (lambda (e)
(message-box (format "Error in \"~a\""
(game-name game))
(let ([ep (open-output-string)])
(parameterize ([current-error-port ep])
((error-display-handler) (exn-message e) e))
(get-output-string ep))
f
'(ok)))])
(run))))))
(define games
(for/list ([gamedir (in-list (find-relevant-directories '(game)))])
(get-game gamedir)))
(define game-sets
(let ([ht (make-hash)])
(for ([g (in-list games)])
(let ([set (game-set g)])
(hash-set! ht set (cons g (hash-ref ht set '())))))
(sort (hash-map ht cons)
(lambda (x y)
(let ([xlen (length x)] [ylen (length y)])
(cond [(> xlen ylen) #t]
[(< xlen ylen) #f]
[else (string<? (car x) (car y))]))))))
(define f (new (class frame%
(augment* [on-close (lambda () (exit))])
(super-new))
[label "PLT Games"]
[style '(metal no-resize-border)]))
(define main (make-object horizontal-panel% f))
(send f set-alignment 'left 'top)
(send f stretchable-width #f)
(send f stretchable-height #f)
(for ([set (in-list game-sets)])
(define set-name (car set))
(define games (cdr set))
(define panel
(new group-box-panel% [label set-name] [parent main]))
(define buttons
(map (lambda (game)
(new button%
[label (list (read-bitmap (game-icon game)) (game-name game) 'left)]
[parent panel]
[callback (lambda _ (run-game game))]))
games))
(define sorted
(sort buttons (lambda (x y) (< (send x min-width) (send y min-width)))))
(send panel change-children (lambda (l) sorted)))
(define (show-games-help)
(with-handlers ([exn:fail? (lambda (exn)
(message-box
"Error"
(~a "Could not open help.\n"
(if (exn:missing-module? exn)
"Support for documentation may not be installed.\n"
"")
"\n"
(exn-message exn))
#f
'(ok stop)))])
(define-values (path anchor)
((dynamic-require 'scribble/xref 'xref-tag->path+anchor)
((dynamic-require 'setup/xref 'load-collections-xref))
((dynamic-require 'scribble/tag 'make-section-tag)
"top"
#:doc '(lib "games/scribblings/games.scrbl"))))
(send-url/file path #:fragment anchor)))
(application-about-handler show-games-help)
(application-preferences-handler
(lambda ()
(message-box
"Oops"
"There aren't actually any preferences."
f
'(ok))))
(send f show #t)
;; For test mode, check that we can at least start,
;; but exit right away:
(module+ test
(queue-callback (lambda () (exit )) #f))
|