Subject Re: UUID (octets) to something readable
Author woodsmailbox
Ugh, I didn't catch your message. If it's not too late, here's the
whole updated .pas file (tested on fpc/linux, fb superserver 2.1.2)

-----------------------------------------------
{
#
# UDF library for the gazolin web app.
# All this is freepascal code in delphi dialect.
#
# General tips:
# - by default, all input and output parameters are pointers, so `by
reference' is the implicit calling method.
# - if you never return null, use the `by value' calling method to
avoid having to malloc the result.
# - when returning `by reference', malloc() the result yourself, and
declare the udf with the `free_it' directive. for this to work
# you have to use either clib's malloc() (on linux), msvcrt's malloc()
(on windows) or ib_util's ib_util_malloc() (cross-platform).
# - in case your udf takes cstring(N) as the <n>'th parameter and
returns cstring(at most N) of the same charset as that parameter,
# use `returns parameter <n>' instead, and just write on it's buffer
instead of malloc'ing another block.
# Null handling:
# - firebird 2.0+ will pass nulls as null pointers but only for
parameters declared as `by reference null'.
# otherwise you'll get a 0 (zero) for an integer or double parameter,
and an empty string for a string parameter.
# - null parameters can also be detected with the `by descriptor'
calling method (see code for details).
# - returning a nil pointer is interpreted as null (note that you
can't say `returning ... by reference null'; tested in 2.1.1).
# Type mapping (firebird-freepascal):
# INTEGER BY REFERENCE - var Longint or PLongint if you want to
catch/return nulls
# INTEGER BY VALUE - Longint
# DOUBLE PRECISION BY REFERENCE - var Double or PDouble if you
want to catch/return nulls
# DOUBLE PRECISION BY VALUE - Double
# CSTRING(N) BY REFERENCE - PChar
# CSTRING(N) BY VALUE - doesn't make sense
# <anything> BY DESCRIPTOR - PParamDsc
# Charsets:
# - firebird gives/expects text parameters in the charsets the udf was
declared with.
# - gotcha: you won't be able to catch/return strings containing
ascii_char(0) characters except with the `by descriptor'
# calling method where ??? or with `varchar by reference' (instead of
cstring), and you get the length at PLongint(param)^ and the contents
at @param[2].
# Using descriptors:
# - declaring parameters as `<datatype> by descriptor' won't
guarrantee you that the engine will give you the values in that
datatype!
# instead you gotta check dsc_dtype yourself and interpret the value
accordingly. the advantage is you can write polymorphic functions.
#
}

{$LONGSTRINGS ON}
{$MODE DELPHI}

library gazolin_fpc_udfs;

uses
md5,
classes,
sysutils;

const
// ParamDsc.dsc_dtype
DTYPE_UNKNOWN = 0;
DTYPE_TEXT = 1; // CHAR; dsc_length = length of the field, not
content; actual length must be computed by trimming the padding
spaces.
DTYPE_CSTRING = 2; // CSTRING; dsc_length = length of the field,
not content + 1; actual length must be computed with strlen()
DTYPE_VARYING = 3; // VARCHAR; dsc_length = length of the field,
not content + 2; actual length is at dsc_address[0]; content is at
dsc_address[2] !
DTYPE_PACKED = 6;
DTYPE_BYTE = 7; // ?
DTYPE_SHORT = 8; // SMALLINT ?
DTYPE_LONG = 9; // INTEGER ?
DTYPE_QUAD = 10;
DTYPE_REAL = 11;
DTYPE_DOUBLE = 12; // DOUBLE PRECISION ?
DTYPE_D_FLOAT = 13;
DTYPE_SQL_DATE = 14;
DTYPE_SQL_TIME = 15;
DTYPE_TIMESTAMP = 16;
DTYPE_BLOB = 17;
DTYPE_ARRAY = 18;
DTYPE_INT64 = 19;

// ParamDsc.dsc_sub_type for text types
DSC_TEXT_TYPE_NONE = 0; // normal text
DSC_TEXT_TYPE_FIXED = 1; // can have #0 in it
DSC_TEXT_TYPE_METADATA = 2; // for metadata

// ParamDsc.dsc_sub_type for dsc_dtype in (short, long, quad)
DSC_NUM_TYPE_NONE = 0; // SMALLINT or INTEGER
DSC_NUM_TYPE_NUMERIC = 1; // NUMERIC(n,m)
DSC_NUM_TYPE_DECIMAL = 2; // DECIMAL(n,m)

// ParamDsc.dsc_flags
DSC_NULL = 1;
DSC_NO_SUBTYPE = 2;
DSC_NULLABLE = 3;

type
ParamDsc = record
dsc_dtype : Byte; // one of DTYPE_* (sure is not a
bitmask?)
dsc_scale : ShortInt; // where's precision?
dsc_length : Word; // size of buffer, including
trailing #0, etc.
dsc_sub_type: SmallInt; // one of DSC_*_TYPE
dsc_flags : Word; // a bitmask of DSC_* constants
dsc_address : Pointer; // a cstring begins as
dsc_address[2] !!
end;
PParamDsc = ^ParamDsc;

// either malloc work in linux. pick the first for portability, pick
the second for not depending on ib_util.
// function malloc(size: Longint): Pointer; cdecl; external 'ib_util'
name 'ib_util_malloc';
function malloc(size: Longint): Pointer; cdecl; external 'libc';
procedure free(p: Pointer); cdecl; external 'libc';

{--- demo stuff starts here ---}

// declare ... integer, <idem> returns integer by value ...
function test_int(var i1, i2: Longint): Longint; cdecl; export;
begin
result := i1 + i2;
end;

// declare ... double precision, <idem> returns double precision by
value ...
function test_double(var d1, d2: Double): Double; cdecl; export;
begin
result := d1 / d2; // OBS: when d2 = 0 you get INF, instead of a
div-by-zero error.
end;

// declare ... cstring(N) chaset <any-single-byte-charset> null,
<idem> returns cstring(2*N) free_it ...
function test_freeit(s1, s2: PChar): PChar; cdecl; export;
begin
if (s1 = nil) or (s2 = nil) then
begin
result := nil;
exit;
end;
result := malloc(strlen(s1) + strlen(s2) + 1);
Move(s1^, result^, strlen(s1));
Move(s2^, result[strlen(s1)], strlen(s2));
result[strlen(s1) + strlen(s2)] := #0;
end;

// declare ... cstring( >= Length(s) ) null returns parameter 1 ...
function test_retparam(s1: PChar): PChar; cdecl; export;
var
s: string;
begin
if s1 = nil then
begin
result := nil;
exit;
end;
result := s1;
s := 'TEST OK';
Move(result^, s[1], Length(s));
result[Length(s)] := #0;
end;

// declare ... integer by descriptor, integer by descriptor returns
integer by value ...
function test_paramdsc(i1, i2: PParamDsc): Longint; cdecl; export;
begin
result := -1;
if (i1 = nil) or ((i1^.dsc_flags and DSC_NULL) <> 0) then
exit;
if (i2 = nil) or ((i2^.dsc_flags and DSC_NULL) <> 0) then
exit;

result := PLongint(i1^.dsc_address)^ + PLongint(i2^.dsc_address)^;
end;

{--- private lib stuff starts here ---}

function paramdsc_is_null(p: PParamDsc): boolean;
begin
result := (p = nil) or (p^.dsc_address = nil) or (p^.dsc_flags and
DSC_NULL <> 0);
end;

function paramdsc_field_length(p: PParamDsc): Longint;
begin
case p^.dsc_dtype of
DTYPE_TEXT: result := p^.dsc_length;
DTYPE_CSTRING: result := p^.dsc_length - 1;
DTYPE_VARYING: result := p^.dsc_length - 2;
else
result := 0;
end;
end;

function paramdsc_text_length(p: PParamDsc): Longint;
begin
case p^.dsc_dtype of
DTYPE_TEXT: result := p^.dsc_length; // we shall not look at
padding spaces!
DTYPE_CSTRING: result := strlen(p^.dsc_address);
DTYPE_VARYING: result := PWord(p^.dsc_address)^;
else
result := 0;
end;
end;

function paramdsc_text_pointer(P: PParamDsc): PChar;
begin
case p^.dsc_dtype of
DTYPE_TEXT: result := p^.dsc_address;
DTYPE_CSTRING: result := p^.dsc_address;
DTYPE_VARYING: result := p^.dsc_address + 2;
else
result := nil;
end;
end;

function paramdsc_is_text(p: PParamDsc): boolean;
begin
result := (p^.dsc_dtype >= DTYPE_TEXT) and (p^.dsc_dtype <=
DTYPE_VARYING);
end;

function paramdsc_is_date(p: PParamDsc): boolean;
begin
result := (p^.dsc_dtype >= DTYPE_SQL_DATE) and (p^.dsc_dtype <=
DTYPE_TIMESTAMP);
end;

// allocates result and copies s in result.
// useful for returning strings declared it in firebird as "cstring(N)
free_it"
function to_pchar(s: string): PChar;
begin
result := malloc(length(s) + 1);
Move(s[1], result^, length(s));
result[length(s)] := #0;
end;

function utf8_char_size(p: PChar): Longint;
var
b: byte;
begin
b := byte(p[0]);
if b <= 127 then
result := 1
else
if (b >= $C0) and (b <= $DF) then
result := 2
else
if (b >= $E0) and (b <= $EF) then
result := 3
else
if (b >= $F0) and (b <= $F4) then
result := 4
else
result := 0;
end;

function utf8_advance(p: PChar): PChar;
var
k: Longint;
begin
k := utf8_char_size(p);
if (k > 0) then
result := @p[k]
else
result := nil;
end;

function utf8_string_length(p: PChar): LongInt;
var
k: LongInt;
begin
result := 0;
if p = nil then
exit;

k := 0;
while p <> #0 do
begin
inc(k);
p := utf8_advance(p);
if p = nil then
exit;
end;
result := k;
end;

function utf8_char_equal(p1, p2: PChar): Boolean;
var
l1, l2: Longint;
begin
l1 := utf8_char_size(p1);
l2 := utf8_char_size(p2);
result := (l1 <> 0) and (l1 = l2) and (CompareByte(p1^, p2^, l1) =
0);
end;

procedure utf8_char_copy(target, source: PChar);
begin
Move(source^, target^, utf8_char_size(source));
end;

{--- public lib stuff starts here ---}

// declare ... cstring(N) charset <any-single-byte-charset> null, ...
returns parameter 3 ...
function sbc_string_replace_chars(search_chars, replace_chars, target:
PChar): PChar; cdecl; export;
var
s, r, t: PChar;
begin
if (search_chars = nil) or (replace_chars = nil) or (target = nil)
then
result := nil
else
begin
result := target;
t := target;
while t^ <> #0 do
begin
s := search_chars;
r := replace_chars;
while (s^ <> #0) and (r^ <> #0) do
begin
if t^ = s^ then
begin
t^ := ^r;
break;
end;
s := @s[1];
// we allow replace_chars to be shorter than
search_chars, in which case
// we use the last char of replace_chars.
if (r[1] <> #0) then
r := @r[1];
end;
t := @t[1];
end;
end;
end;

// declare ... cstring(N) charset utf8 null, ... returns cstring(N)
charset utf8 free_it
function utf8_string_replace_chars(search_chars, replace_chars,
target: PChar): PChar; cdecl; export;
var
s, r, test_r, t: PChar;
tl: LongInt;
begin
if (search_chars = nil) or (replace_chars = nil) or (target = nil)
then
begin
result := nil;
exit;
end;

tl := utf8_string_length(target);
result := malloc(tl*4 + 1);
try
result^ := #0; // safety stop
t := target;
while t^ <> #0 do
begin
s := search_chars;
r := replace_chars;
while (s^ <> #0) and (r^ <> #0) do
begin
if (utf8_char_equal(t, s)) then
begin
t^ := r^;
break;
end;
s := utf8_advance(s); if s = nil then exit;
// we allow replace_chars to be shorter than
search_chars, in which case
// we use the last char of replace_chars.
test_r := utf8_advance(r); if test_r = nil then exit;
if (test_r^ <> #0) then
r := test_r;
end;
t := utf8_advance(t); if t = nil then exit;
end;
except
free(result);
raise;
end;
end;

// declare ... cstring(N) charset utf8 null, ... returns integer by
value
function utf8_string_made_of(char_list, target: PChar): Longint;
cdecl; export;
var
i, k: Longint;
p: PChar;
begin
utf8_string_made_of := 0;
if (char_list = nil) or (target = nil) then
exit;
i := 0;
while target[0] <> #0 do
begin
p := char_list;
while p[0] <> #0 do
if utf8_char_equal(target, p) then
break
else
p := utf8_advance(p);
if p[0] = #0 then exit;
target := utf8_advance(target);
if target = nil then exit;
end;
utf8_string_made_of := 1;
end;

// declare ... cstring(N) charset <any-charset> null, ... returns
varchar(16) charset octets free_it ...
function md5(token: PChar): PChar; cdecl; export;
begin
result := nil;
if (token = nil) then
exit;

result := malloc(2 + 16);
Move(MD5String(token), result[2], 16);
PWord(result)^ := 16;
end;

// declare ... varchar(N) charset octets null returns cstring(N*2)
charset <any-sbc-or-utf8> free_it ...
function bin_to_hex(token: PChar): PChar; cdecl; export;
var
len: Longint;
begin
result := nil;
if (token = nil) then
exit;

len := PWord(token)^;
result := malloc(len*2 + 1);
BinToHex(@token[2], result, len);
result[len*2] := #0;
end;

// declare ... cstring(N) charset <any-sbc> null returns varchar(N/2)
charset octets free_it
function hex_to_bin(token: PChar; max_bin_length: Longint = 0): PChar;
var
len: Longint;
begin
result := nil;
if (token = nil) then
exit;

len := strlen(token);
if ((len mod 2 <> 0) or (len > 2*max_bin_length)) then
exit;

result := malloc(2 + len div 2);
PWord(result)^ := HexToBin(token, @result[2], len div 2);
end;

{--- applib stuff starts here ---}

exports
// test funcs
test_int,
test_double,
test_freeit,
test_retparam,
test_paramdsc,
// lib funcs
sbc_string_replace_chars,
utf8_string_replace_chars,
utf8_string_made_of,
md5,
bin_to_hex,
hex_to_bin;
// applib funcs: none yet

begin
//this is required when loaded from firebird for UDFs.
IsMultiThread := True;


end.