@program #2510 1 10000 d i ( nb: There is code in the rtn-makeprepend word that assumes quirks of Caspian's lib-ansi-free.muf library. ) $def Glow ($def SMT) $ifdef Glow $def ansi? "c" flag? $else $include $lib/ansi $endif ( KICK: turns on the incomplete, non-functional channel kicking code. ) ($def KICK (line 61)) ( ONOFF_MESSAGES: turns on messages when someone joins or leaves the channel. ) $def ONOFF_MESSAGES (line 63) ( __props on the program object propdir_channels: Where all the channel data is kept. Properties under this propdir are: : the properly capitalized name for this channel /on: everyone who's listening to this channel /kicked: dbrefs of users who have been banned from this channel /kick/: dbrefs of users who have voted to ban from this channel /lock: the lock users must pass to be able to join this channel int_pdchannelslength: The length of propdir_channels. propdir_bleep: The globally-registered cursewords. Must be lowercase. propdir_cmdmap: Where the conversions from command@ to channel are kept. ) $def propdir_channels "_com/channels/c" $def int_pdchannelslength 15 $def propdir_bleep "_com/bleep#/" $def propdir_cmdmap "_com/cmdmap/c" ( __props on the user prop_osay: Where the user's osay verb is. prop_bleep: 'no' if the user does NOT want to censor globally-registered cursewords. propdir_block: Where blocking patterns are. prop_ignored: Where #ignored dbrefs are. Ideally a wizprop, so it can't be peeked at or mangled or anything. propdir_prepend: Where channel #prepends live. ) $def prop_osay "_say/def/osay" $def prop_bleep "_prefs/com/bleep?" $def propdir_block "_prefs/com/patterns#/" $def prop_ignored "_prefs/com/@ignore" $def propdir_prepend "_prefs/com/prepend/c" ( __other definitions str_commands: The commands implemented in this program. str_channellesscommands: The commands implemented in this program that still work if you don't give a channel name or not. str_posepunctuation: Characters which, if starting a pose, should indicate no space between the name and the punctuation. Lets you do things like 'Natty's here!' instead of getting 'Natty 's here!' like you would on IRC. str_bleephash: Characters from which the masking for bleeped words are taken. int_bleephash: Length of str_bleephash. ) $def str_commands " on off prepend who all list bleep lock help say mine ignore !ignore help2 " $def str_channellesscommands " list mine bleep ignore help !ignore help2 " $def str_posepunctuation "!?',-. " $def str_bleephash "!@&%_%!*%*%@!%&&@&!@$@&%_!@%*%#" $def int_bleephashlength 31 ( __variables Uses for variables are listed before the start of each word. ) lvar v_channel lvar v_message lvar v_bleepedmessage lvar v_string lvar v_whichth (***** * General routines. * * rtn-lockedout? * rtn-removeBad *****) : rtn-lockedout? ( strChannel -- bool } Return true if I@ am locked out of the given channel. ) ( Get the lock for that channel. ) prog propdir_channels rot strcat "/lock" strcat ( dbProg strLockprop ) getprop ( ??Lock ) ( It is a lock, right? ) dup lock? if ( ??Lock ) ( Yes, it's a lock. Test it against me@. ) me @ swap testlock not ( boolLockedout ) ( Well, if it's not a lock, the channel's unlocked, so return false. ) else pop 0 then ( bool ) ; : rtn-removeBad ( db -- bool } If db is not a valid player, removes db from v_channel and returns true. Otherwise returns false. ) ( Invalid? ) dup ok? if dup player? not else 1 then if ( dbListener ) ( Yes, whoops. Remove from the channel and continue. ) prog propdir_channels v_channel @ strcat "/on" strcat ( dbListener dbProg strOnChannelProp ) over over getpropstr " " strcat ( dbListener dbProg strOnChannelProp strOnChannel ) " " "#" 6 rotate intostr strcat " " strcat subst ( dbProg strOnChannelProp strOnChannel' ) strip setprop ( ) 1 else pop 0 then ( bool ) ; (***** * Message-notification routines. * * rtn-coretell * rtn-greentell * rtn-redtell * rtn-yellowtell * rtn-yellownotify *****) $ifdef SMT $def rtn-greentell .tellgood $def rtn-redtell .tellbad $def rtn-yellowtell .tellwarn $else : rtn-coretell ( strMessage strNormal strAnsi -- } Give the user the given message, with the given prepend, as appropriate. ) $ifdef Glow ( Am I ansi-on? ) me @ ansi? if ( Yes; use the ansiful prepend. ) swap pop ( strMessage strPrepend ) "~&R" strcat else ( No; use the normal prepend. ) pop ( strMessage strPrepend ) then ( strMessage strPrepend ) ( Add the prepend and notify. ) swap strcat me @ swap ansi_notify ( ) $else ( Am I ansi-on? ) me @ ansi? if ( Yes; use the ansiful prepend. ) swap pop ( strMessage strPrepend ) ansify_string ( strMessage strPrepend ) else ( No; use the normal prepend. ) pop ( strMessage strPrepend ) then ( strMessage strPrepend ) ( Add the prepend and notify. ) swap strcat .tell ( ) $endif ; ( rtn-tell { str -- } Give the user the given message, with the prepends specified by . ) : rtn-greentell "[%] " "~&100[~&120%~&100]~&R " rtn-coretell ; : rtn-redtell "]%[ " "~&100]~&110%~&100[~&R " rtn-coretell ; : rtn-yellowtell "[%[ " "~&100[~&130%~&100[~&R " rtn-coretell ; $endif (v_message} The message to tell everyone. ) (v_bleepedmessage} A deansified version of v_message. ) : rtn-yellownotify ( strPeople strMessage -- } Tell all the strPeople the given strMessage, prepended yellowly. ) $ifdef SMT v_message ! ( strPeople ) $else ( Prepend. ) $ifdef Glow "~&100[~&130%~&100[~&R " swap strcat v_message ! ( strPeople ) $else "~&100[~&130%~&100[~&R " ansify_string over strcat ( strPeople strMessage strMessage' ) v_message ! ( strPeople strMessage ) "[%[ " swap strcat v_bleepedmessage ! ( strPeople ) $endif $endif ( Break into dbrefs. ) " " explode ( strPn..strP1 intN ) ( Start notifying. ) begin dup while ( strPn..strP1 intN ) ( Get a new dbref. ) swap ( strPn..strP2 intN strP1 ) 1 strcut swap pop ( strPn..strP2 intN -strP1 ) atoi dbref ( strPn..strP2 intN dbP1 ) dup rtn-removeBad if pop 1 - continue then ( strPn..strP2 intN dbP1 ) ( Notificate. ) $ifdef Glow v_message @ $ifdef SMT .notifywarn $else ansi_notify $endif $else ( Is this user ansified? ) dup ansi? if ( strPn..strP2 intN dbP1 ) ( Yes, use ansified. ) v_message ( strPn..strP2 intN dbP1 varMessage ) else ( No, use ansiless. ) v_bleepedmessage ( strPn..strP2 intN dbP1 varMessage ) then @ ( strPn..strP2 intN dbP1 strMessage ) notify ( strPn..strP2 intN ) $endif 1 - repeat pop ( ) ; (***** * List 'columnization' routines. * * rtn-columnize-who * rtn-columnize-ignore * rtn-columnize-list * rtn-columnize-mine * rtn-columnize *****) : rtn-columnize-who ( str -- str' } Convert the given '#123'-style player dbref to a name, or to a null string if the player is asleep. ) ( Turn the string into a dbref. ) 1 strcut swap pop atoi dbref ( db ) ( Is this user awake? ) dup player? if dup awake? else 0 then if ( dbP1 ) ( Yes, this user is awake. Return his/her name. ) name ( str' ) else ( No, this user is asleep. Return null. ) pop "" ( str' ) then ( str' ) ; : rtn-columnize-ignore ( str -- str' } Convert the given '#123'-style player dbref to a name. ) ( Turn the string into a name. ) 1 strcut swap pop atoi dbref ( db ) dup rtn-removeBad if pop "" else name then ( str' ) ; : rtn-columnize-list ( str -- str' } Convert the given channel propdir into a channel name. ) ( Remove the first part and pop it off. ) int_pdchannelslength strcut swap pop ( str' ) ( Am I locked out of this channel? ) dup rtn-lockedout? if ( str' ) ( Yes, I'm locked out; pass a null string away. ) pop "" ( str" ) else ( str' ) ( No, I'm not locked out; worry about if the name's too long. ) ( If it's too long for the columnized list {ie, more than 18}.. ) dup strlen 18 > if ( str' ) ( ..truncate to 16 and add '..'. ) 16 strcut pop ".." strcat ( str" ) then ( str" ) then ( str" ) ; : rtn-columnize-mine ( str -- str' } Convert the given channel propdir into a channel name if the user is in the channel, or to a null string if the user isn't. ) ( Get the list of people who're in the channel. ) prog over "/on" strcat getpropstr " " strcat ( str strOn ) ( Who am I@? ) "#" me @ intostr strcat " " strcat ( str strOn strMe ) ( So, am I@ in the list? ) instr if ( str ) ( Sure enough, I am. ) ( Hehe, make rtn-columnize-list do the work. ) rtn-columnize-list ( str' ) else ( str ) ( Sure amn't. Return a null string. ) pop "" ( str' ) then ( str' ) ; (v_string} The list to columnize. ) (v_whichth} Which column we're in at the given time. ) (v_message} addyConvert, the conversion routine we use on these particular list members. ) lvar v_messageIfAny : rtn-columnize ( strLn..strL1 intN addyConvert strMsgIfAny -- boolIfAny } Puts all the strings in the given list in columns, after running them through word addyConvert. ) v_messageIfAny ! ( Remember addyConvert for later. ) v_message ! ( Start with v_string pseudoempty, and v_whichth at 0. ) " " v_string ! 0 v_whichth ! ( Start the loop. ) begin dup while ( strLn..strL1 intN ) ( Fetch the next item from the list. ) swap ( strLn..strL2 intN strL1 ) ( Cogitate on it. ) v_message @ execute ( strLn..strL2 intN strL1' ) ( Did our addyConvert return a null string? ) dup not if ( strLn..strL2 intN strL1' ) ( We should leave this out of the list. ) pop ( strLn..strL2 intN ) 1 - continue ( strLn..strL2 intN ) then ( strLn..strL2 intN strL1' ) v_messageIfAny @ if v_messageIfAny @ rtn-greentell "" v_messageIfAny ! then ( strLn..strL2 intN strL1' ) ( Pad the string to 18 characters. ) " " strcat 18 strcut pop ( strLn..strL2 intN strL1' ) ( Add it to the v_string. ) v_string @ swap strcat ( strLn..strL2 intN strString ) ( Is this the last name for this line? ) v_whichth @ 3 = if ( strLn..strL2 intN strString ) ( Yes. Add a \n. ) .tell ( strLn..strL2 intN ) " " ( strLn..strL2 intN strString' } The four-space pad here is kind of dependent on rtn-greentell, to line up correctly with the message. ) ( Reset the line count. ) 0 ( strLn..strL2 intN strString' intWhichth ) else ( Nope, add a space. ) " " strcat ( Increment the line count. ) v_whichth @ 1 + ( strLn..strL2 intN strString' intWhichth ) then ( strLn..strL2 intN strString' intWhichth ) v_whichth ! v_string ! ( strLn..strL2 intN ) 1 - repeat pop ( ) ( Return our final string. ) v_string @ striptail ( strInColumns ) dup if .tell else pop then ( ) v_messageIfAny @ not ( boolIfAny ) ; (***** * Commands using the list 'columnization' routines. * * do-ignore * do-!ignore * * rtn-channellist * do-list * do-mine * * rtn-showchannellock * do-who *****) (v_string} The list of people the user currently ignores. ) : do-ignore ( strChannel strMessage -- } Add the given user to the user's #ignore list. ) ( Channel doesn't matter. Message is/are the user{s} to #ignore. ) swap pop strip ( strNewIgnored ) ( Load my@ #ignore list. ) me @ prop_ignored getpropstr ( strNewIgnored strOldIgnored ) ( Do I want to add someone, or just see my list? ) ( If strIgnored is null, I want to just see my list. ) over not if ( strIgnored ) ( I just want to see who I've ignored. ) swap pop ( strOldIgnored ) ( Am I ignoring someone? ) dup if ( Yes, I'm ignoring someone. Tell me about it. ) "default" v_channel ! ( strOldIgnored } rtn-columnize-ignore needs a channel name in v_channel. ) ( Explode into a list, and columnize. ) " " explode ( strPn..strP2 intN ) 'rtn-columnize-ignore "You are ignoring:" rtn-columnize pop ( ) else ( ) ( No, I'm not ignoring anyone. ) pop ( ) "You are ignoring no one." rtn-greentell ( ) then ( ) exit ( ) then v_string ! ( strNewIgnored ) ( Assume it's a list, not just one person. ) " " explode ( strIn..strI1 intN ) begin dup while ( strIn..strI1 intN ) ( Fetch the next dbref. ) swap ( strIn..strI2 intN strI1 ) ( Find their dbref. And that is a real player, right? ) dup .pmatch dup ok? not if ( strIn..strI2 intN strI1 dbI1 ) ( Whoops, it isn't. Break it to them. ) pop ( strIn..strI2 intN strI1 dbI1 ) "I can't tell who '" swap strcat "' is." strcat rtn-redtell ( strIn..strI2 intN ) 1 - continue ( strIn..strI2 intN ) then ( strIn..strI2 intN strI1 dbI1 ) swap pop ( strIn..strI2 intN dbI1 ) ( Is that person in the user's #ignore list? ) "#" over intostr strcat " " strcat ( strIn..strI2 intN dbI1 strIgnoree ) v_string @ over instr if ( strIn..strI2 intN dbI1 strIgnoree ) ( Yes, that person is already in the user's #ignore list. ) pop "You are already ignoring " swap name strcat "." strcat rtn-redtell ( strIn..strI2 intN ) 1 - continue ( strIn..strI2 intN ) then ( strIn..strI2 intN dbI1 strIgnoree ) ( Add this person to the user's #ignore list. ) v_string @ swap strcat v_string ! ( strIn..strI2 intN dbI1 ) "You ignore " swap name strcat "." strcat rtn-greentell ( strIn..strI2 intN ) 1 - repeat pop ( ) ( Save my new ignore list. ) me @ prop_ignored v_string @ setprop ( ) ; (v_string} My@ ignored people. ) : do-!ignore ( strChannel strMessage -- ) ( If we have no people, pretend it's a list to list. ) dup not if ( strChannel strMessage ) do-ignore ( ) exit ( ) then ( strChannel is irrelevant; strMessage is a list of people to ignore. ) swap pop ( strPeople ) ( Load my ignored people. ) me @ prop_ignored getpropstr " " strcat v_string ! ( strPeople ) ( Loop through the people in the list. ) " " explode ( strPn..strP1 intN ) begin dup while ( strPn..strP1 intN ) ( Dbrefify the next person. Could I figure out who they are? ) swap dup .pmatch dup ok? if ( strPn..strP2 intN strP1 dbP1 ) ( Yes, I could. ) swap pop ( strPn..strP2 intN dbP1 ) ( Is he/she in the ignore list? ) v_string @ "#" 3 pick intostr strcat " " strcat instr if ( strPn..strP2 intN dbP1 ) ( Yes, he/she is; remove. ) v_string @ "" "#" 4 pick intostr strcat " " strcat subst v_string ! ( strPn..strPn..strP2 intN dbP1 ) "You stop ignoring " swap name strcat "." strcat rtn-greentell ( strPn..strPn..strP2 intN ) else ( strPn..strP2 intN dbP1 ) ( No, he/she isn't; error. ) "You aren't ignoring " swap name strcat "." strcat rtn-redtell ( strPn..strPn..strP2 intN ) then ( strPn..strPn..strP2 intN ) else ( strPn..strP2 intN strP1 dbP1 ) ( No, I couldn't; error. ) pop ( strPn..strP2 intN strP1 ) "I can't tell who '" swap strcat "' is." strcat rtn-redtell ( strPn..strP2 intN ) then ( strPn..strP2 intN ) 1 - repeat pop ( ) ( Set the new prop. ) me @ prop_ignored v_string @ striptail setprop ; (v_string} The list to columnize. ) lvar v_isItMine : rtn-channellist ( strChannel strMessage intMine? -- } List all the channels with anyone in them. ) ( We don't care about the message *or* the channel. Ha. ) -3 rotate pop pop ( intMine? ) ( Am I only listing the channels the user is in? ) dup if ( intMine? ) ( Yes, #mine. ) 'rtn-columnize-mine ( intMine? addyConvert ) 1 else ( intMine? ) ( No, #list. ) 'rtn-columnize-list 0 then v_isItMine ! ( intMine? addyConvert ) ( Make a list of all the channelprops. ) "" v_string ! ( intMine? addyConvert ) propdir_channels begin prog swap nextprop dup while ( intMine? addyConvert strChannelprop ) v_string @ " " strcat over strcat v_string ! ( intMine? addyConvert strChannelProp ) repeat pop ( intMine? addyConvert ) v_string @ striplead ( intMine? addyConvert strChannels ) ( We're done with v_string, so we can stash addyConvert there, to get it on the other side of the exploded list without doing stack math. ) swap v_string ! ( intMine? strChannels ) " " explode ( intMine? strCn..strC1 intN ) v_string @ ( intMine? strCn..strC1 intN addyConvert ) ( Columnize. ) v_isItMine @ if "Channels you are on are:" else "Existing channels are:" then ( intMine? strCn..strC1 intN addyConvert strMessageIfAny ) rtn-columnize ( intMine? boolWereAny ) ( Output the string. ) not if ( intMine? ) pop if ( intMine? ) "You are on no channels." ( intMine? strMessage ) else ( intMine? ) "There are no existant channels." ( intMine? strMessage ) then rtn-redtell ( intMine? ) then pop ( ) ; : do-list ( strChannel strMessage -- } List all the channels. ) 0 rtn-channellist ( ) ; : do-mine ( strChannel strMessage -- } List all the channels of which the user is a member. ) 1 rtn-channellist ( ) ; : rtn-showchannellock ( strChannel -- } Spiffily show the given channel's channel lock. ) ( Is there a channel lock? ) prog propdir_channels 3 pick strcat "/lock" strcat ( strChannel dbProg strLockprop ) getprop ( strChannel lockLock? ) dup lock? if ( strChannel lockLock? ) ( Yes, the channel has a lock. Tell me of it. ) "Channel '" rot strcat "' is locked to '" strcat ( lockLock strMessage ) swap prettylock strcat ( strMessage ) "'." strcat ( strMessage ) rtn-greentell ( ) ( No, no channel lock; don't do anything. ) else pop pop then ( ) ; (v_message} The addy telling us to do-who or do-all. ) : rtn-whoall ( strChannel strMessage addyWhoAll? -- } List everyone on the given channel. ) ( Messages are futile. You will be fluffificated. ) v_message ! pop ( strChannel ) ( Is that channel locked against me? ) dup rtn-lockedout? if ( strChannel ) ( Yes, I'm locked out of that channel. Error. ) "You're locked out of channel '" over strcat "'." strcat rtn-redtell ( strChannel ) rtn-showchannellock ( ) exit ( ) then ( strChannel ) dup v_channel ! ( Find everyone in the channel. ) prog propdir_channels 3 pick strcat "/on" strcat ( strChannel dbProg strOnprop ) getpropstr ( strChannel strOn ) ( If it contains anything, explode it into a list. ) dup if ( strChannel strOn ) " " explode ( strChannel strPn..strP1 intN } We lose strChannel from now on, but we don't need it until we get rid of the list anyhow. ) else ( strChannel strOn ) ( Otherwise we can just make it up. ) pop 0 then ( strChannel strPn..strP1 intN ) v_message @ ( strChannel strPn..strP1 intN addyConvert ) "The people listening to channel '" v_channel @ strcat "':" strcat rtn-columnize ( strChannel boolIfAny ) ( If we have any people to list, list them. ) if ( strChannel ) rtn-showchannellock ( ) else ( strChannel ) "No one is listening to channel '" swap strcat "'." strcat rtn-redtell ( ) then ( ) ; : do-who ( strChannel strMessage -- } List all players on the given channel who are awake and listening. ) 'rtn-columnize-who rtn-whoall ; : do-all ( strChannel strMessage -- } List all players, awake or asleep, on the given channel. ) 'rtn-columnize-ignore rtn-whoall ; (***** * The 'say' command and its routines. * * rtn-ignoredby * rtn-blockedby * * rtn-razzafrackin * rtn-bleep * * rtn-makeprepend * rtn-notificate * * do-say *****) : rtn-ignoredby? ( dbIgnored? dbBywhom -- bool } Returns true if dbIgnored is on one of dbBywhom's ignore lists. ) ( Check for com-specific ignore. ) dup prop_ignored getpropstr " " strcat ( dbIgnored? dbBywhom strIgnorees ) "#" 4 pick intostr strcat " " strcat ( dbIgnored? dbBywhom strIgnorees strIgnored? ) instr not not ( dbIgnored? dbBywhom bool#Ignored ) ( Check with $lib/ignore. ) -3 rotate pop pop ( bool ) ; : rtn-blockedby? ( strMessage dbBywhom -- bool } Returns true if strMessage matches one of dbBywhom's blocking rules. ) ( Does dbBywhom have any blocking rules? ) dup propdir_block dup strlen 1 - strcut pop getpropstr dup if ( strMessage dbBywhom strHowmany ) ( Yes, he does. Check them. ) atoi begin dup while ( strMessage dbBywhom intWhich ) ( Get the next pattern. ) 3 pick ( strMessage dbBywhom intWhich strMessage ) 3 pick ( strMessage dbBywhom intWhich strMessage dbBywhom ) propdir_block 4 pick intostr strcat ( strMessage dbBywhom intWhich strMessage dbBywhom strPatternprop ) getpropstr ( strMessage dbBywhom intWhich strMessage strPattern ) ( Match safely. ) .smatch ( strMessage dbBywhom intWhich boolThis ) ( If the pattern did match, break while we have a non-zero on the stack. ) if break then ( strMessage dbBywhom intWhich ) pop ( strMessage dbBywhom intWhich ) 1 - repeat ( strMessage dbBywhom bool } If intWhich is non-zero, we didn't go through all the patterns without a hit. Ergo, there was a hit, and intWhich is bool. ) -3 rotate pop pop ( bool ) else ( No, he doesn't. Skip out. ) pop pop pop 0 ( bool ) then ( bool ) ; : rtn-razzafrackin ( int -- str } Generate a string of bleephash of the given length. ) ( Get hash. ) str_bleephash ( Start where? ) random int_bleephashlength 4 pick - % ( int strHash intHashstart ) ( Then start there. ) strcut swap pop ( int strHash' ) ( But make it only int long. Ta da. ) swap strcut pop ( str ) ; : rtn-bleep ( str -- strBleeped } Scribble out the globally registered cursewords in str. ) ( Keep a lowercase copy of this string. ) dup tolower ( str strLc ) propdir_bleep begin prog swap nextprop dup while ( str strLc strProp ) ( What word are we trying to find now? ) prog over getpropstr ( str strLc strProp strWord ) ( Is it in our lowercased version? ) begin 3 pick over instr dup while ( str strLc strProp strWord intLocation ) ( Yes, it is. Replace it. {Ew.} ) 5 rotate swap ( strLc strProp strWord str intLocation ) 1 - strcut ( strLc strProp strWord str- -str ) 3 pick strlen ( strLc strProp strWord str- -str intWordlength ) swap over strcut ( strLc strProp strWord str- intWordlength strWord -str ) swap pop ( strLc strProp strWord str- intWordlength -str ) swap rtn-razzafrackin ( strLc strProp strWord str- -str strBleep ) swap strcat strcat ( strLc strProp strWord str' ) ( Update the lowercase version. ) 4 rotate pop ( strProp strWord str' ) dup tolower ( strProp strWord str' strLc ) -4 rotate -4 rotate ( str' strLc strProp strWord ) repeat pop pop ( str' strLc strProp ) repeat pop pop ( strBleeped ) ; : rtn-makeprepend ( dbListener strMessage strChannel -- dbListener strMessage' } Add the user's correct prepend to the message. ) ( Get the prepend I have set for this channel. ) 3 pick propdir_prepend 3 pick strcat getpropstr ( dbListener strMessage strChannel strPrepend? ) dup not if ( dbListener strMessage strChannel strPrepend? ) ( Whoops, I don't have one set for this channel. Use the default. ) pop 3 pick propdir_prepend "default" strcat getpropstr ( dbListener strMessage strChannel strPrepend? ) dup not if ( dbListener strMessage strChannel strPrepend? ) ( Eek, no default, either. Use the hard default. ) pop "%c>" ( dbListener strMessage strChannel strPrepend ) then then ( dbListener strMessage strChannel strPrepend ) ( Activate the prepend thingy. ) ( Replace the channel name. ) swap "%c" subst ( dbListener strMessage strPrepend' ) ( Do timefmt. ) systime timefmt ( dbListener strMessage strPrepend' ) $ifdef Glow swap ( dbListener strPrepend" strMessage' ) $else ( Ansi colorize, if 1} the user is ansi?:true and 2} the prepend has ansi in it. ) 3 pick ansi? if dup "~&" instr else 0 then if ( dbListener strMessage strPrepend' ) ( Ansify the prepend. ) ansify_string ( dbListener strMessage strPrepend' ) ( Move the ~&R from the end of the ansified string to the end of the message, so the message gets colorized as well. ) ( Note: this bit contains much hackery specific to Caspian's lib-ansi-free.muf library, such as the reset code being ten characters long, and '"~&R" ansify_string' returning two of them. ) dup "~&R" ansify_string 10 strcut pop ( dbListener strMessage strPrepend' strResetcode } This strResetcode is made fresh while you wait. ) rinstr 1 - strcut ( dbListener strMessage strPrepend" strResetcode } This strResetcode was removed from the end of strPrepend'. ) rot swap strcat ( dbListener strPrepend" strMessage' ) else ansi_strip swap then ( dbListener strPrepend" strMessage' ) $endif ( Insert a space between the prepend and the message, and smack together. ) " " swap strcat strcat ( dbListener strMessage" ) ; (v_channel} The channel we're telling. ) (v_message} The message to tell the people in the channel. ) (v_bleepedmessage} The message to tell the people in the channel who have curse-word-bleeping on. ) : rtn-notificate ( strChannel strPeople strMessage -- } Tell the given message to the given people. ) ( Remember the message. ) dup v_message ! ( strChannel strPeople strMessage ) rtn-bleep v_bleepedmessage ! ( strChannel strPeople ) ( Normalize the capitalization of the channel name first. ) swap ( strPeople strChannel ) prog propdir_channels rot strcat getpropstr ( strPeople strChannel ) v_channel ! ( strPeople ) ( Split dbrefs. ) " " explode ( strPn..strP1 intN ) ( Tell everyone. ) begin dup while ( strPn..strP1 intN ) ( Dbrefify. ) swap ( strPn..strP2 intN strP1 ) 1 strcut swap pop ( strPn..strP2 intN strP1' } Remove the '#'. ) atoi dbref ( strPn..strP2 intN dbListener ) dup rtn-removeBad if ( strPn..strP2 intN dbListener ) pop 1 - continue ( strPn..strP2 intN ) then ( strPn..strP2 intN dbListener ) ( Am I ignored? ) me @ over rtn-ignoredby? if pop 1 - continue then ( strPn..strP2 intN dbListener ) ( Is user bleeping? ) dup prop_bleep getpropstr .no? if v_message else v_bleepedmessage then @ ( strPn..strP2 intN dbListener strMessage ) ( Is this text blocked? ) ( Do this after ascertaining bleepedness, so bleeped text doesn't cause blockage. ) dup 3 pick rtn-blockedby? if pop pop 1 - continue then ( strPn..strP2 intN dbListener strMessage ) ( Add listener's prepend message for this channel. ) v_channel @ rtn-makeprepend ( strPn..strP2 intN dbListener strMessage' ) $ifdef Glow ansi_notify ( strPn..strP2 intN ) $else notify ( strPn..strP2 intN ) $endif 1 - repeat pop ( ) ; : do-say ( strChannel strMessage -- ) ( In the interest of processor safety, we do the actual intensive prepending and list-processing in background mode. ) background ( strChannel strMessage ) ( Did I not give a message? ) dup not if ( Whoops, sure didn't. ) "Say what, again?" rtn-redtell ( strChannel strMessage ) pop pop exit ( ) then ( strChannel strMessage ) ( Do this first instead of formatting the message, since we should see if the user is in this channel anyhow. ) ( Get the people in the channel. ) prog propdir_channels 4 pick strcat "/on" strcat ( strChannel strMessage dbProg strOnprop ) getpropstr ( strChannel strMessage strOn ) ( Am I not in this channel? ) dup " " strcat ( strChannel strMessage strOn strOn' ) "#" me @ intostr strcat " " strcat ( strChannel strMessage strOn strOn' strMe ) instr not if ( strChannel strMessage strOn ) pop pop ( strChannel ) "You are not in channel '" swap strcat "'." strcat rtn-redtell ( ) exit ( ) then ( strChannel strMessage strOn ) ( Formatify my message. ) swap ( strChannel strOn strMessage ) $ifdef Glow "^^" "^" subst $endif ( Is this a pose? ) ( strMessage should be non-null, so this stringpfx isn't a problem. ) dup striplead ":" stringpfx if ( strChannel strOn strMessage ) ( Yup, it's a pose. ) striplead 1 strcut swap pop ( strChannel strOn strMessage' ) ( Does it not start with one of our special punctuation characters? ) str_posepunctuation over 1 strcut pop instr not if ( strChannel strOn strMessage' ) ( Sure doesn't! Add a space. ) " " swap strcat ( strChannel strOn strMessage' ) then ( strChannel strOn strMessage' ) else ( strChannel strOn strMessage ) ( No, it's a say. ) "\"" strcat ( strChannel strOn strMessage ) ( Ascertain my sayverb. ) " " me @ prop_osay getpropstr ( strChannel strOn strMessage strSpace strVerb? ) dup if ( strChannel strOn strMessage strSpace strVerb? ) ( Yup, I have one set. ) ( But does it need a comma? ) dup "," instr if " \"" else ", \"" then strcat ( strChannel strOn strMessage strSpace strVerb ) else ( I don't have one set! Use 'says,'. ) pop "says, \"" ( strChannel strOn strMessage strSpace strVerb ) then strcat ( strChannel strOn strMessage strVerb' ) swap strcat ( strChannel strOn strMessage' ) then ( strChannel strOn strMessage' ) me @ name swap strcat ( strChannel strOn strMessage" ) ( Notificate. ) rtn-notificate ( ) ; (***** * The other commands. * * do-bleep * do-prepend * do-lock * do-off * do-on * do-help *****) : do-bleep ( strChannel strMessage -- } Toggle or set {according to message} user's bleepedness. ) ( Channel is irrelevant. ) swap pop ( strMessage ) ( Normalize the message. ) strip tolower ( strMessage' ) " " swap strcat " " strcat ( strMessage' ) ( Is it 'on' or 'yes'? ) " on yes " over instr if ( strMessage' ) ( Yes, we want to enable. ) pop 1 ( bool ) else ( strMessage' ) ( No; is it 'off' or 'no'? ) " off no " swap instr if ( ) ( Yes, we want to disable. ) 0 ( bool ) else ( ) ( No, we want to toggle. ) me @ prop_bleep getpropstr .no? (not) ( bool } We would use the commented-out 'not' if we wanted to get the user's current setting, but we would just want to 'not' that, so it's already what we want. ) then ( bool ) then ( bool } If 'yes, turn on,' bool==1; if 'no, turn off,' bool==0. ) ( If we're turning it off, ask if we're sure? ) dup not if ( bool ) "Are you sure you want to disable bleeping of possibly offensive words? (y/N)" rtn-yellowtell ( bool ) read .yes? not if ( bool ) pop ( ) "Your bleeping option has not been changed." rtn-redtell ( ) exit ( ) then ( bool ) then ( bool ) ( Set the new bleep setting. ) ( Where are we setting it to? ) me @ prop_bleep ( bool dbMe strBleepprop ) ( Are we setting or removing the prop? ) rot if remove_prop ( ) "Potentially offensive words will now be bleeped." else "no" setprop ( ) "You will now hear potentially offensive words." then rtn-greentell ( ) ; : do-prepend ( strChannel strMessage -- } Set the user's prepend for the given channel. ) ( Where are we setting to? ) me @ propdir_prepend 4 pick strcat ( strChannel strMessage dbMe strPrepprop ) 3 pick setprop ( strChannel strMessage ) ( Say we're golden. ) "Your prepend for channel '" rot strcat "' has been set to '" strcat ( strMessage strTotell ) ( Ansify so we get a little preview. ) $ifdef Glow swap "^ ^~&R" strcat ( strTotell strPrepend ) me @ ansi? not if ansi_strip then ( strTotell strPrepend ) $else swap "~&R" strcat ( strTotell strPrepend ) me @ ansi? if ansify_string else ansi_strip then ( strTotell strPrepend ) $endif strcat "'." strcat ( strTotell ) rtn-greentell ( ) ; : do-lock ( strChannel strMessage -- } Set the given channel's lock. ) ( The message is the lock. ) swap ( strLock strChannel ) ( I am in the channel, right? ) prog propdir_channels 3 pick strcat "/on" strcat getpropstr " " strcat ( strLock strChannel strOn ) "#" me @ intostr strcat " " strcat instr not if ( strLock strChannel ) ( Whoops, I'm not. Tell me so. ) "Sorry, you must be in channel '" swap strcat "' to lock it." strcat rtn-redtell ( strLock ) pop exit ( ) then ( strLock strChannel ) ( Is the channel's permalock property set? ) prog propdir_channels 3 pick strcat "/@lock?" strcat getpropstr if ( strLock strChannel ) ( It is; that means we can't set the lock here. ) "Sorry, the lock for channel '" swap strcat "' is unmodifiable." strcat rtn-redtell ( strLock ) pop exit ( ) then ( strLock strChannel ) ( Parse the lock. ) ( Is the lock non-null? ) over if ( strLock strChannel ) ( Yes, the lock is non-null. Parse the lock. ) over parselock ( strLock strChannel lockLock ) ( Was it parsable? ) dup not if ( strLock strChannel lockLock ) ( No, it wasn't parsable. ) pop ( strLock strChannel ) "I can't lock '" swap strcat "' to '" strcat swap strcat "', since I couldn't figure out what you meant; sorry." strcat rtn-redtell ( ) exit ( ) then rot pop ( strChannel lockLock ) ( Write a message. ) " locks channel '" 3 pick strcat "' to '" strcat ( strChannel lockLock strMessage ) over prettylock strcat "'." strcat ( strChannel lockLock strMessage ) else ( strLock strChannel ) ( No, the lock is null. We want to set the lock to a null string. ) swap pop ( strChannel ) ( Add the 'lock.' ) "" ( strChannel strLock ) ( Do the message. ) " unlocks channel '" 3 pick strcat "'." strcat ( strChannel strLock strMessage ) then ( strChannel ??Lock strMessage } ??Lock is either a lock, or a null string. It should be set either way. ) ( Set the lock, then. ) prog propdir_channels 5 pick strcat "/lock" strcat ( strChannel ??Lock strMessage dbProg strLockprop ) 4 rotate setprop ( strChannel strMessage ) ( Display. ) me @ name swap strcat ( strChannel strMessage ) over v_channel ! ( strChannel strMessage } rtn-yellownotify needs to know what channel we're doing in, through v_channel. ) prog propdir_channels 4 rotate strcat "/on" strcat ( strMessage dbProg strOnprop ) getpropstr ( strMessage strOn ) swap rtn-yellownotify ( ) ; : do-off ( strChannel strMessage -- ) ( strMessage doesn't matter to #off. ) pop ( strChannel ) ( Go ahead and tell me so, since there are multiple exits from the next part. ) "You have left channel '" over strcat "'." strcat rtn-greentell ( Remove me from this channel. ) prog propdir_channels 3 pick strcat "/on" strcat ( strChannel dbProg strOnprop ) over over getpropstr " " strcat ( strChannel dbProg strOnprop strOn ) ( Replace '#123 ' where I'm #123, with ''. ) "" "#" me @ intostr strcat " " strcat ( strChannel dbProg strOnprop strOn strSpace strMe ) subst strip ( strChannel dbProg strOnprop strOn ) ( Hey, was I last one out? ) dup not if ( strChannel dbProg strOnprop strOn ) ( Whoops, I *am* the last one out. ) ( Remove the whole propdir. ) pop pop ( strChannel dbProg ) ( What propdir is it, again? ) propdir_channels 3 pick strcat ( strChannel dbProg strPropdir ) remove_prop ( strChannel ) pop exit ( ) then ( strChannel dbProg strOnprop strOn ) $ifdef ONOFF_MESSAGES ( Wait, notify while we have the list out. ) 4 pick v_channel ! dup me @ name " leaves channel '" strcat ( strChannel dbProg strOnprop strOn strOn strMsg ) prog propdir_channels ( strChannel dbProg strOnprop strOn strOn strMsg dbProg strChandir ) 8 pick strcat getpropstr strcat "'." strcat ( strChannel dbProg strOnprop strOn strOn strMsg ) rtn-yellownotify ( strChannel dbProg strOnprop strOn ) $endif setprop ( strChannel ) $ifdef KICK ( Recalculate kick votes. ) ( We have kick votes? ) prog propdir_channels 3 pick strcat "/kick" strcat ( strChannel dbProg strKickpropdir ) propdir? if ( Yes, we have kick votes. ) ( Check each prop in the propdir; if there are N/2+1 or more votes where N is number of people in channel, kick. ) pop "Recalculated kick votes!" rtn-greentell else pop then ( ) $else pop ( ) $endif ; : do-on ( strChannel strMessage -- ) ( strMessage is irrelevant for #on. ) pop ( strChannel ) ( The user isn't banned from that channel, is he? ) ( Who's banned? ) prog propdir_channels ( strChannel dbProg strPropdir ) 3 pick strcat "/kicked" strcat getpropstr ( strChannel strKicked ) " " strcat ( strChannel strKicked ) ( Who am I? ) "#" me @ intostr strcat " " strcat ( strChannel strKicked strMe ) ( Am I banned? ) instr if ( strChannel ) ( Yes, I am. Whoops. ) "You have been kicked from channel '" rot strcat "'." strcat rtn-redtell ( ) exit ( ) then ( strChannel ) ( Is the user locked from the that channel? ) dup rtn-lockedout? ( strChannel bool ) if ( strChannel ) ( Yes, he is. Error and quit. ) "The channel '" swap strcat "' is locked." strcat rtn-redtell ( ) exit ( ) then ( strChannel ) ( Add the user to the channel. ) prog propdir_channels ( strChannel dbProg strPropdir ) 3 pick strcat "/on" strcat ( strChannel dbProg strOnprop ) over over getpropstr ( strChannel dbProg strOnprop strOn ) ( And who am I? ) "#" me @ intostr strcat " " strcat ( strChannel dbProg strOnprop strOn strMe ) ( Er, is the channel empty? ) over not if ( strChannel dbProg strOnprop strOn strMe ) ( Set the 'correct' capitalization for the channel name. ) prog propdir_channels ( strChannel dbProg strOnprop strOn strMe dbProg strPropdir ) 7 pick strcat 7 pick ( strChannel dbProg strOnprop strOn strMe dbProg strChannelpropdir strChannel ) setprop ( strChannel dbProg strOnprop strOn strMe ) else ( strChannel dbProg strOnprop strOn strMe ) ( Wait, I'm not already in the channel, am I? ) over " " strcat over instr if ( strChannel dbProg strOnprop strOn strMe ) ( Whoops, I am already in the channel. ) pop pop pop pop ( strChannel ) "You're already in the channel '" swap strcat "'." strcat rtn-redtell ( ) exit ( ) then ( strChannel dbProg strOnprop strOn strMe ) then ( strChannel dbProg strOnprop strOn strMe ) ( OK, I'm not; continue. ) $ifdef ONOFF_MESSAGES me @ awake? if ( Wait, notify while we have the list out, minus strMe. ) 5 pick v_channel ! over me @ name " joins channel '" strcat ( strChannel dbProg strOnprop strOn strMe strOn strMsg ) prog propdir_channels ( strChannel dbProg strOnprop strOn strMe strOn strMsg dbProg strChandir ) 9 pick strcat getpropstr strcat "'." strcat ( strChannel dbProg strOnprop strOn strMe strOn strMsg ) rtn-yellownotify ( strChannel dbProg strOnprop strOn strMe ) then $endif ( OK, continue. ) striptail " " swap strcat strcat striplead ( strChannel dbProg strOnprop strOn" ) setprop ( strChannel ) "You have joined the channel '" swap strcat "'." strcat rtn-greentell ( ) ; : do-help ( strChannel strMessage -- ) ( Message and channel are irrelevant. ) pop pop ( ) prog "_help#" getpropstr atoi 1 ( intLast intCurrent ) begin over over >= while ( intLast intCurrent ) prog "_help#/" 3 pick intostr strcat "(#help)" 1 parseprop .tell 1 + repeat pop pop ( ) ; : do-help2 ( strChannel strMessage -- ) ( Message and channel are irrelevant. ) pop pop ( ) prog "_help2#" getpropstr atoi 1 ( intLast intCurrent ) begin over over >= while ( intLast intCurrent ) prog "_help2#/" 3 pick intostr strcat "(#help)" 1 parseprop .tell 1 + repeat pop pop ( ) ; (***** * :main *****) : main ( strArg -- ) ( I'm not a zombie or something, am I? ) me @ player? not if "Sorry, only players can use dotcom channels." .tell pop exit ( ) then ( What channel are we dealing with? ) ( Is the command@ the channel name? ) prog propdir_channels ( strArg dbProg strProp ) command @ strip tolower dup command ! ( strArg dbProg strProp strChannel? } Save a clean copy of command@, while we're at it. ) strcat propdir? if ( strArg } If _com/channels/c is a propdir, it's a channel of its own. ) ( Yes, it's a channel of its own. ) command @ swap ( strChannel strMessage } If command@ is strChannel, all of strArg is strMessage. ) else ( strArg ) ( Well, if the program has a '_com/cmdmap/c' prop, it says the channel it means. ) prog propdir_cmdmap command @ strcat ( strArg dbProg strCmdmapprop ) getpropstr dup if ( strArg strChannel? ) ( Yes, the command@ maps to a channel. ) swap ( strChannel strMessage ) else ( strArg strChannel? ) ( No, it must be in the argument. ) pop ( strArg ) ( Is strArg just a channel? ) striplead dup " " instr dup if ( strArg intFirstspace ) ( No, there's a message, too. ) strcut ( strChannel strMessage ) ( Strip the last space from the channel name. ) swap striptail swap ( strMessage strChannel ) else ( strArg intFirstspace ) ( Yes, there's no message part. ) pop "" then ( strChannel strMessage ) then ( strChannel strMessage ) then ( strChannel strMessage ) ( Did we specify a #command? ) ( Whoops, strMessage might be null, causing trouble if no message is given. Check for the null case. ) dup if dup striplead "#" stringpfx else 0 then if ( strChannel strMessage ) ( Yes, we did. Strip the command off. ) 1 strcut swap pop ( strChannel strMessage' ) ( Er, is there a space in strMessage'? ) dup " " instr dup if ( strChannel strMessage' intFirstspace ) ( Yup; separate the command from the message. ) strcut swap striptail ( strChannel strMessage strCommand ) else ( strChannel strMessage' ) ( No, the message must be the command. ) pop "" swap ( strChannel strMessage strCommand ) then ( Is strCommand a valid command? ) str_commands " " 3 pick strcat " " strcat instr not if ( strChannel strMessage strCommand ) ( It isn't. Aiee. ) "'" over strcat "' doesn't seem to be a valid command." strcat rtn-redtell ( strChannel strMessage ) pop pop exit ( ) then ( strChannel strMessage strCommand ) else ( strChannel strMessage ) ( No, no command was specified. ) ( Er, wait, did we assume the first thing was the channel, when it was actually the command? ) over "#" stringpfx if ( strChannel strMessage ) ( Well, it starts with a '#'... ) over 1 strcut swap pop ( strChannel strMessage strCommand? ) str_channellesscommands " " 3 pick striptail strcat " " strcat instr if ( strChannel strMessage strCommand? ) ( Yes, it's one of our channelless commands. ) rot pop "" -3 rotate ( strChannel strMessage strCommand } strChannel for this case is a null string. ) else ( strChannel strMessage strCommand? ) ( No, it's not one of our channelless commands. ) pop ( strChannel strMessage ) ( If a message was specified, assume 'say'; otherwise assume 'help'. ) dup if "say" else "help" then ( strChannel strMessage strCommand ) then ( strChannel strMessage strCommand ) else ( strChannel strMessage ) ( If a message was specified, assume 'say'; otherwise assume 'help'. ) dup if "say" else "help" then ( strChannel strMessage strCommand ) then ( strChannel strMessage strCommand ) then ( strChannel strMessage strCommand ) ( Do the command. ) prog "do-" rot strcat ( strChannel strMessage dbProg strWord ) call ( ) ; PUBLIC do-ignore PUBLIC do-!ignore PUBLIC do-list PUBLIC do-mine PUBLIC do-who PUBLIC do-all PUBLIC do-say PUBLIC do-bleep PUBLIC do-lock PUBLIC do-prepend PUBLIC do-off PUBLIC do-on PUBLIC do-help PUBLIC do-help2 . c q