puny.asp

puny.asp

<%
' *********************************************************************
' ** DISCLAIMER AND LICENSE                                          **
' ** The author of this code makes no guarantees and is not          **
' ** responsible for any damage resulting from its use.              **
' ** You may modify the code for your own use in any way you like,   **
' ** but it may only be distributed in its original form.            **
' ** The VBScript punycode conversion functions in this code is      **
' ** derived from the sample C code in RFC 3492.                     **
' ** Author: Jesper G. Høy - JH Software ApS - www.jhsoft.com        **
' *********************************************************************

Const IDN_VALID_CHARS = "abcdefghijklmnopqrstuvwxyz0123456789-"

Function IIf(a, b, c)
	If a Then IIf = b Else IIf = c
End Function

Function DomainPunyEncode(ByVal domStr)
	Dim i, segStr, segPuny, x, outStr
	domStr = LCase(Trim(domStr))
	outStr = ""
	While Len(domStr) > 0
		i = Instr(domStr,".")-1
		If i < 0 Then i = Len(domStr)
		If i = 0 Then Err.Raise vbObjectError + 513, , "Invalid placement of dot in domain name"
		If i > 63 Then Err.Raise vbObjectError + 513, , "Invalid domain name - segment between dots longer than 63 characters"
		segStr = Left(domStr,i)
		domStr = Mid(domStr, i + 2)
		segPuny = False
		
		'check valid chars
		For i = 1 To Len(segStr) 
			If AscW(Mid(segStr,i,1)) > 127 Then
				segPuny = True
			Else
				If Instr(IDN_VALID_CHARS, Mid(segStr, i, 1)) = 0 Then Err.Raise vbObjectError + 513, , "Invalid character in domain name"
			End If
		Next
		If segPuny Then x = "xn--" & PunyEncode(segStr) Else x = segStr
		If Len(x) > 63 Then Err.Raise vbObjectError + 513, , "Invalid domain name - encoded segment longer than 63 characters"
		outStr = outStr & IIf(Len(outStr) > 0, ".", "") & x
	Wend
	DomainPunyEncode=outStr
End Function

Function PunyEncodeDigit(ByVal dgVal)
	If dgVal < 26 Then
		PunyEncodeDigit=Chr(97 + dgVal)
	ElseIf dgVal < 36 Then
		PunyEncodeDigit=Chr(22 + dgVal)
	Else
		Err.Raise vbObjectError + 513, , "Bad value for punycode digit encoding"
	End If
End Function

Function PunyAdapt(ByVal delta, ByVal numpoints, ByVal firsttime)
	dim k
	
	delta = IIf(firsttime, delta \ 700, delta \ 2)
	delta = delta + delta \ numpoints
	k = 0
	While delta > 455
		delta = delta \ 35
		k = k + 36
	Wend
	PunyAdapt= k + 36 * delta \ (delta + 38)
End Function

Function PunyEncode(ByVal uc)
	Dim j, t, outStr, n, delta, bias, h, b, m, q, k
	outStr = ""
	n = 128
	delta = 0
	bias = 72
	
	'handle the basic code points
	For j = 1 To Len(uc)
		If AscW(Mid(uc, j, 1)) < 128 Then outStr = outStr & Lcase(Mid(uc, j, 1))
	Next
	
	h = Len(outStr)
	b = h
	If b > 0 Then outStr = outStr & "-"
	
	'main encoding loop
	While h < Len(uc)
		m = -1
		For j = 1 To Len(uc)
			If AscW(Mid(uc, j, 1)) >= n And (m = -1 Or AscW(Mid(uc, j, 1)) < m) Then m = AscW(Mid(uc, j, 1))
		Next
		delta = delta + (m - n) * (h + 1)
		n = m
		
		For j = 1 To Len(uc)
			If AscW(Mid(uc, j, 1)) < n Then delta = delta + 1
			If AscW(Mid(uc, j, 1)) = n Then
				q = delta
				k = 36
				Do
					t = IIf(k <= bias, 1, IIf(k >= bias + 26, 26, k - bias))
					If q < t Then Exit Do
					outStr = outStr & PunyEncodeDigit(t + (q - t) Mod (36 - t))
					q = (q - t) \ (36 - t)
					k = k+ 36
				Loop
				outStr = outStr & PunyEncodeDigit(q)
				bias = PunyAdapt(delta, h + 1, h = b)
				delta = 0
				h = h + 1
			End If
		Next
		delta = delta + 1
		n = n + 1
	Wend
	
	PunyEncode = outStr
End Function

Function DomainPunyDecode(ByVal domStr)
	Dim i, segStr, outStr
	domStr = LCase(Trim(domStr))
	outStr = ""
	While Len(domStr) > 0
		i = instr(domStr,".")-1
		If i < 0 Then i = Len(domStr)
		If i = 0 Then Err.Raise vbObjectError + 513, , "Invalid placement of dot in domain name"
		If i > 63 Then Err.Raise vbObjectError + 513, , "Invalid domain name - segment between dots longer than 63 characters"
		segStr =Left(domStr,i)
		domStr = Mid(domStr, i + 2)
		
		'check valid chars
		For i = 1 To Len(segStr)
			If instr(IDN_VALID_CHARS, Mid(segstr,i,1))=0 Then Err.Raise vbObjectError + 513, , "Invalid character in domain name"
		Next
		
		If Left(segStr, 4) = "xn--" Then
			outStr=outStr & IIf(Len(outStr) > 0, ".", "") & PunyDecode(Mid(segStr,5))
		Else
			outStr=outStr & IIf(Len(outStr) > 0, ".", "") & segStr
		End If
	Wend
	DomainPunyDecode=outStr
End Function

Function PunyDecode(ByVal pc)
	Dim outBufPos, i, digit, outStr, bias, n, t, pcPos, oldi, w, k
	outBufPos = 0
	outStr = ""
	
	'handle basic code points (clear text)
	i = InStrRev(pc, "-") - 1
	If i >= 0 Then
		outBufPos = i
		outStr =Left(pc,i)
		pc =Mid(pc,i+2)
	End If
	
	'main decoding loop
	i = 0
	bias = 72
	n = 128
	pcPos = 0
	
	Do While pcPos < Len(pc)
	oldi = i
	w = 1
	k = 36
	Do
		If pcPos >= Len(pc) Then Err.Raise vbObjectError + 513, , "Not a valid punycode domain. Bad input."
		digit = PunyDecodeDigit(AscW(Mid(pc, pcPos+1, 1)))
		pcPos = pcPos + 1
		i = i + digit * w
		t = IIf(k <= bias, 1, IIf(k >= bias + 26, 26, k - bias))
		If digit < t Then Exit Do
		w = w * (36 - t)
		k = k + 36
	Loop
	
	bias = PunyAdapt(i - oldi, outBufPos + 1, (oldi = 0))
	n = n+ i \ (outBufPos + 1)
	i = i Mod (outBufPos + 1)
	
	'insert n at position i of the output
	outStr = Left(outStr, i) & ChrW(n) & Mid(outStr, i + 1)
	i=i+1
	
	'prepare next loop
	outBufPos=outBufPos+1
	Loop
	
	PunyDecode=outStr
End Function

Function PunyDecodeDigit(ByVal ascVal)
	If ascVal >= 65 And ascVal <= 90 Then
		PunyDecodeDigit=ascVal - 65
	ElseIf ascVal >= 97 And ascVal <= 122 Then
		PunyDecodeDigit=ascVal - 97
	ElseIf ascVal >= 48 And ascVal <= 57 Then
		PunyDecodeDigit=ascVal - 22
	Else
		Err.Raise vbObjectError + 513, , "Not a valid punycode domain. Bad input."
	End If
End Function
%>