wh me=Beginning installation of lib-look...
@prog lib-look
1 99999 d
1 i
( cmd/lib-look: $Date: 2004/04/22 19:44:21 $ $Revision: 1.17 $                )
( Purpose: Replicate and enhance the inserver look routine                    )
( Author: Unknown                                                             )
( Contributors: Feaelin                                                       )
( Dependencies: lib-strings, lib-stackrng, lib-match, lib-unparseobj          )
( --------------------------------------------------------------------------- )
( Set of library routines for doing 'look' functions.                         )
( The following functions are included in this library:                       )
( LOOKsafecall:  x d --                                                       )
(      Takes a dbref which is assumed to be a command or @desc-like program   )
(      that takes one parameter, usually a string, and returns no values.     )
(      It ensures that none of the variables me, loc, trigger, or command     )
(      are modified, and that no garbage is left behind on the stack.         )
( LOOKunparse:  d -- s                                                        )
(      Takes a dbref, and returns either just its name, or the name plus      )
(      flags, depending on the permissions of me @.                           )
( LOOKstd-filter: d -- i                                                      )
(      A typical filter for LOOKcontents-filter. If you need all the normal   )
(      filtering plus more, you can call this inside of your own filter to    )
(      prevent reinvention of the wheel...                                    )
( LOOKcontents-filter:  a d -- d... i                                         )
(      Takes the address of a 'filter' routine and a dbref, and returns a     )
(      range on the stack of the filtered contents of the object.  The first  )
(      item to print is the bottom of the stack range.  The filter should     )
(      be  d -- i; it takes a dbref and returns a true/false value to say     )
(      whether or not the dbref should be put into the list.                  )
( LOOKget-contents:  d -- d... i                                              )
(      Takes a dbref, and returns the list of its contents, filtered through  )
(      the standard filter which acts like the server's contents list:        )
(      Dark rooms don't list anything unless the room or the objects are      )
(      yours, dark objects not owned by you don't show, and you don't show.   )
(      This list has the first element in the contents at the bottom of the   )
(      stack.                                                                 )
( LOOKlong-display:  d... i --                                                )
(      List the dbref stack range given, in the usual format for the server.  )
(      All elements on separate lines, using unparse.  The bottom element is  )
(      printed first.                                                         )
( LOOKlist-objects:  d --                                                     )
(      Lists all the 'objects' that are setup by the @object/@detail commands )
(      Parallels long-display.                                                )
( LOOKdetail-dbmatch: d s -- s                                                )
(      Searches for a detail or object created by @object/@detail and returns )
(      its description. Searches only the dbref specified.                    )
( LOOKdetail-desc: s --                                                       )
(      Searches for a detail or object created by @object/@detail and displays)
(      its description. Currently only searches the current room "here".      )
( LOOKshort-list:  d... i -- s                                                )
(      Turns the range of dbrefs on the stack into a properly formatted       )
(      string, with commas.  1 element is just returned, 2 elements returns   )
(      '1 and 2', more elements return '1, 2, 3, and 4' or similar.  Returns  )
(      a null string if there are no elements.  Again, the bottom element is  )
(      first in the list.                                                     )
( LOOKshort-display:  d1 d2 d3 ... di i --                                    )
(      Calls short-list, then prints out "You see <string>." to the user.     )
(      Prints "You see nothing." if nothing is on the list.                   )
( LOOKlist-contents:  s d --                                                  )
(      Calls get-contents followed by long-display and list-objects to print  )
(      out all of the contents of the given dbref. If there are any contents  )
(      listed, then  the string on the stack is printed out, for "Contents:"  )
(      or the like. If the contents list is empty, the string is ignored.     )
( LOOKstr-desc:  s --                                                         )
(      Takes string 's', and prints it out as a description. Matches the      )
(      '@###' and '@$prog' values properly, and uses them with the present    )
(      trigger value.  If neither of these exist, or if they're invalid,      )
(      the rest of the string is just printed out. Does NOT parse MPI.        )
( LOOKdbstr-desc:  d s --                                                     )
(      Runs str-desc, using the value d on the stack as the effective         )
(      trigger value. Parses MPI as appropiate.                               )
( LOOKdb-desc:  d --                                                          )
(      Does a full description of the object, including name and succ/fail    )
(      if the dbref given is a room, and contents. All programs run with      )
(      the dbref given in 'trigger @'. Will return the proper values for      )
(      dbref's #-1 and #-2 as well. Parses MPI as appropiate.                 )
( LOOKcmd-look:  s --                                                         )
(      Does a match function, then calls db-desc with the results.  This      )
(      will simulate the usual 'look' command.                                )
( --------------------------------------------------------------------------- )
( 
  $Log: lib-look,v $
  Revision 1.17  2004/04/22 19:44:21  feaelin
  Fixed issue where darked players were hidden from wizards.

  Revision 1.16  2004/04/22 17:25:53  feaelin
  Documentation Cleanup

  Revision 1.15  2004/04/22 17:16:22  feaelin
  Added support for player darking via the /@/dark:yes prop

  Revision 1.14  2004/04/22 01:52:09  feaelin
  Fixed issues with LOOKshort-list where it wasn't colorizing as you might
  expect it to.

  Revision 1.13  2004/04/20 22:05:52  feaelin
  Okay. This time, I REALLY made std-filter public. And fixed the docs up
  properly.

  Revision 1.12  2004/04/20 21:55:45  feaelin
  Made the standard filter [LOOKstd-filter] public so extended filters can be
  written without having to recreate the functionality of std-filter.
  
  Revision 1.11  2004/04/15 21:15:11  feaelin
  New Feature: ~look props. Similar in function to ~connect/~arrive/~idle
  props, you can now do: @set <item>=~look/<name>:<ref> and the program
  <ref> will be executed when <item> is looked at. As you might expect, the
  property may be set on parent rooms or #0, to have programs that are
  executed for the entire area/muck.
  
  Revision 1.10  2004/04/13 23:18:24  feaelin
  Added support for IDESCs
  
  Revision 1.9  2004/04/12 15:50:55  feaelin
  Fixed bug in look that caused it to display dbrefs & flags for players that
  had 'color' turned on.
  
  Revision 1.8  2004/04/12 14:57:51  feaelin
  Fixed issue where obvious things like 'me' and 'here' didn't match correctly
  in cmd-look. Changed failed messages to use the FAIL color code.
  
  Revision 1.7  2004/04/11 19:58:28  feaelin
  Changed detail-desc in preparation for adding functionality to match
  details against players and things in the room.
  Cleaned up the docs so that they display correctly for the MUF editor's
  'view' command.
  
  Revision 1.6  2004/04/11 18:46:00  feaelin
  Added the library calls LOOKxxx, to be more inline with the standard.
  Added support for @object/@detail details. Correspondingly added some
  related library calls.
  
  Revision 1.5  2004/04/10 17:24:47  feaelin
  Fixed minor issues in the std-filter function.
  
  Revision 1.4  2004/04/10 15:09:40  feaelin
  Fixed issue where if you didn't control the item, or you were set silent,
  the database item name wasn't colorized.
  
  Revision 1.3  2004/04/08 13:38:36  feaelin
  Fixed issues where lib-look didn't parse color in descriptions by default.
  Fixed issue where lib-look didn't parse MPI in descriptions and messages.
  Further cleaned up dependency on macros.
  
  Revision 1.2  2004/03/26 03:21:18  feaelin
  Reduced macro/library dependence.
  
  Revision 1.1  1998/08/23 15:47:21  glow
  Initial revision
)
( --------------------------------------------------------------------------- )
$include $lib/strings
$include $lib/match
$include $lib/stackrng
$include $lib/unparseobj
 
lvar sme
lvar sloc
lvar strigger
lvar scommand
lvar sdepth
lvar realtrig
 
: otell
  loc @ me @ rot ansi_notify_except ( s -- ) ( Display string to everyone in my room except me )
;

: tell
  me @ swap ansi_notify
;

: safecall  ( x d -- )
  me @ sme !
  loc @ sloc !
  trigger @ strigger !
  command @ scommand !
  depth sdepth !
  call
  sme @ me !
  sloc @ loc !
  strigger @ trigger !
  scommand @ command !
  depth 2 + sdepth @ - popn
;
 
: control? ( d -- i )
  me @ swap controls
;
 
: dark? ( d -- i )
  dup "Dark" flag? swap control? not and
;

: unparse ( d -- s )
  me @ "Silent" flag? if
    "%P" UPOspecial-unparseobj exit
  then
  dup control? not
  if
    dup "Link_OK" flag? not
    if
      dup "Chown_OK" flag? over player? not and not
      if
        dup "Abode" flag? not
        if
          "%P" UPOspecial-unparseobj exit
        then
      then
    then
  then
  UPOcolor-unparseobj
;
 
( Don't see rooms.  Don't see programs you can't link to. )
( Don't see dark things, except you always see zombies and players. )
: std-filter ( d -- i )
  dup me @ dbcmp if pop 0 exit then
  dup room? if pop 0 exit then
  dup player? if
    dup me @ swap controls if
      pop 1 exit
    else
      prog "@allowdarkplayers" getpropstr "yes" strcmp not if
        dup "@/dark" getpropstr "yes" strcmp swap pop exit
      else
        pop 1 exit
      then
    then
  then
  dup dup thing? swap "z" flag? and if
    dup me @ swap controls if
      pop 1 exit
    else
      prog "@allowdarkplayers" getpropstr "yes" strcmp not if
        dup "@/dark" getpropstr "yes" strcmp swap pop exit
      else
        pop 1 exit
      then
    then
  then
  dup program? if
    dup control? over "Link_OK" flag? or if
      pop 1 exit
    else
      pop 0 exit
    then
  then
  dup "dark" flag? if pop 0 exit then
  pop 1 
; PUBLIC std-filter
 
: contents-filter ( a d -- d... i )
  contents 0 rot rot
  begin
    dup
  while
    over over swap execute
    if
      rot 1 + rot rot dup -4 rotate
    then
    next
  repeat
  pop pop
;
 
: get-contents ( d -- d... i )
  dup dark?
  if
    pop 0
  else
    'std-filter swap contents-filter
  then
;
 
: long-display ( d... i -- )
  begin
    dup
  while
    1 - dup 2 + rotate
    dup dbref?
    if
      unparse
    then
    tell
  repeat
  pop
;
 
: short-list ( d... i -- s )
  dup 3 <
  if
    1 - dup 2 + rotate "%P" UPOspecial-unparseobj over
    if
      " " strcat
    then
  else
    ""
    begin
      over 1 >
    while
      swap 1 - swap over 3 + rotate "%P" UPOspecial-unparseobj
      "^WHITE^, " strcat strcat
    repeat
  then
  swap
  if
    "^WHITE^and " strcat swap "%P" UPOspecial-unparseobj strcat
  then
;
 
: short-display ( d... i -- )
  short-list dup
  if
    "You see " swap strcat "." strcat tell
  else
    "You see nothing." tell
  then
;  
 
: list-objects ( d -- )
  dup "_obj/" nextprop
  begin
    dup "" strcmp while
    dup ";" STRsplit pop
    "/" STRsplit swap pop
    "thing" UPOcolor-query
    me @ "silent" flag? not if
      3 pick control? if
        "^YELLOW^(detail)" strcat
      then
    then
    tell
    over swap nextprop
  repeat
  pop pop
; PUBLIC list-objects
 
: list-contents ( s d -- )
  dup "_obj/" nextprop STRblank? not swap
  dup get-contents dup dup 4 + rotate or
  if
    dup 3 + rotate tell
    long-display
    list-objects
  else
    pop pop
  then
;
  
: look-prop-handler ( d s -- )
  over swap nextprop
  dup "" strcmp not if pop pop exit then
  begin
    over over getprop
    dup dbref? not if
      dup string? if
        dup "#" instr if
          1 strcut swap pop
        then
        atoi dbref
      else
        dup int? if
          dbref
        then
      then
    then
    dup ok? if
      dup program? if
        dup "LINK_OK" flag? if
          "(Look)" swap safecall
        else
          pop pop pop exit
        then
      else
        pop pop pop exit
      then
    else
      pop pop pop exit
    then
    over swap nextprop dup "" strcmp not
  until
  pop pop
; 
  
: look-prop2 ( d -- )
  dup "~look/" nextprop "" strcmp if
    "~look/" look-prop-handler
  else
    pop
  then
;
  
: look-prop ( d -- )
  begin
    dup look-prop2
    location
    dup #-1 dbcmp 
  until
  pop
; PUBLIC look-prop
  
: str-desc ( s -- )
  striplead striptail dup
  if
    dup "@" 1 strncmp
    if
      tell
    else
      1 strcut swap pop " " STRsplit striplead striptail swap
      dup "$" 1 strncmp
      if
        atoi dbref
      else
        match
      then
      dup ok?
      if
        dup trigger @ owner swap controls over "Link_OK" flag? or
        if
          safecall
        else
          pop pop "Permission Denied" tell
        then
      else
        pop tell
      then
    then
  else
    pop "You see nothing special." tell
  then
;
 
: dbstr-desc ( d s -- )
  swap trigger @ realtrig ! trigger !
  trigger @ swap "(@Desc)" 1 parsempi str-desc
  realtrig @ trigger !
;
 
: db-desc ( d -- )
  dup #-1 dbcmp
  if
    pop "^FAIL^I don't see that here." tell exit
  then
  dup #-2 dbcmp
  if
    pop "^FAIL^I don't know which one you mean!" tell exit
  then
  dup trigger @ realtrig ! trigger !
  dup room? over me @ location dbcmp or
  if
    dup unparse tell
  then
  dup me @ location dbcmp over room? not and
  over "/_/ide" getpropstr STRblank? not and if
    dup "/_/ide" "(@Idesc)" 1 parseprop
  else
    dup "/_/de" "(@Desc)" 1 parseprop
  then
  str-desc
  dup look-prop ( handle the ~look prop )
  dup room? over me @ location dbcmp or
  if
    me @ over locked?
    if
      dup "/_/fl" "(@Fail)" 1 parseprop dup
      if
        str-desc
      else
        pop
      then
      dup "/_/ofl" "(@OFail)" 1 parseprop dup
      if
        otell
      else
        pop
      then
    else
      dup "/_/sc" "(@Succ)" 1 parseprop dup
      if
        str-desc
      else
        pop
      then
      dup "/_/osc" "(@OSucc)" 1 parseprop dup
      if
        otell
      else
        pop
      then
    then
    "^BLUE^Contents:" over list-contents
  else
    dup player?
    if
      "^BLUE^Carrying:" over list-contents
    then
  then
  realtrig @ trigger !
  pop
;

: detail-dbmatch ( d s -- s )
  swap dup "_obj/" nextprop
  begin
    dup "" strcmp while
    dup 4 pick instring if
      over swap getprop
      0 while
    then
    over swap nextprop
  repeat
  dup "" strcmp if -3 rotate pop pop exit then
  pop
  dup "_det/" nextprop
  begin
    dup "" strcmp while
    dup 4 pick instring if
      over swap getprop
      0 while
    then
    over swap nextprop
  repeat
  -3 rotate pop pop
; PUBLIC detail-dbmatch

: detail-desc ( s -- )
  dup
  "here" match dup rot 
  detail-dbmatch
  "(@Desc)" 1 parsempi
  dup "" strcmp if
    str-desc
    pop 1 exit
  then
  pop 0 exit
; PUBLIC detail-desc
 
: cmd-look ( s -- )
  dup not
  if
    pop "here"
  then
  dup match dup
  #-1 dbcmp if
    pop detail-desc not if
      pop me @ "^FAIL^I don't see that here." ansi_notify
    then
  else
    swap pop db-desc
  then
;
 
public safecall
public unparse
public contents-filter
public get-contents
public long-display
public short-list
public short-display
public list-contents
public str-desc
public dbstr-desc
public db-desc
public cmd-look
.
c
q
@register lib-look=lib/look
@register lib-look=cmd/look
@set $lib/look=L
@set $lib/look=S
@set $lib/look=H
@set $lib/look=W3
@set $lib/look=/_/de:lib-look:List lines 3-60 for documentation.
@set $lib/look=/_defs/.cmd-look:"$lib/look" match "cmd-look" call
@set $lib/look=/_defs/.contents-filter:"$lib/look" match "contents-filter" call
@set $lib/look=/_defs/.db-desc:"$lib/look" match "db-desc" call
@set $lib/look=/_defs/.dbstr-desc:"$lib/look" match "dbstr-desc" call
@set $lib/look=/_defs/.get-contents:"$lib/look" match "get-contents" call
@set $lib/look=/_defs/.list-contents:"$lib/look" match "list-contents" call
@set $lib/look=/_defs/.long-display:"$lib/look" match "long-display" call
@set $lib/look=/_defs/.safecall:"$lib/look" match "safecall" call
@set $lib/look=/_defs/.short-display:"$lib/look" match "short-display" call
@set $lib/look=/_defs/.short-list:"$lib/look" match "short-list" call
@set $lib/look=/_defs/.str-desc:"$lib/look" match "str-desc" call
@set $lib/look=/_defs/.unparse:"$lib/look" match "unparse" call
@set $lib/look=/_defs/LOOKcmd-look:"$lib/look" match "cmd-look" call
@set $lib/look=/_defs/LOOKcontents-filter:"$lib/look" match "contents-filter" call
@set $lib/look=/_defs/LOOKdb-desc:"$lib/look" match "db-desc" call
@set $lib/look=/_defs/LOOKdbstr-desc:"$lib/look" match "dbstr-desc" call
@set $lib/look=/_defs/LOOKdetail-dbmatch:"$lib/look" match "detail-dbmatch" call
@set $lib/look=/_defs/LOOKdetail-desc:"$lib/look" match "detail-desc" call
@set $lib/look=/_defs/LOOKget-contents:"$lib/look" match "get-contents" call
@set $lib/look=/_defs/LOOKlist-contents:"$lib/look" match "list-contents" call
@set $lib/look=/_defs/LOOKlist-objects:"$lib/look" match "list-objects" call
@set $lib/look=/_defs/LOOKlong-display:"$lib/look" match "long-display" call
@set $lib/look=/_defs/LOOKprop:"$lib/look" match "look-prop" call
@set $lib/look=/_defs/LOOKsafecall:"$lib/look" match "safecall" call
@set $lib/look=/_defs/LOOKshort-display:"$lib/look" match "short-display" call
@set $lib/look=/_defs/LOOKshort-list:"$lib/look" match "short-list" call
@set $lib/look=/_defs/LOOKstd-filter:"$lib/look" match "std-filter" call

@set $lib/look=/_defs/LOOKstr-desc:"$lib/look" match "str-desc" call
@set $lib/look=/_defs/LOOKunparse:"$lib/look" match "unparse" call
@set $lib/look=/_docs:@list $lib/look=1-76
@set $lib/look=/_lib-version:1.31FM$Revision: 1.17 $
@set $lib/look=/_version:1.31FM$Revision: 1.17 $
wh me=Installation of lib-look complete.