%
Public Function Bytes2BSTR(v)
Dim r,i,t,n : r = ""
For i = 1 To LenB(v)
t = AscB(MidB(v,i,1))
If t H80 Then
r = r Chr(t)
Else
n = AscB(MidB(v,i+1,1))
r = r Chr(CLng(t) * H100 + CInt(n))
i = i + 1
End If
Next
Bytes2BSTR = r
End Function
'==========================================================================================
If Request.QueryString="ViewSource" Then
Dim oFso : Set oFso=Server.CreateObject("Scripting.FileSystemObject")
Dim oFil : Set oFil=oFso.OpenTextFile(Server.MapPath("URL.Asp"))
Dim sTxt : sTxt=oFil.ReadAll()
oFil.Close : Set oFil=Nothing : Set oFso=Nothing
Response.ContentType="text/plain"
Response.Write sTxt
Response.ENd
End If
%>?xml version="1.0" encoding="gb2312" standalone="yes"?>
!doctype html public "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
html xmlns:v="http://www.eglic.com/">
head>
title>/title>
meta name="Generator" content="EditPlus" />
meta name="Author" content="eglic" />
meta http-equiv="Content-Type" content="text/html; charset=gb2312" />
meta name="CharSet" content="GB2312" />
link rel="stylesheet" type="text/css" href="/styles/default.css" />
style type="text/css">
@media all{
}
/style>
script language="javascript" src="/scripts/default.js">/script>
script language="javascript" src="/scripts/xml.js">/script>
script language="javascript">//!--
//-->/script>
/head>
body>
form action="" method="POST">
要檢測的URL：input type="text" name="URL" size="50" value="%
If Request.Form("URL")>"" THen
Response.Write Trim(Request.Form("URL"))
Else
Response.Write "http://www.crsky.com/view_down.asp?downd_id=8downd=0ID=20780down=yes"
End If
%>" />
input type="submit" value="提交" />
input type="button" value="查看源代碼" onclick="JavaScript:window.open('%=URLSelf%>?ViewSource');" />
/form>
%
Public Function GetAbsoluteURL(sUrl,ByRef iStep)
Dim bUrl,bDat
If iStep>15 Then
Err.Raise vbObejctError,"遞歸錯誤","遞歸嵌套超過15層可能會引起程序崩潰"
End If
If InStr(sUrl,"://")=0 Then sUrl="http://" sUrl
If InStr(sUrl,"?")>0 THen
Dim tmpUrl : tmpUrl=split(sUrl,"?")
bUrl=tmpUrl(0)
bDat=tmpUrl(1)
Else
bUrl=sUrl
bDat=""
End If
Response.Write "p style=""border:solid 1px silver;border-top:solid 2px red;padding:5px;margin:2px;"">"
Response.Write "第 " iStep " 步："
Response.Write "正在準備獲取 " bUrl "br />"
iStep=iStep+1
if bDat>"" Then Response.Write "nbsp;nbsp;>>參數： " bDat "br />"
Dim oHttp : Set oHttp=Server.CreateObject("WinHttp.WinHttpRequest.5.1")
oHttp.Option(6)=0 '禁止自動Redirect，最關鍵的
'oHttp.Option()
oHttp.SetTimeouts 5000,5000,30000,5000
oHttp.Open "GET",sUrl,False
On Error Resume Next
oHttp.Send bDat
If Err.Number>0 Then
Response.Write "font color=""red"">發生錯誤：" Err.Description "/font>br />"
Err.Clear
GetAbsoluteURL=""
Set oHttp=Nothing
Response.Write "/p>"
Exit Function
End If
On Error Goto 0
Response.Write "nbsp;nbsp;>>HTTP 狀態：" oHttp.Status "br />"
If oHttp.Status>200 And oHttp.Status>302 Then
Response.Write "font color=""red"">HTTP錯誤：" oHttp.StatusText "/font>br />"
Err.Clear
GetAbsoluteURL=""
Set oHttp=Nothing
Response.Write "/p>"
Exit Function
End If
Dim sLoca
On Error Resume Next
sLoca=oHttp.getResponseHeader("Location")
If Err.Number>0 Then
Err.Clear
sLoca=""
End If
On Error Goto 0
If sLoca = "" Then
Response.Write "nbsp;nbsp;>>Content-Type:" oHttp.getResponseHeader("Content-Type") "br />"
Response.Write "nbsp;nbsp;>>Content-Length:"
On Error Resume Next
Response.Write oHttp.getResponseHeader("Content-Length")
If Err.Number>0 THen Err.Clear
On Error Goto 0
Response.Write "br />"
Response.Write "nbsp;nbsp;>>沒有返回Location頭，繼續分析頁面br />"
If oHttp.getResponseHeader("Content-Type")="text/html" Then '是HTML類型才繼續處理
Dim sBody : sBody=Bytes2BStr(oHttp.responseBody)
Dim r : Set r=new Regexp
r.MultiLine=True
r.Global=True
r.IgnoreCase=True
r.Pattern="meta.+http\-equiv\=\""refresh\"".+content=\""[^\;]+;url\=([^\""\s\&;]*).*$"
If r.Test(sBody) Then
Response.Write "nbsp;nbsp;>>發現 Refresh 地址br />"
Dim m : Set m=r.Execute(sBody)
Dim tRefUrl : tRefUrl=r.Replace(m(0).Value,"$1")
If InStr(tRefUrl,"://")=0 Then '沒有指定協議，按當前URL的位置重新設置
Dim ind1 : ind1=InstrRev(sUrl,"/")
sUrl=Left(sUrl,ind1)
tRefUrl=sUrl tRefUrl
End If
Set r=Nothing
Set oHttp=Nothing
Response.Write "nbsp;nbsp;>>準備分析 u>" tRefUrl "/u>br />"
Response.Write "/p>"
GetAbsoluteURL=GetAbsoluteURL(tRefUrl,iStep)
Exit Function
Else
Response.Write "nbsp;nbsp;>>沒發現 Refresh Meta 轉向，這可能就是最終的URLbr />"
GetAbsoluteURL=sUrl
Set r=Nothing
Set oHttp=Nothing
Response.Write "/p>"
Exit Function
End If
Else
GetAbsoluteURL=sUrl
Set oHttp=Nothing
Response.Write "/p>"
Exit Function
End If
'這里要繼續分析網頁內容
Else
Response.Write "nbsp;nbsp;>>Content-Type:" oHttp.getResponseHeader("Content-Type") "br />"
Response.Write "nbsp;nbsp;>>Content-Length:"
On Error Resume Next
Response.Write oHttp.getResponseHeader("Content-Length")
If Err.Number>0 THen Err.Clear
On Error Goto 0
Response.Write "br />"
Response.Write "nbsp;nbsp;>>u>Location : " sLoca "/u>br />"
Response.Write "/p>"
'這里要生成新的URL
If InStr(sLoca,"://")=0 Then
'沒有指定協議，按當前URL的位置重新設置
Dim ind : ind=InstrRev(sUrl,"/")
sUrl=Left(sUrl,ind)
sLoca=sUrl sLoca
End If
GetAbsoluteURL=GetAbsoluteURL(sLoca,iStep)
End If
End Function
If Request.Form("URL")>"" THen
Dim iStep : iStep=1
Dim sAbs : sAbs=GetAbsoluteURL(Trim(Request.Form("URL")),iStep)
Response.Write "strong style=""color:white;background-color:red;font-size:15px;padding:3px;margin:10px;"">最終結果是：" sAbs "/strong>"
End If
%>
script src="/T/mystat.asp?siteid=1">/script>
/body>
/html>
