REBOL [ Title: "REBOL2 Codec System" Date: 7-Mar-2025 Name: 'codecs Version: 1.0.1 File: %codecs.r Author: Rights: "Annick ECUYER" History: [ 7-Mar-2025 "Annick" {Bugfixes: prevent duplicate codec loading + View 1.2.1 compability fix} 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/name [ 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 either any-function? :all [none] [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