%@ LANGUAGE="VBSCRIPT" %>
<%
Const AdminPassword = "pass1234"
'**********************************************************
'**********************************************************
'**********************************************************
'**********************************************************
' DONT EDIT BELOW UNLESS YOU KNOW WHAT YOU ARE DOING
'**********************************************************
'**********************************************************
Const ApplicationMsg = "ChatRoomMsg"
Function lastMessageID()
Dim saryMessages
'Get the array
If IsArray(Application(ApplicationMsg)) Then
saryMessages = Application(ApplicationMsg)
Else
ReDim saryMessages(6, 0)
Application.Lock ' OK (rbd)
Application(ApplicationMsg) = saryMessages
Application.UnLock
End If
lastMessageID = saryMessages(5, UBound(saryMessages, 2))
End Function
Function PostMessage(strUsername, strMessage, intType)
Application.Lock ' OK (rbd)
Dim saryMessages
Dim saryTempArray
Dim intArrayPass
'Get the Array
If IsArray(Application(ApplicationMsg)) Then
saryMessages = Application(ApplicationMsg)
Else
ReDim saryMessages(5, 0)
Application(ApplicationMsg) = saryMessages
End If
Dim strColor
Dim strFormat
Dim intLastMessageID
'Double up slahes so it pashes through the javascript and displays
strMessage = Replace(strMessage, "\", "\\")
'Remove HTML if any
strMessage = removeAllTags(strMessage)
'If a link, format it
strMessage = CheckForLink(strMessage)
'format the message
strMessage = FormatMessage(strMessage)
If strMessage <> "" Then
'Array Legend
'0 = Author
'1 = Message
'2 = Date
'3 = Type
'4 = User ID, 0 = All
'5 = Message ID
Dim intTempSize
intTempSize = UBound(saryMessages, 2)
If intTempSize = 0 Then
intLastMessageID = 0
Else
intLastMessageID = Clng(saryMessages(5, intTempSize))
End If
intTempSize = intTempSize + 1
If intTempSize = 1 Then
ReDim saryMessages(5, intTempSize) ' Avoid initial array bounds exception
Else
ReDim Preserve saryMessages(5, intTempSize)
End If
saryMessages(0, intTempSize) = strUsername
saryMessages(1, intTempSize) = strMessage
saryMessages(2, intTempSize) = CDbl(Now())
saryMessages(3, intTempSize) = intType
saryMessages(4, intTempSize) = 0
saryMessages(5, intTempSize) = (intLastMessageID + 1)
Application(ApplicationMsg) = saryMessages
'******************************************
'*** Trim array if over 40 messages ***
'******************************************
If UBound(saryMessages, 2) => 20 Then
'put array in a temp array so we can update it
ReDim saryTempArray(5, 0)
'cut the array in half
For intArrayPass = 10 TO UBound(saryMessages, 2)
ReDim Preserve saryTempArray(5, UBound(saryTempArray, 2) + 1)
saryTempArray(0, UBound(saryTempArray, 2)) = saryMessages(0, intArrayPass)
saryTempArray(1, UBound(saryTempArray, 2)) = saryMessages(1, intArrayPass)
saryTempArray(2, UBound(saryTempArray, 2)) = saryMessages(2, intArrayPass)
saryTempArray(3, UBound(saryTempArray, 2)) = saryMessages(3, intArrayPass)
saryTempArray(4, UBound(saryTempArray, 2)) = saryMessages(4, intArrayPass)
saryTempArray(5, UBound(saryTempArray, 2)) = saryMessages(5, intArrayPass)
Next
'Transfer array to update
saryMessages = saryTempArray
Application(ApplicationMsg) = saryMessages
End If
End If
Application.UnLock
End Function
Function FormatMessage(strMessage)
'Smilies
strMessage = Replace(strMessage, ":huh?", "")
strMessage = Replace(strMessage, ":s", "")
strMessage = Replace(strMessage, ":P", "")
strMessage = Replace(strMessage, "}:)", "")
strMessage = Replace(strMessage, ":D", "")
strMessage = Replace(strMessage, "}:|", "")
strMessage = Replace(strMessage, ":)", "")
strMessage = Replace(strMessage, ":oops", "")
strMessage = Replace(strMessage, ";)", "")
strMessage = Replace(strMessage, ":pff", "")
strMessage = Replace(strMessage, ":\\", "")
strMessage = Replace(strMessage, ":0", "")
strMessage = Replace(strMessage, "[B]", "", 1, -1, 1)
strMessage = Replace(strMessage, "[/B]", "", 1, -1, 1)
strMessage = Replace(strMessage, "[I]", "", 1, -1, 1)
strMessage = Replace(strMessage, "[/I]", "", 1, -1, 1)
strMessage = Replace(strMessage, "[U]", "", 1, -1, 1)
strMessage = Replace(strMessage, "[/U]", "", 1, -1, 1)
'Loop through the message till all font colour codes are turned into fonts colours
Do While InStr(1, strMessage, "[color=", 1) > 0 AND InStr(1, strMessage, "[/color]", 1) > 0
Dim lngStartPos
Dim lngEndPos
Dim strMessageLink
Dim strTempMessage
'Find the start position in the message of the [COLOR= code
lngStartPos = InStr(1, strMessage, "[color=", 1)
'Find the position in the message for the [/COLOR] closing code
lngEndPos = InStr(lngStartPos, strMessage, "[/color]", 1) + 8
'Make sure the end position is not in error
If lngEndPos < lngStartPos Then lngEndPos = lngStartPos + 9
'Read in the code to be converted into a font colour from the message
strMessageLink = Trim(Mid(strMessage, lngStartPos, (lngEndPos - lngStartPos)))
'Place the message colour into the tempoary message variable
strTempMessage = strMessageLink
'Format the link into an font colour HTML tag
strTempMessage = Replace(strTempMessage, "[color=", "", 1, -1, 1)
strTempMessage = Replace(strTempMessage, "]", ">", 1, -1, 1)
Else
strTempMessage = strTempMessage & ">"
End If
'Place the new fromatted colour HTML tag into the message string body
strMessage = Replace(strMessage, strMessageLink, strTempMessage, 1, -1, 1)
Loop
FormatMessage = strMessage
End Function
'*********************************************
'*** Check and Format Links *****
'*********************************************
Function CheckForLink(strMessage)
Dim regEx
Set regEx = New RegExp
regEx.IgnoreCase = True
regEx.Global = True
'regEx.Pattern = "((http|ftp)://\S+)" 'http://
'strMessage = regEx.Replace(strMessage, "$1")
'regEx.Pattern = "([^/])(www\.\S+)" 'www.xxx.xxx
'strMessage = regEx.Replace(strMessage, "$1$2")
'regEx.Pattern = "(\S+@\S+\.\S+)" ' match email addresses
'strMessage = regEx.Replace(strMessage, "$1") ' Make replacement.
CheckForLink=strMessage
End Function
'*********************************************
'*** Strip all tags *****
'*********************************************
'Remove all tags for text only display (mainly for subject lines)
Private Function removeAllTags(ByVal strInputEntry)
'Remove all HTML scripting tags etc. for plain text output
strInputEntry = Replace(strInputEntry, "&", "&", 1, -1, 1)
strInputEntry = Replace(strInputEntry, "<", "<", 1, -1, 1)
strInputEntry = Replace(strInputEntry, ">", ">", 1, -1, 1)
strInputEntry = Replace(strInputEntry, "'", "", 1, -1, 1)
strInputEntry = Replace(strInputEntry, """", """, 1, -1, 1)
'Return
removeAllTags = strInputEntry
End Function
Function CleanMessage(strMessage)
strMessage = Replace(strMessage, "[B]", "", 1, -1, 1)
strMessage = Replace(strMessage, "[/B]", "", 1, -1, 1)
strMessage = Replace(strMessage, "[I]", "", 1, -1, 1)
strMessage = Replace(strMessage, "[/I]", "", 1, -1, 1)
strMessage = Replace(strMessage, "[U]", "", 1, -1, 1)
strMessage = Replace(strMessage, "[/U]", "", 1, -1, 1)
Dim lngMessagePosition
Dim intHTMLTagLength
Dim strHTMLMessage
Dim strTempMessageText
strTempMessageText = strMessage
For lngMessagePosition = 1 to CLng(Len(strMessage))
'If this is the end of the message then save some process time and jump out the loop
If Mid(strMessage, lngMessagePosition, 1) = "" Then Exit For
'If an BBCode tag is found then jump to the end so we can strip it
If Mid(strMessage, lngMessagePosition, 6) = "[color" OR Mid(strMessage, lngMessagePosition, 7) = "[/color" Then
'Get the length of the BBCode tag
intHTMLTagLength = (InStr(lngMessagePosition, strMessage, "]", 1) - lngMessagePosition)
'If the end of the BBCode string is in error then set it to the number of characters being passed
If intHTMLTagLength < 0 Then intHTMLTagLength = CLng(Len(strTempMessageText))
'Place the BBCode tag back into the temporary message store
strHTMLMessage = Mid(strMessage, lngMessagePosition, intHTMLTagLength + 1)
'Strip the BBCode
strTempMessageText = Replace(strTempMessageText, strHTMLMessage, " ", 1, -1, 0)
End If
Next
CleanMessage = strTempMessageText
End Function
%>
<%
Const ApplicationUsers = "ChatUsers"
Dim saryActiveUsers
Dim strUsername
Dim blnIsArray
Dim strAdminCommand
'Get the username
strUsername = Session("Username")
Function RemoveUnActive()
'Iterate through the array to remove old entires
For intArrayPass = 1 To UBound(saryActiveUsers, 2)
'Check the last checked date. If user wasnt updated 20 seconds ago then they must be gone
If CDate(saryActiveUsers(5, intArrayPass)) < CDate(CDbl(DateAdd("s", -20, Now()))) Then
'Post message that the user has left
Call PostMessage("", saryActiveUsers(1, intArrayPass) & " has left the room.", 1)
'Swap this array postion with the last in the array
saryActiveUsers(0, intArrayPass) = saryActiveUsers(0, UBound(saryActiveUsers, 2))
saryActiveUsers(1, intArrayPass) = saryActiveUsers(1, UBound(saryActiveUsers, 2))
saryActiveUsers(2, intArrayPass) = saryActiveUsers(2, UBound(saryActiveUsers, 2))
saryActiveUsers(3, intArrayPass) = saryActiveUsers(3, UBound(saryActiveUsers, 2))
saryActiveUsers(4, intArrayPass) = saryActiveUsers(4, UBound(saryActiveUsers, 2))
saryActiveUsers(5, intArrayPass) = saryActiveUsers(5, UBound(saryActiveUsers, 2))
saryActiveUsers(6, intArrayPass) = saryActiveUsers(6, UBound(saryActiveUsers, 2))
'Remove the last array position as it is no-longer needed
ReDim Preserve saryActiveUsers(6, UBound(saryActiveUsers, 2) - 1)
'Exit for loop to prevent errors
Exit For
End If
Next
End Function
Function getIP()
getIP = Request.ServerVariables("REMOTE_ADDR")
End Function
Function Reset()
Dim saryMessages
Dim saryActiveUsers
ReDim saryMessages(5, 0)
ReDim saryActiveUsers(6, 0)
Application.Lock ' OK (rbd)
Application(ApplicationUsers) = saryActiveUsers
Application(ApplicationMsg) = saryMessages
Application.UnLock
End Function
Function LogOut()
Dim intArrayPass
'' Don't abandon ACP observing session!
''Session.Abandon
saryActiveUsers(5, intArrayPos) = CDbl(DateAdd("s", -30, Now()))
Call RemoveUnActive()
'******************************************
'*** Update application level array ***
'******************************************
Application.Lock 'Lock the application ' OK (rbd)
Application(ApplicationUsers) = saryActiveUsers 'Update the applicaiton
Application.UnLock 'Unlock the application
End Function
Function CheckUsername(strUsername)
CheckUsername = False
Dim intArrayPass
Dim saryActiveUsers
'Get the array
If IsArray(Application(ApplicationUsers)) Then
saryActiveUsers = Application(ApplicationUsers)
Else
ReDim saryActiveUsers(6, 0)
End If
For intArrayPass = 1 TO UBound(saryActiveUsers, 2)
If saryActiveUsers(1, intArrayPass) = strUsername AND saryActiveUsers(3, intArrayPass) <> getIP() Then
CheckUsername = True
Exit For
End If
Next
Application.UnLock
End Function
%>
<%
Application.Lock ' ***QUESTIONABLE*** (rbd)
Dim saryMessages
Dim saryTempArray
Dim intArrayPass
Dim blnAdmin
Dim blnFormatText
strUsername = Session("Username")
blnAdmin = CBool(Session("Admin"))
blnFormatText = CBool(Session("FormatText"))
If strUsername = "" Then Response.End ' Should never happen
'Get the array
If IsArray(Application(ApplicationMsg)) Then
saryMessages = Application(ApplicationMsg)
Else
ReDim saryMessages(5, 0)
Application(ApplicationMsg) = saryMessages
End If
Dim strMessage
Dim strColor
Dim strFormat
Dim intLastMessageID
Dim intType
Dim strCommand
Dim blnPrivateMessage
Dim saryUserMsgTo
blnPrivateMessage = False
intType = 0
saryUserMsgTo = 0
strMessage = Request.Form("message")
strColor = Request.Form("color")
strFormat = Request.Form("format")
If Mid(strMessage, 1, 1) = "/" Then
If Mid(strMessage, 1, 10) = "/password " Then
strCommand = Trim(Mid(CleanMessage(strMessage), 10, Len(CleanMessage(strMessage))))
If strCommand = AdminPassword Then
Session("Admin") = True
strMessage = "Logged in as admin."
Else
strMessage = "Failed to login. Password given: " & strCommand
End If
saryUserMsgTo = Array(strUsername)
intType = 1
ElseIf Mid(strMessage, 1, 7) = "/logout" Then
Session("Admin") = False
If blnAdmin Then
strMessage = "Logged out."
Else
strMessage = "You where never logged in."
End If
saryUserMsgTo = Array(strUsername)
intType = 1
ElseIf Mid(strMessage, 1, 7) = "/alert " Then
strCommand = Trim(Mid(strMessage, 7, Len(strMessage)))
If blnAdmin Then
strMessage = "alert('" & strCommand & "');"
saryUserMsgTo = 0
intType = 2
Else
strMessage = "You do not have permission to use this command."
saryUserMsgTo = Array(strUsername)
intType = 1
End If
ElseIf Mid(strMessage, 1, 8) = "/kickall" Then
If blnAdmin Then
strMessage = "alert('You have been kicked!');parent.location=""default.asp"";"
saryUserMsgTo = 0
intType = 2
Else
strMessage = "You do not have permission to use this command."
saryUserMsgTo = Array(strUsername)
intType = 1
End If
ElseIf Mid(strMessage, 1, 6) = "/kick " Then
strCommand = Trim(Mid(strMessage, 6, Len(strMessage)))
If blnAdmin Then
If KickUser(strCommand) Then
strMessage = strCommand & " has been kicked."
Else
strMessage = strCommand & " username not found."
End If
saryUserMsgTo = Array(strUsername)
intType = 1
Else
strMessage = "You do not have permission to use this command."
saryUserMsgTo = Array(strUsername)
intType = 1
End If
ElseIf Mid(strMessage, 1, 7) = "/format" Then
If blnFormatText Then
Session("FormatText") = False
strMessage = "Text formating turned off."
Else
Session("FormatText") = True
strMessage = "Text formating turned on."
End If
saryUserMsgTo = Array(strUsername)
intType = 1
ElseIf Mid(strMessage, 1, 9) = "/commands" Then
strMessage = "
"
If User.IsAdministrator Then
strMessage = strMessage & _
"
Admin Commands:
" & _
"
Login:
/password [Password]
" & _
"
Logout:
/logout
" & _
"
Kick:
/kick [Username]
" & _
"
Alert:
/alert [Message]
"
End If
strMessage = strMessage & _
"
User Commands:
" & _
"
Private Message:
/[Username] [Message]
" & _
"
Text Formating on/off:
/format
" & _
"
Smilies:
" & _
"
" & _
"
:huh?
" & _
"
:s
" & _
"
:P
" & _
"
}:)
" & _
"
:D
" & _
"
}:|
" & _
"
:)
" & _
"
:oops
" & _
"
;)
" & _
"
:pff
" & _
"
:/
" & _
"
:0
" & _
"
"
saryUserMsgTo = Array(strUsername)
intType = 1
ElseIf Mid(strMessage, 1, 7) = "/color " Then
strCommand = Replace(strMessage, "/color ", "")
Response.Redirect("message.asp?Color=" & strCommand & "&Format=" & strFormat)
Else
'Dim saryActiveUsers
'Dim blnPrivateMessage
blnPrivateMessage = False
'Get the array
If IsArray(Application(ApplicationUsers)) Then
saryActiveUsers = Application(ApplicationUsers)
For intArrayPass = 1 TO UBound(saryActiveUsers, 2)
If Instr(strMessage, "/" & saryActiveUsers(1, intArrayPass) & " ") <> 0 Then
strMessage = Replace(strMessage, "/" & saryActiveUsers(1, intArrayPass) & " ", "")
saryUserMsgTo = Array(saryActiveUsers(1, intArrayPass), strUsername)
intType = 3
blnPrivateMessage = True
Exit For
End If
Next
End If
If blnPrivateMessage = False Then
strMessage = "You typed a unknown command. Type /commands for help."
saryUserMsgTo = Array(strUsername)
intType = 1
End If
End If
Else
If strColor <> "" Then strMessage = "[color=" & strColor & "]" & strMessage & "[/color]"
If strFormat <> "" Then strMessage = "[" & strFormat & "]" & strMessage & "[/" & strFormat & "]"
End If
strMessage = Trim(strMessage)
If strMessage <> "" Then
'Array Legend
'0 = Author
'1 = Message
'2 = Date
'3 = Type
'4 = User ID, 0 = All
'5 = Message ID
Dim intTempSize
intTempSize = UBound(saryMessages, 2)
If intTempSize = 0 Then
intLastMessageID = 0
Else
intLastMessageID = Clng(saryMessages(5, intTempSize))
End If
intTempSize = intTempSize + 1
Response.Write(vbCrLf & intTempSize)
If intTempSize = 1 Then
ReDim saryMessages(5, intTempSize) ' Avoid initial array bounds exception
Else
ReDim Preserve saryMessages(5, intTempSize)
End If
saryMessages(0, intTempSize) = strUsername
saryMessages(1, intTempSize) = strMessage
saryMessages(2, intTempSize) = CDbl(Now())
saryMessages(3, intTempSize) = intType
saryMessages(4, intTempSize) = saryUserMsgTo
saryMessages(5, intTempSize) = (intLastMessageID + 1)
Application(ApplicationMsg) = saryMessages
'******************************************
'*** Trim array if over 40 messages ***
'******************************************
If UBound(saryMessages, 2) => 20 Then
'put array in a temp array so we can update it
ReDim saryTempArray(5, 0)
'cut the array in half
For intArrayPass = 10 TO UBound(saryMessages, 2)
ReDim Preserve saryTempArray(5, UBound(saryTempArray, 2) + 1)
saryTempArray(0, UBound(saryTempArray, 2)) = saryMessages(0, intArrayPass)
saryTempArray(1, UBound(saryTempArray, 2)) = saryMessages(1, intArrayPass)
saryTempArray(2, UBound(saryTempArray, 2)) = saryMessages(2, intArrayPass)
saryTempArray(3, UBound(saryTempArray, 2)) = saryMessages(3, intArrayPass)
saryTempArray(4, UBound(saryTempArray, 2)) = saryMessages(4, intArrayPass)
saryTempArray(5, UBound(saryTempArray, 2)) = saryMessages(5, intArrayPass)
Next
'Transfer array to update
saryMessages = saryTempArray
Application(ApplicationMsg) = saryMessages
End If
End If
Application.UnLock
Response.Redirect("message.asp?Color=" & strColor & "&Format=" & strFormat)
Function KickUser(strUsername)
KickUser = False
Dim intArrayPass
Dim saryActiveUsers
Application.Lock ' OK (rbd)
'Get the array
If IsArray(Application(ApplicationUsers)) Then
saryActiveUsers = Application(ApplicationUsers)
Else
ReDim saryActiveUsers(6, 0)
End If
For intArrayPass = 1 TO UBound(saryActiveUsers, 2)
If saryActiveUsers(1, intArrayPass) = strUsername AND saryActiveUsers(3, intArrayPass) <> getIP() Then
saryActiveUsers(6, intArrayPass) = "kick"
KickUser = True
Application(ApplicationUsers) = saryActiveUsers
Exit For
End If
Next
Application.UnLock
End Function
%>