各大微博短网址(ShortUrl)的asp版算法
各大微博短网址(ShortUrl)的asp版算法,模拟包含了网上的这两种算法：
1.为java版或c#版算法 2.为php算法
代码封装成了一个类了，集成于AspBox开源框架核心ab.url.asp中，具体请看代码：
<% '###################################################################### '## ab.url.asp '## ------------------------------------------------------------------- '## Feature : AspBox Url Block (Plugin) @Single-Page-Version '## Version : v1.0.0 '## Author : Lajox(lajox@19www.com) '## Update Date : 2012/06/15 10:10 (Single-Page) '## Description : AspBox Url Block (Plugin). '## Download : http://code.google.com/p/aspbox-plugin '## You Can Download AspBox(An Open Source Asp Framework) '## From: http://code.google.com/p/aspbox '###################################################################### Class Cls_AB_URL Private s_prefix, s_suffix '用于短网址生成的混合KEY, 分别是：前缀 和 后缀 Private s_by '用于短网址生成的指定算法 Private m_lPower2(31) Private Sub Class_Initialize() s_prefix = "" s_suffix = "" s_by = "" End Sub Private Sub Class_Terminate() End Sub '@ ****************************************************************** '@ 属性值: oUrl.By [= s] 可读/写 '@ 返 回: String (字符串) "0" 或 "1" '@ 作 用: 设置/获取 用于短网址生成的指定算法 '@ 注：By值的默认值缺省为"0"（即采用java版或c#版算法） '==DESC============================================================= '@ 参数 s(可选): String (字符串) 用于短网址生成的指定算法， '@ 值为 "", "0", "java", "c#", "csharp", "c" 这些值时，则算法By值自动转化为："0" '@ 值为 "1", "php" 这些值时，则算法By值自动转化为："1" '==DEMO============================================================= '@ Dim oUrl : Set oUrl = New Cls_AB_URL '@ oUrl.By = "java" '采用java版(或c#) '@ Response.Write oUrl.By 'java版(或c#)对应的By值为"0" '@ ***************************************************************** Public Property Get By() s_by = LCase(s_by) Select Case LCase(s_by) Case "","0","java","c#","csharp","c" : s_by = "0" Case "1","php" : s_by = "1" Case Else : s_by = "0" End Select By = s_by End Property Public Property Let By(byval s) If IsNull(s) Or trim(s)="" Then s = "0" Select Case LCase(Trim(s)) Case "0","java","c#","csharp","c","" : s_by = "0" Case "1","php" : s_by = "1" Case Else : s_by = "0" End Select End Property '-------------------------------------------------------------------- '# oUrl.Prefix 属性 '# @syntax: oUrl.Prefix '# @return: String (字符串) 获取设置的用于短网址生成的混合前缀 '# @dowhat: 设置和获取用于短网址生成的混合前缀,默认值"" '--DESC-------------------------------------------------------------- '# @param: 无参数 '--DEMO-------------------------------------------------------------- '@ Dim oUrl : Set oUrl = New Cls_AB_URL '# oUrl.Prefix = "Lajox" '-------------------------------------------------------------------- Public Property Let Prefix(ByVal p) s_prefix = p End Property Public Property Get Prefix() Prefix = s_prefix End Property '-------------------------------------------------------------------- '# oUrl.Suffix 属性 '# @syntax: oUrl.Suffix '# @return: String (字符串) 获取设置的用于短网址生成的混合后缀 '# @dowhat: 设置和获取用于短网址生成的混合后缀,默认值"" '--DESC-------------------------------------------------------------- '# @param: 无参数 '--DEMO-------------------------------------------------------------- '@ Dim oUrl : Set oUrl = New Cls_AB_URL '# oUrl.Suffix = "Nasrick" '-------------------------------------------------------------------- Public Property Let Suffix(ByVal p) s_suffix = p End Property Public Property Get Suffix() Suffix = s_suffix End Property '------------------------------------------------------------------- '# oUrl.ShortUrl 方法 '# @syntax: arrUrl = oUrl.ShortUrl(url) '# @return: Array (数组) 数组含有4个元素,各元素均包含6位串 '# @dowhat: 实现短网址生成的算法 '# 1.java版或c#版算法（此算法为缺省算法） '# 原理采用各大微博短网址(ShortUrl)的java版或c#版算法 '# 返回值数组含有4个元素,各元素均包含6位串 '# 2.php版算法 '# 原理采用各大微博短网址(ShortUrl)的php版算法 '# 返回值数组含有4个元素,各元素均包含6位串 '# 思路： '# a.将长网址md5生成32位签名串,分为4段, 每段8个字节; '# b.对这四段循环处理, 取8个字节, 将他看成16进制串与0x3fffffff(30位1)与操作, 即超过30位的忽略处理; '# c.这30位分成6段, 每5位的数字作为字母表的索引取得特定字符, 依次进行获得6位字符串; '# d.总的md5串可以获得4个6位串; 取里面的任意一个就可作为这个长url的短url地址; '# 注：数组的4个元素包含6位串，取里面的任意一个就可作为这个长url的短url地址 '# @author: Lajox (2012-06-14 9:25) '--DESC-------------------------------------------------------------- '# @param url: String (字符串) 原网址URL '--DEMO-------------------------------------------------------------- '# Dim oUrl : Set oUrl = New Cls_AB_URL '# dim urls '# '_______(JAVA或C#版算法的实现)_______________ '# oUrl.prefix = "Leejor" '设置用于短网址生成的混合前缀 '# oUrl.suffix = "" '设置用于短网址生成的混合后缀 '# oUrl.by = "java" '算法采用java或c#算法(by值缺省为java) '# urls = oUrl.shorturl("http://www.me3.cn") '# 'urls = oUrl.shorturl_java("http://www.me3.cn") '# Response.Write "<br>" & urls(0) '得到值 fAVfui '# Response.Write "<br>" & urls(1) '得到值 3ayQry '# Response.Write "<br>" & urls(2) '得到值 UZzyUr '# Response.Write "<br>" & urls(3) '得到值 36rQZn '# '_______(php版算法的实现)_______________ '# oUrl.prefix = "" '设置用于短网址生成的混合前缀 '# oUrl.suffix = "" '设置用于短网址生成的混合后缀 '# oUrl.by = "php" '指定算法采用php版算法 '# urls = oUrl.shorturl("http://www.php100.com") '# 'urls = oUrl.shorturl_php("http://www.php100.com") '# Response.Write "<br>" & urls(0) '得到值 cvch1h '# Response.Write "<br>" & urls(1) '得到值 ssjfdx '# Response.Write "<br>" & urls(2) '得到值 zzpkdh '# Response.Write "<br>" & urls(3) '得到值 mbstyx '------------------------------------------------------------------- Public Function ShortUrl(Byval url) Dim Result s_by = LCase(Trim(Me.By)) If s_by="" Or s_by="0" Or s_by="java" Or s_by="c#" Or s_by="csharp" Or s_by="c" Then Result = ShortUrl_Java(url) ElseIf s_by = "1" Or s_by = "php" Then Result = ShortUrl_PHP(url) Else Result = ShortUrl_Java(url) End If ShortUrl = Result End Function Public Function ShortUrl_Java(Byval url) 'java或c#版ShortUrl算法 Dim chars, Hex, subHex, Result chars = Array("a","b","c","d","e","f","g","h","i","j","k","l","m","n","o","p","q","r","s","t","u","v","w","x","y","z","0","1","2","3","4","5","6","7","8","9","A","B","C","D","E","F","G","H","I","J","K","L","M","N","O","P","Q","R","S","T","U","V","W","X","Y","Z") Hex = LCase(Md5(s_prefix & url & s_suffix)) '32位Md5 Result = Array() Dim hexint, index, out, i, j For i = 0 To 3 subHex = Mid(Hex, (i * 8) + 1, 8) Dim temp : temp = Eval("&H" & subHex) hexint = &H3FFFFFFF And (1 * temp) out = "" For j = 0 To 5 index = Cint(&H0000003D And hexint) out = out & chars(index) 'hexint = hexint \ 2^5 '按位右移5位 hexint = RShift(hexint,5) '按位右移5位 Next Result = Push(Result, out) Next ShortUrl_Java = Result End Function Public Function ShortUrl_PHP(Byval url) 'php版ShortUrl算法 Dim base32, Hex, hexLen, subHexLen, subHex, Result base32 = Array("a", "b", "c", "d", "e", "f", "g", "h","i", "j", "k", "l", "m", "n", "o", "p","q", "r", "s", "t", "u", "v", "w", "x","y", "z", "0", "1", "2", "3", "4", "5") Hex = LCase(Md5(s_prefix & url & s_suffix)) '32位Md5 hexLen = Len(Hex) subHexLen = hexLen / 8 Result = Array() Dim hexint, index, out, i, j For i = 0 To subHexLen-1 subHex = Mid(Hex, (i * 8) + 1, 8) Dim temp : temp = Eval("&H" & subHex) hexint = &H3FFFFFFF And (1 * temp) out = "" For j = 0 To 5 index = &H0000001F And hexint ''Response.Write(index & "<br>") out = out & base32(index) 'hexint = hexint \ 2^5 '按位右移5位 hexint = RShift(hexint,5) '按位右移5位 Next Result = Push(Result, out) Next ShortUrl_PHP = Result End Function Private Function Push(ByVal arr, ByVal s) '向数组中从后压入元素 Dim i, a : a = Clone(arr) If arrLen(arr)<=0 Then : Redim Preserve a(0): a(0) = s: Push = a: Exit Function: End If Redim Preserve a(UBound(arr)+1) a(UBound(arr)+1) = s Push = a End Function Private Function Clone(ByVal arr) '数组克隆(拷贝) Dim i, a() If arrLen(arr)<=0 Then : Clone = arr: Exit Function: End If For i = LBound(arr) To UBound(arr) Redim Preserve a(i) a(i) = arr(i) Next Clone = a End Function Private Function arrLen(Byval arr) '检测(一维)数组长度(元素个数) On Error Resume Next If Not IsArray(arr) Then:arrLen=-1:End If Dim temp:temp=Ubound(arr) If Err Or temp<0 Then:arrLen=0:Err.Clear:Exit Function:End If Dim i,iCount:iCount=0 For i=Lbound(arr) To Ubound(arr) iCount = iCount + 1 Next arrLen = iCount On Error GoTo 0 End Function Private Function LShift(ByVal lThis, ByVal lBits) '向左移位(移位运算) On Error Resume Next Init() If (lBits <= 0) Then LShift = lThis ElseIf (lBits > 63) Then ' .. error ... ElseIf (lBits > 31) Then LShift = 0 Else If (lThis And m_lPower2(31 - lBits)) = m_lPower2(31 - lBits) Then LShift = (lThis And (m_lPower2(31 - lBits) - 1)) * m_lPower2(lBits) Or m_lPower2(31) Else LShift = (lThis And (m_lPower2(31 - lBits) - 1)) * m_lPower2(lBits) End If End If On Error Goto 0 End Function Private Function RShift(ByVal lThis, ByVal lBits) '向右移位(移位运算) On Error Resume Next Init() If (lBits <= 0) Then RShift = lThis ElseIf (lBits > 63) Then ' ... error ... ElseIf (lBits > 31) Then RShift = 0 Else If (lThis And m_lPower2(31)) = m_lPower2(31) Then RShift = (lThis And &H7FFFFFFF) \ m_lPower2(lBits) Or m_lPower2(31 - lBits) Else RShift = lThis \ m_lPower2(lBits) End If End If On Error Goto 0 End Function Private Sub Init() On Error Resume Next m_lPower2(0) = &H1& m_lPower2(1) = &H2& m_lPower2(2) = &H4& m_lPower2(3) = &H8& m_lPower2(4) = &H10& m_lPower2(5) = &H20& m_lPower2(6) = &H40& m_lPower2(7) = &H80& m_lPower2(8) = &H100& m_lPower2(9) = &H200& m_lPower2(10) = &H400& m_lPower2(11) = &H800& m_lPower2(12) = &H1000& m_lPower2(13) = &H2000& m_lPower2(14) = &H4000& m_lPower2(15) = &H8000& m_lPower2(16) = &H10000 m_lPower2(17) = &H20000 m_lPower2(18) = &H40000 m_lPower2(19) = &H80000 m_lPower2(20) = &H100000 m_lPower2(21) = &H200000 m_lPower2(22) = &H400000 m_lPower2(23) = &H800000 m_lPower2(24) = &H1000000 m_lPower2(25) = &H2000000 m_lPower2(26) = &H4000000 m_lPower2(27) = &H8000000 m_lPower2(28) = &H10000000 m_lPower2(29) = &H20000000 m_lPower2(30) = &H40000000 m_lPower2(31) = &H80000000 On Error Goto 0 End Sub End Class %>
...
