#topic.mo

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

Option Explicit

TBBS.AddLang "common|head|foot|error|topic"
TBBS.SetNodes "env|user|forums"

TBBS.Page("name") = TBBS.Env("bbs_name")
TBBS.Vars("skin") = "default"

Call main

Private Sub doGet()
    If Not TBBS.CheckForum("crt", Request.QueryString("fid")) Then
        TBBS.AddError "missing_forum", Array()
        Exit Sub
    End If
    If Not TBBS.CheckTopic(Request.QueryString("id")) Then
        TBBS.AddError "missing_topic", Array()
        Exit Sub
    End If
    If atol(TBBS.Forum("crt.seqid")) <> atol(TBBS.Topic("forumid")) Then
        TBBS.AddError "missing_topic", Array()
        Exit Sub
    End If
    If atol(TBBS.Topic("follow")) > 0 Then
        TBBS.AddError "missing_topic", Array()
        Call doRedirect
        Exit Sub
    End If
    TBBS.Vars("ubb") = TBBS.UBB("topic")
    Call SetPage
    Call TBBS.SetTopicNav(TBBS.Page("id") > 1)
    Call SetOther
    Call SetUpload
    Call SetUpload2
    Call SetUsers
    Call TBBS.SetMaster
End Sub

Private Sub doRedirect()
    Dim arr1, arr2, strURL
    Dim lngRows, intSize
    lngRows = atol(TBBS.Topic("serial"))
    intSize = 10
    arr1 = Array("fid", "id", "page")
    arr2 = Array(TBBS.Forum("crt.seqid"), TBBS.Topic("follow"), GetPageNum(lngRows, intSize))
    strURL = "$(URL)#topic$(ID)"
    strURL = Replace(strURL, "$(URL)", GetURL("topic.asp", arr1, arr2))
    strURL = Replace(strURL, "$(ID)", TBBS.Topic("seqid"))
    MyIO.Redirect strURL
End Sub

Private Sub doPost()
    TBBS.AddError "invalid_handle", Array()
End Sub

Private Sub SetPage()
    Dim lngID, lngRows, lngSize, lngTotal, lngMove, lngFlag
    lngID = atoi(MyIO.QueryString("page"))
    If lngID < 1 Then lngID = 1
    lngRows = atol(TBBS.Topic("replies"))
    lngSize = 10
    lngTotal = (lngRows \ lngSize) + IIf(lngRows Mod lngSize = 0, 0, 1)
    If lngTotal < 1 Then lngTotal = 1
    If lngID > lngTotal Then lngID = lngTotal
    If lngRows = 0 Then
        lngMove = 0
        lngFlag = 0
    ElseIf lngID * lngSize >= lngRows Then
        lngMove = IIf(lngRows Mod lngSize = 0, lngSize, lngRows Mod lngSize)
        lngFlag = IIf(lngRows Mod lngSize = 0, lngRows - lngSize, lngRows - (lngRows Mod lngSize))
    Else
        lngMove = lngSize
        lngFlag = (lngID - 1) * lngSize
    End If
    TBBS.Page("id") = lngID
    TBBS.Page("rows") = lngRows
    TBBS.Page("size") = lngSize
    TBBS.Page("total") = lngTotal
    TBBS.Page("move") = lngMove
    TBBS.Page("flag") = lngFlag
    TBBS.Page("datatype") = MyKernel.DB.DataType
    TBBS.Page("table") = T_TOPIC
    TBBS.Page("column") = "*"
    TBBS.Page("where") = "FOLLOW=" & TBBS.Topic("seqid")
    TBBS.Page("sort") = "SEQID ASC"
    TBBS.Page("sorttype") = 0
    TBBS.Page("index") = "SEQID"
    TBBS.SetPagePrefix "topic.asp", Array("fid", "id"), Array(TBBS.Forum("crt.seqid"), TBBS.Topic("seqid"))
    TBBS.SetPageXML "topics", "topic", True
End Sub

Private Sub SetUsers()
    Dim strSQL
    strSQL = "SELECT * FROM $(Table) WHERE SEQID IN ($(SeqID))"
    strSQL = Replace(strSQL, "$(Table)", T_USER)
    strSQL = Replace(strSQL, "$(SeqID)", Join(GetUsers(), ","))
    TBBS.AppendXML MyKernel.DB.SQLToXML(strSQL, "users", "user"), True
End Sub

Private Function GetUsers()
    Dim xmlTopics, xmlNodes
    Dim ret, i
    Set xmlTopics = TBBS.Element("topics")
    Set xmlNodes = xmlTopics.childNodes
    ReDim ret(xmlNodes.length - 1)
    For i = 0 To xmlNodes.length - 1
        ret(i) = xmlNodes(i).getAttribute("userid")
    Next
    Set xmlNodes = Nothing
    Set xmlTopics = Nothing
    GetUsers = ret
End Function

Private Sub SetOther()
    Dim xmlParent
    Dim strSQL
    If TBBS.Page("id") > 1 Then Exit Sub
    Set xmlParent = TBBS.Element("topics")
    xmlParent.insertBefore TBBS.Element("topic").cloneNode(true), xmlParent.childNodes(0)
    Set xmlParent = Nothing
    TBBS.Topic("hits") = atol(TBBS.Topic("hits")) + 1
    strSQL = "UPDATE $(Table) SET HITS=HITS+1 WHERE SEQID=$(SeqID)"
    strSQL = Replace(strSQL, "$(Table)", T_TOPIC)
    strSQL = Replace(strSQL, "$(SeqID)", TBBS.Topic("seqid"))
    MyKernel.DB.Exec strSQL
End Sub

Private Sub SetUpload()
    Dim xmlDoc, xmlTopics, xmlNode, xmlAttr, xmlTopic, xmlNew
    Dim arr, i
    Dim strSQL
    Set xmlTopics = TBBS.Element("topics")
    ReDim arr(xmlTopics.childNodes.length - 1)
    For i = 0 To UBound(arr)
        arr(i) = xmlTopics.childNodes(i).getAttribute("seqid")
    Next
    strSQL = "SELECT A.*,B.SEQID AS BUYED FROM ($(TableA) A LEFT JOIN $(TableB) B ON (A.SEQID=B.FILEID AND B.USERID=$(UserID))) WHERE A.TOPICID IN ($(TopicID))"
    strSQL = Replace(strSQL, "$(TableA)", T_UPLOAD)
    strSQL = Replace(strSQL, "$(TableB)", T_DOWNLOAD)
    strSQL = Replace(strSQL, "$(UserID)", atol(MyKernel.Memory("seqid")))
    strSQL = Replace(strSQL, "$(TopicID)", Join(arr, ","))
    Set xmlDoc = MyKernel.DB.SQLToXML(strSQL, "uploads", "upload")
    For Each xmlNode In xmlDoc.documentElement.childNodes
        Set xmlTopic = xmlTopics.selectSingleNode("topic[@seqid = " & xmlNode.getAttribute("topicid") & "]")
        Set xmlNew = xmlTopic.appendChild(xmlTopics.ownerDocument.createElement("upload"))
        For Each xmlAttr In xmlNode.attributes
            xmlNew.setAttribute xmlAttr.name, xmlAttr.value
        Next
        xmlNew.setAttribute "buyed", IIf(IsNull(xmlNode.getAttribute("buyed")), "0", "1")
        xmlNew.setAttribute "crt_userid", atol(MyKernel.Memory("seqid"))
        xmlNew.setAttribute "crt_cent", atol(MyKernel.Memory("cent"))
        xmlNew.setAttribute "crt_coin", atol(MyKernel.Memory("coin"))
        xmlNew.setAttribute "crt_witchery", atol(MyKernel.Memory("witchery"))
        xmlNew.setAttribute "image", TBBS.Env("allow_image")
        Set xmlNew = Nothing
        Set xmlTopic = Nothing
    Next
    Set xmlDoc = Nothing
    Set xmlTopics = Nothing
End Sub

Private Sub SetUpload2()
    Dim xmlParent, xmlNode
    Dim arr, strData
    Set xmlParent = TBBS.Element("topics")
    For Each xmlNode In xmlParent.childNodes
        strData = xmlNode.getAttribute("content")
        If TBBS.Vars("ubb") Then
            strData = preg_replace2(TUBB_REG, "g", "ParseUBB", strData)
        End If
        arr = GetUploadArray(strData)
        If IsArray(arr) Then
            xmlNode.setAttribute "uploads", Join(arr, "|")
            If atoi(xmlNode.getAttribute("shield")) = 0 Or atoi(TBBS.Attr("user", "master")) = 1 Then
                strData = preg_replace("\[upload\](\d+)\[/upload\]", "g", "GetUpload(" & xmlNode.getAttribute("seqid") & ", $1)", strData)
            End If
        End If
        If TBBS.NetType <> "web" Then
            strData = ClearHTML(strData)
        End If
        xmlNode.setAttribute "content", strData
    Next
    Set xmlParent = Nothing
End Sub

Private Function GetUploadArray(ByVal strData)
    Dim ret, arr, i
    arr = reg_matches("\[upload\](\d+)\[/upload\]", "gi", strData)
    If IsArray(arr) Then
        ReDim ret(UBound(arr, 2))
        For i = 0 To UBound(arr, 2)
            ret(i) = arr(0, i)
        Next
        GetUploadArray = ret
    End If
End Function

Public Function GetUpload(ByVal lngTopicID, ByVal lngID)
    Dim xmlParent, xmlNode
    Dim ret
    Set xmlParent = TBBS.Element("topics")
    Set xmlNode = xmlParent.selectSingleNode("topic[@seqid = " & lngTopicID & "]/upload[@seqid = " & lngID & "]")
    If Not xmlNode Is Nothing Then
        ret = XTransform(xmlNode, TBBS.GetXMLCache("Upload." & TBBS.NetType), "UTF-8")
    Else
        ret = "[upload]" & lngID & "[/upload]"
    End If
    Set xmlNode = Nothing
    Set xmlParent = Nothing
    GetUpload = TBBs.FormatString(ret)
End Function