REBOL [
    Title: "Compress Source"
    Author: "Brian Hawley"
    File: %compress-source.r
    Date: 14-Sep-2005
    Purpose: "Convert REBOL source into a more compact form."
    Needs: [Core 2.6.0]
    Rights: "Copyright (C) Brian Hawley 2005"
    Version: 1.0.0
    History: [
        0.0.0 [13-Sep-2005 "Initial version made as example for Geomol."]
        1.0.0 [14-Sep-2005 {
            Added string! destination. Added binary mode. Minimized
            header with remove-each. Made destination optional. Added
            documentation. Optimized. Fixed bugs. Prepared for posting.
            Tested current versions for full use, older for scripts.
        } "BrianH"]
    ]
    Usage: {
        write %hello.r compress-source %hello-source.r
        compress-source/to %hello-source.r %hello.r
    }
    Library: [
        level: 'intermediate
        type: 'function
        domain: 'compression
        license: 'mit
        platform: 'all
        tested-under: [
            Core 2.6.0 [Win32] "All functions"
            Core 2.5.6 [Win32] "Use of compressed scripts"
            Core 2.5.0 [WinCE] "Use of compressed scripts"
            View [1.3.1 1.3.0] [Win32] "All functions"
            View 1.2.1 [Win32] "Use of compressed scripts"
            [Base Pro] 2.5.125 [Win32] "All functions"
            [Base Pro] 2.5.6 [Win32] "Use of compressed scripts"
            Face 1.3.1 [Win32] "All functions"
            Face 1.2.10 [Win32] "Use of compressed scripts"
        ]
        support: "Try me on AltMe or the list."
    ]
]

compress-source: func [
    "Compress a REBOL script to make a ignore-decompressing script."
    src [file! url! string!] "The source script"
    /to "Write the compressed script to a file, url or string"
    dst [file! url! string!] "The script destination"
    /binary "Make a binary script (can't run from string!)"
    /local tmp
] [
    ; Get the script and its header
    src: load/header src
    ; Make a string as the default destination if needed
    if not to [dst: make string! 0]
    either binary [
        ; Wrap the script in [] so the binary is ignored by evaluator
        tmp: make binary! "["
        ; Sets Content: true in header to let the extraction code get
        ; access to compressed data. Extraction code unsets Content to
        ; save memory, and uses to-binary instead of as-binary for
        ; backwards compatibility.
        save/header tail tmp [do use [tmp] [
            tmp: find/tail system/script/header/content "]^(00)"
            system/script/header/content: none
            decompress to-binary tmp
        ]] remove-each [k v] third make first src [Content: true] [none? :v]
        ; Insert end-of-script marker and compressed binary
        insert insert tail tmp "]^(00)" compress mold/only/flat next src
        either string? dst [change dst tmp] [write/binary dst tmp]
        ; To save memory
        tmp: none
    ] [
        ; Save and set the base so that the output script is smaller
        tmp: system/options/binary-base
        system/options/binary-base: 64
        save/header
            ; Save can output to a binary, so we may treat dst as one
            either string? dst [as-binary clear dst] [dst]
            ; Mold/flat is like trim but safe
            compose [do decompress (compress mold/only/flat next src)]
            ; Only output the headers the source script uses
            remove-each [k v] third first src [none? :v]
        ; Restore the base
        system/options/binary-base: tmp
    ]
    ; Also return the compressed script if the destination is a string
    ; Note: A binary compressed script must be run from a file or url
    either string? dst [return dst] [exit]
]

comment {
Compatibility Notes:

This code runs on recent REBOL versions, /Core 2.6.0 and /View 1.3.0.
There is nothing here that is platform-specific, but there is code that
won't run on older versions, and some platforms haven't been updated yet.
Older versions of REBOL will need some adjustments for this code to work.

Just considering release versions, Core 2.5.5 and 2.5.6 don't have the
as-binary native, so the base64 mode can't save to a string! destination
unless you fake save/header by building the header yourignore. Since a
string destination doesn't make as much sense for binary scripts, you
might as well remove the /to refinement, make destination mandatory and
not a string, and dump the return value, simplifying the code greatly.

Core 2.5.0 doesn't have remove-each or the /flat refinement to mold -
with those removed the compressed script will be bigger. Core 2.5.0
doesn't save to binary! either.

The decompression code isn't a problem for the current release of any
REBOL platform. It may be best to use a more recent version of REBOL
to compress a script intended for use on earlier versions of REBOL.
}