func.asp

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

<%
Public Sub main()
    Select Case MyIO.Env("REQUEST_METHOD")
    Case "GET"
        Call doGet
    Case "POST"
        Call doPost
    Case Else
    End Select
End Sub

Public Function getAString(ByVal strHref, ByVal strText)
    Dim ret
    ret = "<a href=""[href]"">[text]</a>"
    ret = Replace(ret, "[href]", MyIO.HTMLEncode(MyIO.HTMLDecode(strHref)))
    ret = Replace(ret, "[text]", MyIO.HTMLEncode(strText))
    getAString = ret
End Function

Public Function getIMGString(ByVal strSrc, ByVal strAlt)
    Dim ret
    ret = "<img src=""[src]"" alt=""[alt]"" />"
    ret = Replace(ret, "[src]", MyIO.HTMLEncode(MyIO.HTMLDecode(strSrc)))
    ret = Replace(ret, "[alt]", MyIO.HTMLEncode(MyIO.HTMLDecode(strAlt)))
    getIMGString = ret
End Function

Public Function TBBSBool(ByVal strExp)
    TBBSBool = IIf(strExp = TBBS_TRUE, TBBS_TRUE, TBBS_FALSE)
End Function

Private Function ValidName(ByVal strData)
    ValidName = reg_test("^[\w\u4E00-\u9FA5]+$", "", strData)
End Function

Public Function IsIndex()
    IsIndex = CBool(InStr(LCase(Request.ServerVariables("SCRIPT_NAME")), "/index.asp") > 0)
End Function

Public Function GetTemplateNS(ByVal strName)
    GetTemplateNS = str_format("moex.twinbbs.template.$0.$1", Array(TBBS.NetType, strName))
End Function

Public Function GetTemplate(ByVal strName)
    Dim strData
    strData = MyKernel.Resource(GetTemplateNS(strName))
    Do While reg_test("\$\{res\.([\w\.]+)\}", "", strData)
        strData = preg_replace("\$\{res\.([\w\.]+)\}", "g", "MyKernel.Resource(""$1"")", strData)
    Loop
    strData = preg_replace2("<moex:(\w+)\s+([^<>]+?)/>", "g", "FormatMoexFlag", strData)
    strData = preg_replace2("<moex:(\w+)\s+([^<>]+?)>", "g", "FormatMoexFlag2", strData)
    strData = reg_replace("</moex:(\w+)>", "g", "</xsl:element>", strData)
    strData = reg_replace("\$\{(\w+)\.(\w+)\}", "g", "<xsl:value-of select=""//$1/@$2""/>", strData)
    strData = reg_replace("\$\{\$\.(\w+)\}", "g", "<xsl:value-of select=""./@$1""/>", strData)
    strData = reg_replace("\$\{(.+?)\}", "g", "<xsl:value-of select=""$1"" />", strData)
    GetTemplate = strData
End Function

Public Function FormatMoexFlag(match)
    Dim tag, arg
    Dim arr, tmp, i
    tag = match.SubMatches(0)
    arg = match.SubMatches(1)
    arr = reg_matches("([\w\-]+)=""(.+?)""", "g", arg)
    ReDim tmp(UBound(arr, 2))
    For i = 0 To UBound(arr, 2)
        tmp(i) = str_format("<xsl:attribute name=$0$1$0>$2</xsl:attribute>", Array(Chr(34), arr(0, i), arr(1, i)))
    Next
    FormatMoexFlag = str_format("<xsl:element name=$0$1$0>$2</xsl:element>", Array(Chr(34), tag, Join(tmp, "")))
End Function

Public Function FormatMoexFlag2(match)
    Dim tag, arg
    Dim arr, tmp, i
    tag = match.SubMatches(0)
    arg = match.SubMatches(1)
    arr = reg_matches("(\w+)=""(.+?)""", "g", arg)
    ReDim tmp(UBound(arr, 2))
    For i = 0 To UBound(arr, 2)
        tmp(i) = str_format("<xsl:attribute name=$0$1$0>$2</xsl:attribute>", Array(Chr(34), arr(0, i), arr(1, i)))
    Next
    FormatMoexFlag2 = str_format("<xsl:element name=$0$1$0>$2", Array(Chr(34), tag, Join(tmp, "")))
End Function

Public Function ParseUBB(match)
    Dim ret
    If match.SubMatches(0) <> "" Then
        ret = ParseUBB2(match)
    ElseIf match.SubMatches(2) <> "" Then
        ret = ParseUBB3(match)
    Else
        ret = Replace("<img src=""images/emote/$1.gif"" alt=""loading..."" />", "$1", match.SubMatches(5))
    End If
    If reg_test(TUBB_REG, "", ret) Then
        ret = preg_replace2(TUBB_REG, "g", "ParseUBB", ret)
    End If
    ParseUBB = ret
End Function

Private Function ParseUBB2(match)
    Dim ret
    Dim m1, m2
    m1 = match.SubMatches(0)
    m2 = match.SubMatches(1)
    Select Case m1
    Case "b", "i", "u", "sup", "sub"
        ret = "<$2>$1</$2>"
        ret = Replace(ret, "$2", m1)
    Case "url"
        ret = "<a href=""$1"">$1</a>"
    Case "email"
        ret = "<a href=""mailto:$1"">$1</a>"
    Case "quote"
        ret = MyKernel.Resource(GetTemplateNS("UBBQuote"))
    Case "code"
        ret = MyKernel.Resource(GetTemplateNS("UBBCode"))
    Case "img"
        ret = "<img src=""$1"" alt=""loading..."" />"
    Case "fly"
        ret = "<marquee scrollamount=""3"" behavior=""alternate"" width=""90%"">$1</marquee>"
    Case "qq"
        ret = "<a href=""http://wpa.qq.com/msgrd?V=1&amp;Uin=$1&amp;Site=TwinBBS&amp;Menu=yes"">$1</a>"
    Case Else
        Exit Function
    End Select
    ret = Replace(ret, "$1", MyIO.HTMLEncode(MyIO.HTMLDecode(m2)))
    ParseUBB2 = ret
End Function

Private Function ParseUBB3(match)
    Dim ret
    Dim m1, m2, arr
    m1 = match.SubMatches(3)
    m2 = match.SubMatches(4)
    Select Case match.SubMatches(2)
    Case "color"
        ret = "<font color=""$1"">$2</font>"
    Case "size"
        ret = "<font size=""$1"">$2</font>"
    Case "font"
        ret = "<font face=""$1"">$2</font>"
    Case "align"
        ret = "<p align=""$1"">$2</p>"
    Case "url" 
        ret = "<a href=""$1"" target=""_blank"">$2</a>"
    Case "email"
        ret = "<a href=""mailto:$1"">$2</a>"
    Case "img"
        ParseUBB3 = ParseUBBImg(m1, m2)
        Exit Function
    Case "media"
        ParseUBB3 = ParseUBBMedia(m1, m2)
        Exit Function
    Case "flash"
        ParseUBB3 = ParseUBBFlash(m1, m2)
        Exit Function
    Case Else
        Exit Function
    End Select
    ret = Replace(ret, "$1", MyIO.HTMLEncode(MyIO.HTMLDecode(m1)))
    ret = Replace(ret, "$2", MyIO.HTMLEncode(MyIO.HTMLDecode(m2)))
    ParseUBB3 = ret
End Function

Private Function ParseUBBImg(ByVal strWH, ByVal strURL)
    Dim arr, ret
    arr = Split(strWH, ",")
    If UBound(arr) <> 1 Then Exit Function
    If Not IsNumericArray(arr) Then Exit Function
    ret = "<img src=""$1"" width=""$2"" height=""$3"" alt="""" />"
    ret = Replace(ret, "$1", MyIO.HTMLEncode(MyIO.HTMLDecode(strURL)))
    ret = Replace(ret, "$2", arr(0))
    ret = Replace(ret, "$3", arr(1))
    ParseUBBImg = ret
End Function

Private Function ParseUBBMedia(ByVal strAT, ByVal strURL)
    Dim arr, ret
    arr = Split(strAT, ",")
    If UBound(arr) <> 3 Then Exit Function
    If InString("mp3|wma|wmv", arr(0), False) Then
        ret = MyKernel.Resource(GetTemplateNS("UBBMedia"))
        ret = Replace(ret, "[mime]", GetMIMEType(arr(0)))
    Else
        Select Case arr(0)
        Case "ra"
            ret = MyKernel.Resource(GetTemplateNS("UBBMediaRa"))
            ret = Replace(ret, "[rnd]", GetRandom(4))
        Case "rm"
            ret = MyKernel.Resource(GetTemplateNS("UBBMediaRm"))
            ret = Replace(ret, "[rnd]", GetRandom(4))
        Case "mov"
            ret = MyKernel.Resource(GetTemplateNS("UBBMediaMov"))
        Case Else
            Exit Function
        End Select
    End If
    ret = Replace(ret, "$1", arr(1))
    ret = Replace(ret, "$2", arr(2))
    ret = Replace(ret, "$3", arr(3))
    ret = Replace(ret, "$4", MyIO.HTMLEncode(MyIO.HTMLDecode(strURL)))
    ParseUBBMedia = ret
End Function

Private Function ParseUBBFlash(ByVal strWH, ByVal strURL)
    Dim arr, ret
    arr = Split(strWH, ",")
    If UBound(arr) <> 1 Then Exit Function
    If Not IsNumericArray(arr) Then Exit Function
    ret = MyKernel.Resource(GetTemplateNS("UBBFlash"))
    ret = Replace(ret, "$1", arr(0))
    ret = Replace(ret, "$2", arr(1))
    ret = Replace(ret, "$3", MyIO.HTMLEncode(MyIO.HTMLDecode(strURL)))
    ParseUBBFlash = ret
End Function

Public Function GetPageNum(ByVal lngRows, ByVal intSize)
    Dim ret
    ret = lngRows \ intSize
    ret = ret + IIf(lngRows Mod intSize = 0, 0, 1)
    If ret < 1 Then ret = 1
    GetPageNum = ret
End Function

Public Function SafeHTML(ByVal strData)
    Dim ret
    ret = strData
    ret = reg_replace("<script([^>]*)>", "gi", "[script$1]", ret)
    ret = reg_replace("</script[^>]*>", "gi", "[/script]", ret)
    ret = reg_replace("<iframe([^>]*)>", "gi", "[iframe$1]", ret)
    ret = reg_replace("</iframe[^>]*>", "gi", "[/iframe]", ret)
    ret = preg_replace("<(\w+)", "g", "LCase(""<$1"")", ret)
    ret = preg_replace("</(\w+)>", "g", "LCase(""</$1>"")", ret)
    SafeHTML = ret
End Function

'wml|template|card|head|access|meta|go|prev|refresh|noop|do|ontimer|onenterforward|onenterbackward|onpick|onevent|postfield|setvar|input|select|option|optgroup|fieldset|anchor|a|img|timer|em|strong|i|b|u|big|small|br|p|td|table
Public Function ClearHTML(ByVal strData)
    Dim ret, i
    ret = strData
    ret = reg_replace("<(?!/?(?:a|b|i|u|em|strong|big|small|br|img)\b)[^>]*>", "gi", "", ret)
    ret = reg_replace("<br[^>]*>", "gi", "<br/>", ret)
    ClearHTML = ret
End Function

Public Function FormatURL(match)
    Dim strType, strURL, strHost, strFlag, pos
    strType = match.SubMatches(0)
    strURL = MyIO.HTMLDecode(match.SubMatches(1))
    strHost = LCase("http://" & MyIO.Env("HTTP_HOST"))
    If InStr(LCase(strURL), strHost) > 0 Then
        strURL = Mid(strURL, Len(strHost) + 1)
    End If
    If Not reg_test("^(http://|wtai://|ftp://|rtsp://)", "i", strURL) Then
        pos = InStr(strURL, "#")
        If pos > 0 Then
            strFlag = Mid(strURL, pos + 1)
            strURL = Mid(strURL, 1, pos - 1)
        End If
        strURL = reg_replace("[\?&](MID)=[^&]*", "gi", "", strURL)
        strURL = reg_replace("[\?&]+$", "g", "", strURL)
        If InStr(strURL, "?") > 0 Then
            strURL = strURL & "&MID=" & MyKernel.Memory.MemoryID
        Else
            strURL = strURL & "?MID=" & MyKernel.Memory.MemoryID
        End If
        If strFlag <> "" Then
            strURL = strURL & "#" & strFlag
        End If
    End If
    strURL = MyIO.HTMLEncode(strURL)
    FormatURL = str_format("$0=""$1""", Array(strType, strURL))
End Function

Public Function GetURL(ByVal strURL, vtName, vtValue)
    Dim arrName, arrValue
    Dim ret, tmp, i
    If IsArray(vtName) Then
        arrName = vtName
        arrValue = vtValue
    ElseIf vtName = "" Then
        ret = strURL
    Else
        arrName = Array(vtName)
        arrValue = Array(vtValue)
    End If
    If Not IsEmpty(arrName) Then
        ReDim tmp(UBound(arrName))
        For i = 0 To UBound(arrName)
            tmp(i) = MyIO.URLEncode(arrName(i)) & "=" & MyIO.URLEncode(arrValue(i))
        Next
        ret = "$(URL)$(Flag)$(Query)"
        ret = Replace(ret, "$(URL)", strURL)
        ret = Replace(ret, "$(Flag)", IIf(InStr(strURL, "?") > 0, "&", "?"))
        ret = Replace(ret, "$(Query)", Join(tmp, "&"))
    End If
    GetURL = ret
End Function

Public Function FormatTADS()
    Dim xmlDoc, xmlRoot
    Dim intPush, lngSID, lngHash, intBase
    Dim arr, i
    Set xmlDoc = GetTADSXML()
    If xmlDoc Is Nothing Then Exit Function
    Set xmlRoot = xmlDoc.documentElement
    If xmlRoot.hasChildNodes() Then
        intPush = atoi(xmlRoot.getAttribute("push"))
        lngSID = atol(TBBS.Env("twinads_id"))
        If lngSID < 1 Then lngSID = atol(xmlRoot.getAttribute("id"))
        lngHash = atol(xmlRoot.getAttribute("hash"))
        intBase = atoi(xmlRoot.getAttribute("base"))
        arr = GetAdsPush(xmlRoot, lngSID, lngHash, intBase)
        FormatTADS = GetAdsData(arr, intPush)
    End If
    Set xmlRoot = Nothing
    Set xmlDoc = Nothing
End Function

Private Function GetTADSXML()
    Dim clsCache, strName
    Dim xmlDoc
    Set clsCache = vbsre.mocom.util.Cache
    strName = "TwinBBS.TADS"
    If IsEmpty(clsCache(strName)) Then
        clsCache.Expires = DateAdd("d", 1, Now())
        Set xmlDoc = xml.cloneNode(True)
        xmlDoc.async = False
        xmlDoc.setProperty "ServerHTTPRequest", True
        If Not xmlDoc.loadXML(GetRemoteText(TADS_URL, "UTF-8")) Then
            Set GetTADSXML = Nothing
        Else
            Set GetTADSXML = xmlDoc
            clsCache(strName) = xmlDoc
        End If
        Set xmlDoc = Nothing
    Else
        Set GetTADSXML = clsCache(strName)
    End If
    Set clsCache = Nothing
End Function

Private Function GetAdsPush(xmlRoot, ByVal lngSID, ByVal lngHash, ByVal intBase)
    Dim arr1, arr2, i, k, l
    Dim xmlNodes
    Set xmlNodes = xmlRoot.selectNodes("row[@keytype=0]")
    ReDim ret(xmlNodes.length - 1)
    For i = 0 To UBound(ret)
        ret(i) = Array(i + 1, getAString(GetAdsURL(xmlNodes(i).getAttribute("url"), lngSID, lngHash, intBase), xmlNodes(i).getAttribute("name")))
    Next
    Set xmlNodes = Nothing
    GetAdsPush = ret
End Function

Private Function GetAdsURL(ByVal strURL, ByVal lngSID, ByVal intHash, ByVal intBase)
    GetAdsURL = Replace(strURL, "$(SiteID)", BaseX(lngSID + intHash, intBase))
End Function

Private Function GetAdsData(arr, ByVal intPush)
    Dim lngID, i, x, ret
    Dim strName
    strName = "TwinBBS.TADS.Next"
    lngID = atoi(getCache(strName))
    x = intPush
    For i = 0 To UBound(arr)
        If arr(i)(0) > lngID Then
            ret = ret & arr(i)(1) & "<br/>"
            lngID = arr(i)(0)
            x = x - 1
        End If
        If i = UBound(arr) Then lngID = 0
        If x = 0 Then Exit For
    Next
    setCache strName, lngID
    GetAdsData = ret
End Function
%>