[TB-LISP函数]：文本的BASE64编码与解码
本帖最后由 tengteb 于 2022-10-21 09:29 编辑;参数：txt -- 文本；mode: nil -- 解码，其它 -- 编码
(defun TBC:Base64 (txt mode / Char Index Code Decode n m s ss a b c d zs lst)
(defun Char (i)
(cond
((<= 0 i 25) (+ i 65)) ;大写字母
((<= 26 i 51) (+ i 71)) ;小写字母
((<= 52 i 61) (- i 4)) ;数字
((= i 62) 43) ;+
((= i 63) 47) ;/
) ;cond
) ;defun
(defun Index (a)
(cond
((<= 65 a 90) (- a 65)) ;大写字母
((<= 97 a 122) (- a 71)) ;小写字母
((<= 48 a 57) (+ a 4)) ;数字
((= a 43) 62) ;+
((= a 47) 63) ;/
) ;cond
) ;defun
(defun Code (n1 n2 n3)
(list
(lsh n1 -2)
(+ (lsh (logand n1 3) 4) (lsh (logand n2 240) -4))
(+ (lsh (logand n2 15) 2) (lsh (logand n3 192) -6))
(logand n3 63)
)
) ;defun
(defun Decode (n1 n2 n3 n4)
(list
(+ (lsh n1 2) (lsh (logand n2 48) -4))
(+ (lsh (logand n2 15) 4) (lsh (logand n3 60) -2))
(+ (lsh (logand n3 3) 6) n4)
)
) ;defun
(setq lst (vl-string->list txt))
(if mode ;nil:解码；else 编码
(progn
(setq n (length lst)
m (rem n 3)
n (/ n 3)
)
(or (= m 0) (setq n (1+ n)))
(setq ss "")
(repeat (- 3 m)
(setq ss (strcat ss "=")
zs (cons 0 zs)
)
) ;repeat
(setq lst (append lst zs))
(setq s "")
(repeat n
(setq a (car lst)
b (cadr lst)
c (caddr lst)
lst (cdddr lst)
s (strcat s (vl-list->string (mapcar 'Char (Code a b c))))
)
) ;repeat
(setq n (strlen s))
(strcat (substr s 1 (- n m)) ss)
) ;progn/else
(progn
(setq lst (vl-remove-if '(lambda (x) (= x 10)) lst)) ;允许编码中出现无用的换行符
(setq m (length (member 61 lst))) ;"="及后面的长度
(setq lst (mapcar 'Index (subst 65 61 lst))) ;"="替换为"A"
(setq s "")
(repeat (/ (length lst) 4)
(setq a (car lst)
b (cadr lst)
c (caddr lst)
d (cadddr lst)
lst (cddddr lst)
s (strcat s (vl-list->string (Decode a b c d)))
)
)
(setq n (strlen s))
(substr s 1 (- n m))
) ;progn
) ;if
)
感谢分享! 还有不少不明白的地方，学习一下。感谢分享。
页:
[1]