twinbbs.asp

来自「WAPmo手机网站管理平台是一款创建与管理维护WAP网站的的软件产品」· ASP 代码 · 共 1,115 行 · 第 1/3 页

End Function

Public Function FormatString(ByVal strData)
    Dim ret
    ret = strData
    Do While reg_test(TBBS_REG, "i", ret)
        ret = preg_replace(TBBS_REG, "gi", "TBBS.$1(""$2"")", ret)
    Loop
    ret = preg_replace2(TADS_REG, "gi", "FormatTADS", ret)
    FormatString = ret
End Function

Public Sub Module(ByVal strName)
    Dim strPath
    strPath = "modules/MoEx/TwinBBS/" & Replace(strName, ".", "/") & ".mo"
    strPath = GetMapPath(strPath)
    If Not fso.FileExists(strPath) Then
        Err.Raise vbObjectError + 1, "TwinBBS.Module", "Missing Module: " & strName
    End If
    ExecuteGlobal GetFileString(strPath, LOCAL_CHARSET)
End Sub

Public Function GetXMLCache(ByVal strName)
    Dim strCacheName
    strCacheName = "TBBS." & strName
    If IsEmpty(GetCache(strCacheName)) Then
        SetXMLCache strName
    End If
    Set GetXMLCache = GetCache(strCacheName)
End Function

Public Sub SetXMLCache(ByVal strName)
    Dim strCacheName
    strCacheName = "TBBS." & strName
    Select Case strName
    Case "Forums"
        SetCache strCacheName, MyKernel.DB.SQLToXML("SELECT * FROM " & T_FORUM & " ORDER BY SERIAL", "forums", "forum")
    Case "UnionBBS"
        SetCache strCacheName, MyKernel.DB.SQLToXML("SELECT * FROM " & T_UNIONBBS & " ORDER BY ID", "unions", "union")
    Case "Bulletin"
        SetCache strCacheName, MyKernel.DB.SQLToXML("SELECT * FROM " & T_BULLETIN, "bulletins", "bulletin")
    Case "Groups"
        SetCache strCacheName, MyKernel.DB.SQLToXML("SELECT * FROM " & T_GROUP & " ORDER BY MINPOSTS,SEQID", "groups", "group")
    Case "Persist"
        SetCache strCacheName, XMLLoadFile(MapPath("include/persist.xsl"))
    Case "Upload.WAP12"
        SetUploadCache "WAP12"
    Case "Upload.WAP20"
        SetUploadCache "WAP20"
    Case "Upload.WEB"
        SetUploadCache "WEB"
    Case "TopicNew"
        SetCache strCacheName, MyKernel.DB.SQLToXML(MyKernel.DB.GetLimitSQL(10, "SEQID,TITLE,FORUMID", T_TOPIC, "FOLLOW=0", "", "SEQID DESC"), "news", "new")
    Case "TopicTop"
        SetCache strCacheName, MyKernel.DB.SQLToXML(MyKernel.DB.GetLimitSQL(10, "SEQID,TITLE,FORUMID", T_TOPIC, "FOLLOW=0 AND TOPTYPE=3", "", "SEQID DESC"), "tops", "top")
    Case "TopicHot"
        SetCache strCacheName, MyKernel.DB.SQLToXML(MyKernel.DB.GetLimitSQL(10, "SEQID,TITLE,FORUMID", T_TOPIC, "FOLLOW=0 AND HITS>" & atol(clsEnv("replies_for_hot")), "", "SEQID DESC"), "hots", "hot")
    Case "TopicSoul"
        SetCache strCacheName, MyKernel.DB.SQLToXML(MyKernel.DB.GetLimitSQL(10, "SEQID,TITLE,FORUMID", T_TOPIC, "SOULED=1", "", "SEQID DESC"), "souls", "soul")
    Case Else
        Err.Raise vbObjectError + 1, "TwinBBS.SetXMLCache", "Unknown cache name:" & strName
    End Select
End Sub

Private Sub SetUploadCache(ByVal strName)
    Dim xmlDoc
    Set xmlDoc = xml.cloneNode(True)
    xmlDoc.async = False
    If Not xmlDoc.load(MapPath("include/upload." & strName & ".xsl")) Then
        Err.Raise vbObjectError + 1, "TwinBBS.SetUploadCache", "Invalid xslt document: " & xslDoc.parseError.reason
    End If
    SetCache "TBBS.Upload." & strName, xmlDoc
    Set xmlDoc = Nothing
End Sub

Public Sub SetTopCache(ByVal intType, ByVal lngID)
    Dim strSQL
    Dim strName
    Select Case intType
    Case TBBS_TOP_CURRENT
        strName = "TBBS.Tops.1." & lngID
        strSQL = "SELECT $(Column) FROM $(Table) WHERE TOPTYPE=1 AND FORUMID=$(FID) ORDER BY LASTPOSTTIME DESC"
    Case TBBS_TOP_PARENT
        strName = "TBBS.Tops.2." & lngID
        strSQL = "SELECT $(Column) FROM $(Table) WHERE TOPTYPE=2 AND FORUMID=$(FID) ORDER BY LASTPOSTTIME DESC"
    Case TBBS_TOP_ALL
        strName = "TBBS.Tops.3"
        strSQL = "SELECT $(Column) FROM $(Table) WHERE FOLLOW=0 AND TOPTYPE=3 ORDER BY LASTPOSTTIME DESC"
    End Select
    strSQL = Replace(strSQL, "$(Table)", T_TOPIC)
    strSQL = Replace(strSQL, "$(Column)", "SEQID,FORUMID,FORUMNAME,TITLE,USERID,USERNAME,REPLIES,HITS,LASTPOSTID,LASTPOSTTITLE,LASTPOSTUSERID,LASTPOSTUSERNAME,LASTPOSTTIME,TOPTYPE")
    strSQL = Replace(strSQL, "$(FID)", lngID)
    SetCache strName, MyKernel.DB.SQLToXML(strSQL, "topics", "topic")
End Sub

Public Function GetTopCache(ByVal intType, ByVal lngID)
    Dim strName
    Select Case intType
    Case TBBS_TOP_CURRENT
        strName = "TBBS.Tops.1." & lngID
    Case TBBS_TOP_PARENT
        strName = "TBBS.Tops.2." & lngID
    Case TBBS_TOP_ALL
        strName = "TBBS.Tops.3"
    End Select
    If IsEmpty(GetCache(strName)) Then
        SetTopCache intType, lngID
    End If
    Set GetTopCache = GetCache(strName)
End Function

Public Function PathName(ByVal strPath)
    Dim ret
    ret = "$(Home)$(Path)"
    If Left(strPath, 1) = "/" Then
        ret = Replace(ret, "$(Home)", "")
    Else
        ret = Replace(ret, "$(Home)", TBBS_HOME)
    End If
    ret = Replace(ret, "$(Path)", strPath)
    PathName = ret
End Function

Public Function MapPath(ByVal strPath)
    MapPath = Server.MapPath(PathName(strPath))
End Function

Public Property Get TimeStart()
    TimeStart = tmStart
End Property

Public Function Validate(ByVal strName)
    Validate = CBool(InString(Env("validate"), strName, False) And NetType = "web")
End Function

Public Function UBB(ByVal strName)
    UBB = InString(Env("ubb"), strName, False)
End Function

Public Function HTML(ByVal strName)
    HTML = InString(Env("html"), strName, False)
End Function

Public Sub SetNodes(ByVal strData)
    Dim arr, ptr
    arr = Split(strData, "|")
    For Each ptr In arr
        Select Case ptr
        Case "env"
            Call SetEnvNode
        Case "user"
            Call SetUserNode
        Case "group"
            AppendXML GetXMLCache("Groups"), True
        Case "forums"
            AppendXML GetXMLCache("Forums"), True
            Call SetForumNode
        Case "unionbbs"
            AppendXML GetXMLCache("UnionBBS"), True
        Case "bulletin"
            AppendXML GetXMLCache("Bulletin"), True
        Case "topic.new"
            AppendXML GetXMLCache("TopicNew"), True
        Case "topic.top"
            AppendXML GetXMLCache("TopicTop"), True
        Case "topic.hot"
            AppendXML GetXMLCache("TopicHot"), True
        Case "topic.soul"
            AppendXML GetXMLCache("TopicSoul"), True
        End Select
    Next
End Sub

Private Sub SetEnvNode()
    Dim ptr
    For Each ptr In clsEnv.Keys
        Attr("env", ptr) = clsEnv(ptr)
    Next
End Sub

Private Sub SetUserNode()
    Dim ptr
    Attr("user", "logined") = IIf(UserLogined, 1, 0)
    For Each ptr In MyKernel.Memory.Keys
        Attr("user", ptr) = MyKernel.Memory(ptr)
    Next
    Call SetPermitNode
End Sub

Private Sub SetPermitNode()
    Dim xmlNode, xmlNew
    Dim ptr
    Set xmlNode = Element("user")
    Set xmlNew = xmlNode.selectSingleNode("permit")
    If xmlNew Is Nothing Then
        Set xmlNew = xmlNode.appendChild(xmlTemp.createElement("permit"))
    End If
    For Each ptr In clsPermit.keys
        xmlNew.setAttribute ptr, clsPermit(ptr)
    Next
    Set xmlNew = Nothing
    Set xmlNode = Nothing
End Sub

Public Sub XMLClear(ByVal strName)
    Dim xmlNode
    Set xmlNode = xmlRoot.selectSingleNode(strName)
    If Not xmlNode Is Nothing Then
        Do While xmlNode.childNodes.length > 0
            xmlNode.removeChild xmlNode.childNodes(0)
        Loop
    End If
    Set xmlNode = Nothing
End Sub

Public Sub AppendXML(xmlDoc, byVal blnStandalone)
    Dim xmlParent, xmlNode
    Set xmlParent = Element(xmlDoc.documentElement.tagName)
    If blnStandalone Then
        Do While xmlParent.childNodes.length > 0
            xmlParent.removeChild xmlParent.childNodes.item(0)
        Loop
    End If
    For Each xmlNode In xmlDoc.documentElement.childNodes
        xmlParent.appendChild xmlNode.cloneNode(True)
    Next
    Set xmlParent = Nothing
End Sub

Public Sub AppendNode(xmlNode)
    Dim xmlNode2, xmlAttr2
    Set xmlNode2 = xmlRoot.selectSingleNode(xmlNode.tagName)
    If xmlNode2 Is Nothing Then
        xmlRoot.appendChild xmlNode.cloneNode(True)
    Else
        For Each xmlAttr2 In xmlNode.childNodes
            xmlNode2.setAttribute xmlAtt2.name, xmlAtt2.value
        Next
    End If
    Set xmlNode2 = Nothing
End Sub

Private Sub SetForumNode()
    Dim xmlParent, xmlChild
    Dim strMaster
    Set xmlParent = Element("forums")
    For Each xmlChild In xmlParent.childNodes
        strMaster = XMLAttr(xmlChild, "master")
        If strMaster <> "" Then
            SetMasterNode xmlChild, strMaster
        End If
        xmlChild.setAttribute "optionname", String(UBound(Split(xmlChild.getAttribute("mark"), "_")) * 2, "-") & xmlChild.getAttribute("name")
    Next
    Set xmlParent = Nothing
End Sub

Private Sub SetMasterNode(xmlParent, ByVal strData)
    Dim arr, ptr
    Dim xmlNode
    arr = Split(strData, "|")
    For Each ptr In arr
        Set xmlNode = xmlParent.selectSingleNode("master[@name = '" & XPathString(ptr) & "']")
        If xmlNode Is Nothing Then
            Set xmlNode = xmlParent.appendChild(xmlTemp.createElement("master"))
        End If
        xmlNode.setAttribute "name", ptr
        Set xmlNode = Nothing
    Next
End Sub

Public Function SendEmail(ByVal strDest, ByVal strSubject, ByVal strBody)
    Dim objMail
    Set objMail = Server.CreateObject("JMAIL.Message")
    objMail.Silent = True
    objMail.Logging = True
    objMail.Charset = "GBK"
    objMail.ContentType = "text/html"
    objMail.ContentTransferEncoding = "base64"
    objMail.From = Env("smtp_username")
    objMail.FromName = Env("bbs_name")
    objMail.AddRecipient strDest
    objMail.MailServerUserName = Env("smtp_username")
    objMail.MailServerPassword = Env("smtp_password")
    objMail.Priority = 1
    objMail.Subject = strSubject
    objMail.Body = strBody
    SendEmail = objMail.Send(Env("smtp_server"))
    objMail.Close
    Set objMail = Nothing
End Function

Public Function SendMessage(ByVal strSender, ByVal strSendto, ByVal strTitle, ByVal strContent, ByVal blnSave)
    Dim strSQL
    Dim arr
    arr = Split(strSendto, ",")
    strSQL = "INSERT INTO $(TableA) (SENDER,SENDTO,TITLE,CONTENT,FLAG,SENDTIME) SELECT '$(Sender)',USERNAME,'$(Title)','$(Content)',$(Flag),$(Timeval) FROM $(TableB) WHERE USERNAME IN ($(UserName))"
    strSQL = Replace(strSQL, "$(TableA)", T_INBOX)
    strSQL = Replace(strSQL, "$(TableB)", T_USER)
    strSQL = Replace(strSQL, "$(Sender)", SafeString(strSender))
    strSQL = Replace(strSQL, "$(Title)", SafeString(strTitle))
    strSQL = Replace(strSQL, "$(Content)", SafeString(strContent))
    strSQL = Replace(strSQL, "$(Flag)", 0)
    strSQL = Replace(strSQL, "$(Timeval)", clsVars("time"))
    strSQL = Replace(strSQL, "$(UserName)", SafeArray(arr))
    SendMessage = MyKernel.DB.Exec(strSQL)
    strSQL = "UPDATE $(Table) SET MSGRECV=MSGRECV+1,MSGNEW=MSGNEW+1 WHERE USERNAME IN ($(UserName))"
    strSQL = Replace(strSQL, "$(Table)", T_USER)
    strSQL = Replace(strSQL, "$(UserName)", SafeArray(arr))
    MyKernel.DB.Exec strSQL
    If blnSave Then
        strSQL = "INSERT INTO $(TableA) (SENDER,SENDTO,TITLE,CONTENT,SENDTIME) SELECT '$(Sender)',USERNAME,'$(Title)','$(Content)',$(Timeval) FROM $(TableB) WHERE USERNAME IN ($(UserName))"
        strSQL = Replace(strSQL, "$(TableA)", T_OUTBOX)
        strSQL = Replace(strSQL, "$(TableB)", T_USER)
        strSQL = Replace(strSQL, "$(Sender)", SafeString(strSender))
        strSQL = Replace(strSQL, "$(Title)", SafeString(strTitle))
        strSQL = Replace(strSQL, "$(Content)", SafeString(strContent))
        strSQL = Replace(strSQL, "$(Timeval)", clsVars("time"))
        strSQL = Replace(strSQL, "$(UserName)", SafeArray(arr))
        MyKernel.DB.Exec strSQL
        strSQL = "UPDATE $(Table) SET MSGSEND=MSGSEND+$(Count) WHERE USERNAME='$(UserName)'"
        strSQL = Replace(strSQL, "$(Table)", T_USER)
        strSQL = Replace(strSQL, "$(Count)", SendMessage)
        strSQL = Replace(strSQL, "$(UserName)", strSender)
        MyKernel.DB.Exec strSQL
        MyKernel.Memory("msgsend") = atol(MyKernel.Memory("msgsend")) + SendMessage
    End If
End Function

Public Function Encode(ByVal strData)
    Dim ret
    ret = atos(strData)
    ret = Replace(ret, "[", "#5B;")
    ret = Replace(ret, "]", "#5D;")
    Encode = ret
End Function

Public Function Decode(ByVal strData)
    Dim ret
    ret = atos(strData)
    ret = Replace(ret, "#5B;", "[")
    ret = Replace(ret, "#5D;", "]")
    Decode = ret
End Function

Public Sub AddOnline(ByVal lngForumID, ByVal strState)
    If MyKernel.Memory("online_state") = strState Then Exit Sub
    MyKernel.Memory("online_state") = strState
    Dim rs, strSQL
    Dim strUserName
    Dim strIPAddr
    Dim lngTime
    strIPAddr = MyIO.Env("REMOTE_ADDR")
    lngTime = clsVars("time")
    If UserLogined Then
        strUserName = MyKernel.Memory("UserName")
        If atoi(MyKernel.Memory("online_type")) = 0 Then
            MyKernel.Memory("online_type") = 1
            strSQL = MyKernel.DB.GetLimitSQL(1, "*", T_ONLINE, "IPADDR='$(IPAddr)' AND USERNAME IS NULL", "", "")
        Else
            strSQL = MyKernel.DB.GetLimitSQL(1, "*", T_ONLINE, "IPADDR='$(IPAddr)' AND USERNAME='$(UserName)'", "", "")
        End If
        strSQL = Replace(strSQL, "$(UserName)", SafeString(strUserName))
    Else
        strSQL = MyKernel.DB.GetLimitSQL(1, "*", T_ONLINE, "IPADDR='$(IPAddr)'", "", "")
    End If
    strSQL = Replace(strSQL, "$(IPAddr)", strIPAddr)
    Set rs = MyKernel.DB.Exec2(strSQL)
    If Not rs.EOF Then
        strSQL = "UPDATE $(Table) SET FORUMID=$(ForumID),STATE='$(State)',LASTTIME=$(Timeval)"
        If UserLogined And IsNull(rs("UserName")) Then
            strSQL = strSQL & ",USERNAME='$(UserName)'"
        End If