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

cabinsummer

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

1. (defun Base64Encode (str / strlst n i map ad y base64 a b c s)
   
2.   (setq map "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
   
3.   (setq strlst (vl-string->list str))
   
4.   (setq n (/ (length strlst) 3))
   
5.   (setq ad "")
   
6.   (if (= (gcd (length strlst) 3) 1)(setq n (1+ n)))
   
7.   (setq i 0)
   
8.   (repeat n
   
9.     (if (< i (length strlst))(setq a (append a (list (nth i strlst)))))
   
10.     (if (< (1+ i) (length strlst))(setq b (append b (list (nth (1+ i) strlst)))))
    
11.     (if (< (+ i 2) (length strlst))(setq c (append c (list (nth (+ i 2) strlst)))))
    
12.     (setq i (+ i 3))
    
13.   )
    
14.   (if (< (length b)(length a))(setq ad (strcat ad "=") b (append b (list 0))))
    
15.   (if (< (length c)(length a))(setq ad (strcat ad "=") c (append c (list 0))))
    
16.   (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))))))
    
17.   (setq s (strcat (substr s 1 (- (strlen s)(strlen ad))) ad))
    
18.   (setq base64 "" i 1)
    
19.   (if (zerop (rem (strlen s) 76))(/ (strlen s) 76)(1+ (/ (strlen s) 76)))
    
20.   (repeat (if (zerop (rem (strlen s) 76))(/ (strlen s) 76)(1+ (/ (strlen s) 76)))
    
21.     (setq base64 (strcat base64 "\n" (substr s i 76)) i (+ i 76))
    
22.   )
    
23.   (substr base64 2)
    
24. )
    
25. (defun alter34 (lst3 / n1 n2 n3 m1 m2 m3 m4)
    
26.   (setq n1 (car lst3) n2 (cadr lst3) n3 (last lst3))
    
27.   (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))
    
28.   (list m1 m2 m3 m4)
    
29. )

(defun Base64Encode (str / strlst n i map ad y base64 a b c s)<br />   (setq map "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")<br />   (setq strlst (vl-string->list str))<br />   (setq n (/ (length strlst) 3))<br />   (setq ad "")<br />   (if (= (gcd (length strlst) 3) 1)(setq n (1+ n)))<br />   (setq i 0)<br />   (repeat n<br />     (if (< i (length strlst))(setq a (append a (list (nth i strlst)))))<br />     (if (< (1+ i) (length strlst))(setq b (append b (list (nth (1+ i) strlst)))))<br />     (if (< (+ i 2) (length strlst))(setq c (append c (list (nth (+ i 2) strlst)))))<br />     (setq i (+ i 3))<br />   )<br />   (if (< (length b)(length a))(setq ad (strcat ad "=") b (append b (list 0))))<br />   (if (< (length c)(length a))(setq ad (strcat ad "=") c (append c (list 0))))<br />   (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))))))<br />   (setq s (strcat (substr s 1 (- (strlen s)(strlen ad))) ad))<br />   (setq base64 "" i 1)<br />   (if (zerop (rem (strlen s) 76))(/ (strlen s) 76)(1+ (/ (strlen s) 76)))<br />   (repeat (if (zerop (rem (strlen s) 76))(/ (strlen s) 76)(1+ (/ (strlen s) 76)))<br />     (setq base64 (strcat base64 "\n" (substr s i 76)) i (+ i 76))<br />   )<br />   (substr base64 2)<br /> )<br /> (defun alter34 (lst3 / n1 n2 n3 m1 m2 m3 m4)<br />   (setq n1 (car lst3) n2 (cadr lst3) n3 (last lst3))<br />   (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))<br />   (list m1 m2 m3 m4)<br /> )

测试：

1. (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.")
   
2. (base64encode txt)

(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.")<br /> (base64encode txt)

返回
TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz
IHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg
dGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu
dWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo
ZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=

解码函数

1. (defun Base64Decode (str / map ad s1 i lst a b c d ss)
   
2.   (setq map "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
   
3.   (setq lst (vl-remove-if '(lambda(x)(= x 10)) (vl-string->list str)))
   
4.   (if (member 61 lst)
   
5.     (setq ad (length (member 61 lst)))
   
6.     (setq ad 0)
   
7.   )
   
8.   (setq lst (mapcar '(lambda(x)(vl-string-position (ascii x) map)) (mapcar 'chr (subst 65 61 lst))))
   
9.   (setq i 0)
   
10.   (repeat (/ (length lst) 4)
    
11.     (setq a (append a (list (nth i lst))))
    
12.     (setq b (append b (list (nth (1+ i) lst))))
    
13.     (setq c (append c (list (nth (+ i 2) lst))))
    
14.     (setq d (append d (list (nth (+ i 3) lst))))
    
15.     (setq i (+ i 4))
    
16.   )
    
17.   (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)))))
    
18.   (substr ss 1 (- (strlen ss) ad))
    
19. )
    
20. (defun alter43 (lst4 / n1 n2 n3 n4 m1 m2 m3)
    
21.   (setq n1 (car lst4))
    
22.   (setq n2 (cadr lst4))
    
23.   (setq n3 (caddr lst4))
    
24.   (setq n4 (last lst4))
    
25.   (setq m1 (+ (lsh n1 2)(lsh (logand n2 48) -4)))
    
26.   (setq m2 (+ (lsh (logand n2 15) 4) (lsh (logand n3 60) -2)))
    
27.   (setq m3 (+ (lsh (logand n3 3) 6) n4))
    
28.   (list m1 m2 m3)
    
29. )

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

kqqt6236

太棒了，这个一定要支持。

satan421

正需要这个,非常感谢