@prog teleport.muf
1 9999 d
i
( teleport.muf by Wog

--- Change History ----------------------------------
v 1.0		02/24/00
    Assignment of version number to programs.
v 2.0		May 13 2000 .. Nov. 24 2000
    Added #lock feep. Added wizard teleport warning option
        and change how control overrides work...
    Also made internals find all teleport problems...
    Added _tel/~silent? property support.
    Added temp. darkening.
    Added teleport to player.
v 2.0.1		1 Aug 2003
	(FB6 color) Fixed non-use of textattr
	Removed macro dependicies.
	Thanks to Irwin <arcana -at- yetta.net>
--- Distrubution Information ------------------------
Copyright {C} Charles "Wog" Reiss <car@cs.brown.edu>

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or {at your option} any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

For a copy of the GPL:
   a> see: http://www.gnu.org/copyleft/gpl.html
   b> write to: the Free Software Foundation, Inc., 
     59 Temple Place - Suite 330, Boston, MA  02111-1307, USA
)

(** Configuration stuff: **)
$def DEFAULT_SUCC "Teleporting..."
$def DEFAULT_OSUCC "disappears with a mild flash of light."
$undef DEFAULT_DROP (This message, and only this message doesn't need a default.)
$def DEFAULT_ODROP "appears with a *pop*."

( Require that the player teleporting to another player be able to do so,
	or that the player being teleported to own the room being teleported to, [that
    last is only checked if OWNER_OVERRIDES_CHECKS is defined.] )
$def PLAYER_TELEPORT_ROOM_CHECK
( Comment this to not let those who owner an area [own it or are a wizard]
  to be immune to checking premissions props [like _tel/ok? and JUMP_OK] on it)
$def OWNER_OVERRIDES_CHECKS
( Wizard override confirm... Comment this to NOT require wizards to confirm overriding
  checks on rooms where teleport would otherwise not be allowed )
$def WIZARD_OVERRIDE_CONFIRM
( If you want CONTROL and _not_ OWNERSHIP or being a wizard to override checks then
  uncomment this: )
( $def CONTROL_OVERRIDES_CHECKS )
( To NOT have wizard override enabled comment this: )
$def WIZARD_OVERRIDE
( To temperaily set players dark to suppress ... has arrived., etc. messages.
  NOTE: _tel/~silent? and such will OVERRIDE this in temperarily setting the DARK
  flag, but it will act the same with respect to DARK_VERY_PARANOID in that case.)
$def TEMP_DARK
( If you are VERY VERY paranoid about the temp. dark settting define this, to have
  the program preempt while it's set so as to avoid the player from doing
  the extremely unlikely act of aborting the program for the 4 instructions during which
  [s]he will be set DARK... )
$undef DARK_VERY_PARANOID


$ifdef __glowver
(If you are running glowmuck you may wish to set the below: )
$def wizflag "mage"
$else
$ifdef __neon (On the off-change you are using NeonMuck use this: )
$def wizflag "mage"
$else
(Otherwise you probably want to leave it as is:)
$def wizflag "wizard"
$endif
$endif

(** End configuration stuff. **)

$def .null? not
$def .spc80 "                                                                                "

( std_override_check will be defined to something to check for
    non-wizard premission checking overrides caused by ownership or
    control; depending on setings above. )
$ifdef CONTROL_OVERRIDES_CHECKS
$def std_override_check controls
$else
$ifdef OWNER_OVERRIDES_CHECK
$def std_override_check owner
$else
$def NO_OVERRIDE_CHECK
$endif
$endif

$def color_support

$ifdef color_support
$ifdef __glowver
$def .tell me @ swap ansi_notify
$def .otell loc @ me @ rot ansi_notify_except
$else
$ifdef __neon
$def .tell me @ swap ansi_notify
$def .otell loc @ me @ rot ansi_notify_except
$else
$include $lib/ansi
$def .tell ansi-tell
$def .otell ansi-otell
$endif
$endif
$endif

( --- Universal Portable Routines --- )
: parseEnvProp ( d s s i -- s 0 OR 1) (0 -> found; 1 -> not found )
  -4 rotate -4 rotate
  (i s d s)
  dup -3 rotate
  (i s s d s)
  envprop pop (i s s d)
  dup #-1 dbcmp if
    pop pop pop pop 1 exit
  then
  swap ( i s d s )
  4 rotate 4 rotate (d s s i)
  parseprop 0
;

: mymatch ( s -- d )
  dup "me" stringcmp not if pop me @ exit then
  dup "here" stringcmp not if pop me @ location exit then
  dup "home" stringcmp not if pop me @ getlink exit then
  dup "$" stringpfx if 
    match exit
  then
  dup "#" stringpfx if 
    1 strcut swap pop (Get number part)
    atoi dbref exit
  then
  dup "*" stringpfx if
    1 strcut swap pop
    .pmatch exit
  then
  #-1
;

: yesNoValue ( s - i ) ( i is -1 if .no? 1 if .yes? and 0 if neither )
  dup not if pop 0 exit then
  dup .no? if pop -1 exit then
  .yes? if 1 exit then
  0
;
(Results from this are good for comparisions like 0 >= for yes or neither or
  < 0 for no, absoulute)

  (Sets a lock property, returns whether lock parsed okay. 1 is okay.)
: setlockprop_fromstr ( d s s -- i )
  parselock
  dup not if pop pop pop 0 exit then
  setprop 1
;

(Tests a lock prop. against me @, returns -1 if no lock set.)
: checklock ( d s -- i )
  getprop
  dup lock? not if pop -1 exit then
  me @ swap testlock
;

: checklockand ( i d s -- i )
  checklock dup -1 = not if and else pop then
;

( --- Other Stuffs --- )


lvar to
lvar from
lvar pto
lvar silent?
lvar dark_save
: myGetYesNoProp ( d s -- i )
  "(teleport)" 1 
  4 pick room? if 
    parseEnvProp if (not found) 0 exit then
  else 
    parseprop
  then
  yesNoValue
;

lvar tmp
$def do-setbit
: checkPerms ( -- i )

             ( Returns an integer with bits set like so:
                0x1 => Location Dissallows
                0x2 => Destination Dissallows
                0x4 => Player Dissalows...
              So, 3 would be location and destination denies,
                  7, all of them.
                  1, 2, or 4 the appropiate one,
              and 0 none of them.
             )
( Location: )
  0 tmp !
$ifndef NO_OVERRIDE_CHECK
  me @ from @ std_override_check not if
$endif
    from @ "_tel/ok?" myGetYesNoProp 0 >
    from @ "_tel/out?" myGetYesNoProp 0 >
    or (Explict Authorization)
    from @ "j" flag?
    from @ "_tel/ok?" myGetYesNoProp 0 <
    from @ "_tel/out?" myGetYesNoProp 0 <
    or not
    and (Implict authorization, not overrided)
    or not
    1
    from @ "_tel/lock" checklockand
    from @ "_tel/olock" checklockand
    not or if tmp @ 1 bitor tmp ! then
$ifndef NO_OVERRIDE_CHECK
  then
$endif

  pto @ ok? if
    pto @ "_tel/ok?" myGetYesNoProp 0 >
    pto @ "_tel/in?" myGetYesNoProp 0 >
    or (Explict Authorization)
    pto @ "j" flag?
    pto @ "_tel/ok?" myGetYesNoProp 0 <
    pto @ "_tel/in?" myGetYesNoProp 0 <
    or not
    and (Implict authorization, not overrided)
    or not
    1
    pto @ "_tel/lock" checklockand
    pto @ "_tel/ilock" checklockand
    not or if tmp @ 4 bitor tmp ! then
$ifdef PLAYER_TELEPORT_ROOM_CHECK
  then
$else
  else
$endif

( Destintation: )
$ifndef NO_OVERRIDE_CHECK
  me @ to @ std_override_check not
  pto @ ok? if pto @ to @ std_override_check not and then
  if
$endif
    to @ "_tel/ok?" myGetYesNoProp 0 >
    to @ "_tel/in?" myGetYesNoProp 0 >
    or (Explict Authorization)
    to @ "j" flag?
    to @ "_tel/ok?" myGetYesNoProp 0 <
    to @ "_tel/in?" myGetYesNoProp 0 <
    or not
    and (Implict authorization, not overrided)
    or not
    1
    to @ "_tel/lock" checklockand
    to @ "_tel/ilock" checklockand
    not or if tmp @ 2 bitor tmp ! then
$ifndef NO_OVERRIDE_CHECK
  then
$endif

$ifndef PLAYER_TELEPORT_ROOM_CHECK
  then
$endif

  tmp @
;

: matchDest ( s -- d )
(This match will silently ignore errors occuring from not matching a room
  or player.)
  dup mymatch dup room? over player? or if swap pop exit else pop then
  dup me @ "/_tel/dests/" rot strcat getprop dup int? not if
    dup string? if atoi dbref then exit
  else pop then
  dup trig "/_tel/dests/" rot strcat getprop dup int? not if
    dup string? if atoi dbref then exit
  else pop then
  #-1
;

$ifdef DARK_VERY_PARANOID
$def beg_dp getmode tmp ! preempt
$def end_dp tmp @ setmode
$else
$def beg_dp ( ** nothing ** )
$def end_dp ( ** nothing ** )
$endif
( dp = Dark Paranoia )

: doMove ( -- )
  
  me @ "_tel/succ" "(teleport)" 1 parseprop 
  dup .null? if pop DEFAULT_SUCC then me @ swap pronoun_sub .tell
  
  silent? @ not if

    me @ "_tel/osucc" "(teleport)" 1 parseprop 
    dup .null? if pop DEFAULT_OSUCC then
    " " swap strcat me @ name swap strcat me @ swap pronoun_sub .otell
  then

(We only need to have silent set dark if we wouldn't do it otherwise.) 
$ifndef TEMP_DARK 
  silent? @ if
    beg_dp me @ "D" flag? dup dark_save ! not if me @ "D" set end_dp then
  then
$endif
 
$ifdef TEMP_DARK
  me @ "D" flag? dup dark_save !
  not if beg_dp me @ "D" set then
$endif

  me @ to @ moveto

$ifdef TEMP_DARK
  dark_save @ not if end_dp me @ "!D" set then
$else
  silent? @ if dark_save @ not if me @ "!D" set end_dp then then
$endif

  me @ location loc !  

  me @ "_tel/drop" "(teleport)" 1 parseprop
$ifdef DEFAULT_DROP
  dup .null? if pop DEFAULT_DROP then me @ swap pronoun_sub .tell
$else
  dup .null? if pop else me @ swap pronoun_sub .tell then
$endif

  silent? @ not if 
    me @ "_tel/odrop" "(teleport)" 1 parseprop
    dup .null? if pop DEFAULT_ODROP then
    " " swap strcat me @ name swap  strcat me @ swap pronoun_sub .otell
  then
;

lvar itmp
: doHelp
  "~&170 teleport by Wog " .tell
  "~&100-----------------" .tell
  "~&150Options: " .tell
  "~&060 #dbref,                  " .tell
  "~&060 $regname,                " .tell
  "~&060 *Player,                 " .tell
  "~&160 or ~&060named teleport alias  ~&130-- ~&030Teleports you to their destination..." .tell
  "~&060 #help                    ~&130-- ~&030This screen" .tell
  "~&060 #props                   ~&130-- ~&030Displays properties used by teleport" .tell
  "~&060 #list                    ~&130-- ~&030Displays all personal and global aliases" .tell
  "~&060 #add <d>=<place>         ~&130-- ~&030Adds an alias to your personal list" .tell
  "~&060 #del <d>                 ~&130-- ~&030Removes an alias from your personal list" .tell
  me @ trig controls if
    "~&150Maintainer options: " .tell
    "~&060 #gAdd <d>=<place>        ~&130-- ~&030Adds an alias to the global list" .tell
    "~&060 #gDel <d>                ~&130-- ~&030Removes an alias from the global list" .tell
  then
    "~&150Locking options: " .tell
    "~&060 #lock <place>=<lock>     ~&130--~&030 Locks a room from teleporting. Args. like @lock." .tell
    "~&060 #ilock <place>=<lock>    ~&130--~&030 Locks teleporting into a room." .tell
    "~&060 #olock <place>=<lock>    ~&130--~&030 Locks teleporting out of a room." .tell
    "~&030'me' is a valid place for #lock and #ilock. Those will restrict teleporting" .tell
    "~&030 to you." .tell
  me @ wizflag flag? if
    "~&150Wizard-only options:" .tell
    "~&060 #s <place>              ~&130--~&030 Teleports silently to a place. Extra letters" .tell
    "~&030                                  can be added after the #s..." .tell
    "~&060 #n <place>              ~&130--~&030 Teleports noisely to a place. Extra letters" .tell
    "~&030                                  can be added after the #n..." .tell
    "~&030 Default teleport noisiness is controlled by properties. See 'tport #props'" .tell
  then
;

: doProps
  "~&170 teleport by Wog " .tell
  "~&100-----------------" .tell
  "~&150Properties:" .tell
  "~&050 On you:" .tell
  "~&060  _tel/succ   ~&130--~&030 Message you see where and when you teleport out" .tell
  "~&060  _tel/osucc  ~&130--~&030 Message others when and where see you teleport out" .tell

  "~&060  _tel/drop   ~&130--~&030 Message you see when and where you teleport in" .tell
  "~&060  _tel/odrop  ~&130--~&030 Message others see when you teleport in" .tell
  "~&050 On room/parent room:" .tell
  "~&030  The JUMP_OK flag will be used to allow/deny teleport permission if these" .tell
  "~&030  properties are unset. Non y/n/yes/no values are treated as unset for these." .tell
  "~&060  _tel/ok?    ~&130--~&030 If yes, allows teleport; if no, disallows teleport." .tell
  "~&060  _tel/in?    ~&130--~&030 If yes, allows teleport in; if no, disallows teleport in." .tell
  "~&060  _tel/out?   ~&130--~&030 If yes, allows teleport out; no disallows teleport out." .tell
  "~&060  _tel/lock   ~&130--~&030 A lock prop. Best set with 'tport #lock <place>=<lock>'" .tell
  "~&060  _tel/ilock  ~&130--~&030 Like _tel/lock, but only for teleport in. [Set with #ilock]" .tell
  "~&060  _tel/olock  ~&130--~&030 Like the above, but only for teleport out. [Set with #olock]" .tell
  "~&060  _tel/fail   ~&130--~&030 Property for teleport failed message. {&how} will be" .tell
  "~&030                 'in' for teleport in attempts, 'out' for teleport out" .tell
  "~&030                 attempts. ('at' if parsed on player.)" .tell
  "~&050 On player being teleported to:" .tell
  "~&030  Props. above [for teleport in] will be checked on the player being" .tell
  "~&030  teleported to" $ifdef PLAYER_TELEPORT_ROOM_CHECK " AND their location." strcat $else "." strcat $endif .tell
$ifdef OWNER_OVERRIDES_CHECKS
  "~&030  But if the player being teleported to owns" .tell
  "~&030  the room they are in, then such checks will not take place." .tell
$else
$ifdef CONTROL_OVERRIDES_CHECKS
  "~&030  But if the player being teleported to controls" .tell
  "~&030  the room they are in, then such checks will not take place." .tell
$endif
$endif
  me @ wizflag flag? if
  "~&150Wizard-only properties:" .tell
  "~&060  _tel/~silent? ~&130--~&030 If yes, teleport will be silent by default. If no, " .tell
  "~&030                   teleport will NOT be silent by default. Works on " .tell
  "~&030                   normal players, too." .tell
  then
  "~&150MPI is parsed on all properties. Pronouns are parsed on props listed as 'on you'." 
  .tell
;

: outputPrefix
  "~&170>> ~&R" swap strcat
;
: e-outputPrefix
  "~&170>> ~&110" swap strcat
;
: s-outputPrefix
  "~&170>> ~&120" swap strcat
;
$def u-outputPrefix e-outputPrefix

: doAdd 
  " " .split 
  swap pop
  dup "=" instr 0 = if
    "To add a alias use the format " command @ strcat " #add <name>=<place>" strcat u-outputPrefix .tell exit
  then
  "=" .split
  (name place)
  dup "home" strcmp not if #-3 else match then
  dup room? not if "That's not a room!"e-outputPrefix .tell exit then
  swap 
  "/_tel/dests/" swap strcat swap me @ -3 rotate setprop
  "Added." s-outputPrefix .tell
;

: doGlobalAdd
  me @ trig controls not if "Permission denied." e-outputPrefix then
  " " .split 
  swap pop
  dup "=" instr 0 = if
    "To add a alias use the format " command @ strcat " #add <name>=<place>" strcat u-outputPrefix .tell exit
  then
  "=" .split
  (name place)
  dup "home" strcmp not if #-3 else match then
  dup room? not if "Invalid location!"e-outputPrefix .tell exit then
  swap 
  "/_tel/dests/" swap strcat swap trig -3 rotate setprop
  "Added." s-outputPrefix .tell
;

: doDel
  " " .split swap pop
  "/_tel/dests/" over strcat me @ swap getpropstr .null? if
    pop "That is not a personal alias." e-outputPrefix .tell exit
  then
  "/_tel/dests/" swap strcat me @ swap remove_prop
  "Removed." s-outputPrefix .tell
;

: doGlobalDel
  " " .split swap pop
  "/_tel/dests/" over strcat trig swap getpropstr .null? if
    pop "That is not a global alias." e-outputPrefix .tell exit
  then
  "/_tel/dests/" swap strcat trig swap remove_prop
  "Removed." s-outputPrefix .tell
;
$def name dup #-3 dbcmp if pop "home" else \name then

: formatLine ( s s -- )
  ""
  swap .spc80 strcat 20 strcut pop strcat
  " " strcat
  swap .spc80 strcat 30 strcut pop strcat
  "" strcat
;
: doList
(       12345678901234567890 0123456789012345678901234567890 )
  "~&120Alias Name           Location                       \r"
  "~&140-------------------- -------------------------------" strcat .tell
  "~&150>> Personal Aliases:" .tell
  "/_tel/dests/"
  begin
    me @ swap nextprop dup .null? not while
    dup 12 strcut swap pop over me @ swap getprop dup string? if atoi dbref then name swap formatLine .tell
  repeat
  "~&150>> Global Aliases:" .tell
  "/_tel/dests/"
  begin
    trig swap nextprop dup .null? not while
    dup 12 strcut swap pop over trig swap getprop dup string? if atoi dbref then name swap formatLine .tell
  repeat
;

: lockSet ( prop thing=setting -- )
  dup " " instr not if pop "~&110Use <place/me>=<lock> to set a lock." u-outputPrefix .tell exit then
  " " .split swap pop
  dup "=" instr not if pop "~&110Use <place/me>=<lock> to set a lock." u-outputPrefix .tell exit then
  "=" .split
  swap mymatch
  dup room? over player? or not if
    "~That's not a room or player!" e-outputPrefix .tell exit
  then
  me @ over controls not if
    "You don't control that!" e-outputPrefix .tell exit
  then
  -3 rotate
  dup not if pop remove_prop "Lock removed." s-outputPrefix .tell exit then
  parselock
  dup not if pop pop pop "Invalid lock string!" e-outputPrefix .tell exit then
  setprop
  "Lock set." s-outputPrefix .tell
;

: doLock
  "_tel/lock" swap lockSet
;

: doILock
  "_tel/ilock" swap lockSet
;

: doOLock
  "_tel/olock" swap lockSet
;

: check-wiz-override ( -- 0/1 ) ( 1 if do NOT teleport... )
  "Do you (as a wizard) want to override this?" outputPrefix .tell
  read
  .yes? if 0 else 1 then
;

: handlePerms ( i -- 0/1 ) ( 1 if bad; do NOT teleport; 0 otherwise. )
  dup 0 = not if
    dup 1 bitand if 
      from @ "_tel/fail" "out" 1 parseenvprop
      if 
        "Location does not allow teleport." e-outputPrefix
      then
      .tell
      me @ wizflag flag? not if 1 exit then
    then
    dup 2 bitand if
      to @ "_tel/fail" "in" 1 parseenvprop
      if 
        "Destination does not allow teleport." e-outputPrefix
      then
      .tell
      me @ wizflag flag? not if 1 exit then
    then
    (dup) 4 bitand if
      pto @ "_tel/fail" "to" 1 parseprop
      dup not if
        pop "Player being teleported to does not allow teleport." e-outputPrefix
      then
      .tell
      me @ wizflag flag? not if 1 exit then
    then
    me @ wizflag flag? if 
      check-wiz-override exit
    else 1 exit then
  then
  0
;

: do-teleport
  me @ location from !
  matchDest to !
( Replace #-3 with the actaul dbref of the players home. )
  to @ player? if to @ dup pto ! location to ! else #-1 pto ! then
  to @ #-3 dbcmp if me @ getlink to ! then
  to @ #-1 dbcmp if
    "Unrecognized destination!" e-outputPrefix .tell exit
  then
  to @ room? not if
    "That's not a room!" e-outputPrefix .tell exit
  then
  checkPerms handlePerms if exit then
  doMove
;

: main
(Make sure no one's messing with the me variable...)
  "me" match me !
  
  dup "#h" stringpfx 
  over not or if (help)
    doHelp exit
  then
  dup "#p" stringpfx if (props)
    doProps exit
  then
  dup "#add" stringpfx if (add)
    doAdd exit
  then
  dup "#gAdd" stringpfx if (global-add)
    doGlobalAdd exit
  then
  dup "#del" stringpfx if (delete)
    doDel exit
  then
  dup "#gDel" stringpfx if (global-delete)
    doGlobalDel exit
  then
  dup "#list" stringpfx if (list)
    doList exit
  then
  dup "#lock" stringpfx if
    doLock exit
  then
  dup "#ilock" stringpfx if
    doILock exit
  then
  dup "#olock" stringpfx if
    doOLock exit
  then
  dup "#s" stringpfx if
    me @ wizflag flag? not if
      "Only wizards can teleport silently!" .tell exit
    then
    1 silent? !
    dup " " instr not if "Please specify where to teleport to!" e-outputPrefix .tell exit then
    " " .split
    swap pop
  else
    dup "#n" stringpfx if
      0 silent? !
      dup " " instr not if "Please specify where to teleport to!" e-outputPrefix .tell exit then
      " " .split swap pop
    else
      (Use mygetyesnoprop here?)
      me @ "_tel/~silent?" "(teleport)" 1 parseprop
      me @ "D" flag? if
        .no? if 0 else 1 then
      else
        .yes? if 1 else 0 then
      then
      silent? !
    then
  then
    
  do-teleport
;
.
c
q
@set teleport.muf=W