twinbbs.asp

WAPmo手机网站管理平台是一款创建与管理维护WAP网站的的软件产品

<!--#include file="config.asp"-->
<!--#include file="define.asp"-->
<!--#include file="func.asp"-->
<%
Class ImplTwinBBS
Private clsEnv, blnModifyEnv
Private clsVars
Private clsPermit
Private xmlTemp, xmlRoot
Public NetType

Private Sub Class_Initialize()
    Set clsEnv = Server.CreateObject(PROGID_HASH)
    Set clsVars = Server.CreateObject(PROGID_HASH)
    Set clsPermit = Server.CreateObject(PROGID_HASH)
    Set xmlTemp = xml.cloneNode(True)
    HashAdd clsEnv, MyKernel.Resource("moex.twinbbs.env"), "|"
    blnModifyEnv = False
    HashAdd clsPermit, MyKernel.Resource("moex.twinbbs.permit"), "|"
    xmlTemp.appendChild xmlTemp.createProcessingInstruction("xml", "version=""1.0"" encoding=""utf-8""")
    Set xmlRoot = xmlTemp.appendChild(xmlTemp.createElement("root"))
    AddNav "index.asp", Env("bbs_name")
    Call InitPermit
    Call CheckEnv
    Call SetReferer
    Vars("handle") = Request.QueryString("handle")
    Vars("action") = Request.QueryString("action")
    Vars("date") = GetTime(Date())
    Vars("time") = GetTime(Now())
    Vars("mid") = MyKernel.Memory.MemoryID
    NetType = GetNetType()
End Sub

Private Sub Class_Terminate()
    Set xmlRoot = Nothing
    Set xmlTemp = Nothing
    Set clsPermit = Nothing
    Set clsVars = Nothing
    If blnModifyEnv Then
        MyKernel.Resource("moex.twinbbs.env") = HashString(clsEnv, "|")
    End If
    Set clsEnv = Nothing
End Sub

Private Function GetNetType()
    Dim strAccept, strUA, strOS, strContentType
    Dim ret
    strAccept = MyIO.Env("HTTP_ACCEPT")
    strUA = MyIO.Env("HTTP_USER_AGENT")
    strOS = MyIO.Env("HTTP_UA_OS")
    If InStr(strAccept, "application/vnd.wap.xhtml+xml") > 0 Then
        ret = "wap20"
    ElseIf InStr(strUA, "Opera") > 0 Then
        ret = "wap20"
    ElseIf InStr(strAccept, "application/xhtml+xml") > 0 Then
        If strUA = "" Then
            ret = "wap20"
        ElseIf InStr(strUA, "SymbianOS") > 0 Then
            ret = "wap20"
        ElseIf InStr(strUA, "Windows CE") > 0 Then
            ret = "wap20"
        ElseIf InStr(strUA, "Linux") > 0 Then
            ret = "wap20"
        ElseIf strOS <> "" Then
            ret = "wap20"
        Else
            ret = "web"
        End If
    ElseIf strOS <> "" Then
        ret = "wap20"
    ElseIf InStr(strAccept, "wap") > 0 Then
        ret = "wap12"
    ElseIf strUA = "" Then
        ret = "wap12"
    Else
        ret = "web"
    End If
    If ret = "web" And MyKernel.Config("search_engine") <> "" Then
        ret = IIf(IsSearchEngine(), "wap12", "web")
    End If
    GetNetType = ret
End Function

Private Function IsSearchEngine()
    Dim strUA, arr, ptr
    strUA = LCase(MyIO.Env("HTTP_USER_AGENT"))
    arr = Split(LCase(MyKernel.Config("search_engine")), "|")
    For Each ptr In arr
        If InStr(strUA, ptr) > 0 Then
            IsSearchEngine = True
            Exit Function
        End If
    Next
    IsSearchEngine = False
End Function

Private Sub CheckEnv()
    If atol(clsEnv("index_time")) < clsVars("date") Then
        If atol(clsEnv("index_today")) > atol(clsEnv("index_maxday")) Then
            clsEnv("index_maxday") = clsEnv("index_today")
            clsEnv("index_maxtime") = clsEnv("index_time")
        End If
        clsEnv("index_yesterday") = clsEnv("index_today")
        clsEnv("index_time") = clsVars("time")
        clsEnv("index_today") = 0
    End If
End Sub

Public Property Get Env(ByVal strKey)
    Env = clsEnv(strKey)
End Property

Public Property Let Env(ByVal strKey, vtValue)
    clsEnv(strKey) = vtValue
    blnModifyEnv = True
End Property

Public Function XPEnv(ByVal strName, ByVal strKey)
    Dim arr1, arr2, i
    arr1 = Split(Env(strName), "|")
    arr2 = Split("reg|login|topic|reply|soul|delete", "|")
    For i = 0 To UBound(arr2)
        If arr2(i) = strKey Then
            If i > UBound(arr1) Then
                XPEnv = 0
            Else
                XPEnv = atoi(arr1(i))
            End If
            Exit Function
        End If
    Next
    XPEnv = 0
End Function

Public Sub AddHash(ByVal strName, ByVal strData)
    Dim arr, tmp, ptr
    arr = Split(strData, "|")
    For Each ptr In arr
        tmp = Split(ptr, "=", 2)
        If UBound(tmp) = 1 Then
            Attr(strName, tmp(0)) = HashDecode(tmp(1), "|")
        End If
    Next
End Sub

Public Sub AddLang(ByVal strName)
    Dim arr, ptr
    arr = Split(strName, "|")
    For Each ptr In arr
        AddHash "lang", MyKernel.Resource("moex.twinbbs.lang." & ptr)
    Next
End Sub

Public Property Get Lang(ByVal strKey)
    Lang = Attr("lang", strKey)
End Property

Public Property Let Lang(ByVal strKey, vtValue)
    Attr("lang", strKey) = vtValue
End Property

Public Property Get UserLogined()
    UserLogined = CBool(atol(MyKernel.Memory("seqid")) > 0)
End Property

Public Sub UserAsync(clsCmd)
    Dim key
    For Each key In clsCmd.Keys
        MyKernel.Memory(key) = clsCmd(key)
    Next
End Sub

Private Sub InitPermit()
    Dim arr, key, i
    Dim xmlDoc, xmlNode
    Set xmlDoc = GetXMLCache("Groups")
    If UserLogined() Then
        Set xmlNode = XMLQuery(xmlDoc.documentElement, "group[@seqid = " & MyKernel.Memory("groupid") & "]")
    Else
        Set xmlNode = XMLQuery(xmlDoc.documentElement, "group[@seqid = 5]")
    End If
    If Not xmlNode Is Nothing Then
        arr = Split(xmlNode.getAttribute("permit"), "|")
        key = clsPermit.Keys
        For i = 0 To UBound(key)
            If i > UBound(arr) Then
                Permit(key(i)) = 0
            Else
                Permit(key(i)) = arr(i)
            End If
        Next
    End If
    Set xmlNode = Nothing
    Set xmlDoc = Nothing
    Permit("fav") = IIf(UserLogined(), 1, 0)
    Permit("console") = IIf(UserLogined(), 1, 0)
End Sub

Public Property Get Permit(ByVal strKey)
    Permit = clsPermit(strKey)
End Property

Public Property Let Permit(ByVal strKey, vtValue)
    clsPermit(strKey) = atol(vtValue)
End Property

Public Property Get XMLTemplate()
    Set xmlTemplate = xmlTemp
End Property

Public Function Create(ByVal strName)
    Set Create = xmlTemp.createElement(strName)
End Function

Public Property Get Element(ByVal strName)
    Set Element = xmlRoot.selectSingleNode(strName)
    If Element Is Nothing Then
        Set Element = xmlRoot.appendChild(xmlTemp.createElement(strName))
    End If
End Property

Public Property Let Attr(ByVal strName, ByVal strAttr, vtValue)
    Dim xmlNode
    Set xmlNode = Element(strName)
    xmlNode.setAttribute LCase(strAttr), atos(vtValue)
    Set xmlNode = Nothing
End Property

Public Property Get Attr(ByVal strName, ByVal strAttr)
    Dim xmlNode
    Set xmlNode = xmlRoot.selectSingleNode(strName)
    If Not xmlNode Is Nothing Then
        Attr = xmlNode.getAttribute(strAttr)
    End If
    Set xmlNode = Nothing
End Property

Public Property Get Vars(ByVal strKey)
    Vars = clsVars(strKey)
End Property

Public Property Let Vars(ByVal strKey, vtValue)
    Attr("vars", strKey) = vtValue
    clsVars(LCase(strKey)) = vtValue
End Property

Public Sub Redirect(ByVal strURL)
    Vars("redirect") = strURL
End Sub

Private Sub SetReferer()
    Dim strURL
    strURL = MyIO.QueryString("refer")
    If strURL = "" Then
        strURL = MyIO.Env("REQUEST_URI")
    End If
    Vars("referer") = strURL
End Sub

Public Sub GetReferer()
    Dim strURL
    strURL = MyIO.QueryString("refer")
    Vars("refer") = strURL
End Sub

Public Sub AddHint(ByVal strKey, arr)
    Dim xmlNode
    Dim strName, strAttr, i
    Set xmlNode = Element("hint")
    strName = "attr" & xmlNode.attributes.length + 1
    strAttr = "hint_" & strKey
    For i = 0 To UBound(arr)
        arr(i) = MyIO.HTMLEncode(arr(i))
    Next
    If UBound(arr) <> -1 Then
        xmlNode.setAttribute strName, str_format(Lang(strAttr), arr)
    Else
        xmlNode.setAttribute strName, Lang(strAttr)
    End If
    Set xmlNode = Nothing
End Sub

Public Sub AddError(ByVal strKey, arr)
    Dim xmlNode
    Dim strName, strAttr, i
    Set xmlNode = Element("error")
    If xmlNode.attributes.length = 0 Then
        AddNav "", Lang("error_hint")
    End If
    strName = "attr" & xmlNode.attributes.length + 1
    strAttr = "error_" & strKey
    For i = 0 To UBound(arr)
        arr(i) = MyIO.HTMLEncode(arr(i))
    Next
    If UBound(arr) <> -1 Then
        xmlNode.setAttribute strName, str_format(Lang(strAttr), arr)
    Else
        xmlNode.setAttribute strName, Lang(strAttr)
    End If
    Set xmlNode = Nothing
End Sub

Public Property Get ErrorExists()
    Dim xmlNode
    Set xmlNode = xmlRoot.selectSingleNode("error")
    ErrorExists = CBool(Not xmlNode Is Nothing)
    Set xmlNode = Nothing
End Property

Public Sub AddNav(ByVal strHref, ByVal strTitle)
    Dim xmlNavs, xmlNav
    Set xmlNavs = Element("navs")
    Set xmlNav = xmlNavs.appendChild(xmlTemp.createElement("nav"))
    xmlNav.setAttribute "href", strHref
    xmlNav.setAttribute "title", strTitle
    Set xmlNav = Nothing
    Set xmlNavs = Nothing
End Sub

Public Function GetNav()
    Dim xmlNavs
    Dim ret, i, l
    Set xmlNavs = xmlRoot.selectNodes("navs/nav")
    l = xmlNavs.length - 1
    ReDim ret(l)
    For i = 0 To l
        ret(l - i) = xmlNavs(i).getAttribute("title")
    Next
    GetNav = Join(ret, " - ")
End Function

Public Sub Template(ByVal strName)
    Dim tpl, strData
    If ErrorExists Then
        strData = ParseTemplate("Error")
    Else
        strData = ParseTemplate(strName)
    End If
    Select Case NetType
    Case "wap12"
        MyIO.ContentType = "text/vnd.wap.wml"
    Case "wap20"
        MyIO.ContentType = "application/vnd.wap.xhtml+xml"
    Case "web"
        MyIO.ContentType = "text/html"
    End Select
    MyIO.Echo strData
End Sub

Private Function ParseTemplate(ByVal strName)
    Dim xslDoc, strNS, strData
    strNS = GetTemplateNS(strName)
    If IsEmpty(GetCaChe(strNS)) Then
        strData = GetTemplate(strName)
        Set xslDoc = xml.cloneNode(True)
        xslDoc.async = False
        If Not xslDoc.loadXML(strData) Then
            Err.Raise vbObjectError + 1, "TwinBBS.ParseTemplate(" & strName & ")", "Invalid template: " & xslDoc.parseError.reason
        End If
        SetCache strNS, xslDoc
    Else
        Set xslDoc = GetCache(strNS).cloneNode(True)
    End If
    Vars("queries") = MyKernel.DB.Count
    Vars("time_use") = FormatNumber(Timer() - tmStart, 5, True)
    strData = XMLTransformToString(xmlTemp, xslDoc, "utf-8")
    Set xslDoc = Nothing
    If NetType <> "web" Then
        strData = preg_replace2("(href|action)=""([^""]+)""", "gi", "FormatURL", strData)
        strData = preg_replace("\$\(TwinAds\)", "gi", "FormatTADS", strData)
    End If
    ParseTemplate = strData