%
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>