wapmo.asp

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

        t1 = GetTime(Date)
        strSQL = "SELECT COUNT(1) FROM $(Table) WHERE INTIME>=$(Startime)"
        strSQL = Replace(strSQL, "$(Table)", T_USER_LOG)
    Case stVisitYeday
        t1 = GetTime(DateAdd("d", -1, Date))
        t2 = GetTime(Date)
        strSQL = "SELECT COUNT(1) FROM $(Table) WHERE INTIME>=$(Startime) AND INTIME<=$(Stoptime)"
        strSQL = Replace(strSQL, "$(Table)", T_USER_LOG)
    Case stIPToday
        t1 = GetTime(Date)
        strSQL = "SELECT COUNT(1) FROM $(Table) WHERE INTIME>=$(Startime)"
        strSQL = Replace(strSQL, "$(Table)", T_IPDB)
    Case stIPYeday
        t1 = GetTime(DateAdd("d", -1, Date))
        t2 = GetTime(Date)
        strSQL = "SELECT COUNT(1) FROM $(Table) WHERE INTIME>=$(Startime) AND INTIME<=$(Stoptime)"
        strSQL = Replace(strSQL, "$(Table)", T_IPDB)
    Case stIPAll
        If WM_DataType = adAccess Then
            strSQL = "SELECT COUNT(IP) FROM (SELECT DISTINCT(IPAddr) AS IP FROM $(Table))"
        Else
            strSQL = "SELECT COUNT(DISTINCT(IPAddr)) FROM $(Table)"
        End If
        strSQL = Replace(strSQL, "$(Table)", T_IPDB)
    Case stOnlineUser
        t1 = GetTime(DateAdd("n", -20, Now()))
        strSQL = "SELECT COUNT(1) FROM $(Table) WHERE LASTVISITTIME>=$(Startime)"
        strSQL = Replace(strSQL, "$(Table)", T_USER)
    Case stOnlineIP
        t1 = GetTime(DateAdd("n", -20, Now()))
        strSQL = "SELECT COUNT(1) FROM $(Table) WHERE OUTIME>=$(Startime)"
        strSQL = Replace(strSQL, "$(Table)", T_IPDB)
    End Select
    strSQL = Replace(strSQL, "$(Startime)", t1)
    strSQL = Replace(strSQL, "$(Stoptime)", t2)
    GetUserStat = atol(DB.GetRow(strSQL))
End Function

Public Property Get XMLParser()
    If objXML Is Nothing Then
        Set objXML = vbsre.mocom.WAPmo.XMLParser
        objXML.Title = Config("SiteName")
        objXML.Meta("http-equiv", "Cache-Control") = "no-cache"
        If Config("Description") <> "" Then
            objXML.Meta("name", "Description") = Config("Description")
        End If
        If Config("Keywords") <> "" Then
            objXML.Meta("name", "Keywords") = Config("Keywords")
        End If
        If Config("CheckXHTML") = "1" Then
            Select Case NetType
            Case "wap20"
                objXML.DocType = "xhtml"
            Case "wap12"
                objXML.DocType = "wml"
            Case "web"
                objXML.DocType = "html"
            End Select
        Else
            objXML.DocType = "wml"
        End If
    End If
    Set XMLParser = objXML
End Property

Public Sub OutputXML(ByVal strData)
    Dim ret
    If strData = "" Then
        ret = GetXMLString()
    Else
        ret = strData
    End If
    ret = preg_replace2("\s+(href|action|src)=""([^""]*)""", "g", "FormatURL", ret)
    ret = reg_replace("(" & MyKernel.Config("ForbidWord") & ")", "gi", "***", ret)
    If MyKernel.Modlist(moAd) = 0 And InStr(ret, ADS_MARK) > 0 Then
        ret = Replace(ret, ADS_MARK, FormatAds())
    End If
    IO.Echo ret
End Sub

Private Function GetXMLString()
    Dim objTemp
    Set objTemp = Server.CreateObject("ADODB.Stream")
    objTemp.Type = adTypeBinary
    objTemp.Open
    objXML.Transform objTemp
    objTemp.Position = 0
    objTemp.Type = adTypeText
    objTemp.Charset = WAPMO_CHARSET
    GetXMLString = objTemp.ReadText(adReadAll)
    objTemp.Close
    Set objTemp = Nothing
End Function

Private Function FormatAds()
    Dim xmlDoc, xmlRoot
    Dim intPush, lngSID, lngHash, intBase
    Dim arr, i
    Dim ret
    Set xmlDoc = GetTADSXML()
    If Not xmlDoc Is Nothing Then
        Set xmlRoot = xmlDoc.documentElement
        If xmlRoot.hasChildNodes() Then
            intPush = atoi(xmlRoot.getAttribute("push"))
            lngSID = atol(xmlRoot.getAttribute("id"))
            lngHash = atol(xmlRoot.getAttribute("hash"))
            intBase = atoi(xmlRoot.getAttribute("base"))
            arr = GetAdsPush(xmlRoot, lngSID, lngHash, intBase)
            ret = GetAdsData(arr, intPush)
        End If
        Set xmlRoot = Nothing
    End If
    Set xmlDoc = Nothing
    FormatAds = ret
End Function

Private Function GetTADSXML()
    Dim clsCache, strName
    Dim xmlDoc
    Set clsCache = vbsre.mocom.util.Cache.newInstance()
    strName = "WAPmo.TADS"
    If IsEmpty(clsCache(strName)) Then
        clsCache.Expires = DateAdd("d", 1, Now())
        Set xmlDoc = xml.cloneNode(True)
        If Not xmlDoc.loadXML(GetRemoteText("http://twinads.cn/service.asp?handle=ads", "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 = "WAPmo.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

Private Sub CheckPermit()
    Dim objTemp, strPath, objBase16
    Dim arr, lngSize, strPermit, i
    strPath = GetMapPath("config/WAPmo.lic")
    Set objTemp = Server.CreateObject("ADODB.Stream")
    objTemp.Type = adTypeBinary
    objTemp.Open
    If fso.FileExists(strPath) Then
        Set objBase16 = vbsre.mocom.util.Base16
        objTemp.LoadFromFile strPath
        objTemp.Position = 0
        objTemp.Read 4
        objBase16.Table = BytesToArray(objTemp.Read(128))
        objBase16.Queue = BytesToArray(objTemp.Read(16))
        objBase16.Mapping = BytesToArray(objTemp.Read(16))
        lngSize = htol(objTemp.Read(2))
        strPermit = objBase16.Decode(BytesToString(objTemp.Read(lngSize), LOCAL_CHARSET))
        If strPermit <> "" Then
            arr = Split(strPermit, "|")
            PermitHost = arr(0)
            If LCase(PermitHost) = LCase(IO.Env("HTTP_HOST")) Then
                For i = 1 To UBound(arr)
                    Modlist(i - 1) = atoi(arr(i))
                Next
            End If
        End If
        objBase16.Table = WM_BASE16_TABLE
        objBase16.Queue = WM_BASE16_QUEUE
        objBase16.Mapping = WM_BASE16_MAPPING
        Set objBase16 = Nothing
    End If
    objTemp.Close
    Set objTemp = Nothing
End Sub

Public Function ResPath(ByVal strNS)
    Dim ret, tmp
    tmp = Replace(strNS, ".", "/")
    ret = "resources/$0.res"
    ret = Replace(ret, "$0", tmp)
    ResPath = GetMapPath(ret)
End Function

Public Property Get Resource(ByVal strNS)
    Dim strPath
    strPath = ResPath(strNS)
    If Not fso.FileExists(strPath) Then
        Err.Raise vbObjectError + 1, "WAPmoKernel.Resource", "Missing resource: " & strNS
    End If
    Resource = GetFileString(strPath, LOCAL_CHARSET)
End Property

Public Property Let Resource(ByVal strNS, ByVal strValue)
    Dim strPath
    strPath = ResPath(strNS)
    If Not fso.FileExists(strPath) Then
        DetectFile GetMapPath(""), Replace("resources/$0.res", "$0", Replace(strNS, ".", "/"))
    End If
    SetFileString strPath, LOCAL_CHARSET, strValue, True
End Property
End Class
%>