staple

来自「WAP手机网页XXXXX WAP手机网页XXXXX」· 代码 · 共 118 行

Public Sub main()
    If Request.ServerVariables("REQUEST_METHOD") = "post" Then
        Call doPost
    Else
        Call doGet
    End If
End Sub

Private Sub doGet()
    Dim lngId
    Dim intPage
    Dim MyAPI
    Dim MyCore
    Dim strName
    Dim blnParse
    lngId = atol(Request.QueryString("StapleId"))
    intPage = atoi(Request.QueryString("PageNo"))
    If intPage < 1 Then intPage = 1
    If lngId < 1 Then
        MyRedirect "index.asp"
    ElseIf Not ExportCache(lngId, intPage) Then
        Set MyXML = MyKernel.XMLParser
        Set MyAPI = New ImplFactory
        Set MyCore = MyAPI.Core
        blnParse = False
        If Not MyCore.CheckStaple() Then
            MyRedirect "index.asp"
        ElseIf MyCore.Staple("Category") = wmStapleLinking Then
            Call doLog("staple", MyCore.Staple("SeqId"), MyKernel.Env("REQUEST_URI"))
            MyRedirect MyCore.Staple("Content")
        Else
            MyXML.Printf MyXML.CreateC("UserStatus_" & MyCore.Staple("UserStatus"))
            MyXML.Printf MyXML.CreateC("Mark_" & MyCore.Staple("Mark"))
            strName = MyCore.Staple("Templet")
            If strName = "" Then strName = getIndexTemplet(IIf(MyCore.Staple("Follow") = 0, 2, 3))
            If strName <> "" Then blnParse = MyAPI.Parse(strName)
            If Not blnParse Then
                blnParse = MyAPI.ParseString(getFileString(getMapPath("templet/" & IIf(MyCore.Staple("Follow") = 0, 2, 3) & ".tpl"), "gb2312"))
            End If
            If blnParse Then
                Call setLog("staple", MyCore.Staple("SeqId"))
                If MyKernel.Config("CheckXHTML") = "1" Then
                    MyXML.TransformToObject "xhtml", getStaplePath(lngId, MyCore.PageNo, "xml")
                    MyXML.TransformToObject "wml", getStaplePath(lngId, MyCore.PageNo, "wml")
                    MyXML.TransformToObject "html", getStaplePath(lngId, MyCore.PageNo, "html")
                Else
                    MyXML.TransformToObject "wml", getStaplePath(lngId, MyCore.PageNo, "wml")
                End If
                Call ExportCache(lngId, MyCore.PageNo)
            Else
                MyXML.Println "模板解析错误，请稍后访问"
                MyXML.Transform Response
            End If
        End If
        Set MyCore = Nothing
        Set MyAPI = Nothing
    End If
End Sub

Private Sub doPost()
End Sub

Private Function getStaplePath(ByVal lngId, ByVal intPageNo, ByVal strExt)
    Dim strPath
    Dim fso
    Set fso = vbsre.mocom.util.com.forName("Scripting.FileSystemObject")
    strPath = getMapPath("cache/staple" & lngId)
    If Not fso.FolderExists(strPath) Then fso.CreateFolder strPath
    strPath = strPath & "\index_" & intPageNo & "." & strExt
    getStaplePath = strPath
    Set fso = Nothing
End Function

Private Function ExportCache(ByVal lngId, ByVal intPageNo)
    Dim strPath
    Dim strTemp
    Select Case MyKernel.Env("XML_DOCTYPE")
    Case "xhtml"
        strPath = getStaplePath(lngId, intPageNo, "xml")
    Case "wml"
        strPath = getStaplePath(lngId, intPageNo, "wml")
    Case "html"
        strPath = getStaplePath(lngId, intPageNo, "html")
    End Select
    strTemp = getFileString(strPath, "UTF-8")
    If strTemp = "" Then
        ExportCache = False
    ElseIf ValidVisit(strTemp) Then
        ExportCache = True
        Response.Charset = "utf-8"
        Response.ContentType = MyKernel.Env("XML_CONTENTTYPE")
        MyIO.Echo FormatXML(strTemp)
    End If
End Function

Private Function ValidVisit(ByVal strData)
    Dim reg, arr
    Dim intStatus
    Set reg = New RegExp
    reg.Pattern = "<\!--UserStatus_([\d]+)-->"
    Set arr = reg.Execute(strData)
    If arr.Count > 0 Then
        intStatus = atol(arr(0).SubMatches(0))
        ValidVisit = CBool(atol(MyKernel.Memory("Status")) >= intStatus)
        If Not ValidVisit Then
            If intStatus = wmUserRegister Then
                ExportError 403.3
            Else
                ExportError 403.4
            End If
        End If
    Else
        ValidVisit = True
    End If
    Set arr = Nothing
    Set reg = Nothing
End Function