class_sys.asp

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

		strLength = Len(Str)
		End If
		If Err.Number <> 0 Then Err.Clear
	End Function

	Public Function InterceptStr(txt, length)
		Dim x, y, ii
		txt = Trim(txt)
		x = Len(txt)
		y = 0
		If x >= 1 Then
			For ii = 1 To x
				If Asc(Mid(txt, ii, 1)) < 0 Or Asc(Mid(txt, ii, 1)) > 255 Then '如果是汉字
					y = y + 2
				Else
					y = y + 1
				End If
				If y >= length Then
					txt = Left(Trim(txt), ii) '字符串限长
					Exit For
				End If
			Next
			InterceptStr = txt
		Else
			InterceptStr = ""
		End If
	End Function

	'读取用户目录对应绑定的路径，未绑定返回空
	Public Function getdirdomain(udir)
		Dim tmp1, tmp2, Str
		Str = Application(Cache_Name & "dirdomain")
		udir = Trim(udir)
		tmp1 = InStr(Str, udir & "!!??((")
		tmp2 = Len(udir & "!!??((") + tmp1
		If tmp1 > 0 Then
			getdirdomain = Mid(Str, tmp2, InStr(tmp1, Str, "##))==") - tmp2)
		Else
			getdirdomain = ""
		End If
	End Function

	Public Function GetUrl()
		On Error Resume Next
		Dim sTmp
		If LCase(request.ServerVariables("HTTPS")) = "off" Then
		sTmp = "http://"
		Else
		sTmp = "https://"
		End If
		sTmp = sTmp & request.ServerVariables("SERVER_NAME")
		If request.ServerVariables("SERVER_PORT") <> 80 Then sTmp = sTmp & ":" & request.ServerVariables("SERVER_PORT")
		sTmp = sTmp & request.ServerVariables("URL")
		If Trim(request.QueryString) <> "" Then sTmp = sTmp & "?" & Trim(request.QueryString)
		GetUrl = sTmp
	End Function

	Public Function trueurl(strContent)
		On Error Resume Next
		Dim tempReg, url
		url = Trim("http://" & request.ServerVariables("SERVER_NAME"))
		url = LCase(url & request.ServerVariables("script_NAME"))
		url = Left(url, InStrRev(url, "/"))
		Set tempReg = New RegExp
		tempReg.IgnoreCase = True
		tempReg.Global = True
		tempReg.Pattern = "(^.*\/).*$" '含文件名的标准路径
		url = tempReg.Replace(url, "$1")
		tempReg.Pattern = "((?:src|href).*?=[\'\u0022](?!ftp|http|https|mailto))"
		trueurl = tempReg.Replace(strContent, "$1" + url)
		Set tempReg = Nothing
	End Function

	Public 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

	Public Function chkDomain(domain)
		Dim name, i, c
		name = domain
		chkdomain = True
		If Len(name) <= 0 Then
			chkdomain = 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
			   chkdomain = False
			Exit Function
		   End If
	   Next
	End Function

	Public Function CodeCookie(Str)
		If Is_password_cookies = 1 Then
			Dim i
			Dim StrRtn
			For i = Len(Str) To 1 Step -1
				StrRtn = StrRtn & AscW(Mid(Str, i, 1))
				If (i <> 1) Then StrRtn = StrRtn & "a"
			Next
			CodeCookie = StrRtn
		Else
			CodeCookie = Str
		End If
	End Function

	Public Function DecodeCookie(Str)
		If Is_password_cookies = 1 Then
			Dim i
			Dim StrArr, StrRtn
			StrArr = Split(Str, "a")
			For i = 0 To UBound(StrArr)
				If IsNumeric(StrArr(i)) = True Then
					StrRtn = ChrW(StrArr(i)) & StrRtn
				Else
					StrRtn = Str
					Exit Function
				End If
			Next
			DecodeCookie = StrRtn
		Else
			DecodeCookie = Str
		End If
	End Function

	Public Function BuildFile(ByVal sFile, ByVal sContent)
		Dim oFSO, oStream
		If CacheConfig(24) = 1 Then
			Set oFSO = server.CreateObject(CacheCompont(1))
	'			If Is_Debug=1 Then Response.Write sFile
	'			If Is_Debug=1 Then Response.Write sContent
			Set oStream = oFSO.CreateTextFile(sFile,True)
			oStream.Write sContent
			oStream.Close
			Set oStream = Nothing
			Set oFSO = Nothing
		Else
			Set oStream = server.CreateObject(CacheCompont(2))
			With oStream
				.Type = 2
				.Mode = 3
				.open
				'.Charset = "utf-8"
				.Charset = "gb2312"
				.Position = oStream.size
				.WriteText = sContent
				.SaveToFile sFile, 2
				.Close
			End With
			Set oStream = Nothing
		End If
	End Function
	'-----------Oblog4----------
	'sType:1-邀请码
	Public Function CheckOBCode(sCode, sType)
		Dim i, iAsc, rst,Sql
		sCode = UCase(Trim(sCode))
		CheckOBCode = False
		If Len(sCode)<>32 Then Exit FUnction
		For i = 1 To Len(sCode)
			iAsc = Asc(Mid(sCode, i, 1))
			'48~57,65~90
			If iAsc < 48 Or (iAsc > 57 And iAsc < 65) Or iAsc > 90 Then Exit Function
		Next
		If sType<>"" Then sType = CInt(sType)
		Sql="Select iState From oblog_obcodes Where iState=0 And obcode='" & LCase(sCode) & "' "
		Sql =Sql & " "
		Set rst = Execute("Select iState From oblog_obcodes Where iState=0 And obcode='" & LCase(sCode) & "' And iType=" & sType)
		If Not rst.EOF Then
			CheckOBCode = True
		End If
		rst.Close
		Set rst = Nothing
	End Function

	'检测用户发贴的许可
	Public Function CheckPostAccess()
		Dim rst
		CheckPostAccess=""
		'首先进行新用户注册检验

		If CacheConfig(19)>0 Then
			If Int(datediff("n",l_uAddtime,Now))<Int(CacheConfig(19)) Then    			
				CheckPostAccess="系统设定您在注册后 " & CacheConfig(19) & " 分钟后才可以发布日志或者相册"
				Exit Function
			End If
		End If
		'检查每天最大的发帖数目
		If l_Group(10,0)<=0 Or l_Group(10,0)="" Then
			CheckPostAccess=""
		Else
			Set rst=Execute("Select Count(logid) From oblog_log Where userid=" & l_uid & " And Datediff("& G_Sql_d &",truetime," & G_Sql_Now &")<1")
			If rst(0)<l_Group(10,0) Then
				CheckPostAccess=""
			Else
				CheckPostAccess="您目前所属的组限制您一天内只允许发布 " & l_gDayPosts & " 篇(日志+相册)<br/>您目前已经达到了该限额"
			End If    			
			Set rst=Nothing
		End If    	
	End Function

	'积分检查
	Public Function CheckScore(iScore)
		Dim rst
		CheckScore = False
		If iScore >= 0 Then CheckScore = True: Exit Function
		Set rst = Execute("Select scores From oblog_user Where userid=" & l_uId)
		If rst.EOF Then
			Set rst = Nothing
			Exit Function
		Else
			If rst(0) + iScore > 0 Then
				CheckScore = True
			End If
		End If
		Set rst = Nothing
	End Function

	'给分,删分
	Public Function GiveScore(blogid, Score ,userid)
		Dim uid
		If userid<>"" Then 
			uid = CLng(userid)
		Else 
			uid = l_uId
		End if
		Execute ("Update oblog_user Set scores=scores+" & Score & " Where  userid=" & uid)
		If blogid <> "" Then
			Execute ("Update oblog_log Set scores=scores+" & Score & " Where logid=" & Int(blogid) & "' And userid=" & uid)
		End If
	End Function

	'-------------------------------------------------------
	'内容保护模块!
	'-------------------------------------------------------
	'接管所有安全防护/内容过滤
	'内容类过滤,整合安全性过滤
	'关键字已经被分割成数组
	'此处的Content为返回参数
	Function CheckContent(byval Content, byval sType)
		Dim i,iCount,iLen,sKeep
		iCount=0
		Content=LCase(Content)
		'顶级过滤,直接封杀,系统对该用户进行计数,达到一定数目后,将该用户封禁
		For i=0 to Ubound(oblog.Keywords1)
			If Instr(Content,LCase(oblog.Keywords1(i)))>0 Then
	'				CheckContent=1 & "," & oblog.Keywords1(i)
				CheckContent=1
				Exit Function
			End If
		Next
		'次级过滤,提示审核
		For i=0 to Ubound(oblog.Keywords2)
			If Instr(Content,LCase(oblog.Keywords2(i)))>0 Then
				iCount=iCount+1		
				sKeep= sKeep & "," & oblog.Keywords2(i)
				'If iCount>oblog.Setup(21) Then
				'	'此处借用了一个,
	'					CheckContent="2"& sKeep
					CheckContent=2
					Exit Function
				'End If
			End If			
		Next
		'如果通过了第二次审核，则进入下一环节
		'一般过滤,全局字符替换
		For i=0 to Ubound(oblog.Keywords3)
			'如果是注册时存在，则直接跳出
			If sType="1" Then
				If Instr(Content,LCase(oblog.Keywords3(i)))>0 Then
					CheckContent=3
					Exit Function
				End If
			Else
			'如果是内容检测，则直接替换，不必执行查找过程						
				Content=Replace(Content,oblog.Keywords3(i),"xxxx")
				CheckContent=3
			End If
		Next
		If CheckContent<>3 Then CheckContent=0
	End Function


	'注册时重复的用户名
	'注册禁止使用的用户名
	Function chk_regname(sUserName)
		Dim i
		chk_regname=0
		sUserName=Lcase(sUserName)
		'用户名不能为非英文字符
		If CacheConfig(6) <> "1" Then 
			If CheckValidEnName(sUserName)=false Then
					chk_regname=1
					Exit Function
			End If
		End if
		'用户名不能为系统禁止的关键字/审核字/过滤字
		If CheckContent(sUserName,1)<>0 Then
				chk_regname=2
				Exit Function
		End If
		'处理单独的注册关键字
		For i=0 to Ubound(oblog.Keywords4)
			If Trim (oblog.Keywords4(i))<>"" Then
				If Instr(sUserName,LCase(oblog.Keywords4(i)))>0 Then
					chk_regname=3
					Exit Function
				End If
			End if
		Next
		'如果不允许数字ID
		If en_nameisnum=0 Then
			If IsNumeric(sUserName) Then
				chk_regname=4
				Exit Function
			End if
		End if
		'判断是否存在重复
		'Dim rs
	'		Set rs=Execute("select userid from oblog_user where username='"&ProtectSql(sUserName)&"'")
	'		If Not rs.EOF Then
	'			chk_regname=4
	'			Set rs=Nothing
	'			Exit Function
	'		End If	
	'		Set rs=Nothing
		chk_regname=0
	End Function


	'进行IP控制	
	Public Function ChkIpLock()
		Dim IPlock,i, sUserIP, sIP,BalckList,WhiteList,iCheck
		IPlock = False