spy.asp

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

    pos = InStr(tmp, "?")
    If pos > 0 Then tmp = Left(tmp, pos - 1)
    pos = InStrRev(tmp, "/")
    tmp = Left(tmp, pos)
    GetPath = tmp
End Function

Private Function GetList(ByVal lngId)
    Dim xdb
    Dim strName
    Set xdb = vbsre.mocom.util.XMLDB.newInstance()
    strName = "Spy_" & lngId & "_" & FormatTime(Now(), "Ymd")
    If Not xdb.Execute(strName) Then
        xdb.Append "URL", adVarChar, 255
        xdb.Append "Title", adVarChar, 255
        xdb.Append "Status", adChar, 1
        xdb.Append "Time", adInteger, 4
        xdb.Append "Intime", adInteger, 4
    End If
    Set GetList = xdb
    Set xdb = Nothing
End Function

Private Sub AddList(xlist, xdb, ByVal strURL, ByVal strTitle, ByVal lngTime)
    xdb.Filter = "@URL='" & strURL & "'"
    If xdb.EOF Then
        xdb.AddNew
        xdb("URL") = strURL
        xdb("Title") = strTitle
        xdb("Time") = lngTime
        xdb("Intime") = GetTime(Now())
        xdb("Status") = 0
        xdb.Update
        xlist("Total") = xlist("Total") + 1
        xlist.Update
    End If
End Sub

Private Sub doGetRunPage()
    Dim lngId, strURL, strTitle
    lngId = atol(MyIO.QueryString("SeqId"))
    strURL = Trim(MyIO.QueryString("URL"))
    strTitle = Trim(MyIO.QueryString("Title"))
    If lngId < 0 Then
        MyIO.Echo "未指定采集"
    ElseIf strURL = "" Then
        MyIO.Echo "未指定地址"
    ElseIf strTitle = "" Then
        MyIO.Echo "未指定标题"
    Else
        Dim xdb
        Set xdb = WM_XMLDB("Spy")
        xdb.Filter = "(@SeqId=" & lngId & ") and @Check=1"
        If xdb.EOF Then
            MyIO.Echo "找不到采集规则，或者该规则尚未经过检测"
        Else
            If ParsePage(xdb("SeqId"), strURL, strTitle, xdb("Charset"), xdb("ContentRule"), xdb("PageRule"), xdb("Mark"), xdb("StapleId"), CBool(xdb("Repeat") = 1)) Then
                xdb("Success") = xdb("Success") + 1
            Else
                xdb("Failed") = xdb("Failed") + 1
            End If
            xdb("Time") = GetTime(Now())
            xdb.Update
        End If
        Set xdb = Nothing
    End If
End Sub

Private Function ParsePage(ByVal lngId, ByVal strURL, ByVal strTitle, ByVal strCharset, ByVal strCRule, ByVal strPRule, ByVal strMark, ByVal lngStapleId, ByVal blnRepeat)
    Dim strData
    Dim reg, arr, i
    Dim strContent
    Dim pages
    Dim ptnContent, ptnPage
    Dim tmp
    Dim xdb
    Set xdb = GetList(lngId)
    xdb.Filter = "@URL='" & strURL & "'"
    ParsePage = False
    If Not xdb.EOF Then
        strData = GetRemoteText(strURL, strCharset)
        If strData = "" Then
            MyIO.Echo "获取页面出错"
            Set xdb = Nothing
            Exit Function
        End If
        ptnContent = MyRegStr(strCRule)
        
        Set reg = New RegExp
        reg.Pattern = ptnContent
        Set arr = reg.Execute(strData)
        If arr.Count > 0 Then
            strContent = arr(0).SubMatches(0)
        End If
        Set arr = Nothing
        If strContent = "" Then
            MyIO.Echo "获取内容出错，可能内容规则不符合"
            Set xdb = Nothing
            Exit Function
        End If
        
        If strPRule <> "" Then
            ptnPage = MyRegStr(strPRule)
            reg.Pattern = ptnPage
            reg.Global = True
            Set arr = reg.Execute(strData)
            If arr.Count > 0 Then
                ReDim pages(arr.Count - 1)
                For i = 0 To arr.Count - 1
                    pages(i) = GetFullURL(strURL, arr(i).SubMatches(0))
                Next
                Set arr = Nothing
                
                reg.Pattern = ptnContent
                For i = 0 To UBound(pages)
                    Set arr = reg.Execute(GetRemoteText(pages(i), strCharset))
                    If arr.Count > 0 Then
                        strContent = strContent & arr(0).SubMatches(0)
                    End If
                    Set arr = Nothing
                Next
            End If
        End If
        Set reg = Nothing
        tmp = "script|select"
        If strMark <> "" Then
            tmp = "|" & Replace(strMark, ",", "|")
        End If
        strContent = FormatText(strContent)
        strContent = reg_replace("<(" & tmp & ")[^>]*>[\s\S]*?</\1>", "gi", "", strContent)
        strContent = FormatMark(strURL, FilterMark(strContent))
        If strContent = "" Then
            MyIO.Echo "解析标签失败，获取了一个空内容"
        Else
            ParsePage = AddContent(lngStapleId, strTitle, strContent, blnRepeat)
            If ParsePage Then
                xdb("Status") = 1
                xdb.Update
            End If
        End If
    Else
        MyIO.Echo "找不到URL记录"
    End If
    Set xdb = Nothing
End Function

Private Function FilterMark(ByVal strData)
    Dim reg, arr, ptr
    Dim pos, ret, mak
    Set reg = New RegExp
    reg.Pattern = "<(b|u|i|strong|p|h\d)[^>]*>([\s\S]*?)</\1>|<img[^>]+?>|<br[^>]+>"
    reg.Global = True
    reg.IgnoreCase = True
    Set arr = reg.Execute(strData)
    If arr.Count > 0 Then
        pos = 1
        For Each ptr In arr
            ret = ret & ClearMark(SubString(strData, pos, ptr.FirstIndex + 1))
            pos = ptr.FirstIndex + 1 + ptr.Length
            If ptr.SubMatches(0) <> "" Then
                mak = LCase(ptr.SubMatches(0))
                ret = ret & "<" & mak & ">" & FilterMark(Trim(ptr.SubMatches(1))) & "</" & mak & ">"
            Else
                ret = ret & ptr.Value
            End If
        Next
        ret = ret & ClearMark(Mid(strData, pos))
    Else
        ret = ClearMark(strData)
    End If
    FilterMark = ret
End Function

Function ClearMark(ByVal strData)
    Dim reg, arr, ptr
    Dim ret, pos
    Set reg = New RegExp
    reg.Pattern = "<([^\s>]+)[^>]*>([\s\S]*?)</\1>|<([^\s>]+)[^>]*>"
    reg.Global = True
    Set arr = reg.Execute(strData)
    If arr.Count > 0 Then
        pos = 1
        For Each ptr In arr
            ret = ret & SubString(strData, pos, ptr.FirstIndex + 1)
            pos = ptr.FirstIndex + 1 + ptr.Length
            If LCase(ptr.SubMatches(0)) = "div" Then
                ret = ret & Chr(13)
            ElseIf LCase(ptr.SubMatches(2)) = "/div" Then
                ret = ret & Chr(13)
            End If
        Next
        ret = ClearMark(ret & Mid(strData, pos))
    Else
        ret = strData
    End If
    ClearMark = ret
End Function

Private Function FormatMark(ByVal strURL, ByVal strData)
    Dim reg, arr, ptr
    Dim ret, pos
    Set reg = New RegExp
    reg.Pattern = "<img.+?src=[""']*([^""'\s]+)[^>]*>"
    reg.Global = True
    reg.IgnoreCase = True
    Set arr = reg.Execute(strData)
    pos = 1
    For Each ptr In arr
        ret = ret & SubString(strData, pos, ptr.FirstIndex + 1)
        pos = ptr.FirstIndex + 1 + ptr.Length
        ret = ret & "<img src=""" & GetFullURL(strURL, ptr.SubMatches(0)) & """ alt=""装载中……"" />"
    Next
    ret = ret & Mid(strData, pos)
    Set arr = Nothing
    Set reg = Nothing
    FormatMark = FormatLine(ret)
End Function

Private Function FormatLine(ByVal strData)
    Dim arr, ptr
    Dim ret, tmp
    arr = Split(reg_replace("<p>([\s\S]*?)</p>", "gi", "$1" & Chr(13), strData), Chr(13))
    For Each ptr In arr
        tmp = Trim(ptr)
        If tmp <> "" Then
            ret = ret & "    " & tmp & vbCrLf
        End If
    Next
    FormatLine = ret
End Function

Private Function FormatText(ByVal strData)
    Dim ret
    ret = UDecode(strData)
    ret = MyIO.HTMLDecode(ret)
    ret = Replace(ret, Chr(9), "    ")
    ret = Replace(ret, "　", "  ")
    ret = Replace(ret, Chr(10), "")
    FormatText = ret
End Function

Private Function AddContent(ByVal lngStapleId, ByVal strTitle, ByVal strContent, ByVal blnRepeat)
    Dim objStaple
    Dim objCmd
    Dim blnExists
    Dim strSQL
    Set objStaple = MyKernel.Command(T_STAPLE)
    objStaple.CommandType = "SELECT"
    objStaple.Column = "SEQID,TITLE,MARK"
    objStaple.Where = "SEQID=" & lngStapleId
    AddContent = objStaple.Exec
    If AddContent Then
        Set objCmd = MyKernel.Command(T_CONTENT)
        blnExists = False
        If blnRepeat Then
            objCmd.CommandType = "SELECT"
            objCmd.Column = "SEQID"
            objCmd.Where = "STAPLEID=" & lngStapleId & " AND TITLE='" & SafeString(strTitle) & "'"
            blnExists = objCmd.Exec
        End If
        If blnRepeat And blnExists Then
            MyIO.Echo "内容重复"
        Else
            objCmd.CommandType = "INSERT"
            objCmd.Add "StapleId", objStaple("SeqId")
            objCmd.Add "StapleTitle", objStaple("Title")
            objCmd.Add "Category", wmContentNormal
            objCmd.Add "Title", MyIO.HTMLDecode(strTitle)
            objCmd.Add "Content", strContent
            objCmd.Add "Length", 512
            objCmd.Add "Place", wmImgUnderContent
            objCmd.Add "Download", 0
            objCmd.Add "Templet", ""
            objCmd.Add "Commend", 0
            objCmd.Add "Hot", 0
            objCmd.Add "IsWML", 1
            objCmd.Add "Price", ""
            objCmd.Add "Matter", 0
            objCmd.Add "Mark", objStaple("Mark")
            objCmd.Add "Examine", 1
            objCmd.Add "Hidden", 0
            objCmd.Add "RemarkTotal", 0
            objCmd.Add "Intime", GetTime(Now())
            objCmd.Add "GroupId", MyAdmin("GroupId")
            objCmd.Add "TeamId", MyAdmin("TeamId")
            objCmd.Add "AdminId", MyAdmin("SeqId")
            objCmd.Exec
            strSQL = "UPDATE $(Table) SET CONTENTTOTAL=$(ContentTotal) WHERE SEQID=$(SeqId)"
            strSQL = Replace(strSQL, "$(Table)", T_STAPLE)
            strSQL = Replace(strSQL, "$(ContentTotal)", objStaple("ContentTotal") + 1)
            strSQL = Replace(strSQL, "$(SeqId)", objStaple("SeqId"))
            MyKernel.DB.Exec strSQL
            RemoveCache "staple", objStaple("SeqId"), 0, 0
            RemoveCache "index", 0, 0, 0
            WM_SetCache "staple"
            MyIO.Echo "OK"
        End If
        Set objCmd = Nothing
    Else
        MyIO.Echo "找不到目标栏目"
    End If
    Set objStaple = Nothing
End Function

Public Function newInstance()
    Set newInstance = New ImplMocomWAPmoManagerSpy
End Function
End Class
%>