[风之影]文本BASE64编码解码

cabinsummer · 发表于 2017-10-21 23:24

本帖最后由 cabinsummer 于 2017-10-31 12:51 编辑

近期用到BASE64编码，用XMLDOM加ADODB.Stream的方法没试成功。百度了一些LISP方法，觉得效率太低，所以自己写了一个文本BASE64编码的函数。数字lsh和logand确实比十进制转二进制再查表快不知多少倍，顺便用了一下gcd函数。
因为LISP不能直接操作二进制数据，所以只好先拿文本来试试。函数如下：

(defun Base64Encode (str / strlst n i map ad y base64 a b c s)
(setq map "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
(setq strlst (vl-string->list str))
(setq n (/ (length strlst) 3))
(setq ad "")
(if (= (gcd (length strlst) 3) 1)(setq n (1+ n)))
(setq i 0)
(repeat n
(if (< i (length strlst))(setq a (append a (list (nth i strlst)))))
(if (< (1+ i) (length strlst))(setq b (append b (list (nth (1+ i) strlst)))))
(if (< (+ i 2) (length strlst))(setq c (append c (list (nth (+ i 2) strlst)))))
(setq i (+ i 3))
)
(if (< (length b)(length a))(setq ad (strcat ad "=") b (append b (list 0))))
(if (< (length c)(length a))(setq ad (strcat ad "=") c (append c (list 0))))
(setq s (apply 'strcat (mapcar '(lambda(x)(substr map (1+ x) 1)) (foreach x (mapcar '(lambda(x)(alter34 x)) (mapcar '(lambda(x y z)(list x y z)) a b c)) (setq y (append y x))))))
(setq s (strcat (substr s 1 (- (strlen s)(strlen ad))) ad))
(setq base64 "" i 1)
(if (zerop (rem (strlen s) 76))(/ (strlen s) 76)(1+ (/ (strlen s) 76)))
(repeat (if (zerop (rem (strlen s) 76))(/ (strlen s) 76)(1+ (/ (strlen s) 76)))
(setq base64 (strcat base64 "\n" (substr s i 76)) i (+ i 76))
)
(substr base64 2)
)
(defun alter34 (lst3 / n1 n2 n3 m1 m2 m3 m4)
(setq n1 (car lst3) n2 (cadr lst3) n3 (last lst3))
(setq m1 (lsh n1 -2) m2 (+ (lsh (logand n1 3) 4) (lsh (logand n2 240) -4)) m3 (+ (lsh (logand n2 15) 2) (lsh (logand n3 192) -6)) m4 (logand n3 63))
(list m1 m2 m3 m4)
)

(defun Base64Encode (str / strlst n i map ad y base64 a b c s) 
  (setq map "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") 
  (setq strlst (vl-string->list str)) 
  (setq n (/ (length strlst) 3)) 
  (setq ad "") 
  (if (= (gcd (length strlst) 3) 1)(setq n (1+ n))) 
  (setq i 0) 
  (repeat n 
    (if (
    (if (< (1+ i) (length strlst))(setq b (append b (list (nth (1+ i) strlst))))) 
    (if (< (+ i 2) (length strlst))(setq c (append c (list (nth (+ i 2) strlst))))) 
    (setq i (+ i 3)) 
  ) 
  (if (< (length b)(length a))(setq ad (strcat ad "=") b (append b (list 0)))) 
  (if (< (length c)(length a))(setq ad (strcat ad "=") c (append c (list 0)))) 
  (setq s (apply 'strcat (mapcar '(lambda(x)(substr map (1+ x) 1)) (foreach x (mapcar '(lambda(x)(alter34 x)) (mapcar '(lambda(x y z)(list x y z)) a b c)) (setq y (append y x)))))) 
  (setq s (strcat (substr s 1 (- (strlen s)(strlen ad))) ad)) 
  (setq base64 "" i 1) 
  (if (zerop (rem (strlen s) 76))(/ (strlen s) 76)(1+ (/ (strlen s) 76))) 
  (repeat (if (zerop (rem (strlen s) 76))(/ (strlen s) 76)(1+ (/ (strlen s) 76))) 
    (setq base64 (strcat base64 "\n" (substr s i 76)) i (+ i 76)) 
  ) 
  (substr base64 2) 
) 
 
(defun alter34 (lst3 / n1 n2 n3 m1 m2 m3 m4) 
  (setq n1 (car lst3) n2 (cadr lst3) n3 (last lst3)) 
  (setq m1 (lsh n1 -2) m2 (+ (lsh (logand n1 3) 4) (lsh (logand n2 240) -4)) m3 (+ (lsh (logand n2 15) 2) (lsh (logand n3 192) -6)) m4 (logand n3 63)) 
  (list m1 m2 m3 m4) 
)

测试：

(setq txt "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure.")
(base64encode txt)

结果已经把\n显示为换行
TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz
IHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg
dGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu
dWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo
ZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=

Base64解码函数

(defun Base64Decode (str / map ad s1 i lst a b c d ss)
(setq map "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
(setq lst (vl-remove-if '(lambda(x)(= x 10)) (vl-string->list str)))
(if (member 61 lst)
(setq ad (length (member 61 lst)))
(setq ad 0)
)
(setq lst (mapcar '(lambda(x)(vl-string-position (ascii x) map)) (mapcar 'chr (subst 65 61 lst))))
(setq i 0)
(repeat (/ (length lst) 4)
(setq a (append a (list (nth i lst))))
(setq b (append b (list (nth (1+ i) lst))))
(setq c (append c (list (nth (+ i 2) lst))))
(setq d (append d (list (nth (+ i 3) lst))))
(setq i (+ i 4))
)
(setq ss (apply 'strcat (mapcar 'vl-list->string (mapcar '(lambda(u)(alter43 u)) (mapcar '(lambda(w x y z)(list w x y z)) a b c d)))))
(substr ss 1 (- (strlen ss) ad))
)
(defun alter43 (lst4 / n1 n2 n3 n4 m1 m2 m3)
(setq n1 (car lst4))
(setq n2 (cadr lst4))
(setq n3 (caddr lst4))
(setq n4 (last lst4))
(setq m1 (+ (lsh n1 2)(lsh (logand n2 48) -4)))
(setq m2 (+ (lsh (logand n2 15) 4) (lsh (logand n3 60) -2)))
(setq m3 (+ (lsh (logand n3 3) 6) n4))
(list m1 m2 m3)
)

(defun Base64Decode (str / map ad s1 i lst a b c d ss) 
  (setq map "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") 
  (setq lst (vl-remove-if '(lambda(x)(= x 10)) (vl-string->list str))) 
  (if (member 61 lst) 
    (setq ad (length (member 61 lst))) 
    (setq ad 0) 
  ) 
  (setq lst (mapcar '(lambda(x)(vl-string-position (ascii x) map)) (mapcar 'chr (subst 65 61 lst)))) 
  (setq i 0) 
  (repeat (/ (length lst) 4) 
    (setq a (append a (list (nth i lst)))) 
    (setq b (append b (list (nth (1+ i) lst)))) 
    (setq c (append c (list (nth (+ i 2) lst)))) 
    (setq d (append d (list (nth (+ i 3) lst)))) 
    (setq i (+ i 4)) 
  ) 
  (setq ss (apply 'strcat (mapcar 'vl-list->string (mapcar '(lambda(u)(alter43 u)) (mapcar '(lambda(w x y z)(list w x y z)) a b c d))))) 
  (substr ss 1 (- (strlen ss) ad)) 
) 
 
(defun alter43 (lst4 / n1 n2 n3 n4 m1 m2 m3) 
  (setq n1 (car lst4)) 
  (setq n2 (cadr lst4)) 
  (setq n3 (caddr lst4)) 
  (setq n4 (last lst4)) 
  (setq m1 (+ (lsh n1 2)(lsh (logand n2 48) -4))) 
  (setq m2 (+ (lsh (logand n2 15) 4) (lsh (logand n3 60) -2))) 
  (setq m3 (+ (lsh (logand n3 3) 6) n4)) 
  (list m1 m2 m3) 
)

dcl1214 · 发表于 2020-1-8 00:12

(defun $str->base64$
(str / code *SCR DATA)
;大于20kb后速度很慢
(if (and STR (= (type str) 'str))
(if (or
*SCR
(setq
*SCR (vlax-create-object
"Aec32BitAppServer.AecScriptControl.1"
)
)
(setq *SCR (vlax-create-object "ScriptControl"))
)
(progn
(vlax-put *SCR 'language "VBScript")
(setq code
"Base64Encode(str)
Function Base64Encode(byVal s)
b=\"\"
h=\"\"
bs=\"\"
n=0
For i=1 to len(s)
h=h & StrToHex(Mid(s, i, 1))
Next
For i=1 to len(h) Step 2
b=b & HexToBin(Mid(h,i,2))
Next
For i=1 to len(b) Step 6
n=n+1
t=(Mid(b,i,6))
If len(t) <> 6 Then
t=Left(t & \"000000\", 6)
End If
bs=bs & BinToChr(BinToDec(t))
Next
m=n Mod 4
If m =2 Then
bs=bs & \"==\"
End If
If m =3 Then
bs=bs & \"=\"
End If
Base64Encode=bs
End Function
Function StrToHex(byVal s)
h=\"\"
c=\"&H\" & Hex(AscW(s))
If c >= &H0001 And c <= &H007F Then
h=h & Hex(c)
ElseIf c > &H07FF Then
h=h & Hex(&HE0 Or (c\\(2^12) And &H0F))
h=h & Hex(&H80 Or (c\\(2^6) And &H3F))
h=h & Hex(&H80 Or (c\\(2^0) And &H3F))
Else
h=h & Hex(&HC0 Or (c\\(2^6) And &H1F))
h=h & Hex(&H80 Or (c\\(2^0) And &H3F))
End If
StrToHex=h
End Function
Function HexToBin(byVal s)
b=\"\"
dec=Clng(\"&H\" & s)
Do While dec > 0
b=dec Mod 2 & b
dec=dec \\ 2
Loop
b=Right(\"00000000\" & CStr(b), 8)
HexToBin=b
End Function
Function BinToDec(byVal s)
d=0
For i=6 to 1 Step -1
d=d + CInt(Mid(s, i, 1)) * 2 ^ (6 - i)
Next
BinToDec=d
End Function
Function BinToChr(byVal s)
dic=\"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\"
BinToChr=Mid(dic, s+1, 1)
End Function"
)
(if (and
(not (vl-catch-all-error-p
(vl-catch-all-apply
'vlax-invoke
(list *SCR
'addcode
code
)
)
)
)
(not (vl-catch-all-error-p
(setq str (vl-catch-all-apply
'vlax-invoke
(list *SCR
'run
"Base64Encode"
str
)
)
)
)
)
)
()
(setq str nil)
)
(if *SCR
(vlax-release-object *SCR)
)
)
(progn (print "调用VBScript转码失败，组件未找到"))
)
)
str
)

(defun $str->base64$ 
    (str / code *SCR DATA) 
          ;大于20kb后速度很慢 
  (if (and STR (= (type str) 'str)) 
    (if  (or 
    *SCR 
    (setq 
      *SCR (vlax-create-object 
       "Aec32BitAppServer.AecScriptControl.1" 
     ) 
    ) 
    (setq *SCR (vlax-create-object "ScriptControl")) 
  ) 
      (progn 
  (vlax-put *SCR 'language "VBScript") 
  (setq code 
         "Base64Encode(str) 
  Function Base64Encode(byVal s) 
  b=\"\" 
  h=\"\" 
  bs=\"\" 
  n=0   
  For i=1 to len(s) 
  h=h & StrToHex(Mid(s, i, 1))   
  Next 
  For i=1 to len(h) Step 2   
  b=b & HexToBin(Mid(h,i,2)) 
  Next 
  For i=1 to len(b) Step 6 
  n=n+1 
  t=(Mid(b,i,6)) 
  If len(t) <> 6 Then   
  t=Left(t & \"000000\", 6) 
  End If 
  bs=bs & BinToChr(BinToDec(t)) 
  Next 
  m=n Mod 4 
  If m =2 Then   
  bs=bs & \"==\" 
  End If 
  If m =3 Then 
  bs=bs & \"=\"   
  End If 
  Base64Encode=bs   
  End Function 
  Function StrToHex(byVal s)   
  h=\"\" 
  c=\"&H\" & Hex(AscW(s))   
  If c >= &H0001 And c <= &H007F Then   
  h=h & Hex(c) 
  ElseIf c > &H07FF Then   
  h=h & Hex(&HE0 Or (c\\(2^12) And &H0F)) 
  h=h & Hex(&H80 Or (c\\(2^6) And &H3F)) 
  h=h & Hex(&H80 Or (c\\(2^0) And &H3F)) 
  Else 
  h=h & Hex(&HC0 Or (c\\(2^6) And &H1F)) 
  h=h & Hex(&H80 Or (c\\(2^0) And &H3F)) 
  End If 
  StrToHex=h 
  End Function 
  Function HexToBin(byVal s) 
  b=\"\" 
  dec=Clng(\"&H\" & s) 
  Do While dec > 0 
  b=dec Mod 2 & b 
  dec=dec \\ 2 
  Loop 
  b=Right(\"00000000\" & CStr(b), 8) 
  HexToBin=b 
  End Function 
  Function BinToDec(byVal s) 
  d=0 
  For i=6 to 1 Step -1 
  d=d + CInt(Mid(s, i, 1)) * 2 ^ (6 - i) 
  Next 
  BinToDec=d 
  End Function 
  Function BinToChr(byVal s) 
  dic=\"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\" 
  BinToChr=Mid(dic, s+1, 1) 
  End Function" 
  ) 
  (if (and 
        (not (vl-catch-all-error-p 
         (vl-catch-all-apply 
           'vlax-invoke 
           (list *SCR 
           'addcode 
           code 
           ) 
         ) 
       ) 
        ) 
        (not (vl-catch-all-error-p 
         (setq str (vl-catch-all-apply 
         'vlax-invoke 
         (list *SCR 
               'run 
               "Base64Encode" 
               str 
         ) 
             ) 
         ) 
       ) 
        ) 
      ) 
    () 
    (setq str nil) 
  ) 
  (if *SCR 
    (vlax-release-object *SCR) 
  ) 
      ) 
      (progn (print "调用VBScript转码失败，组件未找到")) 
    ) 
  ) 
  str 
)

Gu_xl · 发表于 2017-10-24 09:31

本帖最后由 Gu_xl 于 2017-10-24 09:34 编辑

XLRX函数库提供相应的Base64功能如下：
XLRX-String-Base64Encode
功能:将指定的字串编码为Base64字符串    语法: (XLRX-String-Base64Encode String)
参数:    String 字符串
返回值: 成功返回Base64字符串 ,否则返回nil
XLRX-String-Base64Decode
功能:将指定的Base64字符串解码 语法: (XLRX-String-Base64Decode String)
参数:    String Base64字符串
返回值: 成功返回字符串 ,否则返回nil
XLRX-File-Base64Encode
语法1: (XLRX-File-Base64Encode Filename [Flag])
   功能:将指定二进制文件编码为Base64编码字串或Base64编码字串表
   参数:   Filename 指定的文件名称。
         Flag 可选参数，存在且不为nil时，返回Base64编码字串表，否则返回Base64编码字串
   返回值: 成功返回Base64编码字串或Base64编码字串表，否则返回nil
   语法2: (XLRX-File-Base64Encode Filename SaveName [Flag])
   功能:将指定二进制文件编码为Base64编码文本文件
   参数:       Filename 指定的文件名称。
   SaveName 要保存的文本文件名称
   Flag 可选参数，存在且不为nil时，文本文件保存为Base64编码字串表，否则文本文件中直接Base64编码字串
   返回值: 成功返回T，否则返回nil
XLRX-File-Base64Decode
功能:将Base64编码字串转为二进制文件保存
语法: (XLRX-File-Base64Decode strBase64 Filename)
      参数:       strBase64 Base64编码字串
   Filename 保存的二进制文件名称。
   返回值: 成功返回T，否则返回nil
另外，二进制文件和文本文件转换提供如下函数：
XLRX-File-Binary2Text
功能:将二进制文件输出为十六进制文本文件
语法: (xlrx-File-Binary2Text BinaryFileName TextFileName)
参数:          BinaryFileName 二进制文件名称
TextFileName 输出的文本文件名称
返回值: 成功返回T，否则返回nil
XLRX-File-Binary2TextStr
功能:将二进制文件输出为十六进制文本字符串
语法: (xlrx-File-Binary2TextStr BinaryFileName)
参数:          BinaryFileName 二进制文件名称
返回值: 成功返回十六进制文本字符串，否则返回nil
XLRX-File-TextStr2Binary
功能:将由函数XLRX-File-Binary2TextStr输出的十六进制文本字符串还原成二进制文件
语法: (xlrx-File-TextStr2Binary TextBuf BinaryFileName)
   参数:          TextBuf 十六进制文本字符串
   BinaryFileName 二进制文件名称
返回值: 成功返回T，否则返回nil
XLRX-File-Text2Binary
功能:将由函数XLRX-File-Binary2Text输出的十六进制文本文件还原成二进制文件
语法: (xlrx-File-Text2Binary TextFileName BinaryFileName)
参数:          TextFileName 文本文件名称
   BinaryFileName 二进制文件名称
   返回值: 成功返回T，否则返回nil

上述两组函数，均可实现任意二进制文件打包到vlx中去！

cabinsummer · 发表于 2017-10-23 22:01

elitefish 发表于 2017-10-23 15:10
用自己的码表可以实现简单的加密

这个完全可以，但是这样加密是有缺陷的，只要拿到一组足够长明文和密文，就破解了。

自贡黄明儒 · 发表于 2017-10-21 23:53

"地板“http://bbs.xdcad.net/forum.php?m ... F2%B0%FC&page=1
功能是不是一样的呢？

cabinsummer · 发表于 2017-10-22 05:17

不是为了打包。用vbs功能会更强大一些，因为vbs可以处理二进制，我这个纯lisp的，就只能处理文本了。

pengfei2010 · 发表于 2017-10-23 09:02

回帖是一种美德！感谢楼主的无私分享谢谢

我爱lisp · 发表于 2017-10-23 13:55

好高达上，base64是用来做什么的？给扫一下盲

elitefish · 发表于 2017-10-23 15:10

用自己的码表可以实现简单的加密

土土木木人 · 发表于 2018-1-9 20:29

回帖是一种美德！感谢楼主的无私分享谢谢

langke52 · 发表于 2018-1-10 14:45

谢谢分享

账号		自动登录	找回密码
密码			注册

[源码] [风之影]文本BASE64编码解码