class_sys.asp

来自「是个不错的文件代码,希望大家好好用,」· ASP 代码 · 共 1,851 行 · 第 1/5 页

		WhiteList = Application(Cache_Name & "_WhiteIp")
		BalckList = Application(Cache_Name & "_BlackIp")
		'如果无黑名单,则直接跳出
		If UBound(BalckList) < 0 Then 
			ChkIpLock=False
			Exit Function
		End if
		'获取用户IP	
		sUserIP = oblog.UserIp
		If sUserIP = "" Then Exit Function
		sUserIP = Split(UserIp, ".")

		If UBound(sUserIP) <> 3 Then Exit Function        	
		'检测白名单,白名单支持XXX.*.*.*,如果位于白名单内直接跳出检测流程
		For i = 0 To UBound(WhiteList)
			If WhiteList(i) <> "" Then
			  sIP = Split(WhiteList(i), ".")
			  If UBound(sIP) <> 3 Then Exit For
			  IPlock = false
			  If sUserIP(0) = sIP(0) Then
				If sUserIP(1) = sIP(1) Or  sIP(1)= "*" Then
					If sUserIP(2) = sIP(2) Or sIP(2)= "*" Then
						If sUserIP(3) = sIP(3) Or sIP(3)="*" Then
							ChkIpLock=false
							Exit Function
						End If
					End If
				End If
				End If
			End If                			
			Next
		'检测黑名单
		For i = 0 To UBound(BalckList)
			If BalckList(i) <> "" Then
				sIP = Split(BalckList(i), ".")
				If UBound(sIP) = 3  Then	
					IPlock = True
					If (sUserIP(0) <> sIP(0)) And InStr(sIP(0), "*") = 0 Then IPlock = False
					If (sUserIP(1) <> sIP(1)) And InStr(sIP(1), "*") = 0 Then IPlock = False
					If (sUserIP(2) <> sIP(2)) And InStr(sIP(2), "*") = 0 Then IPlock = False
					If (sUserIP(3) <> sIP(3)) And InStr(sIP(3), "*") = 0 Then IPlock = False
					If IPlock Then Exit For
				End If
			End If
		Next
		ChkIpLock = IPlock
	End Function

	'进行白名单控制	
	Public Function ChkWhiteIP()
		Dim IPlock,i, sUserIP, sIP,BalckList,WhiteList,iCheck
		ChkWhiteIP = False
		WhiteList = Application(Cache_Name & "_WhiteIp")
		'如果无黑名单,则直接跳出
		If UBound(WhiteList) < 0 Then 
			Exit Function
		End if
		'获取用户IP	
		sUserIP = oblog.UserIp
		If sUserIP = "" Then Exit Function
		sUserIP = Split(UserIp, ".")
		If UBound(sUserIP) <> 3 Then Exit Function        	
		'检测白名单,白名单支持XXX.*.*.*,如果位于白名单内直接跳出检测流程
		For i = 0 To UBound(WhiteList)
			If WhiteList(i) <> "" Then
			  sIP = Split(WhiteList(i), ".")
			  If UBound(sIP) <> 3 Then Exit For
			  IPlock = false
			  If sUserIP(0) = sIP(0) Then
				If sUserIP(1) = sIP(1) Or  sIP(1)= "*" Then
					If sUserIP(2) = sIP(2) Or sIP(2)= "*" Then
						If sUserIP(3) = sIP(3) Or sIP(3)="*" Then
							ChkWhiteIP=True
							Exit Function
						End If
					End If
				End If
				End If
			End If                			
		Next
	End Function


	'进行脚本过滤
	Function CheckScript(Content)
		Dim oRegExp,oMatch,spamCount
		Set oRegExp = New Regexp
		oRegExp.IgnoreCase = True
		oRegExp.Global = True
		oRegExp.pattern ="<script.+?/script>"
		Content=oRegExp.Replace(Content,"")
		Set oRegExp=Nothing
	End Function

	'进行多媒体对象检测
	'提取媒体文件,清理播放器
	Function CheckMedia(Content)
		Dim oRegExp,oRegExp1,oMatch,Matches,oMatch1,Matches1
		Dim sFiles1,sFiles2,sFile
		sFiles="swf,mp3,rm,ram,rmvb,mp4,wma,wav,avi"
		Set oRegExp = New Regexp
		oRegExp.IgnoreCase = True
		oRegExp.Global = True
		Set oRegExp1 = New Regexp
		oRegExp1.IgnoreCase = True
		oRegExp1.Global = True
		
		'媒体文件
		oRegExp.pattern ="<object.+?>"
		Set Matches=oRegExp.Execute(Content)
		For Each oMatch In Matches			
			oRegExp1.pattern="http://([\w-]+\.)+[\w-]+(/[\w- ./?%&=]*)?"
			Set Matches1=oRegExp.Execute(oMatch.Value)
			For Each oMathch1 In Matches1
				'只取媒体文件
				sFile=Split(oMathch1.value,".")
				If InStr(sFiles1,sFile(UBound(sFile)))>0 Then
					strFiles2="<a href=""" &  oMathch1.value & """ target=_blank>" & oMathch1.value & "</a><br>"
				End If
			Next			
		Next
		'清空
		oRegExp.pattern ="<object.+?/object>"		
		Content=oRegExp1.Replace(Content,"")
		oRegExp.pattern ="<em.+?>"
		Set Matches=oRegExp.Execute(Content)
		For Each oMatch In Matches			
			oRegExp1.pattern="http://([\w-]+\.)+[\w-]+(/[\w- ./?%&=]*)?"
			Set Matches1=oRegExp.Execute(oMatch.Value)
			For Each oMathch1 In Matches1
				'只取媒体文件
				sFile=Split(oMathch1.value,".")
				If InStr(sFiles1,sFile(UBound(sFile)))>0 Then
					strFiles2="<a href=""" &  oMathch1.value & """ target=_blank>" & oMathch1.value & "</a><br>"
				End If
			Next			
		Next		
		oRegExp.pattern ="<em.+?/em>"
		Content=oRegExp1.Replace(Content,"")
		Set oRegExp1=othing
		Set oRegExp2=othing
	End Function

	Function ubb_comment(strContent)
		Dim re
		
		If IsNull(strContent) THen 
			ubb_comment=""
			Exit Function
		End If
		
		Set re=new RegExp
		re.IgnoreCase =true
		re.Global=True
		'以下过滤html代码
		strContent = Replace(strContent, "<br />", "[br]")
		strContent = Replace(strContent, ">", "&gt;")
		strContent = Replace(strContent, "<", "&lt;")
		strContent = Replace(strContent, Chr(32), " ")
		strContent = Replace(strContent, Chr(9), " ")
		strContent = Replace(strContent, Chr(34), "&quot;")
		'strContent = Replace(strContent, CHR(39), "&#39;")
		strContent = Replace(strContent, Chr(13), "")
		strContent = Replace(strContent, Chr(10), "<br /> ")
		strContent = Replace(strContent, "[br]", "<br />")
		'以下过滤ubb标签
		re.Pattern="(\[EMOT\])(.[^\[]*)(\[\/EMOT\])"
		strContent= re.Replace(strContent,"<img src="""&blogdir&"editor/images/emot/face"&"$2"&".gif"&""" />")	
		re.Pattern="\[i\](.[^\[]*)(\[\/i\])"
		strContent=re.Replace(strContent,"<em>$1</em>")
		re.Pattern="\[u\](.[^\[]*)(\[\/u\])"
		strContent=re.Replace(strContent,"<u>$1</u>")
		re.Pattern="\[b\](.[^\[]*)(\[\/b\])"
		strContent=re.Replace(strContent,"<strong>$1</strong>")
		re.Pattern="\[QUOTE\](.[^\[]*)(\[\/QUOTE\])"
		strContent=re.Replace(strContent,"<div class='quote'>$1</div><br>")
		Set re=Nothing
		ubb_comment=strContent
	End Function

	Sub MakeEditorJs(sInput,stype)
	 If sInput="" Then sInput="myTextArea"
		 %>
	  <script type="text/javascript">
		_editor_url  = "<%=C_Editor%>"; //编辑器路径
		_editor_lang = "ch"; //语言
	  </script>
	  <script type="text/javascript" src="<%=C_Editor%>/htmlarea.js"></script>
	  <script type="text/javascript">
		oblog_editors = null;
		oblog_init    = null;
		oblog_config  = null;
		oblog_plugins = null;
		oblog_editortype=<%=stype%>;//1是默认模式,2是精简模式
		//oblog_toxhtml=0; //0不转换xhtml,1转换到xhtml
		oblog_init = oblog_init ? oblog_init : function()
		{
		  oblog_editors = oblog_editors ? oblog_editors :['<%=sInput%>'];
		  oblog_config = oblog_config ? oblog_config : new HTMLArea.Config(oblog_editortype);
		  oblog_editors   = HTMLArea.makeEditors(oblog_editors, oblog_config, oblog_plugins);
		  HTMLArea.startEditors(oblog_editors);
		  window.onload = null;
		}
		window.onload   = oblog_init;
	  </script>
	  <%
	 End Sub
	 '发送系统信息
	 Sub SendSysMsg(fromId,toId,toName,toContent)
		
	 End Sub
	 
	 'CheckAdmin
	Public Function CheckAdmin()
		Dim admin_name,admin_password,sql,rs	
		CheckAdmin=False
		admin_name=filt_badstr(session("adminname"))
			admin_password=filt_badstr(session("adminpassword"))
		If IsEmpty(admin_name) Or admin_name="" Then Exit Function
			sql="select id,password from oblog_admin where username='" & admin_name & "' and password='"&admin_password&"'"
			If Not IsObject(conn) Then link_database
			Set rs=conn.execute(sql)
			if Not rs.eof then
				If rs(1)=admin_password Then
					rs.close
					set rs=nothing
					CheckAdmin=True
					Exit Function				
				End If
			End if
			rs.close
			Set rs=Nothing	
		End Function	
		'验证用户提交的域名根是否合法
		Public Function CheckDomainRoot(R_DomainRoot)
			CheckDomainRoot=False
			Dim DomainRoot,i
			DomainRoot=Trim(CacheConfig(4))
			R_DomainRoot=Trim (R_DomainRoot)
			If DomainRoot="" Or CacheConfig(5) = 0 Then Exit Function
			If InStr(DomainRoot,"|")<0 Then
				If R_DomainRoot=DomainRoot Then 
					CheckDomainRoot=True 
					Exit Function
				End If
			Else 
				DomainRoot=Split(DomainRoot,"|")
				For i=0 To UBound(DomainRoot)
					If R_DomainRoot = DomainRoot(i) Then
						CheckDomainRoot=True 
						Exit Function	
					End If
				Next
			End if
		End Function

	'过滤掉flash UBB标记
	Function FilterUBBFlash(byval strFlash)
		Dim strFlash1,t
		t=0
		strFlash1=LCase(strFlash)
		If InStr(strFlash1,"[/flash]")>0 Then
			strFlash1 = Replace(strFlash1,"[/flash]","[ /flash ]")
			strFlash1 = Replace(strFlash1,"[flash","[ flash ")
			t=1
		end if
		if InStr(strFlash1,"[/mp]")>0 Then
			strFlash1 = Replace(strFlash1,"[/mp]","[ /mp ]")
			strFlash1 = Replace(strFlash1,"[mp","[ mp ")
			t=1
		end if
		if InStr(strFlash1,"[/rm]")>0 Then
			strFlash1 = Replace(strFlash1,"[/rm]","[ /rm ]")
			strFlash1 = Replace(strFlash1,"[rm","[ rm ")
			t=1
		End If
		if InStr(strFlash1,"[/url]")>0 Then
			strFlash1 = Replace(strFlash1,"[/url]","[ /url ]")
			strFlash1 = Replace(strFlash1,"[url","[ url ")
			t=1
		End If
		if InStr(strFlash1,"meta")>0 Then
			strFlash1 = Replace(strFlash1,"meta","ｍeta")
			t=1
		End If
		if InStr(strFlash1,"embed")>0 Then
			strFlash1 = Replace(strFlash1,"embed","ｅmbed")
			t=1
		End If
		if t=1 then
			FilterUBBFlash=strFlash1
		else
			FilterUBBFlash=strFlash
		end if
	End Function

	'封IP
	Public Sub KillIP(sIP) 
		Dim rstCache
		Set rstCache = Server.CreateObject("Adodb.RecordSet")       	        
		rstCache.Open "Select * From  oblog_config Where id=5",conn,1,3
		rstCache("ob_value")=rstCache("ob_value")& vbCrLf & sIP
		rstCache.Update
		rstCache.Close
		Set rstCache=Nothing
		reloadsetup
	End Sub
	'过滤关键字、黑白名单ip中的空行
	Function FilterEmpty(badstr)
		Dim arrStr,strReturn,i
		badstr=Trim (badstr)
		If badstr= "" Then 
			FilterEmpty=badstr 
			Exit Function
		End if
		If InStr (badstr,vbcrlf)>0 Then
			arrStr = Split (badstr,vbcrlf)
			For i = 0 To UBound(arrStr)
				If arrStr(i)<>"" Then 
					strReturn = strReturn & vbcrlf & arrStr(i)
				End if
			Next
			strReturn = Replace (strReturn,vbcrlf,"",1,1,1)
		Else 
			strReturn = badstr
		End If
		FilterEmpty = strReturn
	End Function

	End Class

	Class AjaxXml
	Private m_contentType,m_encoding,m_xml

	Private Sub Class_Initialize()
		m_contentType = "text/xml"
		m_encoding = "gb2312"
		m_xml=true
	End sub

	Public sub re(result)
		Response.contentType = m_contentType
		Response.Expires=0
		response.Write serialize(result)
	End Sub

	Private function serialize(result)
		Dim restr,i
		if m_xml then
			restr = "<?xml version=""1.0"" encoding="""&m_encoding&"""?>"
			restr = restr+"<Response>"
			if IsArray(result) then
				For i=0 to UBound(result)
					restr = restr + "<item><![CDATA["&result(i)&"]]></item>"
				next
			else
				restr = restr + result
			end If
			restr = restr + "</Response>"
		else
			restr = result
		end if
		serialize = restr
	end function
End Class
%>