anchor.diff:  ;;;;AUTHORS
   ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
   ;;;;MODIFICATIONS
  +;;;;    2012-04-13 <PJB> Removed dependency on external data files for tests.
  +;;;;                     Ran around a bug in ccl-1.5.
   ;;;;    2004-08-18 <PJB> Added base16, base32 and filebase64.
   ;;;;    2004-08-17 <PJB> Created (extracted from antispam.lisp).
   ;;;;BUGS
   ;;;;LEGAL
   ;;;;    GPL
   ;;;;    
  -;;;;    Copyright Pascal J. Bourguignon 2004 - 2004
  +;;;;    Copyright Pascal J. Bourguignon 2004 - 2012
   ;;;;    
   ;;;;    This program is free software; you can redistribute it and/or
   ;;;;    modify it under the terms of the GNU General Public License
  
positive.code: ;;;;    Boston, MA 02111-1307 USA
  ;;;;****************************************************************************
   
  (IN-PACKAGE "COMMON-LISP-USER")
  (DEFPACKAGE "COM.INFORMATIMAGO.COMMON-LISP.RFC3548.RFC3548"
    (:USE "COMMON-LISP"
          "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STREAM")
    (:EXPORT
     "BASE16-DECODE-BYTES" "BASE16-ENCODE-BYTES" "BASE32-DECODE-BYTES"
     "BASE32-ENCODE-BYTES" "FILEBASE64-DECODE-BYTES" "FILEBASE64-ENCODE-BYTES"
     "BASE64-DECODE-BYTES" "BASE64-ENCODE-BYTES" "BASE16-DECODE" "BASE16-ENCODE"
     "BASE32-DECODE" "BASE32-ENCODE" "FILEBASE64-DECODE" "FILEBASE64-ENCODE"
     "BASE64-DECODE" "BASE64-ENCODE")
    (:IMPORT-FROM "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STREAM"
                  "BVSTREAM-WRITE-BYTE" "BVSTREAM-READ-BYTE"
                  "WITH-INPUT-FROM-BYTE-VECTOR" "WITH-OUTPUT-TO-BYTE-VECTOR")
    (:DOCUMENTATION
     "This packages exports functions to encode an decode text blocks
      according to the encoding described in:
        RFC3548: The Base16, Base32, and Base64 Data Encodings
  
      Copyright Pascal J. Bourguignon 2004 - 2004
      This package is provided under the GNU General Public License.
      See the source file for details."))
  (IN-PACKAGE "COM.INFORMATIMAGO.COMMON-LISP.RFC3548.RFC3548")
  
  
  
  
  (DEFUN MAKE-DECODE-TABLE (CODE &KEY (CASE-SENSITIVE T))
    "
  CODE:        A string of length (1+ (expt 2 n)).
  RETURN:      An array A:[0..255] --> [-1..(expt 2 n)]
               character-code --> encoding-value
  "
    (DO* ((TABLE (MAKE-ARRAY '(256)
                             :ELEMENT-TYPE `(INTEGER -1 ,(1- (LENGTH CODE)))
                             :INITIAL-ELEMENT -1))
          (INDEX 0                (1+ INDEX))
          (CHAR  (AREF CODE INDEX) (AREF CODE INDEX)))
         ((<= (1- (LENGTH CODE)) INDEX) TABLE)
      (IF CASE-SENSITIVE
          (SETF (AREF TABLE (CHAR-CODE CHAR)) INDEX)
          (SETF (AREF TABLE (CHAR-CODE (CHAR-DOWNCASE CHAR))) INDEX
                (AREF TABLE (CHAR-CODE (CHAR-UPCASE   CHAR))) INDEX)))
    ) ;;MAKE-DECODE-TABLE
          
  
  (DEFPARAMETER +BASE64-ENCODE+
    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
    "An array A[0..64] --> character  giving the character used to encode
     the values from 0 to 63, and the padding character in slot 64.")
  
  
  (DEFPARAMETER +BASE64-DECODE+ (MAKE-DECODE-TABLE +BASE64-ENCODE+)
    "An array A:[0..255] |--> [-1..63] 
          character-code ---> encoding-value")
  
  
  (DEFPARAMETER +FILEBASE64-ENCODE+
    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_="
    "An array A[0..64] --> character  giving the character used to encode
     the values from 0 to 63, and the padding character in slot 64.")
  
  
  (DEFPARAMETER +FILEBASE64-DECODE+ (MAKE-DECODE-TABLE +FILEBASE64-ENCODE+)
    "An array A:[0..255] |--> [-1..63] 
          character-code ---> encoding-value")
  
  
  (DEFPARAMETER +BASE32-ENCODE+
    "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567="
    "An array A[0..32] --> character  giving the character used to encode
     the values from 0 to 31, and the padding character in slot 32.")
  
  
  (DEFPARAMETER +BASE32-DECODE+ (MAKE-DECODE-TABLE +BASE32-ENCODE+ :CASE-SENSITIVE NIL)
    "An array A:[0..255] |--> [-1..31] 
          character-code ---> encoding-value")
  
  
  (DEFUN PADDING-CODE (CODE) 
    "The position of the padding character in code (the last one)."
    (1- (LENGTH CODE)))
  
  
  ;; encode:
  
negative.code: ;;     base16:   1*8 --> 2*4
  
      
  (defun encode64 (encode read-byte write-char)
    (macrolet ((out (code) `(funcall write-char (aref encode ,code))))
      (do ((i1 (funcall read-byte) (funcall read-byte))
           (i2 (funcall read-byte) (funcall read-byte))
           (i3 (funcall read-byte) (funcall read-byte))
           (padding (padding-code encode)))
          ((null i3)
           (cond
             ((null i1))
             ((null i2)
              (out (ldb (byte 6 2) i1))
              (out (dpb (ldb (byte 2 0) i1) (byte 2 4) 0))
              (out padding)
              (out padding))
             (t
              (out (ldb (byte 6 2) i1))
              (out (dpb (ldb (byte 2 0) i1) (byte 2 4) (ldb (byte 4 4) i2)))
              (out (dpb (ldb (byte 4 0) i2) (byte 4 2) 0))
              (out  padding)))
           (values))
        ;; aaaaaaaa  bbbbbbbb cccccccc
        ;; aaaaaa aabbbb bbbbcc cccccc
        (out (ldb (byte 6 2) i1))
        (out (dpb (ldb (byte 2 0) i1) (byte 2 4) (ldb (byte 4 4) i2)))
        (out (dpb (ldb (byte 4 0) i2) (byte 4 2) (ldb (byte 2 6) i3)))
        (out (ldb (byte 6 0) i3)))))
  
  
  (defun encode32 (encode read-byte write-char)
    (macrolet ((out (code) `(funcall write-char (aref encode ,code))))
      (do ((i1 (funcall read-byte) (funcall read-byte))
           (i2 (funcall read-byte) (funcall read-byte))
           (i3 (funcall read-byte) (funcall read-byte))
           (i4 (funcall read-byte) (funcall read-byte))
           (i5 (funcall read-byte) (funcall read-byte))
           (padding (padding-code encode)))
          ((null i5)
           (cond
             ((null i1))
             ((null i2)
              (out (ldb (byte 5 3) i1))
              (out (dpb (ldb (byte 3 0) i1) (byte 3 2) 0))
              (out padding)
              (out padding)
              (out padding)
              (out padding)
              (out padding)
              (out padding))
             ((null i3)
              (out (ldb (byte 5 3) i1))
              (out (dpb (ldb (byte 3 0) i1) (byte 3 2) (ldb (byte 2 6) i2)))
              (out (ldb (byte 5 1) i2))
              (out (dpb (ldb (byte 1 0) i2) (byte 1 4) 0))
              (out padding)
              (out padding)
              (out padding)
              (out padding))
             ((null i4)
              (out (ldb (byte 5 3) i1))
              (out (dpb (ldb (byte 3 0) i1) (byte 3 2) (ldb (byte 2 6) i2)))
              (out (ldb (byte 5 1) i2))
              (out (dpb (ldb (byte 1 0) i2) (byte 1 4) (ldb (byte 4 4) i3)))
              (out (dpb (ldb (byte 4 0) i3) (byte 4 1) 0))
              (out padding)
              (out padding)
              (out padding))
             (t
              (out (ldb (byte 5 3) i1))
              (out (dpb (ldb (byte 3 0) i1) (byte 3 2) (ldb (byte 2 6) i2)))
              (out (ldb (byte 5 1) i2))
              (out (dpb (ldb (byte 1 0) i2) (byte 1 4) (ldb (byte 4 4) i3)))
              (out (dpb (ldb (byte 4 0) i3) (byte 4 1) (ldb (byte 1 7) i4)))
              (out (ldb (byte 5 2) i4))
              (out (dpb (ldb (byte 2 0) i4) (byte 2 3) 0))
              (out padding)))
           (values))
        ;; aaaaaaaa  bbbbbbbb  cccccccc dddddddd  eeeeeeee
        ;; aaaaa aaabb bbbbb bcccc ccccd ddddd ddeee eeeee
        (out (ldb (byte 5 3) i1))
        (out (dpb (ldb (byte 3 0) i1) (byte 3 2) (ldb (byte 2 6) i2)))
        (out (ldb (byte 5 1) i2))
        (out (dpb (ldb (byte 1 0) i2) (byte 1 4) (ldb (byte 4 4) i3)))
        (out (dpb (ldb (byte 4 0) i3) (byte 4 1) (ldb (byte 1 7) i4)))
        (out (ldb (byte 5 2) i4))
        (out (dpb (ldb (byte 2 0) i4) (byte 2 3) (ldb (byte 3 5) i5)))
        (out (ldb (byte 5 0) i5)))))
  
      
  ;; decode:
  