'=========================================================
' ip2region.xdb ASP(VBScript) 解析函数 + Application全局缓存版
' 函数：GetIpRegion(ip)
' 参数：ip字符串，如 "220.181.208.61"
' 返回：合并字符串 国家 省 市 区县，无数据返回"未知"
' 参考：oa22.cn/bbs.asp?id=41332
' 缓存说明：使用Application缓存IP结果，设置过期时间，避免无限膨胀
' 注意：Application是应用程序全局缓存，IIS回收后缓存清空
'=========================================================
Dim xdbBuf, xdbFileLen, xdbIndexStart, xdbIndexEnd, xdbDataStart
Dim xdbVectorIndexPtr, xdbVectorIndexLen
Dim xdbIsLoad : xdbIsLoad = False
Const CACHE_KEY_PREFIX = "ipreg_"
Const CACHE_EXPIRE_SEC = 1800 '缓存30分钟，可自行调整，单位秒
' 【初始化：加载xdb到内存，全局只加载一次】
Sub LoadXdb()
Dim stm
Dim xdbPath
xdbPath = Server.MapPath("/ip2region.xdb") '修改xdb路径
Set stm = Server.CreateObject("ADODB.Stream")
stm.Mode = 3
stm.Type = 1
stm.Open
stm.LoadFromFile xdbPath
xdbBuf = stm.Read
xdbFileLen = LenB(xdbBuf)
stm.Close
Set stm = Nothing
If xdbFileLen < 36 Then
xdbIsLoad = False
Exit Sub
End If
xdbIndexStart = ReadUint4(0)
xdbIndexEnd = ReadUint4(4)
xdbVectorIndexPtr = ReadUint4(8)
xdbVectorIndexLen = ReadUint4(12)
xdbDataStart = 36
xdbIsLoad = True
End Sub
' 从字节数组指定偏移读4字节无符号int (Little-Endian)
Function ReadUint4(offset)
If offset + 4 > xdbFileLen Then
ReadUint4 = 0
Exit Function
End If
Dim b1,b2,b3,b4
b1 = AscB(MidB(xdbBuf, offset+1, 1))
b2 = AscB(MidB(xdbBuf, offset+2, 1))
b3 = AscB(MidB(xdbBuf, offset+3, 1))
b4 = AscB(MidB(xdbBuf, offset+4, 1))
ReadUint4 = b1 + b2*256 + b3*65536 + b4*16777216
End Function
' 从字节数组指定偏移读3字节无符号int (Little-Endian)
Function ReadUint3(offset)
If offset + 3 > xdbFileLen Then
ReadUint3 = 0
Exit Function
End If
Dim b1,b2,b3
b1 = AscB(MidB(xdbBuf, offset+1, 1))
b2 = AscB(MidB(xdbBuf, offset+2, 1))
b3 = AscB(MidB(xdbBuf, offset+3, 1))
ReadUint3 = b1 + b2*256 + b3*65536
End Function
' IP字符串转uint32
Function IpToUint(ipStr)
Dim arr, i, ret
arr = Split(ipStr,".")
If UBound(arr)<>3 Then
IpToUint = -1
Exit Function
End If
ret = 0
For i=0 To 3
Dim v
v = CInt(arr(i))
If v<0 Or v>255 Then
IpToUint = -1
Exit Function
End If
ret = ret * 256 + v
Next
IpToUint = ret
End Function
' 二分查找索引
Function BinarySearch(ipUint)
Dim low, high, mid, ipStart, ipEnd, dataPtr, offset
low = 0
high = (xdbIndexEnd - xdbIndexStart)\12 -1
Do While low <= high
mid = Int((low + high)/2)
offset = xdbIndexStart + mid * 12
ipStart = ReadUint4(offset)
ipEnd = ReadUint4(offset+4)
dataPtr = ReadUint3(offset+8)
If ipUint < ipStart Then
high = mid -1
ElseIf ipUint > ipEnd Then
low = mid +1
Else
BinarySearch = dataPtr
Exit Function
End If
Loop
BinarySearch = 0
End Function
' 读取location字符串（utf8）
Function ReadLocation(ptr)
If ptr = 0 Or ptr >= xdbFileLen Then
ReadLocation = ""
Exit Function
End If
Dim p, b, sB
sB = ""
p = ptr
Do
If p >= xdbFileLen Then Exit Do
b = AscB(MidB(xdbBuf, p+1,1))
If b = 0 Then Exit Do
sB = sB & MidB(xdbBuf, p+1,1)
p = p +1
Loop
ReadLocation = Utf8ToGb2312(sB)
End Function
' UTF8字节串转GB2312（ASP VBS）
Function Utf8ToGb2312(sUtf8)
Dim stm
Set stm = Server.CreateObject("ADODB.Stream")
stm.Type = 2
stm.Charset = "UTF-8"
stm.Open
stm.WriteText sUtf8
stm.Position = 0
stm.Type = 1
Dim bin
bin = stm.Read
stm.Close
stm.Type = 2
stm.Charset = "GB2312"
stm.Open
stm.Write bin
stm.Position = 0
Utf8ToGb2312 = stm.ReadText
stm.Close
Set stm = Nothing
End Function
' 内部：直接查询xdb，不经过缓存
Function RawQueryIp(ipStr)
If Not xdbIsLoad Then Call LoadXdb()
If Not xdbIsLoad Then
RawQueryIp = "未知"
Exit Function
End If
Dim ipUint, dataPtr, loc
ipUint = IpToUint(ipStr)
If ipUint = -1 Then
RawQueryIp = "未知"
Exit Function
End If
dataPtr = BinarySearch(ipUint)
If dataPtr <= 0 Then
RawQueryIp = "未知"
Exit Function
End If
loc = ReadLocation(dataPtr)
Dim arrLoc
arrLoc = Split(loc,"|")
Dim res
res = ""
If UBound(arrLoc)>=0 Then res = res & Trim(arrLoc(0))
If UBound(arrLoc)>=1 Then res = res & " " & Trim(arrLoc(1))
If UBound(arrLoc)>=2 Then res = res & " " & Trim(arrLoc(2))
If UBound(arrLoc)>=3 Then res = res & " " & Trim(arrLoc(3))
RawQueryIp = res
End Function
' ===================== 对外主函数（带Application缓存+锁） =====================
Function GetIpRegion(ipStr)
Dim cacheKey, cacheVal, cacheInfo, nowSec
cacheKey = CACHE_KEY_PREFIX & Replace(ipStr,".","_")
nowSec = DateDiff("s", "1970-01-01", Now())
Application.Lock
On Error Resume Next
cacheInfo = Application(cacheKey)
On Error GoTo 0
'缓存存在并且没过期，直接返回
If cacheInfo <> "" Then
Dim expSec, retStr
expSec = Split(cacheInfo,"|")(0)
retStr = Split(cacheInfo,"|")(1)
If nowSec < CLng(expSec) Then
Application.UnLock
GetIpRegion = retStr
Exit Function
Else
'过期，删掉旧缓存
Application(cacheKey) = Empty
End If
End If
Application.UnLock
'缓存缺失/过期，真实查询xdb
Dim result
result = RawQueryIp(ipStr)
'写入缓存：过期时间|结果文本
Dim saveInfo
saveInfo = CStr(nowSec + CACHE_EXPIRE_SEC) & "|" & result
Application.Lock
Application(cacheKey) = saveInfo
Application.UnLock
GetIpRegion = result
End Function
' ============ 辅助：清空全部IP缓存，后台可以调用 ============
Sub ClearIpRegionCache()
Dim key
Application.Lock
For Each key In Application.Contents
If Left(key, Len(CACHE_KEY_PREFIX)) = CACHE_KEY_PREFIX Then
Application.Contents.Remove(key)
End If
Next
Application.UnLock
End Sub
' ============ 测试示例 ============
'Response.Write GetIpRegion("220.181.208.61")
400 186 1886
