<%
Sub SaveReg(IsApi,UserName,PassWord,GroupID,Sex,Email,UserFace,RealName,apitype,OpenId,Token)		 
  Dim RS
  set rs=conn.db("select top 1 {pre}GroupID,{pre}Name,{pre}PassWord,{pre}Question,{pre}Answer,{pre}Email,{pre}RealName,{pre}Sex,{pre}Face,{pre}RegDate,{pre}BeginDate,{pre}JoinDate,{pre}LastLoginTime,{pre}RndPassword,{pre}LoginTimes,{pre}PostNum,{pre}Money,{pre}Score,{pre}Point,{pre}Locked,{pre}ChargeType,{pre}IsAPI,{pre}LastLoginIP,{pre}QQOpenId,{pre}QQToken,{pre}SinaId,{pre}SinaToken,{pre}alipayID from {pre}user where {pre}name='"&username&"'","records3")
  if not rs.eof then
	rs.close:set rs=nothing
	conn.die"您输入的用户名已被使用，请换个名称！"
  end if
  RS.AddNew
  RS(0)=GroupID
  RS(1)=UserName
  RS(2)=PassWord
  RS(3)=""
  RS(4)=""
  RS(5)=Email
  RS(6)=RealName
  RS(7)=Sex
  RS(8)=UserFace
  RS(9)=Now
  RS(10)=Now'开始计算时间
  RS(11)=Now
  RS(12)=Now
  RS(13)=PassWord
  RS(14)=1
  RS(15)=0'新会员注册，更新相应的数据
  RS(16)=0
  RS(17)=0
  RS(18)=0
  RS(19)=0
  RS(20)=1
  RS(21)=IsAPI
  RS(22)=fun.GetIP
  if apitype="qq" then
    RS(23)=OpenId
    RS(24)=Token
  elseif apitype="sina" then
    RS(25)=OpenId
    RS(26)=Token
  elseif apitype="alipay" then
    RS(27)=OpenId
  end if
  RS.Update
  RS.MoveLast
  RS.Close
'===================写入个人空间================
'  if KS.SSetting(0)=1 And KS.SSetting(1)=1 then
'	RS.Open "Select top 1 * From KS_Blog Where 1=0",conn,1,3
'	RS.AddNew
'	RS("AddDate")=Now
'	RS("UserID")=UserID
'	RS("UserName")=UserName
'	RS("BlogName")=UserName & "的个人空间"
'	RS("ClassID") = KS.ChkClng(Conn.Execute("Select Top 1 ClassID From KS_BlogClass")(0))
'	If UserType=1 Then
'	RS("TemplateID")=KS.ChkClng(Conn.Execute("Select Top 1 ID From KS_BlogTemplate Where flag=4 and IsDefault='true'")(0))
'	Else
'	RS("TemplateID")=KS.ChkClng(Conn.Execute("Select Top 1 ID From KS_BlogTemplate Where flag=2 and IsDefault='true'")(0))
'	End If
'	RS("Announce")="暂无公告!"
'	RS("ContentLen")=500
'	RS("Recommend")=0
'	if KS.SSetting(2)=1 then
'	RS("Status")=0
'	else
'	RS("Status")=1
'	end if
'	RS.Update
'	RS.Close
'	Set RS=Nothing
'  End If
''''''''''''''''''''''''''''''''''''''''''''''
  Call DoLogin(userName,PassWord)
End Sub
'允许快速自动注册登录
'参数：tips 标题提示信息,username 昵称 userface 头像 sex 性别,openid 接口唯一返回的ID
Sub DoBind(tips,RealName,userface,sex,apitype,OpenId,Token)'快速自动注册登录
  Dim Email,Api_GroupID,PassWord,UserName
  Api_GroupID=2 '默认用户组
  Email=""
  UserName=year(now)&month(now)&day(now)&hour(now)&fun.MakeRandom(4)
  PassWord=fun.MakeRandomChar(15)'生成随机密码
  Call SaveReg(1,UserName,PassWord,Api_GroupID,Sex,Email,UserFace,RealName,apitype,OpenId,Token)'保存
  conn.echo "注册完成" 
End Sub
'获得用户信息
'参数：apitype 接口类型 1 qq 2新浪
function get_user_info(ApiType,access_token,openid)
  dim url
  if apitype="1" then 'qq
	url = "https://graph.qq.com/user/get_user_info"
	get_user_info = getRemoteContent(url,"access_token="&access_token&"&oauth_consumer_key="&appid &"&openid="&openid&"&format=json","text","get")
  elseif apitype="2" then '新浪
	url = "https://api.weibo.com/2/users/show.json"
	get_user_info = getRemoteContent(url,"access_token="&access_token&"&uid="&openid,"text","get")
  end if
end function
Function getRemoteContent(Byval url,Byval postdata,Byval returnType,Byval method)
  if not isObject(gXmlHttpObj) then:set gXmlHttpObj=tryXmlHttp():End if
  On error resume next
  if method="post" then
	gXmlHttpObj.open"POST",url,False     
	gXmlHttpObj.setRequestHeader "Content-Length", Len(postdata)
	gXmlHttpObj.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
	gXmlHttpObj.send(postdata) 
  else
	gXmlHttpObj.open"GET",url&"?"&postdata,False     
	gXmlHttpObj.send() 
  end if
  if err.number=-2147012889  then
	dim des
	select case gXmlHttpObj.readyState
	  Case 1:des="解析域名或连接远程服务器"
	  Case 2:des="发送请求"
	  Case 3:des="接收数据"
	  Case else:des="未知阶段"
	End select
  else
	select case returnType
	  case"text":getRemoteContent=gXmlHttpObj.responseText
	  case"body":getRemoteContent=gXmlHttpObj.responseBody
	End select
  End if
End Function
dim gXmlHttpObj
Function tryXmlHttp()
  dim i,ah:ah=array("MSXML2.ServerXMLHTTP.3.0","MSXML2.ServerXMLHTTP.5.0","MSXML2.ServerXMLHTTP.4.0","MSXML2.ServerXMLHTTP.2.0","MSXML2.ServerXMLHTTP","MSXML2.ServerXMLHTTP.6.0","Microsoft.XMLHTTP","MSXML2.XMLHTTP","MSXML2.XMLHTTP.3.0","MSXML2.XMLHTTP.4.0","MSXML2.XMLHTTP.5.0")
  On Error Resume Next
  for i=0 to UBound(ah)
	SET tryXmlHttp=Server.CreateObject(ah(i))
	if err.number=0 then:gXmlHttpVer=ah(i):tryXmlHttp.setTimeouts 2000,20000,20000,180000:err.clear:Exit Function:else:err.clear:End if
  next
End Function
function parse_str(str)'将url变成集合
  dim objData,aryData,i,aryT
  set objData=Server.CreateObject("Scripting.Dictionary")
  aryData=split(str,"&")
  for i=0 to ubound(aryData)
	 aryT=split(aryData(i),"=")
	 if ubound(aryT)>0 then 
	  objData.add aryT(0),aryT(1)
	 else
	  objData.add aryT(0),""
	 End if
  next
  set parse_str=objData
End function
Function CheckXSS(ByVal Str)'过滤xss
	If IsNull(Str) Then
		CheckStr = ""
		Exit Function
	End If
	Str = Replace(Str, "&", "&amp;")
	Str = Replace(Str, "'", "&acute;")
	Str = Replace(Str, """", "&quot;")
		Str = Replace(Str, "<", "&lt;")
		Str = Replace(Str, ">", "&gt;")
		Str = Replace(Str, "/", "&#47;")
		Str = Replace(Str, "*", "&#42;")
	Dim re
	Set re = New RegExp
	re.IgnoreCase = True
	re.Global = True
	re.Pattern = "(w)(here)"
	Str = re.Replace(Str, "$1h&#101;re")
	re.Pattern = "(s)(elect)"
	Str = re.Replace(Str, "$1el&#101;ct")
	re.Pattern = "(i)(nsert)"
	Str = re.Replace(Str, "$1ns&#101;rt")
	re.Pattern = "(c)(reate)"
	Str = re.Replace(Str, "$1r&#101;ate")
	re.Pattern = "(d)(rop)"
	Str = re.Replace(Str, "$1ro&#112;")
	re.Pattern = "(a)(lter)"
	Str = re.Replace(Str, "$1lt&#101;r")
	re.Pattern = "(d)(elete)"
	Str = re.Replace(Str, "$1el&#101;te")
	re.Pattern = "(u)(pdate)"
	Str = re.Replace(Str, "$1p&#100;ate")
	re.Pattern = "(\s)(or)"
	Str = re.Replace(Str, "$1o&#114;")
		re.Pattern = "(\n)"
	Str = re.Replace(Str, "$1o&#114;")
	'----------------------------------
		re.Pattern = "(java)(script)"
	Str = re.Replace(Str, "$1scri&#112;t")
		re.Pattern = "(j)(script)"
	Str = re.Replace(Str, "$1scri&#112;t")
		re.Pattern = "(vb)(script)"
	Str = re.Replace(Str, "$1scri&#112;t")
	'----------------------------------
	If Instr(Str, "expression") > 0 Then
			Str = Replace(Str, "expression", "e&#173;xpression", 1, -1, 0) '防止xss注入
	End If
	Set re = Nothing
	Checkxss = Str
End Function
Sub DoLogin(userName,Password)'登录成功后调用登录函数进行登录
  Dim UserRS
  Set UserRS=conn.db("Select top 1 {pre}Locked,{pre}GroupID,{pre}Score,{pre}PostNum,{pre}ClubSpecialPower,{pre}ID From {pre}User Where {pre}Name='" &UserName & "' And {pre}PassWord='" & PassWord & "'","records1")
  If UserRS.Eof And UserRS.BOf Then
	UserRS.Close:Set UserRS=Nothing
	conn.die "你输入的用户名或密码有误，请重新输入!"
  ElseIf UserRS(0)=1 Then
	conn.Die "您的账号已被管理员锁定，请与管理员联系!"
  ElseIf UserRS(0)=2 Then
	conn.Die "您的账号未审核，不能登录!"
  ElseIf UserRS(0)=3 Then
	conn.Die"您的账号未激活，不能登录!"
  Else
	GroupID=UserRS(1)'登录成功，更新用户相应的数据
	Dim RndPassword:RndPassword=fun.MakeRandomChar(20)
	Dim CurrScore:CurrScore=UserRS(2)
	Dim GroupID:GroupID=UserRS(1)
	Dim PostNum:PostNum=UserRS(3)
	Dim ClubSpecialPower:ClubSpecialPower=fun.ChkClng(3)
	conn.db"Update {pre}User Set {pre}LastLoginIP='" & conn.GetIP &"',{pre}LastLoginTime=" & SQLNowString &",	{pre}LoginTimes={pre}LoginTimes+1,{pre}RndPassWord='" & RndPassWord &"' Where {pre}ID=" & UserRS(5),"execute"'更新登录信息	
	End if
	conn.wCookie "pre_userid",UserRS(5)
	conn.wCookie "pre_username",UserName
	conn.wCookie "pre_password",Password
	UserRS.Close : Set UserRS=Nothing
    Response.Redirect "/user/"
End Sub
%>
<script language="javascript" type="text/javascript" runat="server">
function getjson(str){
  try{eval("var jsonStr=("+str+")");}
  catch(ex){var jsonStr=null;}
  return jsonStr;
}
</script>
