REBOL [
    Title: "Encodings."
    Author: "Brett Handley"
    Date: 19-Feb-2002
    Version: 0.9.5
    Email: brett@codeconscious.com
    File: %encodings.r
    Purpose: {Provides different data encodings (primarily used for email).}
    History: [
        0.9.5 [17-Jan-2002 "Replace DEBASE for View 1.2.1 only." "Brett Handley"]
        0.9.4 [17-Jan-2002 "Fixed typo bug caused by last version." "Brett Handley"]
        0.9.3 [16-Jan-2002 "Replaced debase with dehex in decode-quoted-printable." "Brett Handley"]
        0.9.2 [31-Dec-2001 "Just realised I can work around the DEBASE bug in View 1.2.1 by using LOAD." "Brett Handley"]
        0.9.1 [11-Dec-2001 "Added a to-quoted-printable conversion." "Brett Handley"]
        0.9.0 [31-July-2001 "Initial version." "Brett Handley"]
    ]
    Rights: {Copyright (c) Brett Handley 2001

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, subrights,
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.}
]

encoding-map: [
    base64            decode-base64           encode-base64
    uuencoding        uudecode                uuencode
    quoted-printable  decode-quoted-printable to-quoted-printable
]

decodings?: function [
    "Available schemes for decoding."
][encmap result][
    encmap: encoding-map
    result: copy []
    forskip encmap 3 [  if not equal? 'none second encmap [append result first encmap] ]
    RETURN result
]

encodings?: function [
    "Available schemes for encoding."
][encmap result][
    encmap: encoding-map
    result: copy []
    forskip encmap 3 [  if not equal? 'none third encmap [append result first encmap] ]
    RETURN result
]

encoding?: function [
    "Determine the encoding indicated by the header."
    transfer-encoding-header [string!]
][encmap][
    encmap: encoding-map
    forskip encmap 3 [
        if find transfer-encoding-header to-string first encmap [
            RETURN first encmap
        ]
    ]
    RETURN none
]

decode: function [
    "Decode the data according to an encoding scheme"
    encoding-name data
][encoding-rec decoder][
    encoding-rec: find/skip encoding-map encoding-name 3
    either encoding-rec [
        decoder: get second encoding-rec
        RETURN decoder data
    ][RETURN none]
]

encode: function [
    "Encode the data according to an encoding scheme"
    encoding-name data
][encoding-rec encoder][
    encoding-rec: find/skip encoding-map encoding-name 3
    either encoding-rec [
        encoder: get third encoding-rec
        RETURN encoder data
    ][RETURN none]
]

;
; Decoders follow.
;

; Replace DEBASE if View 1.2.1
if all [
    equal? "View" first parse to-string system/product "/"
    find/match form system/version "1.2.1."
] [

    debase: function [
        {Converts a string from a different base representation to binary.
Note: This is a patched version.}
        value [any-string!] "The string to convert"
        /base {Allow a selection of a different base for conversion}
        base-value [integer!] "The base to convert from: 64, 16, or 2"
    ] [tmp] [
        if not base [base-value: system/options/binary-base]
        if not found? find [64 16 2] base-value [return none]
        tmp: either string? value [copy value] [to-string value]
        RETURN first load/all append insert tmp compose [(base-value) "#{"] "}"
    ]

]

decode-base64: func [ encoded-data ][
    debase/base encoded-data 64
]

encode-base64: func [ data ][
    RETURN enbase/base data 64
]

quoted-printable-encoding: make object! [
    decoded-data: none
    hex-rep: none
    data-char: none
    hex-char: charset "0123456789ABCDEFabcdef"
    ordinary-char: complement charset [] ; Ignoring illegal characters for the moment.
    decoding-rule: [
        (decoded-data: copy #{})
        some [
            "=3D" (insert tail decoded-data #"=") |
            "=20" (insert tail decoded-data #" ") |
            "=^/" |
            "=0A" (insert tail decoded-data #"^/") |
            [copy hex-rep ["=" 2 hex-char] (insert tail decoded-data dehex head change hex-rep #"%")] |
            copy data-char ordinary-char (insert tail decoded-data data-char)
        ] |
        end
    ]
    decode-quoted-printable: func [
        "Decodes quoted-printable encoded data."
        data
    ][
        if parse/all data decoding-rule [
            RETURN to-string decoded-data
        ]
    ]
]

do func[/local w][
    set w: 'decode-quoted-printable get in quoted-printable-encoding w
]

to-quoted-printable: function [
    "Creates a quoted printable encoding of the input. No line break functionality for binary input."
    data [string! binary!]
    /CRLFin "Input has CRLF type line breaking."
    /CRLFout "Output must have CRLF type line breaking."
    /pipe output [any-function!] "Supply a function to receive the output as it becomes available."
] [
    nl nlo encode-data line-breaking litrep txt *lit *8bit *nl result linelen flush binary
] [
    emit: does [
        if pipe [
            output result
            clear result
        ]
    ]
    binary: binary? data
    linelen: 0
    *lit: function[s][avail p copied need][
        until [
            avail: subtract 76 linelen
            if all [
                lesser? need: length? s 60
                lesser? avail need
            ] [avail: 0]
            insert tail result p: copy/part s avail
            s: skip s copied: length? p
            linelen: add linelen copied
            either tail? s [
                if all [equal? linelen 76 find {^- } last result] [
                    insert back tail result reduce [{=} nlo]
                    linelen: 1
                ]
                true
            ][
                if any [zero? avail equal? 76 linelen] [
                    insert back tail result reduce [{=} nlo]
                    linelen: 1
                ]
                false
            ]
        ]
    ]
    *8bit: function[c][s][
        s: join "=" enbase/base c 16
        either lesser? linelen 74 [
            insert tail result s 3
            linelen: add linelen 3
        ][
            insert tail result join {=} reduce [nlo s]
            linelen: 3
            if greater? length? result 1024 [emit]
        ]
    ]
    *checklast: does [
        if all [greater? linelen 0 find {^- } c: last result] [
            clear back tail result
            linelen: subtract linelen 1
            *8bit to-string c
        ]
    ]
    *nl: has [c] [ *checklast emit insert tail result nlo linelen: 0]
    litrep: charset [#"!" - #"<" #">" - #"~"]
    ws: charset [#"^-" #" "]
    nl: either CRLFin [ CRLF ][ newline ]
    nlo: either CRLFout [ CRLF ][ newline ]
    encode-data: [
        copy txt some litrep (*lit txt) |
        copy txt some ws (*lit txt) |
        copy txt 1 skip (*8bit txt)
    ]
    either binary [
        encoding-rule: [any encode-data]
    ][ 
        encoding-rule: [any [nl (*nl) | encode-data]]
    ]
    result: make string! 10
    parse/all data encoding-rule
    *checklast
    emit
    if not pipe [RETURN result]
]

uuencoding: make object! [
    binary-string: copy {}
    filename: none
    line-length: none
    encoded-line-length: none
    binary-string: none
    temp-string: none
    unencoded-data: none
    decoded-data: none
    input-position: none
    decoded-sections: none
    encoding-data: complement charset "`^/"
    unix-permission-digit: charset "01234567"
    any-char: complement charset []
    unix-permission: [ 3 unix-permission-digit ]
    uuencoding-rule: [
        (decoded-sections: copy []) some
        [ input-position:
            [   "begin " unix-permission " "
                copy filename to "^/" skip
                (append decoded-sections to-file filename)
                uuencoded-data-rule
                ( append decoded-sections decoded-data )
                opt ["end" opt "^/" opt "^/"]
            ] |
            [
                [copy unencoded-data thru "^/" | copy unencoded-data any-char]
                ( either all [not empty? decoded-sections string? last decoded-sections] [
                        append last decoded-sections unencoded-data
                    ][
                        append decoded-sections unencoded-data
                    ]
                )
            ]
        ] | end
    ]
    uuencoded-data-rule: [
        (decoded-data: none binary-string: copy {})
        some [
            copy encoded-line-length encoding-data
            (
                line-length: subtract to-integer to-char encoded-line-length 32
                temp-string: make string! multiply line-length 8
            )
            copy line-data to "^/" skip
            (
                foreach c line-data [
                    insert tail temp-string copy at enbase/base to-string to-char subtract to-integer c 32 2 3
                ]
                insert tail binary-string temp-string
            )
        ]
        "`^/"
        (decoded-data: debase/base binary-string 2)
    ]
    set 'uudecode func [
        "Decodes uuencoded data."
        data
    ] [
        parse/all data uuencoding-rule
        RETURN decoded-sections
    ]
    set 'uuencoding? func [
        "Decoded uuencoded data."
        data
    ] [
        parse/all data [thru "begin " unix-permission to end]
    ]

    set 'uuencode function [
        filename [file! string!]
        unix-permissions [integer!]
        data
    ][bin-digit sixbit-char bit-string lines left-over][

        lines: to-integer divide length? data 45
        left-over: subtract length? data multiply 45 lines
        bin-digit: charset "01"

        result: join "begin " [unix-permissions " " filename "^/"]
        line-start: tail result
        parse/all enbase/base data 2 [
            any [
                copy bit-string 6 bin-digit (
                    sixbit-char: to-char add 32 to-integer debase/base join "00" bit-string 2
                    if equal? #" " sixbit-char [
                        sixbit-char: #"`"
                    ]
                    insert tail result sixbit-char
                    if equal? offset? line-start tail result 60 [
                        insert tail result "^/"
                        insert line-start "M"
                        line-start: tail result
                        line-length: 0
                    ]
                )
            ]
        ]
        if not equal? line-start tail result [
            insert line-start to-char add 32 left-over
            insert tail result "^/"
        ]
        insert tail result "`^/end^/"
        RETURN result
    ]
]