<%
' 判断提交是否來自外部
Public Function ChkPost()
Dim server_v1,server_v2
Chkpost=False
server_v1=Cstr(Request.ServerVariables("HTTP_REFERER"))
server_v2=Cstr(Request.ServerVariables("SERVER_NAME"))
If Mid(server_v1,8,len(server_v2))=server_v2 Then Chkpost=True
End Function
'系统分配随机密码
Public Function Createpass()
Dim Ran,i,LengthNum
LengthNum=16
Createpass=""
For i=1 To LengthNum
Randomize
Ran = CInt(Rnd * 2)
Randomize
If Ran = 0 Then
Ran = CInt(Rnd * 25) + 97
Createpass =Createpass& UCase(Chr(Ran))
ElseIf Ran = 1 Then
Ran = CInt(Rnd * 9)
Createpass = Createpass & Ran
ElseIf Ran = 2 Then
Ran = CInt(Rnd * 25) + 97
Createpass =Createpass& Chr(Ran)
End If
Next
End Function
'重写execute
Rem Function
Public Function Execute(Command)
If Not IsObject(Conn) Then ConnectionDatabase
'检查权限，防止注入攻击
If InStr(LCase(Command),"dv_admin")>0 And Left(ScriptName,6)<> "admin_" Then
Response.Write SaveSQLLOG(Command,"")
Command=Replace(LCase(Command),"dv_admin","dv<i>"&Chr(95)&"</i>admin")
End If
If IsDeBug = 0 Then
On Error Resume Next
Set Execute = Conn.Execute(Command)
If Err Then
err.Clear
Set Conn = Nothing
Response.Write SaveSQLLOG(Command,"查询数据的时候发现错误，请检查您的查询代码是否正确。<br>基于安全的理由，只显示本信息，要查看详细的错误信息，请修改您的程序文件conn.asp。把""Const IsDeBug = 0""改为：""Const IsDeBug = 1""")
Response.End
End If
Else
'Response.Write command & "<br>"
Set Execute = Conn.Execute(Command)
End If
SqlQueryNum = SqlQueryNum+1
End Function
'记录查询错误事件
Public Function SaveSQLLOG(sCommand,message)
Dim lConnStr,lConn,ldb,SQL,RS
ldb = "data/DvSQLLOG.mdb"
lConnStr = "PRovider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(ldb)
Set lConn = Server.CreateObject("ADODB.Connection")
lConn.Open lConnStr
Set Rs = Server.CreateObject("adodb.recordset")
Sql="select * from dv_sql_log"
Rs.open sql,lconn,1,3
Rs.addnew
Rs("ScriptName")=ScriptName
Rs("S_Info")=Left(sCommand,255)
Rs("ip")=UserTrueIP
Rs.update
Rs.close
lConn.Execute(SQL)
lConn.Close
Set lConn = Nothing
SaveSQLLOG = message
End Function
'IP来源
Public Function address(sip)
Dim aConnStr,aConn,adb
Dim str1,str2,str3,str4
Dim num
Dim country,city
Dim irs,SQL
If IsNumeric(Left(sip,2)) Then
If sip="127.0.0.1" Then sip="192.168.0.1"
str1=Left(sip,InStr(sip,".")-1)
sip=mid(sip,instr(sip,".")+1)
str2=Left(sip,instr(sip,".")-1)
sip=Mid(sip,InStr(sip,".")+1)
str3=Left(sip,instr(sip,".")-1)
str4=Mid(sip,instr(sip,".")+1)
If isNumeric(str1)=0 or isNumeric(str2)=0 or isNumeric(str3)=0 or isNumeric(str4)=0 Then
Else
num=CLng(str1)*16777216+CLng(str2)*65536+CLng(str3)*256+CLng(str4)-1
adb = "data/ipaddress.mdb"
aConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(adb)
Set AConn = Server.CreateObject("ADODB.Connection")
aConn.Open aConnStr
sql="select top 1 country,city from dv_address where ip1 <="&num&" and ip2 >="&num&""
Set irs=aConn.execute(sql)
If irs.EOF And irs.bof Then
country="亚洲"
city=""
Else
country=irs(0)
city=irs(1)
End If
Set irs=Nothing
Set aConn = Nothing
SqlQueryNum = SqlQueryNum+1
End If
address=country&city
Else
address="未知"
End If
End Function
'用于用户发布的各种信息过滤，带脏话过滤
Public Function HTMLEncode(fString)
If Not IsNull(fString) Then
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString = Replace(fString, CHR(32), " ") '
fString = Replace(fString, CHR(9), " ") '
fString = Replace(fString, CHR(34), """)
fString = Replace(fString, CHR(39), "'") '过滤单引号
fString = Replace(fString, CHR(13), "")
fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
fString = Replace(fString, CHR(10), "<BR> ")
fString=ChkBadwords(fString)
HTMLEncode = fString
End If
End Function
'用于论坛本身的过滤，不带脏话过滤
Public Function iHTMLEncode(fString)
If Not IsNull(fString) Then
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString = Replace(fString, CHR(32), " ")
fString = Replace(fString, CHR(9), " ")
fString = Replace(fString, CHR(34), """)
fString = Replace(fString, CHR(39), "'")
fString = Replace(fString, CHR(13), "")
fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
fString = Replace(fString, CHR(10), "<BR> ")
iHTMLEncode = fString
End If
End Function
Public Function strLength(str)
If isNull(str) or Str = "" Then
StrLength = 0
Exit Function
End If
Dim WINNT_CHINESE
WINNT_CHINESE=(len("例子")=2)
If WINNT_CHINESE Then
Dim l,t,c
Dim i
l=len(str)
t=l
For i=1 To l
c=asc(mid(str,i,1))
If c<0 Then c=c+65536
If c>255 Then t=t+1
Next
strLength=t
Else
strLength=len(str)
End If
End Function
Public Function ChkBadwords(Str)
If IsNull(Str) Then Exit Function
Dim i
For i = 0 To Ubound(Badwords)
If i > UBound(rBadword) Then
Str = Replace(Str,Badwords(i),"*")
Else
Str = Replace(Str,Badwords(i),rBadword(i))
End If
Next
ChkBadwords = Str
End Function
Public Function Checkstr(Str)
If Isnull(Str) Then
CheckStr = ""
Exit Function
End If
CheckStr = Replace(Str,"'","''")
End Function
'取得带端口的URL，推荐使用
Property Get Get_ScriptNameUrl()
If request.servervariables("SERVER_PORT")="80" Then
Get_ScriptNameUrl="http://" & request.servervariables("server_name")&replace(lcase(request.servervariables("script_name")),ScriptName,"")
Else
Get_ScriptNameUrl="http://" & request.servervariables("server_name")&":"&request.servervariables("SERVER_PORT")&replace(lcase(request.servervariables("script_name")),ScriptName,"")
End If
End Property
'检查Email地址有效性
function IsValidEmail(email)
dim names, name, i, c
IsValidEmail = true
names = Split(email, "@")
if UBound(names) <> 1 then
IsValidEmail = false
exit function
end if
for each name in names
if Len(name) <= 0 then
IsValidEmail = false
exit function
end if
for i = 1 to Len(name)
c = Lcase(Mid(name, i, 1))
if InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 and not IsNumeric(c) then
IsValidEmail = false
exit function
end if
next
if Left(name, 1) = "." or Right(name, 1) = "." then
IsValidEmail = false
exit function
end if
next
if InStr(names(1), ".") <= 0 then
IsValidEmail = false
exit function
end if
i = Len(names(1)) - InStrRev(names(1), ".")
if i <> 2 and i <> 3 then
IsValidEmail = false
exit function
end if
if InStr(email, "..") > 0 then
IsValidEmail = false
end if
end function
function strLength(str)
ON ERROR RESUME NEXT
dim WINNT_CHINESE
WINNT_CHINESE = (len("论坛")=2)
if WINNT_CHINESE then
dim l,t,c
dim i
l=len(str)
t=l
for i=1 to l
c=asc(mid(str,i,1))
if c<0 then c=c+65536
if c>255 then
t=t+1
end if
next
strLength=t
else
strLength=len(str)
end if
if err.number<>0 then err.clear
end function
function cutStr(str,strlen)
dim l,t,c
l=len(str)
t=0
for i=1 to l
c=Abs(Asc(Mid(str,i,1)))
if c>255 then
t=t+2
else
t=t+1
end if
if t>=strlen then
cutStr=left(str,i)&"..."
exit for
else
cutStr=str
end if
next
cutStr=replace(cutStr,chr(10),"")
end function
Function fixjs(Str)
If Str <>"" Then
str = replace(str,"", "")
Str = replace(str, chr(34), """")
Str = replace(str, chr(39),"'")
Str = Replace(str, chr(13), "n")
Str = Replace(str, chr(10), "r")
str = replace(str,"'", "'")
End If
fixjs=Str
End Function
Function enfixjs(Str)
If Str <>"" Then
Str = replace(str,"'", "'")
Str = replace(str,"""" , chr(34))
Str = replace(str, "'",chr(39))
Str = Replace(str, "r", chr(10))
Str = Replace(str, "n", chr(13))
Str = replace(str,"", "")
End If
enfixjs=Str
End Function
Class Cls_Browser
Public Browser,version ,platform
Private Sub Class_Initialize()
Browser="unknown"
version="unknown"
platform="unknown"
Dim Agent
Agent=Request.ServerVariables("HTTP_USER_AGENT")
Agent=Split(Agent,";")
If InStr(Agent(1),"MSIE")>0 Then
Browser="Microsoft Internet Explorer "
version=Trim(Left(Replace(Agent(1),"MSIE",""),6))
ElseIf InStr(Agent(4),"Netscape")>0 Then
Browser="Netscape "
Dim tmpstr
tmpstr=Split(Agent(4),"/")
version=tmpstr(UBound(tmpstr))
End If
If InStr(Agent(2),"NT 5.2")>0 Then
platform="Windows 2003"
ElseIf InStr(Agent(2),"NT 5.1")>0 Then
platform="Windows xp"
ElseIf InStr(Agent(2),"NT 5.0")>0 Then
platform="Windows 2000"
ElseIf InStr(Agent(2),"9x")>0 Then
platform="Windows ME"
ElseIf InStr(Agent(2),"98")>0 Then
platform="Windows 98"
ElseIf InStr(Agent(2),"95")>0 Then
platform="Windows 95"
End If
'记录未知Agent
If Browser="unknown" or version="unknown" or platform="unknown" Then
Agent=Dvbbs.checkStr(Request.ServerVariables("HTTP_USER_AGENT"))
Dim lConnStr,lConn,ldb
ldb = "data/DvSQLLOG.mdb"
lConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(ldb)
Set lConn = Server.CreateObject("ADODB.Connection")
lConn.Open lConnStr
lConn.Execute("insert into [Agent](UserAgent)Values('" & Agent & "')")
lConn.Close
Set lConn = Nothing
End If
End Sub
End Class
%>