Archive version of: codecs.r ... version: 1 ... vincentecuye 2-Mar

Amendment note: new script || Publicly available? Yes

REBOL [
	Title: "REBOL2 Codec System"
    Date: 2-Mar-2025
	Name: 'codecs
	Version: 1.0.0
	File: %codecs.r
	Author: Rights: "Annick ECUYER"
	History: [
        2-Mar-2025 "Annick" {Initial version}
	]
	Usage: {
        REBOL2 Codec System

        Implements a coder/encoder system for REBOL2, like in R3/Red,
        modules that converts to/from mostly binary formats  

        It's a component (system/components), and cam be used with the 
        'Needs header field : Needs: [codecs 1.0.0]

        The predefined codecs are (options in parenthesis):

        image: bmp, png, gif, jpeg,
        audio: wav
        text: base64, markup (xml), percent-encoding, text (rebol)

        Theses are linked to internal Rebol function but can be replaced.

        ===Loading / Execution

        >> do %codecs.r

        It's only updated if it isn't loaded / the existing version is older.
        To force a refresh/reload :
        >> do/args %codecs.r 'force

        By default, all words in header/exports are bound to the global context.
        It can be prevented at script execution:

        ; only exports 'encode and 'decode functions
        >> do/args %codecs.r [with [encode decode]]

        The rest is still available in 'ctx-codecs .

        ===Codec registration

        register-codec block! : regiser a new codec
        unregister-codec 'word : removes a codec from the internal list

        ===Codecs information

        list-codecs      : list registered codecs
        list-codecs 'all : list registered codecs
        list-codecs 'codec | 'type | 'method : list related codecs

        codec-info 'codec : print info about a codec and returns its definition
        codec-info/query 'codec : returns a codec definition

        ===Codec usage - data identification

        encoding?  : determines encoding of binary! data ('identify method)
        file-type? : determines file type from suffix (returns a word!)

        ===Codec usage - decoding

        decode 'codec date  : returns the decoded data ('decode method)
        load/as data 'codec : loads and decodes the data ('decode method)

        decode/as 'codec date option : returns the decoded data with codec options
        load/as data [codec option]  : loads and decodes the data with codec options

        ===Codec usage - encoding

        encode 'codec data  : returns the encoded data ('encode method)
        save/as data 'codec : encodes and saves the data ('encode method)

        encode/as 'codec data option : returns the encoded data with codec options
        save/as data 'codec          : encodes and saves the data with codec options

        'load and 'save both auto-detect file-type from filename by default 
        (only when no refinements are provided)

        'load and 'save are overloaded by the system. It can be prevented by excluding them
        from the import :

        do/args %codecs.r [with [register-codec unregister-codec list-codecs encoding? file-type? encode decode codec-info]] 

        ===Module context

        'ctx-codecs 
            contains both the related methods and codecs list (ctx-codecs/codecs)

        'ctx-codecs/codecs is a block! of values in the format : 
        [codec-name [word!] codec-definition [object!] ...]

        ===Codec structure

        codec!: make object! [
            name: none     ; mandatory, used to identify the codec
            type: none     ; category for classification (optional)
            title: none    ; text description (optional)
            version: none  ; codec version (optional)
            suffixes: none ; block! of suffixes in the form [%.txt %.bin] (optional)

            encoding: any-function! ; encoding method (optional)
            decoding: any-function! ; decoding method (optional)
            identify: any-function! ; identify method (optional)
        ]
    }
	Exports: [register-codec unregister-codec list-codecs encoding? file-type? encode decode codec-info load save]
    Library: [
        level: 'advanced
        platform: 'all
        type: [module tool codec codecs]
        domain: [file-handling files]
        tested-under: [
        	view 1.2.1.3.1 on [Windows11]
        	view 2.7.8.3.1 on [Windows11]
        ]
        support: none
        license: 'bsd
    ]
]

if value? 'ctx-codecs [
    load: ctx-codecs/overload/purge :load none none 
    save: ctx-codecs/overload/purge :save none none 
]
ctx-codecs: context [
    defined?: func ['word] [all [in system/words word value? in system/words word]]
    defined-in?: func [ctx 'word] [all [in ctx word value? in ctx word]]
    as-binary: either defined? 'as-binary [get in system/words 'as-binary] [:to-binary]
    as-string: either defined? 'as-string [get in system/words 'as-string] [:to-string]
    suffix?: either defined? 'suffix? [get in system/words 'suffix?] [func [path] [find/last path %.]]

    codecs: make block! []
    codec!: make object! [
        name: none
        type: none
        title: none
        version: none
        suffixes: none
    ]
    register-codec: func [
        "Registers codec to ctx-codecs/codecs"
        [catch]
        codec [block! object!] "Codec to register (based on ctx-codecs/codec!)"
     /local 
        name
    ] [
        codec: make codec! codec

        either all [defined-in? codec 'name not none? codec/name] [
            name: codec/name: to-word codec/name
        ] [
            throw make error! "Missing codec name!"
        ]

        either any [file? codec/suffixes string? codec/suffixes] [
            codec/suffixes: compose [(to-file codec/suffixes)]
        ] [if none? codec/suffixes [codec/suffixes: copy []]]

        either select codecs codec [
            change next find codecs codec/name codec
        ] [
            append codecs reduce [name codec]
        ]
    ]
    unregister-codec: func [
        "Removes a codec from ctx-codecs/codecs"
        codec [word!] "The codec to removes"
    ] [
        if select codecs codec [
            remove/part find codecs codec 2
            return true
        ]
        none
    ]
    encoding?: func [
        "Returns the media codec name for given binary data (or NONE) (identify)."
        data [binary!] "The data to identify."
    ] [
        foreach [name codec] codecs [
            if all [defined-in? codec 'identify codec/identify data] [return name]
            if all [defined-in? codec 'identify? codec/identify? data] [return name]
        ]
        none
    ]
    file-type?: func [
        "Returns the identifying word for a specific file type (or NONE)."
        file [file! url!] "The filename to identify."
    ] [
        file: suffix? file
        foreach [name codec] codecs [
            if all [defined-in? codec 'suffixes find compose [(codec/suffixes)] file] [return name]
        ]
        none
    ]
    decode: func [
        "Decodes a series of bytes into the related datatype (e.g. image!)."
        [catch] 
        codec [word!] "Media type (jpeg, png, etc.)." 
        data "The data to decode."
        /as "Specifies 'decode options" type "Codec-specific options"
    ] [
        if none? select codecs codec [throw make error! rejoin ["Missing codec: " codec]]
        if not defined-in? codecs/:codec 'decode [throw make error! rejoin ["Missing 'decode method for " form codec]]
        either as [codecs/:codec/decode/as data type][codecs/:codec/decode data]
    ]
    encode: func [
        "Encodes a datatype (e.g. image!) into a series of bytes." 
        [catch]
        codec [word!] "Media type (jpeg, png, etc.)." 
        data "The data to encode"
        /as "Specifies 'encode options" type "Codec-specific options"
    ] [
        if none? select codecs codec [throw make error! rejoin ["Missing codec: " codec]]
        if not defined-in? codecs/:codec 'encode [throw make error! rejoin ["Missing 'encode method for " form codec]]
        either as [codecs/:codec/encode/as data type][codecs/:codec/encode data]
    ]
    codec-info: func [[catch] codec /query /tabs number /local result out] [
        if word? codec [
            if none? codec: select codecs codec [
                throw make error! rejoin ["Unknown codec: " codec]
            ]
        ]
        number: any [all [tabs number] 0] 
        tabs: func [] [head insert/dup copy "" "^-" number]
        
        result: copy []
        out: func [value] [append result rejoin compose value]

        out [
            tabs uppercase form codec/name
            either codec/version [rejoin [" " codec/version]] [""] 
            either codec/type [rejoin [" (" codec/type ")"]] [""] 
            newline
        ]
        all [codec/title out [tabs codec/title newline]]
        if all [defined-in? codec 'url codecs/url] [
            out [tabs "Sources: " newline]
            foreach url compose [(codec/url)] [
                out [tabs tab url newline]
            ]
        ]
        out [tabs "Includes: " (form skip first :codec 6) newline]
        all [
            defined-in? codec 'suffixes 
            not empty? compose [(codec/suffixes)] 
            out [tabs "Suffixes: " form codec/suffixes newline]
        ]
        if not query [prin result]
        codec
    ]
    list-codecs: func ['type [any-type!] /local sorted] [
        sorted: copy []
        foreach [name codec] codecs [
            if any [
                not value? 'type
                all [value? 'type word? type type = to-word form codec/type] ; type
                all [value? 'type word? type type = to-word form codec/name] ; name
                all [value? 'type word? type find next first :codec type]    ; methods
                all [value? 'type file? type find compose [(codec/suffixes)] type] ; suffixes
                'all = type
            ] [
                if not find sorted codec/type [
                    append/only sorted codec/type
                    append/only sorted copy []
                ] 
                append select sorted codec/type codec
            ]
        ]
        sorted: sort/skip sorted 2
        foreach [type codecs] sorted [
            prin rejoin [
                either type [uppercase form type] ["OTHER"] " CODECS:" newline
                newline
            ]
            codecs: sort/compare codecs func [a b] [a/name < b/name]
            foreach codec codecs [codec-info/tabs codec 1 print ""]
        ]
    ]
    register-codec [
        name: 'png
        type: 'image
        title: "Portable Network Graphics"
        suffixes: [%.png]
        decode: func [data [binary! file! url!]] [load data]
        encode: func [data [image!] /local result] [save/png result: copy #{} data result]
        identify: func [data [binary!]] [parse/all data [#{89504E47} to end]] ; #{89}PNG
    ]
    register-codec [
        name: 'bmp
        type: 'image
        title: "Portable Bitmap"
        suffixes: [%.bmp]
        decode: func [data [binary! file! url!]] [load data]
        encode: func [data [image!]] [save/bmp result: copy #{} data result]
        identify: func [data [binary!]] [parse/all data [#{424D} to end]] ; BM
    ]
    register-codec [
        name: 'gif
        type: 'image
        title: "Graphic Interchange Format"
        suffixes: [%.gif]
        decode: func [data [binary! file! url!]] [load data]
        identify: func [data [binary!]] [parse/all data [[#{4749463837} | #{4749463839}] to end]] ; GIF87 or GIF89
    ]
    register-codec [
        name: 'jpeg
        type: 'image
        title: "Joint Photographic Experts Group"
        suffixes: [%.jpg %.jpeg]
        decode: func [data [binary! file! url!]] [load data]
        identify: func [data [binary!]] [parse/all data [#{FFD8} to end]]
    ]
    register-codec [
        name: 'wav
        type: 'sound
        title: "Waveform Audio File Format"
        suffixes: [%.wav %.wave]
        decode: func [data [binary! file! url!]] [load data]
        identify: func [data [binary!]] [parse/all data [#{52494646} 4 skip #{57415645} to end]] ; RIFF/WAVE
    ]
    register-codec [
        name: 'markup
        type: 'text
        title: "Markup (HTML, XML, SGML) encoding"
        suffixes: [%.html %.htm %.xml]
        decode: func [data [binary! string! file! url!] /as type [word!]] [
            if any [file? data url? data] [data: read data]
            if not string? data [data: as-string data]
            parse/all [opt #{EFBBBF} copy data to end] ; skip UTF-8 BOM
            data: any [data copy ""]
            either all [as type = 'xml] [parse-xml data] [load/markup data]
        ]
    ]
    register-codec [
        name: 'base64
        type: 'text
        title: "Base 64 encoding"
        encode: func [data [binary! string! file! url!]] [
            if any [file? data url? data] [data: read data]
            if not binary? data [data: as-binary data]
            enbase/base as-binary data 64
        ]
        decode: func [data [binary! string! file! url!]] [
            if any [file? data url? data] [data: read data]
            if not string? data [data: as-string data]
            debase/base data 64
        ]
    ]
    register-codec [
        name: 'percent-encoding
        type: 'text
        title: "Percent encoding (url hex encoding)"
        chars: charset {ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_.~}
        encode: func [data [binary! string! file! url!] /local result value] [
            if any [file? data url? data] [data: read/binary data]
            if not string? data [data: as-string data]
            ; more complete than "mold to-url"
            result: copy "" 
            parse/all data [
                any [
                    copy value some chars (append result value) | 
                    copy value 1 skip (append result rejoin ["%" back back tail to-hex to-integer value/1])
                ]
            ] 
            result
        ]
        decode: func [data [binary! string! file! url!]] [
            if any [file? data url? data] [data: read data]
            if not string? data [data: as-string data]
            dehex data
        ]
    ]
    register-codec [
        name: 'text
        type: 'text
        title: "Text document"
        suffixes: [%.txt]
        encode: func [data /as type [word!]] [
            if all [as type = 'rebol] [return mold data]
            if binary? data [return as-string data]
            form data
        ]
        decode: func [data [binary! string! file! url!] /as type [word!]] [
            if any [file? data url? data] [data: read data]
            if not string? data [data: as-string data]
            if all [as type = 'rebol] [return load to-string data]
            data
        ]
    ]

    overloaded: copy []
    overload: func [
        [catch]
        function [any-function! word!] new-spec [block! none!] new-body [block! none!]
        /replace /force /recover /purge /reset
    /local
        ctx arguments refinements refinement word ref-args
    ] [
        if word? :function [function: get function]

        if purge [
            either purge: select overloaded :function [
                remove/part find overloaded :function 2
                return first purge
            ] [return :function]
        ]

        if recover [
            either recover: select overloaded :function [
                return first recover
            ] [return :function]
        ]

        if reset [
            if reset: select overloaded :function [
                remove/part find overloaded :function 2
                function: :reset
            ]
        ]

        if all [
            select overloaded :function
            not force
        ] [throw make error! "Already an overload. Use /force to bypass."]

        new-spec: append either replace [copy []] [
            do mold copy/part third :function any [find third :function /local tail third :function]
        ] any [new-spec []]

        arguments: copy []
        refinements: copy [] 

        parse first :function [
            any [set word word! (append arguments to-get-word word)] 
            any [
                set refinement refinement! (ref-args: copy []) 
                any [
                    set word word! (append ref-args to-get-word word)
                ] (append refinements to-word refinement append/only refinements ref-args)
            ]
        ]

        if not find new-spec /local [append new-spec /local]
 
        ctx: context compose/deep [
            original*: :function
            new*: func [(new-spec) redirect*] [
                redirect*: func [/local argments func-refs] [
                    func-refs: copy [original*]
                    arguments: copy [(arguments)]
                    foreach [refinement arg-list] [(refinements)] [
                        if get refinement [append func-refs refinement append arguments arg-list]
                    ]
                    append reduce [to-path func-refs] arguments
                ]
                (any [new-body second :function])
            ]
        ]

        append overloaded get in ctx 'new*
        append/only overloaded reduce [:function]

        get in ctx 'new*
    ]

    load: overload/reset get in system/words 'load [
        /as "Override default file-type" type [word! block! none!]
    /local file-type
    ] [
        if as [
            either none? type [return do redirect*] [
                system/words/all [block? type 1 = length? type type: type/1]  
                return either block? type [decode/as type/1 source type/2] [decode type source]
            ]
        ]
        if parse reduce [header next library all as] [any none!] [
            if system/words/all [any [file? source url? source] file-type: file-type? source] [
                return decode file-type source
            ]
        ]
        do redirect*
    ]

    save: overload/reset get in system/words 'save [
        /as "Override default file-type" type [word! block! none!]
    /local file-type
    ] [
        if as [
            either none? type [return do redirect*] [
                system/words/all [block? type 1 = length? type type: type/1]  
                either block? type [
                    either binary? where [
                        return append where encode/as type/1 value type/2
                    ] [
                        return write/binary where encode/as type/1 value type/2
                    ]
                ] [
                    either binary? where [
                        return append where encode type value
                    ] [
                        return write/binary where encode type value
                    ]
                ]
            ]
        ]
        if parse reduce [header bmp png all] [any none!] [
            if system/words/all [any [file? where url? where] file-type: file-type? where] [
                return write/binary where encode file-type value
            ]
        ]
        do redirect*
    ]
]

system/script/args: compose [(system/script/args)]
if any [
    find system/script/args 'force
    all [select system/components 'codecs system/components/codecs/version < system/script/header/version]
    none? select system/components 'codecs
] [
    either select system/components 'codecs [
        system/components/codecs: system/script/header
    ] [
        append system/components 'codecs
        append system/components system/script/header
        append system/components none
    ]

    either select system/script/args 'with [
        foreach word compose [(system/script/args/with)] [ 
            if find system/script/header/exports word [
                set word get in ctx-codecs word
            ]
        ]
    ] [foreach word system/script/header/exports [set word get in ctx-codecs word]]
]

system/script/header/version