GET http://chicken.kitten-technologies.co.uk/henrietta.cgi?name=base64 HTTP/1.0
User-Agent: chicken-install 4.4.0
Accept: */*
Host: chicken.kitten-technologies.co.uk
Content-Length: 0
Via: 1.1 pc-paul (squid/3.0.STABLE8)
X-Forwarded-For: 127.0.0.1
Cache-Control: max-age=259200
Proxy-Connection: keep-alive


HTTP/1.0 200 OK
Date: Fri, 16 Apr 2010 14:24:05 GMT
Content-Type: text/plain
X-Cache: MISS from cache.jet.msk.su
Connection: close





#|--------------------|# "./base64-test.scm" 6645
(use test)
(use base64)

(define lorem-ipsum "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.")
(define lorem-ipsum-base64
  '("TG9yZW0gaXBzdW0gZG9sb3Igc2l0IGFtZXQsIGNvbnNlY3RldHVyIGFkaXBpc2ljaW5nIGVsaXQs"
    "IHNlZCBkbyBlaXVzbW9kIHRlbXBvciBpbmNpZGlkdW50IHV0IGxhYm9yZSBldCBkb2xvcmUgbWFn"
    "bmEgYWxpcXVhLiBVdCBlbmltIGFkIG1pbmltIHZlbmlhbSwgcXVpcyBub3N0cnVkIGV4ZXJjaXRh"
    "dGlvbiB1bGxhbWNvIGxhYm9yaXMgbmlzaSB1dCBhbGlxdWlwIGV4IGVhIGNvbW1vZG8gY29uc2Vx"
    "dWF0LiBEdWlzIGF1dGUgaXJ1cmUgZG9sb3IgaW4gcmVwcmVoZW5kZXJpdCBpbiB2b2x1cHRhdGUg"
    "dmVsaXQgZXNzZSBjaWxsdW0gZG9sb3J
lIGV1IGZ1Z2lhdCBudWxsYSBwYXJpYXR1ci4gRXhjZXB0"
    "ZXVyIHNpbnQgb2NjYWVjYXQgY3VwaWRhdGF0IG5vbiBwcm9pZGVudCwgc3VudCBpbiBjdWxwYSBx"
    "dWkgb2ZmaWNpYSBkZXNlcnVudCBtb2xsaXQgYW5pbSBpZCBlc3QgbGFib3J1bS4="
    ""))   ; trailing empty for intersperse

(test-group
 "encoding"
 (test "encode string of length 0"
       ""
       (base64-encode ""))
 (
test "encode string of length 1"
       "YQ=="
       (base64-encode "a"))
 (test "encode string of length 2"
       "YWI="
       (base64-encode "ab"))
 (test "encode string of length 3"
       "YWJj"
       (base64-encode "abc"))
 (test "encode string of length 5*3"
       "YWJjZGVmZ2hpamtsbW5v"
       (base64-encode "abcdefghijklmno"))
 (test "encode string of length 5*3+1"
       "YWJjZGVmZ2hpamtsbW5vcA=="
       (base64-encode "abcdefghijklmnop"))
 (test "encode string of length 5*3+2"
       "YWJjZGVmZ2hpamtsbW5vcHE="
       (base64-encode "abcdefghijklmnopq"))
 (test "encode string of length 6*3"
       "YWJjZGVmZ2hpamtsbW5vcHFy"
       (base64-encode "abcdefghijklmnopqr"))
 (test "encode binary string"
       "3q2+78r+sAs="
       (base64-encode "\xde\xad\xbe\xef\xca\xfe\xb0\x0b"))
 (test "lorem ipsum"
       (apply string-append lorem-ipsum-base64)
       (base64-encode lorem-ipsum))
 (let ((s (make-string (+ 10 (* 57 60)) #\Q)))  ; past one input buffer
   (test "port > 1 buffer length -> port"
    
     (base64-encode s)
         (get-output-string (base64-encode (open-input-string s)
                                           (open-output-string))))
   (test "port > 1 buffer length -> string"
         (base64-encode s)
         (base64-encode (open-input-string s)))))

(test-group
 "encoding linebreaks"
 (parameterize ((base64-line-bre
aks #t))
   (test "encode empty string"
         ""
         (base64-encode ""))
   (test "encode 9 chars"
         "YWFhYWFhYWFh\r\n"
         (base64-encode (make-string 9 #\a)))
   (test "encode 55 chars"
         "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYQ==\r\n"
         (base64-encode (make-string 55 #\a))) 
   (test "encode 56 chars"
         "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWE=\r\n"
         (base64-encode (make-string 56 #\a)))
   (test "encode 57 chars"
         "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh\r\n"
         (base64-encode (make-string 57 #\a)))
   (test "encode 58 chars"
         "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh\r\nYQ==\r\n"
         (base64-encode (make-string 58 #\a)))
   (test "encode 57*2 chars"
         (string-append "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh"
                        "\r\n"
       
                 "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh"
                        "\r\n")
         (base64-encode (make-string (* 57 2) #\a)))
   (test "encode 57*2+1 chars"
         (string-append "YWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh"
                     
   "\r\n"
                        "YWFhYWFhY
WFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFhYWFh"
                        "\r\n"
                        "YQ=="
                        "\r\n")
         (base64-encode (make-string (+ 1 (* 57 2)) #\a)))
   (let ((lorem-ipsum-encoded (string-intersperse lorem-ipsum-base64 "\r\n")))
     (test "lorem ipsum"
           lorem-ipsum-encoded
           (base64-encode lorem-ipsum))
     (test "lorem ipsum string -> port"
           lorem-ipsum-encoded
           (get-output-string (base64-encode lorem-ipsum (open-output-string))))
     (test "lorem ipsum port -> string"
           lorem-ipsum-encoded
           (base64-encode (open-input-string lorem-ipsum)))
     (test "lorem ipsum port -> port"
           lorem-ipsum-encoded
           (get-output-string (base64-encode (open-input-string lorem-ipsum)
                                             (open-output-string)))))
   ))

;; to avoid measuring time in test (doesn't really matter)
(define large-string (make-string 10000001 #\a))
(define large
-encoded-string (base64-encode large-string))
(define large-invalid-string (make-string 10000001 #\%))

(test-group
 "decoding"
 (test "decode empty string -> empty"
       ""
       (base64-decode ""))
 (test "decode string Y -> empty"
       ""
       (base64-decode "Y"))
 (test "decode string YW -> a"
       "a"
       (base64-decode "YW")
)
 (test "decode string YW= -> a"
       "a"
       (base64-decode "YW="))
 (test "decode string YW== -> a"
       "a"
       (base64-decode "YW==")) 
 (test "decode string YWJ => ab"
       "ab"
       (base64-decode "YWJ"))
 (test "decode string YWJ= -> ab"
       "ab"
       (base64-decode "YWJ="))
 (test "decode string YWJj -> abc"
       "abc"
       (base64-decode "YWJj"))
 (test "decode string YW%J^jZ -> abc"
       "abc"
       (base64-decode "YW%J^jZ"))
 (test "decode skips invalid chars"
       "abcdefghijklmnop"
       (base64-decode "YWJjZG(address@hidden&W5v**cA======"))
 (test "decode binary string"
       "\xde\xad\xbe\xef\xca\xfe\xb0\x0b"
       (base64-decode "3q2+78r+sAs="))
 (test "decode large string"
       large-string
       (base64-decode large-encoded-string))
 (test "decode large string of invalid chars"
       ""
       (base64-decode large-invalid-string))
 (test "decode lorem ipsum with linebreaks"
       lorem-ipsum
       (base64-decode (string-intersperse lorem-ipsum-base64 "\r
\n"))))

;; Not on a 64-bit machine! :)
;; (test-error "encode string of length 16,000,000 signals an error"
;;             (base64-encode (make-string 16000000)))

#|--------------------|# "./base64.setup" 201
(compile -s -O2 -d0 -u base64.scm -j base64)
(compile -s -O2 -d0 base64.import.scm)

(install-extension
 'base64 
 '("base64.import.s
o" "base64.so")
 '((version 3.2)
   (documentation "base64.html")))

#|--------------------|# "./base64.scm" 17099
;; Copyright (c) 2004 James Bailey (address@hidden).
;; Copyright (c) 2009 Jim Ursetto.
;;
;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"), to
;; deal in the Software without restriction, including without limitation the
;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
;; sell copies of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be included in all
;; copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

;; base64 routines for bigloo, apart from the module info, bit
 routines, "when"
;; and fixed division "/fx" it should be slightly portable

;; Ported to CHICKEN by felix
;; Rewritten for CHICKEN by Jim Ursetto.  Notes:
;;  Local anonymous functions (bits-at) are not inlined; use define-inline.
;;  Toplevel tables moved to lexical scope.
;;  Encode algorithm moves the test for 1 or 2 remaining bytes out
;;  of the main loop; generates -significantly- better code under Chicken.
;;  Decode algorithm rewritten as state machine; invalid input is
;;  silently skipped.
;;  Compiling with -unsafe is HIGHLY recommended, and gains more benefit
;;  as your inner loop gets tighter.
;;  The optimized variants are almost on par with pure C.
;;  Encoding and decoding can now operate on ports.

(declare
  (fixnum))

(cond-expand ((not compiling)
              (define-syntax define-inline
                (syntax-rules () ((_ e0 ...) (define e0 ...)))))
             (else))

(module base64
  (base64-encode base64-decode base64-line-breaks)

  (import scheme chicken
          (only extras
 read-string!)
          (only srfi-13 string-concatenate-reverse))
  (require-library srfi-13)

;; If base64-line-breaks is true, a CRLF is inserted every
;; 76 output chars (57 input chars) and at the end of the last
;; line, if it was partial (between 1 and 75 output chars).
(define base64-line-breaks (make-parameter #f))

;; Optimized str
ing->string implementation
(define (base64-encode/string->string str)
  (define-inline (bits-at idx)
    (char->integer (string-ref str idx)))
  (define-inline (b64->char n)
    (define enc-table
      '#(#\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
         #\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 #\+ #\/))
    (vector-ref enc-table (bitwise-and n 63)))

  (define (encode-tail out i o r)
    ;; Handle last 1 or 2 bytes
    (case r
      ((0) o)
      ((1)
       (let ((n (arithmetic-shift (bits-at i) 16)))
         (string-set! out o (b64->char (arithmetic-shift n -18)))
         (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
         (+ o 4)))
      ((2)
       (let ((n (bitwise-ior (arithmetic-shift (bits-at i) 16)
                             (arithmetic-shift (bits-at (+ i 1)) 8))))
         (string-set
! out o (b64->char (arithmetic-shift n -18)))
         (string-set! out (+ o 1) (b64->char (arithmetic-shift n -12)))
         (string-set! out (+ o 2) (b64->char (arithmetic-shift n -6)))
         (+ o 4)))))

  (##sys#check-string str 'base64-encode)
  (let ((l (string-length str)))
    (let* ((nobreak? (not (base64-line-breaks)))
         
  (outlen (* 4 (fx/ (+ l 2) 3)))
           (full-lines (fx/ l 57))