spy.asp

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

    ElseIf lngStapleId < 1 Then
        strError = "请选择采集的目标栏目"
    ElseIf Not objCmd.Exec Then
        strError = "找不到您指定的目标栏目"
    Else
        Set xdb = WM_XMLDB("Spy")
        xdb.Filter = "@Name='" & strName & "' or @List='" & strList & "'"
        If Not xdb.EOF Then
            strError = "采集名称或列表地址已存在"
        Else
            blnError = False
            strError = "规则新建成功"
            If intCheck = 0 Then strError = strError & "<br/>但尚未经过检测，无法运行"
            xdb.AddNew
            xdb("Name") = strName
            xdb("List") = strList
            xdb("Charset") = strCharset
            xdb("Type") = atoi(MyIO.Form("Type"))
            xdb("Repeat") = atoi(MyIO.Form("Repeat"))
            xdb("ListRule") = strListRule
            xdb("ContentRule") = strContentRule
            xdb("Mark") = Replace(Replace(MyIO.Form("Mark"), " ", ""), ",", "|")
            xdb("PageRule") = strPageRule
            xdb("StapleId") = objCmd("SeqId")
            xdb("StapleTitle") = objCmd("Title")
            xdb("Check") = intCheck
            xdb("Total") = 0
            xdb("Success") = 0
            xdb("Failed") = 0
            xdb("Time") = 0
            xdb.Update
        End If
        Set xdb = Nothing
    End If
    Set objCmd = Nothing
    ExportHead "系统提示"
    MyIO.Echo "<script language=""javascript"">"
    MyIO.Echo "function myload()"
    MyIO.Echo "{"
    MyIO.Echo "var prt = window.parent;"
    If blnError = False Then
        MyIO.Echo "prt.MessageBox.show(MSG_HINT, """ & strError & """);"
    Else
        MyIO.Echo "prt.MessageBox.show(MSG_WARNING, """ & strError & """);"
    End If
    MyIO.Echo "prt.document.getElementById(""frmMain"").btnPost.disabled = false;"
    MyIO.Echo "}"
    MyIO.Echo "</script>"
    ExportFoot
End Sub

Private Sub doPostModify()
    Dim strList, strCharset
    Dim strListRule, strContentRule, strPageRule
    Dim intCheck, lngStapleId
    Dim objCmd
    strCharset = MyIO.Form("Charset")
    strList = Trim(MyIO.Form("List"))
    strListRule = Trim(MyIO.Form("ListRule"))
    strContentRule = Trim(MyIO.Form("ContentRule"))
    strPageRule = Trim(MyIO.Form("PageRule"))
    intCheck = atoi(MyIO.Form("Check"))
    lngStapleId = atol(MyIO.Form("Staple"))
    Set objCmd = MyKernel.Command(T_STAPLE)
    objCmd.CommandType = "SELECT"
    objCmd.Column = "SEQID,TITLE"
    objCmd.Where = "SEQID=" & lngStapleId
    If strList = "" Then
        strError = "请输入列表地址"
    ElseIf Not InString("gb2312|utf-8|big5", strCharset, False) Then
        strError = "错误的页面编码"
    ElseIf strListRule = "" Then
        strError = "请输入内容规则"
    ElseIf InStr(strList, "'") > 0 Then
        strError = "请勿在名称中使用特殊字符"
    ElseIf lngStapleId < 1 Then
        strError = "请选择采集的目标栏目"
    ElseIf Not objCmd.Exec Then
        strError = "找不到您指定的目标栏目"
    Else
        Dim xdb
        Set xdb = WM_XMLDB("Spy")
        xdb.Filter = "@SeqId=" & atol(MyIO.QueryString("SeqId"))
        If xdb.EOF Then
            strError = "找不到您要编辑的规则"
        Else
            blnError = False
            strError = "规则编辑成功"
            If intCheck = 0 Then strError = strError & "<br/>但尚未经过检测，无法运行"
            xdb("List") = strList
            xdb("Charset") = strCharset
            xdb("Type") = atoi(MyIO.Form("Type"))
            xdb("Repeat") = atoi(MyIO.Form("Repeat"))
            xdb("ListRule") = strListRule
            xdb("ContentRule") = strContentRule
            xdb("Mark") = Replace(Replace(MyIO.Form("Mark"), " ", ""), ",", "|")
            xdb("PageRule") = strPageRule
            xdb("StapleId") = objCmd("SeqId")
            xdb("StapleTitle") = objCmd("Title")
            xdb("Check") = intCheck
            xdb.Update
        End If
        Set xdb = Nothing
    End If
    Set objCmd = Nothing
    ExportHead "系统提示"
    MyIO.Echo "<script language=""javascript"">"
    MyIO.Echo "function myload()"
    MyIO.Echo "{"
    MyIO.Echo "var prt = window.parent;"
    If blnError = False Then
        MyIO.Echo "prt.MessageBox.show(MSG_HINT, """ & strError & """);"
    Else
        MyIO.Echo "prt.MessageBox.show(MSG_WARNING, """ & strError & """);"
    End If
    MyIO.Echo "prt.document.getElementById(""frmMain"").btnPost.disabled = false;"
    MyIO.Echo "}"
    MyIO.Echo "</script>"
    ExportFoot
End Sub

Private Sub doPostRemove()
    Dim arr
    arr = Split(MyIO.Form("SeqId"), ",")
    If Not IsNumericArray(arr) Then
        MyIO.Echo "请选择您要删除的规则"
    Else
        Dim xdb
        Set xdb = WM_XMLDB("Spy")
        xdb.Filter = "@SeqId=" & Join(arr, " or @SeqId=")
        xdb.Delete True
        Set xdb = Nothing
        MyIO.Echo "OK"
    End If
End Sub

Private Sub doGetRun()
    MyIO.Echo "<html>"
    MyIO.Echo "<head>"
    MyIO.Echo "<meta http-equiv=""Content-Type"" content=""text/html; charset=utf-8"" />"
    MyIO.Echo "<meta http-equiv=""Cache-Control"" content=""no-cache, max-age=0"" />"
    MyIO.Echo "<title>内容采集</title>"
    MyIO.Echo "<link rel=""stylesheet"" href=""images/xw.css"" />"
    MyIO.Echo "<script language=""javascript"" src=""jspp/jspp.js""></script>"
    MyIO.Echo "<script language=""javascript"">"
    MyIO.Echo "jspp.Share = " & atoi(MyKernel.Config("StapleGroup")) & ";"
    MyIO.Echo "jspp.GroupId = " & MyAdmin("GroupId") & ";"
    MyIO.Echo "jspp.TeamId = """ & MyAdmin("TeamId") & """;"
    MyIO.Echo "jspp.AdminId = """ & MyAdmin("SeqId") & """;"
    MyIO.Echo "jspp.Power = " & MyPower.Status & ";"
    MyIO.Echo "</script>"
    MyIO.Echo "<script language=""javascript"" src=""images/wm_spy1.js""></script>"
    MyIO.Echo "</head>"
    MyIO.Echo "<body class=""system2"">"
    MyIO.Echo "<table width=""100%"" border=""0"" cellpadding=""2"" cellspacing=""0"" align=""center"">"
    MyIO.Echo "<tr>"
    MyIO.Echo "<td class=""winT0""><b>内容采集</b></td>"
    MyIO.Echo "</tr>"
    MyIO.Echo "<tr class=""winT1"">"
    MyIO.Echo "<td>"
    MyIO.Echo "<b>正在应用如下采集规则<b><br/>"
    Call doGetSpy
    MyIO.Echo "</td>"
    MyIO.Echo "</tr>"
    MyIO.Echo "<tr class=""winT1"">"
    MyIO.Echo "<td>"
    MyIO.Echo "<b>采集日志</b> 按F5刷新可以重新解析未成功的页面<br/>"
    MyIO.Echo "<textarea id=""Log"" name=""Log"" class=""area"" style=""width:100%;height:300px"" readonly=""true""></textarea>"
    MyIO.Echo "</td>"
    MyIO.Echo "</tr>"
    MyIO.Echo "</table>"
    MyIO.Echo "</body>"
    MyIO.Echo "</html>"
End Sub

Private Sub doGetSpy()
    Dim arr
    Dim xdb
    arr = Split(MyIO.QueryString("SeqId"), ",")
    Set xdb = WM_XMLDB("Spy")
    If IsNumericArray(arr) Then
        xdb.Filter = "(@SeqId=" & Join(arr, " or @SeqId=") & ") and @Check=1"
    Else
        xdb.Filter = "@Check=1 and @Type>0"
    End If
    MyIO.Echo "<select id=""List"" name=""List"" size=""10"" disabled=""true"" class=""sel"">"
    Do While Not xdb.EOF
        MyIO.Echo "<option value=""" & xdb("SeqId") & """>" & xdb("Name") & "[" & xdb("List") & "]</option>"
        xdb.MoveNext
    Loop
    MyIO.Echo "</select>"
    Set xdb = Nothing
End Sub

Private Sub doGetRunList()
    Dim xdb
    Set xdb = WM_XMLDB("Spy")
    xdb.Filter = "@SeqId=" & atol(MyIO.QueryString("SeqId")) & " and @Check=1"
    If xdb.EOF Then
        MyIO.Echo "jspp.Spy.log(""找不到采集规则，或者该规则尚未经过检测\r\n"");"
        MyIO.Echo "jspp.Spy.run();"
    Else
        ParseList xdb, xdb("SeqId"), xdb("List"), xdb("Charset"), xdb("ListRule"), xdb("Type")
    End If
    Set xdb = Nothing
End Sub

Private Sub ParseList(xlist, ByVal lngId, ByVal strURL, ByVal strCharset, ByVal strPattern, ByVal intType)
    Dim strData
    Dim reg, arr, ptr
    Dim tmp(2)
    strData = GetRemoteText(strURL, strCharset)
    Set reg = New RegExp
    reg.Pattern = MyRegStr(strPattern)
    reg.Global = True
    Set arr = reg.Execute(strData)
    If arr.Count = 0 Then
        MyIO.Echo "jspp.Spy.log(""获取列表失败\r\n"");"
        MyIO.Echo "jspp.Spy.run();"
    Else
        Dim xdb
        Set xdb = GetList(lngId)
        For Each ptr In arr
            If ptr.SubMatches.Count < 2 Then
                MyIO.Echo "jspp.Spy.log(""连接地址和标题必须存在\r\n"");"
                MyIO.Echo "jspp.Spy.run();"
                Exit For
            End If
            If intType = 0 Then
                tmp(0) = GetFullURL(strURL, ptr.SubMatches(0))
                tmp(1) = ptr.SubMatches(1)
                If ptr.SubMatches.Count = 3 Then
                    tmp(2) = ptr.SubMatches(2)
                    If IsDate(tmp(2)) Then
                        tmp(2) = CDate(tmp(2))
                    Else
                        tmp(2) = Now()
                    End If
                Else
                    tmp(2) = Now()
                End If
                Call AddList(xlist, xdb, tmp(0), tmp(1), GetTime(tmp(2)))
            Else
                If ptr.SubMatches.Count = 3 Then
                    tmp(2) = ptr.SubMatches(2)
                    If IsDate(tmp(2)) Then
                        tmp(2) = CDate(tmp(2))
                    Else
                        tmp(2) = Now()
                    End If
                Else
                    tmp(2) = Now()
                End If
                If DateDiff("d", tmp(2), Date) = IIf(intType = 1, 1, 0) Then
                    tmp(0) = GetFullURL(strURL, ptr.SubMatches(0))
                    tmp(1) = ptr.SubMatches(1)
                    Call AddList(xlist, xdb, tmp(0), tmp(1), GetTime(tmp(2)))
                End If
            End If
        Next
        xdb.Filter = "@Status=0"
        MyIO.Echo "$list = [];"
        Do While Not xdb.EOF
            MyIO.Echo "$list.push({""URL"":""" & MyIO.HTMLEncode(xdb("URL")) & """, ""Title"":""" & MyIO.HTMLEncode(xdb("Title")) & """, ""Time"":""" & FormatTime(GetDate(xdb("Time")), "Y-m-d H:i:s") & """});"
            xdb.MoveNext
        Loop
        MyIO.Echo "jspp.Spy.runx();"
        Set xdb = Nothing
    End If
    Set arr = Nothing
    Set reg = Nothing
End Sub

Private Function MyRegStr(ByVal strData)
    Dim ret
    ret = reg_quote(strData)
    ret = Replace(ret, "{Href}", "([^""\s>]+?)", 1, 1)
    ret = Replace(ret, "{Href}", "\1")
    ret = Replace(ret, "{Title}", "(.+?)", 1, 1)
    ret = Replace(ret, "{Title}", "\2")
    ret = Replace(ret, "{Time}", "(.+?)")
    ret = Replace(ret, "{Page}", "(\d+)")
    ret = Replace(ret, "{Content}", "([\s\S]+?)")
    ret = Replace(ret, "{}", ".*?")
    ret = Replace(ret, "{", "(")
    ret = Replace(ret, "@@@", "|")
    ret = Replace(ret, "}", ")")
    MyRegStr = ret
End Function

Private Function GetFullURL(ByVal strURL1, ByVal strURL2)
    If Left(strURL2, 7) = "http://" Then
        GetFullURL = strURL2
    ElseIf Left(strURL2, 1) = "/" Then
        GetFullURL = GetHost(strURL1) & strURL2
    Else
        GetFullURL = GetPath(strURL1) & strURL2
    End If
End Function

Private Function GetHost(ByVal strURL)
    Dim reg, arr
    Set reg = New RegExp
    reg.Pattern = "^http://([^/]+)"
    Set arr = reg.Execute(strURL)
    GetHost = arr(0).Value
    Set arr = Nothing
    Set reg = Nothing
End Function

Private Function GetPath(ByVal strURL)
    Dim tmp, pos
    tmp = strURL