@prog mwho.muf 1 9999 d 1 i (The defaults for a number of things can be set with props on the program. See the places where str-with-default is called for all; as of this writing, they are: default-mortal-doing-fmt default-mortal-shell-fmt default-mortal-loc-fmt default-wizard-doing-fmt default-wizard-shell-fmt default-wizard-loc-fmt default-wizard-host-fmt The default format strings for mortal and wizard wholists, for -doing, -shell, -loc, and -host formats. default-idle-sleep default-idle-drowse The points [in seconds] at which an idle player is considered sleeping and drowsy. [No checks, such as to ensure that sleep > drowse, are made.] ) forward format- (V@ and V! work with pseudo-variables, kept at the bottom of the stack. They are allocated very early with Valloc, deallocated very late with Vdealloc, and accessed with V@ and V!.) : Valloc dup 0 > if 1 -1 for depth neg rotate loop else pop then ; : Vdealloc dup 0 > if 1 -1 for pop depth rotate pop loop else pop then ; : V@ depth swap - 1 - pick ; : V! depth swap - 2 - put ; $def mewiz? 0 (should I get the wizard wholist?) $def maxll 1 (max line length) $def sort-fxn 2 (function to sort with) $def interest-fxn 3 (function to tell if interested in connection) $def fmt 4 (format string to use) $def padchar 5 (char to pad with) $def idlelimit 6 (idle times >= this aren't shown, 0=infinity) $def filter 7 (program to filter player list) $def minimalist? 8 (skip header/footer?) $def idlesleep 9 (idle time at which player is sleeping) $def idledrowse 10 (idle time at which player is drowsy) $def NV 11 : metw? me @ ok? if me @ true-wizard? else 0 then ; : str-with-default (default-string prop-suffix -- string) "default-" swap strcat prog swap getpropstr dup if swap then pop ; (We could collapse the mortal- and wizard- formats into single format strings with %?W, but that means formatting both forms and discarding the unwanted one...and mwho is already quite slow enough. Doing it this way also slightly simplifes a little of the help-screen code.) : mortal-doing-fmt "%-19%:28c%:33i %d" "mortal-doing-fmt" str-with-default ; : mortal-shell-fmt "%-19%:28c%:33i %s" "mortal-shell-fmt" str-with-default ; : mortal-loc-fmt "%-19%:28c%:33i %l" "mortal-loc-fmt" str-with-default ; : wizard-doing-fmt "%-26%:32L%:35f%:43c%:48i %d" "wizard-doing-fmt" str-with-default ; : wizard-shell-fmt "%-26%:32L%:35f%:43c%:48i %s" "wizard-shell-fmt" str-with-default ; : wizard-loc-fmt "%-26%:32L%:35f%:43c%:48i %l" "wizard-loc-fmt" str-with-default ; : wizard-host-fmt "%-26%:32L%:35f%:43c%:48i %" "wizard-host-fmt" str-with-default ; : default-fmt mewiz? V@ if wizard-host-fmt else mortal-doing-fmt then ; : doing-fmt mewiz? V@ if wizard-doing-fmt else mortal-doing-fmt then ; : shell-fmt mewiz? V@ if wizard-shell-fmt else mortal-shell-fmt then ; : place-fmt mewiz? V@ if wizard-loc-fmt else mortal-loc-fmt then ; : conuser-map dup "(connect: Connection refused" 28 strncmp not if pop "???" else dup "(" 1 strncmp not eif pop "(err)" else "@." "@" "@a" "A" "@b" "B" "@c" "C" "@d" "D" "@e" "E" 6 multisubst then ; : conuser-unmap "E" "@e" "D" "@d" "C" "@c" "B" "@b" "A" "@a" "@" "@." 6 multisubst ; : +mapcon dup 0 < if pop "" exit then dup condbref intostr "A" strcat over intostr strcat "B" strcat over conidle intostr strcat "C" strcat over contime intostr strcat "D" strcat over conuser conuser-map strcat "E" strcat swap conhost strcat ; : +conhdrline? not ; : +condbrefnum atoi ; : +condbref atoi dbref ; : +concon dup "A" instr strcut swap pop atoi ; : +conidle dup "B" instr strcut swap pop atoi ; : +contime dup "C" instr strcut swap pop atoi ; : +conuser dup "D" instr strcut swap pop dup "E" instr 1 - strcut pop conuser-unmap ; : +conhost dup "E" instr strcut swap pop ; : exceeds-idle-limit? (con -- con bool) idlelimit V@ dup if over +conidle <= else pop 0 then ; : interest-wizard exceeds-idle-limit? if pop 0 exit then +condbref dup not if pop 1 exit then dup "@no-who" prop-exists? if pop 0 exit then pop 1 ; : interest-mortal exceeds-idle-limit? if pop 0 exit then +condbref dup not if pop 0 exit then dup "u" flag? if pop 0 exit then dup "@no-who" prop-exists? if pop 0 exit then pop 1 ; : interest-unconnected exceeds-idle-limit? if pop 0 exit then +condbref dup not if pop 0 exit then dup "u" flag? if pop 0 exit then dup "@no-who" prop-exists? if pop 0 exit then dup true-wizard? if dup "*whohide" prop-exists? if pop 0 exit then then pop 1 ; : private? "private" prop-exists? ; : say me @ int? if me @ swap connotify else me @ swap notify then ; : maplist ( x1 ... xN N fxn -- x1' ... xN' N ) over 0 > if over 2 + 3 -1 for dup 1 + pick 3 pick exec swap put loop then pop ; : make-pad-string (n c -- s) dup strlen begin rot over over < while rot dup strcat rot dup + loop swap pop strcut pop ; : appcat (s1 s2 -- s) over if " " swap strcat then strcat ; : einstr over swap instr dup if swap pop else pop strlen 1 + then ; : merge over 4 pick + -4 rotate begin over 4 pick and while over 4 pick + 4 + pick 3 pick 5 + pick 3 pick exec if rot 1 - -3 rotate else over 4 + rotate 4 pick 4 pick + 4 + neg rotate swap 1 - swap then loop pop pop pop ; : sort (x1 ... xN N fn -- x1 ... xN N) (fn is x1 x2 -- i and returns true if the things are correctly ordered.) over 2 < if pop exit then over 2 / rot over - over 3 + neg rotate over over 3 + neg rotate swap sort dup 2 + pick over 4 + pick 3 pick + 4 + 3 pick 2 + roll sort dup 3 + rotate swap dup 3 + rotate merge ; : revlist (x1 ... xN N -- xN ... x1 N) dup 1 > if 3 over 1 + 1 for rotate swap loop then ; : con-idle dup +condbref if +conidle else pop -1 then ; : con-time +contime ; : con-dbref +condbref ; : con-name +condbref dup if name else pop "" then ; : con-location +condbref dup if location then ; : con-host +conhost ; : con-con +concon ; : sort-idle con-idle swap con-idle < ; : sort-time con-time swap con-time < ; : sort-dbref con-dbref int swap con-dbref int < ; : sort-name con-name swap con-name stringcmp 0 < ; : sort-room con-location int swap con-location int < ; : sort-host con-host swap con-host stringcmp 0 < ; : sort-fd con-con swap con-con < ; : sort-random pop pop random 1 & ; : %-flags-and-number (flags n str -- flags n str 1 -- flags n c1 crest 0) 1 strcut over not if 0 exit then over "-!+:*" swap instr if 4 rotate rot strcat rot rot 1 exit then over atoi dup intostr 4 pick strcmp not if rot pop rot 10 * + swap 1 exit then pop 0 ; : fmt-contime dup 864000 < if 30 + 60 / dup 60 % intostr dup strlen 2 < if "0" swap strcat then ":" swap strcat swap 60 / dup 24 % intostr dup strlen 2 < if "0" swap strcat then rot strcat swap 24 / dup if intostr "d" strcat swap strcat else pop then else 3600 / dup 24 / intostr "d" strcat swap 24 % intostr dup strlen 2 < if "0" swap strcat then strcat "h" strcat then ; : fmt-conidle-mixed (time sep div -- str) 3 pick over / intostr rot strcat rot rot % intostr dup strlen 2 < if "0" swap strcat then strcat ; : fmt-conidle dup 60 < if intostr "s" strcat exit then dup 600 < if "m" 60 fmt-conidle-mixed exit then 60 / dup 60 < if intostr "m" strcat exit then dup 600 < if "h" 60 fmt-conidle-mixed exit then 60 / dup 24 < if intostr "h" strcat exit then dup 240 < if "d" 24 fmt-conidle-mixed exit then 24 / intostr "d" strcat ; : %-wizonly mewiz? V@ not if pop "?" then ; : %-% "%" ; : %-uD dup +conhdrline? if pop "Dbref" else +condbref int intostr then %-wizonly ; : %-uF dup +conhdrline? if pop "Flags" else +condbref dup ok? if flagstr else pop "-" then then %-wizonly ; : %-uI dup +conhdrline? if pop "+" else +condbref dup ok? if "i" flag? else pop 0 then if "+" else "" then then ; : %-uL dup +conhdrline? if pop "Where" else +condbref dup ok? if location int intostr else pop "-" then then %-wizonly ; : %-uP ( con sofar rest pad flags n con ) pop 4 rotate 1 strcut -5 rotate dup not if pop " " then dup padchar V! 3 put "" ; : %-uU dup +conhdrline? if pop "*" else +condbref dup ok? if "u" flag? else pop 0 then if "*" else "" then then %-wizonly ; : %-lc dup +conhdrline? if pop "On For" else +contime fmt-contime then ; : %-ld dup +conhdrline? if pop "Doing" else +condbref dup ok? if "_doing" getpropstr else pop "" then then ; : %-lf dup +conhdrline? if pop "&d" else +concon intostr then %-wizonly ; : %-lh dup +conhdrline? if pop "Host" else +conhost then %-wizonly ; : %-li dup +conhdrline? if pop "Idle" else dup +condbref if +conidle fmt-conidle else pop "-" then then ; : %-ll dup +conhdrline? if pop "Location" else +condbref dup not if pop "" exit then mewiz? V@ if location name else dup private? over location private? or if pop "(Private Location)" else location name then then then ; : %-ln dup +conhdrline? if pop "Player Name" else +condbref dup if name else pop "(Not connected)" then then ; : %-ls dup +conhdrline? if pop "Shell" else +condbref dup if dup private? over location private? or mewiz? V@ over over not and if pop pop pop "(Private)" else pop "" rot begin location ( shell-so-far loc ) dup "_shell" getpropstr dup if "/" strcat rot strcat swap else pop then dup #0 dbcmp until pop -1 strcut swap strcat swap if "(Prv)" swap strcat then then else pop "" then then ; : %-lu dup +conhdrline? if pop "User" else +conuser then %-wizonly ; : %-< ( con sofar rest pad flags n con ) 5 pick swap format- ( con sofar rest pad flags n result rest ) 5 put ; : %-? ( con sofar rest pad flags n con ) 0 6 pick 1 strcut 7 put ( con sofar rest pad flags n con fn key ) dup "!" strcmp not if pop not 6 pick 1 strcut 7 put then dup "H" strcmp not if pop over +conhdrline? else dup "C" strcmp not eif pop over +condbref else dup "W" strcmp not eif pop mewiz? V@ else "?%?" strcat -rot pop pop exit then if not then (xor) ( con sofar rest pad flags n con condition ) if ( con sofar rest pad flags n con ) 5 pick swap format- ( con sofar rest pad flags n result rest ) "%>" swap strcat 5 put pop else ( con sofar rest pad flags n con ) pop "" 5 put then ( con sofar rest pad flags n ) "" ; (backward compatability) : %-| ( con sofar rest pad flags n con ) dup +conhdrline? if 5 pick swap format- ( con sofar rest pad flags n result rest ) "%>" swap strcat 5 put pop "" else pop "" 5 put "" then ; : %-_ ( con sofar rest pad flags n con ) dup +condbref if pop "" 5 put "" else 5 pick swap format- ( con sofar rest pad flags n result rest ) "%>" swap strcat 5 put pop "" then ; : %-uM dup +conhdrline? if pop "Player Name" else +condbref dup if dup "u" flag? if "*" else " " then over "i" flag? if "+" else " " then strcat over name strcat "(#" strcat over int intostr strcat swap flagstr strcat ")" strcat else pop " (Not connected)" then then %-wizonly ; : %-uN dup +conhdrline? if pop "Player Name" else +condbref dup if dup name "(#" strcat over int intostr strcat swap flagstr strcat ")" strcat else pop "(Not connected)" then then %-wizonly ; : %-uR dup +conhdrline? if pop "Player Name" else +condbref dup if dup "u" flag? if "*" else " " then over "i" flag? if "+" else " " then strcat over name strcat "(" strcat swap int intostr strcat ")" strcat else pop " (Not connected)" then then %-wizonly ; : %-lm dup +conhdrline? if pop "Player Name" else +condbref dup not if pop " (Not connected)" exit then dup "u" flag? if "*" else " " then over "i" flag? if "+" else " " then strcat swap name strcat then ; (end compatability) : %-string (con sofar rest pad flags n con key -- flags n s) dup not if pop "?" exit then dup "%" strcmp not if pop %-% exit then dup "D" strcmp not if pop %-uD exit then dup "F" strcmp not if pop %-uF exit then dup "I" strcmp not if pop %-uI exit then dup "L" strcmp not if pop %-uL exit then dup "P" strcmp not if pop %-uP exit then dup "U" strcmp not if pop %-uU exit then dup "c" strcmp not if pop %-lc exit then dup "d" strcmp not if pop %-ld exit then dup "f" strcmp not if pop %-lf exit then dup "h" strcmp not if pop %-lh exit then dup "i" strcmp not if pop %-li exit then dup "l" strcmp not if pop %-ll exit then dup "n" strcmp not if pop %-ln exit then dup "s" strcmp not if pop %-ls exit then dup "u" strcmp not if pop %-lu exit then dup "<" strcmp not if pop %-< exit then dup "?" strcmp not if pop %-? exit then (backward compatability) dup "|" strcmp not if pop %-| exit then dup "_" strcmp not if pop %-_ exit then dup "M" strcmp not if pop %-uM exit then dup "N" strcmp not if pop %-uN exit then dup "R" strcmp not if pop %-uR exit then dup "m" strcmp not if pop %-lm exit then (end backward compatability) pop pop "?" ; : %-padding (con sofar rest pad flags n s -- s) 3 pick ":" instr if swap 6 pick strlen - over strlen - dup 1 < if pop 1 then else swap over strlen - then ( pad flags s n-len ) dup 0 > if 3 pick "*" instr if 4 rotate pop pop else 4 rotate make-pad-string 3 pick "-" instr not if swap then strcat then swap pop exit then 4 rotate pop dup 0 < if 3 pick "!" instr if 3 pick "-" instr not 4 pick "+" instr not + 1 = if over strlen + strcut pop else neg strcut swap pop then else pop then swap pop exit then pop swap pop ; : %-key (con sofar rest pad flags n con key -- s) %-string %-padding ; : format- (fmt con -- s rest) "" rot do ( con sofar fmtleft ) dup "%" instr dup not if pop strcat swap pop "" exit then 1 - strcut 1 strcut swap pop rot rot strcat swap ( con sofar post-% ) padchar V@ swap "" swap 0 swap begin %-flags-and-number while loop ( con sofar pad flags n key rest ) -5 rotate 7 pick swap ( con sofar rest pad flags n con key ) dup ">" strcmp not if 5 mpop rot pop exit then %-key rot swap strcat swap ( con sofar rest ) loop ; : format (fmt con -- s) " " padchar V! format- if "Improperly nested %< and %> in format." say then ; : show-hdr fmt V@ -1 +mapcon format maxll V@ strcut pop say ; : argsplit (str -- rest firstarg str -- 0) begin 1 strcut over if over " " strcmp not else pop pop 0 exit then while swap pop loop over "\"" strcmp if strcat dup " " instr dup if 1 - strcut 1 strcut swap pop else pop "" then swap exit then swap pop "" swap do ( accumulated rest ) dup "\"" einstr over "\\" einstr < if dup "\"" instr 1 - strcut 1 strcut -4 rotate pop strcat exit then dup "\\" instr dup if 1 - strcut rot rot strcat swap 1 strcut swap pop dup if 1 strcut rot rot strcat swap then else pop strcat "" swap exit then loop ; : argexplode 0 swap do argsplit dup string? if rot 1 + rot else pop exit then loop ; : setsort sort-fxn V! ; : setfmt fmt V! ; : setfilter atoi dbref filter V! ; : setidlelimit atoi idlelimit V! ; : setuser ([userlist] [arglist] user -- [newuserlist] [arglist]) over 3 + neg rotate dup 2 + rotate 1 + over 2 + neg rotate ; : setwiz (can be entered only when truewiz) dup mewiz? V! if ' interest-wizard else ' interest-mortal then interest-fxn V! default-fmt fmt V! ; : setll atoi dup 0 > if maxll V! else pop "Invalid line length ignored." say then ; : hostgripe "Please use -showhost or -sorthost, not just -host." say ; : helpabort 0 sleep daemon kill ; : dohelp "Option Meaning" say "-help Print this list" say "-idle Sort by idle time" say "-time Sort by connect time" say "-name Sort by player name" say "-random Sort in random order" say metw? if "-dbref Sort by player dbref [wiz-only]" say "-room Sort by player location dbref [wiz-only]" say "-fd Sort by connection descriptor [wiz-only]" say "-sorthost Sort by connection host [wiz-only]" say then "-doing Show player @doing in rightmost column" say "-shell Show player shell in rightmost column" say "-place Show location name in rightmost column" say metw? if "-showhost Show connection host in rightmost column [wiz-only]" say "-w (also -wiz, -wizard, -wwho) [wiz-only]" say " Show list as if wizard, even when quelled" say "-q (also -quell, -qwho) [wiz-only]" say " Show list as if mortal, even when wizard" say then "-filter Program #nnn is an interest filter (see -filterhelp)" say "-fmt Set the format (use -fmthelp for more info)" say "-linelen Set the line length (to which long lines are truncated)." say "-idlelimit Set idle time limit (more idle than this => not shown)." say "-minimalist Don't show header/footer (-nominimalist cancels)" say "Use the -flaghelp option to find out how to set these as defaults." say helpabort ; : dofilterhelp "The argument to -filter must be a dbref number. The dbref must be a program," say "which must either be set L(ink_OK) or be owned by the person looking at the" say "wholist. (If this condition is not met, the -filter option is ignored.)" say "The filter is run after all other tests are done and a list of players who" say "would normally be listed has been constructed. The program is run with a" say "counted list (d1 d2 ... dN N) on top of the stack and is expected to return" say "with a similar list on the stack; any players in the original list that are" say "not in the returned list are omitted before printing." say helpabort ; : dofmthelp "A format string consists of regular characters, with format specifiers" say "beginning with a % sign included. Regular characters are copied to output" say "lines unchanged; % specifiers are replaced by strings as indicated below." say "Between the % and the specifier character, flags and a number are allowed." say "For more details on the flags and number, use -%help." say metw? if "[mortal-usable] [wiz-only]" say "% - a % sign D - player's dbref" say "I - + when Interactive, nothing otherwise" say "Px - use x as padding char F - player's flags" say "c - connect time L - player's location dbref" say "d - player's @doing U - * when Unseen, nothing otherwise" say "i - connection idle time f - connection's descriptor number" say "l - player's location name h - connection's remote host" say "n - player's name u - connection's remote username" say "s - player's shell" say "%< %? %> - see -%help" say "Default format: wizard \"" wizard-host-fmt "\"" strcat strcat say " mortal \"" mortal-doing-fmt "\"" strcat strcat say else "% - a % sign" say "I - + when Interactive, nothing otherwise" say "Px - use x as padding character for short fields" say "c - connect time" say "d - player's @doing" say "i - connection idle time" say "l - player's location name (like `find')" say "n - player's name" say "s - player's shell" say "%< %? %> - see -%help" say "Default format: \"" mortal-doing-fmt "\"" strcat strcat say then "Unrecognized format characters turn into a question mark." say metw? if "(Note that -doing, -place, -shell, and -showhost work by setting the" else "(Note that -doing, -place, and -shell work by setting the" then say "format, so put -fmt *after* those options.)" say metw? if "(Note that -w and -q change the format as well.)" say then helpabort ; : doflaghelp "To customize who's behavior, a _who-flags: property may be placed on a player" say "or on an action linked to this program (#" prog int intostr strcat "). This property is taken as a" strcat say "string that is effectively prepended to what is specified by the user when" say "asking for the who-list, except that it may not include player names. If the" say "exit is on a player or thing, its _who-flags: are processed after those on the" say "player; otherwise, the player's are processed later. Options specified on the" say "\"command line\" are always processed last. (In the case of conflicting" say "options, the last-processed option wins.)" say " " say "For example, an exit with the property" say " _who-flags: -name -fmt \"%-20n %l\"" say "linked to this program could be used to check (online) players' locations." say helpabort ; : do%help "Between the % and the specifier character can appear flags and digits. The" say "digits are interpreted as a number; the flag characters presently implemented" say "are -, !, +, :, and *. The number and flags control whether and how padding" say "is added to the string produced by the specifier character; for information" say "on how, use -%flags." say " " say "%< %?X %> - These provide grouping and conditionals. They may be nested." say "X can be H, C, or W, or any of those prefixed with a ! sign. Usage is" say " %" say "which causes string1 to be used when the conditional is true, string2 when" say "it's false. H is true if the header is being generated. C is true if the" say "descriptor is connected. W is true if the user is empowered to see wiz-only" say "information. (C will never be false unless W is true; also, C is consiered" say "true when H is.) The ! prefix negates the sense of the test. Flags and" say "width values may be specified on any of the three % specifiers, but they work" say "sensibly only on the %<. The %?X and string2 may be omitted; in this case" say "there is no conditional and the only effect is to group everything within" say "the %<...%> and apply any padding and flags from the %< to it." say " " say "%| works like %?H and %_ works like %?!C; they exist for compatability." say helpabort ; : do%flags "First, if the number is omitted, 0 is used. Then, a desired padding width is" say "computed. In the absence of the : flag, this width is simply the number, as" say "given or defaulted. But if the : flag is present, the width computed by" say "subtracting the length of the string generated so far from the given number," say "with the resulting value increased if necessary so it is at least one larger" say "than the length of the generated string. Once the padding width is" say "determined, other flags control what is done with it. In the absence of" say "flags, the string is simply padded on the left with spaces when it's shorter" say "than the column width. If the - flag is given, the padding is placed on the" say "right instead; if the * flag is given, the string is never padded. When the" say "string is longer than the column width, normally, nothing special happens;" say "but when the ! flag is given, such strings are truncated. If the number of -" say "and + flags present is even, the end of the string is kept, otherwise the" say "beginning. (That is, normally, the end of the string is kept fixed, with the" say "beginning padded or truncated; when - is given, the beginning is kept fixed." say "The presence of the + flag means that truncation occurs at the other end from" Say "padding.) Note that when the : flag is used within the scope of a %< %>" say "construct, the \"string generated so far\" is computed from the beginning of" say "the %<. If the %P specifier is used, the character after the P is used as" say "the padding character for further padding; the default pad character is a" say "space." say helpabort ; : getarg (args narg opt -- args narg arg 1 args narg 0) (prints complaint when it returns 0) over 0 > if pop 1 - swap 1 else " needs a following argument" strcat say 0 then ; : doarg dup "-idle" strcmp not if pop ' sort-idle setsort exit then dup "-time" strcmp not if pop ' sort-time setsort exit then dup "-name" strcmp not if pop ' sort-name setsort exit then dup "-random" strcmp not if pop ' sort-random setsort exit then dup "-doing" strcmp not if pop doing-fmt setfmt exit then dup "-shell" strcmp not if pop shell-fmt setfmt exit then dup "-place" strcmp not if pop place-fmt setfmt exit then metw? if dup "-dbref" strcmp not if pop ' sort-dbref setsort exit then dup "-room" strcmp not if pop ' sort-room setsort exit then dup "-sorthost" strcmp not if pop ' sort-host setsort exit then dup "-fd" strcmp not if pop ' sort-fd setsort exit then dup "-showhost" strcmp not if pop wizard-host-fmt setfmt exit then dup "-host" strcmp not if pop hostgripe exit then dup "-w" strcmp not if pop 1 setwiz exit then dup "-wiz" strcmp not if pop 1 setwiz exit then dup "-wizard" strcmp not if pop 1 setwiz exit then dup "-wwho" strcmp not if pop 1 setwiz exit then dup "-q" strcmp not if pop 0 setwiz exit then dup "-quell" strcmp not if pop 0 setwiz exit then dup "-qwho" strcmp not if pop 0 setwiz exit then then dup "-help" strcmp not if dohelp then dup "-%help" strcmp not if do%help then dup "-%flags" strcmp not if do%flags then dup "-fmthelp" strcmp not if dofmthelp then dup "-flaghelp" strcmp not if doflaghelp then dup "-filterhelp" strcmp not if dofilterhelp then dup "-fmt" strcmp not if getarg if setfmt exit then then dup "-filter" strcmp not if getarg if setfilter exit then then dup "-linelen" strcmp not if getarg if setll exit then then dup "-idlelimit" strcmp not if getarg if setidlelimit exit then then dup "-minimalist" strcmp not if pop 1 minimalist? V! exit then dup "-nominimalist" strcmp not if pop 0 minimalist? V! exit then dup 1 strcut pop "-" strcmp not if "Warning: unknown option `" swap strcat "' ignored. Use -help for help." strcat say else setuser then ; : doargs argexplode revlist begin dup 0 > while 1 - swap doarg loop pop ; : -ty (n -- s) ( n must be 2..9 ) "ninety" "eighty" "seventy" "sixty" "fifty" "forty" "thirty" "twenty" 9 rotate 1 - pick -9 rotate pop pop pop pop pop pop pop pop ; : English-digit (n -- s) ( n must be 1..9 ) "nine" "eight" "seven" "six" "five" "four" "three" "two" "one" 10 rotate pick -10 rotate pop pop pop pop pop pop pop pop pop ; : -teen (n -- s) ( n must be 10..19 ) dup 10 = if pop "ten" exit then dup 11 = if pop "eleven" exit then dup 12 = if pop "twelve" exit then "nine" "eigh" "seven" "six" "fif" "four" "thir" 8 rotate 12 - pick -8 rotate pop pop pop pop pop pop pop "teen" strcat ; : intostr-English (n -- s) ( doesn't work above 999 ) "" over 100 >= if over 100 / intostr-English " hundred" strcat appcat swap 100 % swap over if " and" strcat then then over 20 >= if over 10 / -ty appcat swap 10 % dup if English-digit "-" swap strcat strcat else pop then exit then over 10 >= if swap -teen appcat exit then over if swap English-digit appcat exit then swap pop dup not if pop "zero" then ; : N-is/are (n str -- s) over intostr-English swap strcat swap 1 = if " is" else " are" then strcat ; : counts-to-str (counts -- counts s) 3 pick dup not if pop "no players are connected" exit then dup intostr-English " player" strcat swap 1 = if " is" else "s are" then strcat " connected" strcat ( total sleeping drowsy str-so-far ) ( so far: N player{ is|s are} connected ) ( possibilities: nothing more " and sleeping" " and getting drowsy" ", N of whom {is|are} sleeping" ", N of whom {is|are} getting drowsy" ", N of whom {is|are} sleeping and the other is getting drowsy" ", N of whom {is|are} sleeping and the rest are getting drowsy" ", N of whom {is|are} sleeping and another is getting drowsy" ", N of whom {is|are} sleeping and N {is|are} getting drowsy" ) over 4 pick or not if exit then 4 pick 4 pick = if " and sleeping" strcat exit then 4 pick 3 pick = if " and getting drowsy" strcat exit then ", " strcat over not 4 pick and if 3 pick " of whom" N-is/are strcat " sleeping" strcat exit then over 4 pick not and if over " of whom" N-is/are strcat " getting drowsy" strcat exit then over 4 pick + 5 pick = if over 1 = if 3 pick " of whom" N-is/are strcat " sleeping and the other is getting drowsy" strcat else 3 pick " of whom" N-is/are strcat " sleeping and the rest are getting drowsy" strcat then then over 1 = if 3 pick " of whom" N-is/are strcat " sleeping and another is getting drowsy" strcat exit then 3 pick " of whom" N-is/are strcat " sleeping and " strcat over "" N-is/are strcat " getting drowsy" strcat ; : show-numbers (counts -- ) ( total sleeping drowsy ) me @ dbref? if me @ "_English-who" prop-exists? else 0 then if counts-to-str -4 rotate pop pop pop "." strcat caps else rot dup intostr " player" strcat swap 1 = not if "s" strcat then swap dup if intostr ", " swap strcat strcat " drowsy" strcat else pop then swap dup if intostr ", " swap strcat strcat " sleeping" strcat else pop then "." strcat then say ; : chk-who-sort dup "who-sort" prop-exists? if dup owner "Please change the who-sort: property on #" rot int intostr strcat " to a _who-flags: property (use `who -flaghelp' for more)." strcat notify else pop then ; : name-check (names conns conn -- names conns conn interested) over 3 + pick not if 1 exit then dup %-ln 3 pick 5 + dup pick over + 1 - 1 for pick over over strlen strcut pop stringcmp not if pop 1 exit then loop pop 0 ; : count ( total sleeping drowsy conns nconns conn ) over 5 + -3 roll ( conns nc conn t s d ) rot 1 + ( conns nc conn s d t ) 4 pick +conidle dup idlesleep V@ >= if pop rot 1 + rot else idledrowse V@ >= eif -rot 1 + else -rot then ( conns nc conn t s d ) 5 pick 5 + 3 roll ; : filter-by-interest (conns -- conns') 1 + 1 over 1 - 1 for pop dup rotate dup interest-fxn V@ exec if swap else pop 1 - then loop 1 - ; : filter-by-names (names conns -- names conns') 1 - 1 over 1 + 1 for pop dup 0 >= while dup 2 + rotate name-check if swap else pop 1 - then loop 1 + ; : filter-by-filter (conns -- conns') filter V@ not if exit then dup not if exit then fork dup not if filter V@ depth neg rotate depth 1 - mpop 10 begin daemon "*mwho-list" getpropstr dup if break then pop dup if 1 - yield else 1 sleep then loop swap pop "." explode { atoi dbref } maplist depth rotate call { int intostr } maplist "." implode daemon "*mwho-return" rot addprop 999999 sleep daemon kill then dbref over 2 + copy pop { +condbrefnum intostr } maplist "." implode over "*mwho-list" rot addprop 1 10 1 for pop 1 sleep ( 1 100 1 for pop yield ) dup "*mwho-return" getpropstr dup if break then pop loop dup dbref? if kill exit then (fell through for loop) swap kill "." swap over 3 "" implode filter V! 1 over 1 for pop dup 1 + rotate filter V@ "." dup 2 5 pick +condbrefnum intostr implode instr if swap else pop 1 - dup while then loop ; : main NV Valloc me @ ok? if me @ wizard? else 0 then mewiz? V! 78 maxll V! ' sort-time sort-fxn V! " " padchar V! 0 idlelimit V! #-1 filter V! 0 minimalist? V! "300" "idle-sleep" str-with-default atoi idlesleep V! "210" "idle-drowse" str-with-default atoi idledrowse V! me @ int? if ' interest-unconnected interest-fxn V! mortal-doing-fmt fmt V! 0 else mewiz? V@ if ' interest-wizard else ' interest-mortal then interest-fxn V! default-fmt fmt V! 0 trigger @ location dup player? swap thing? or if me @ "_who-flags" getpropstr doargs trigger @ "_who-flags" getpropstr doargs else trigger @ "_who-flags" getpropstr doargs me @ "_who-flags" getpropstr doargs then mpop 0 swap doargs trigger @ chk-who-sort me @ chk-who-sort then ( names ) connections ' +mapcon maplist minimalist? V@ not if show-hdr then ( names conns ) 0 0 0 4 pick dup 6 + pick + 5 + 3 roll ( 0 0 0 names conns ) filter-by-interest filter-by-names filter-by-filter sort-fxn V@ sort dup 2 + pick over + 2 + over 1 + roll mpop begin dup 0 > while 1 - swap count fmt V@ swap format 0 maxll V@ substr say loop pop minimalist? V@ not if show-numbers then NV Vdealloc ; . c q