From: Christopher Allan Webber <cwebber@dustycloud.org>
Date: Sat, 4 Feb 2017 06:17:53 +0000 (-0600)
Subject: more bug-proof exit traversal
X-Git-Tag: fosdem-2017~8
X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=commitdiff_plain;h=1b98acaf025ea951cbbbf318005652c13c79bbfd

more bug-proof exit traversal
---

diff --git a/mudsync/room.scm b/mudsync/room.scm
index 1667b10..ba4af4c 100644
--- a/mudsync/room.scm
+++ b/mudsync/room.scm
@@ -32,7 +32,8 @@
 ;;; =====
 
 (define-class <exit> ()
-  (to #:init-keyword #:to)
+  (to #:init-keyword #:to
+      #:init-value #f)
   ;; Name of the room (@@: Should this be names?)
   (name #:getter exit-name
         #:init-keyword #:name)
@@ -160,34 +161,41 @@
                         (exit-can-traverse? exit room player))
       (lambda* (can-traverse? #:optional player-flavortext
                               room-flavortext)
-        (if can-traverse?
-            ;; looks like we can go, so let's go!
-            (begin
-              ;; Set the player's new location
-              (<-wait player 'set-loc!
-                      #:loc to-address)
-              (when player-flavortext
-                (<-wait player 'tell
-                        #:text player-flavortext))
-              ;; Tell everyone else the person walked away
-              (room-tell-room
-               room (or room-flavortext
-                        (format #f "~a wanders ~a.\n"
-                                player-name direct-obj)))
-              (<- to-address 'announce-entrance
-                  #:who-entered player)
-              ;; Have the new room update the player to the new location
-              (<- to-address 'look-room
-                  #:to-id player))
-            ;; Otherwise, if we can't go...
-            (begin
-              (<- player 'tell
-                  #:text (or player-flavortext
-                             `("You try to go " ,direct-obj " but something "
-                               "seems to block you.")))
-              (when room-flavortext
-                (room-tell-room room room-flavortext
-                                #:exclude player)))))))
+        (cond
+         ;; The exit itself objects to moving
+         ((not can-traverse?)
+          (<- player 'tell
+              #:text (or player-flavortext
+                         `("You try to go " ,direct-obj " but something "
+                           "seems to block you.")))
+          (when room-flavortext
+            (room-tell-room room room-flavortext
+                            #:exclude player)))
+         ;; to-address points nowhere, or exit not set.
+         ((not exit)
+          (<- player 'tell
+              #:text '((i "Yikes!") " Something weird is going on. "
+                       "It seems like this exit leads nowhere, "
+                       "in a programming bug kind of way. "
+                       "Maybe tell an administrator?")))
+         ;; looks like we can go, so let's go!
+         (else
+          ;; Set the player's new location
+          (<-wait player 'set-loc!
+                  #:loc to-address)
+          (when player-flavortext
+            (<-wait player 'tell
+                    #:text player-flavortext))
+          ;; Tell everyone else the person walked away
+          (room-tell-room
+           room (or room-flavortext
+                    (format #f "~a wanders ~a.\n"
+                            player-name direct-obj)))
+          (<- to-address 'announce-entrance
+              #:who-entered player)
+          ;; Have the new room update the player to the new location
+          (<- to-address 'look-room
+              #:to-id player))))))
    (else
     (<- player 'tell
         #:text "You don't see any way to go there.\n"))))