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

fixed a bug that prevented universe from restarting on some occasions

Browse Source 
(cherry picked from commit fbb3145f39)
This commit is contained in:
Matthias Felleisen 2013-01-09 17:51:18 -05:00 committed by Ryan Culpepper
parent 17a48546f8
commit ceb393f5cd
2 changed files with 15 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/2htdp/private/universe.rkt
View File

@ -94,10 +94,7 @@
(send universe set (format "value returned from ~a" 'name) u) (send universe set (format "value returned from ~a" 'name) u)
(unless (boolean? to-string) (send gui add (to-string u))) (unless (boolean? to-string) (send gui add (to-string u)))
(broadcast mails) (broadcast mails)
(for-each (lambda (iw) (for-each (lambda (iw) (kill iw "disconnected ~a")) bad)))))
(iworld-close iw)
(set! iworlds (remq iw iworlds)))
bad)))))
;; [Listof Mail] -> Void ;; [Listof Mail] -> Void
;; send payload of messages to designated worlds ;; send payload of messages to designated worlds
@ -106,11 +103,11 @@
(define w (mail-to p+m)) (define w (mail-to p+m))
(define p (mail-content p+m)) (define p (mail-content p+m))
(define n (iworld-name w)) (define n (iworld-name w))
(if (not (memq w iworlds)) (if (memq w iworlds)
(send gui add (format "~s not on list" n)) (with-handlers ((exn:fail? (lambda (e) (kill w "broadcast failed to ~a"))))
(with-handlers ((exn:fail? (lambda (e) (kill w)))) (send gui add (format "-> ~a: ~a" n p))
(iworld-send w p) (iworld-send w p))
(send gui add (format "-> ~a: ~a" n p))))) (send gui add (format "~s not on list" n))))
lm)) lm))
(def/cback private (pnew iworld) on-new (def/cback private (pnew iworld) on-new
@ -121,7 +118,7 @@
(send gui add (format "~a ->: ~a" (iworld-name iworld) r))) (send gui add (format "~a ->: ~a" (iworld-name iworld) r)))
(def/cback private (pdisconnect iworld) on-disconnect (def/cback private (pdisconnect iworld) on-disconnect
(kill iworld)) (kill iworld "~a !! closed port"))
;; tick, tock : deal with a tick event for this world ;; tick, tock : deal with a tick event for this world
(def/cback pubment (ptock) (let ([on-tick (lambda (w) (pptock w))]) on-tick)) (def/cback pubment (ptock) (let ([on-tick (lambda (w) (pptock w))]) on-tick))
@ -129,13 +126,14 @@
(define/public (name-of-tick-handler) (define/public (name-of-tick-handler)
"the on-tick-handler") "the on-tick-handler")
;; IWorld -> Void ;; IWorld FormatString -> Void
;; effect: remove from given iworld from iworlds ;; effect: remove from given iworld from iworlds
;; and shut down all connections ;; and shut down all connections
(define/private (kill w) (define/private (kill w msg)
(send gui add (format "~a !! closed port" (iworld-name w))) (iworld-close w)
(set! iworlds (remq w iworlds)) (set! iworlds (remq w iworlds))
(iworld-close w)) (send gui add (format msg (iworld-name w)))
(when (null? iworlds) (restart)))
;; ----------------------------------------------------------------------- ;; -----------------------------------------------------------------------
;; start and stop server, start and stop the universe ;; start and stop server, start and stop the universe
@ -154,9 +152,7 @@
(define (loop) (define (loop)
(apply sync (apply sync
(handle-evt (tcp-accept-evt tcp-listener) add-iworld) (handle-evt (tcp-accept-evt tcp-listener) add-iworld)
(map(lambda (p) (map(lambda (p) (handle-evt (iworld-in p) (process-message p))) iworlds)))
(handle-evt (iworld-in p) (process-message p)))
iworlds)))
;;; WHERE ;;; WHERE
(define tcp-listener (define tcp-listener
(with-handlers ((exn:fail:network? (lambda (x) (stop! x)))) (with-handlers ((exn:fail:network? (lambda (x) (stop! x))))
@ -179,7 +175,7 @@
(lambda (in) (lambda (in)
(define (disc e) (define (disc e)
(pdisconnect p) (pdisconnect p)
(if (null? iworlds) (restart) (loop))) (loop))
(with-handlers ((tcp-eof? disc)) (with-handlers ((tcp-eof? disc))
(pmsg p (tcp-receive in)) (pmsg p (tcp-receive in))
(loop)))) (loop))))

1
collects/2htdp/xtest
View File

@ -40,6 +40,7 @@ run on-tick-with-limit.rkt
run on-release-no-key.rkt run on-release-no-key.rkt
run struct-universe.rkt run struct-universe.rkt
run universe-receive.rkt run universe-receive.rkt
run universe-restart.rkt
run name.rkt run name.rkt
run pad1.rkt run pad1.rkt
run pad1-handler.rkt run pad1-handler.rkt