Experimental Tags
One of the most annoying things about passing an array of const (needed for passing f.e. tagitems) is the somewhat awkward way of creating an tagitemlist.
Not only is it awkward, but the current way that the ReadInTags() function is implemented is plain wrong. It is not possible to use/create two taglists at the same time.
ALB42 tried to implement a more practical solution by creating additional functions AddTags() and GetTagPtr() [1].
Now that Free Pascal has a more convenient way of working with record through advanced records [2], i gave it an experimental try.
And boy, are we in for some troubles along the way.
- for reasons beyond me, we must use $MODE DELPHI otherwise we are unable to overload assignment operators. (and that's exactly the fun part we want to 'abuse' here).
- for another reason beyond me, the code completely crashes when passed a NULL, and compiler does not warn on compilation.
- compiler keeps complaining about uninitialized variables, which is technically correct but, which is highly annoying.
- i'm unsure the 'resetting' of the item array is required to force freeing the internal array. Unfortunately an advanced record does not have a destructor (in opposite of an constructor, but which Free Pascal currently does not support).
- there are so many different (extended) implementations possible, that i refrained from adding any additional functionality. The whole source is based on the literal implementation that was already in Free Pascal trunk.
Let's start with wome code for a TagItems list.
unit aros_modern_tags;
{ $MODESWITCH ADVANCEDRECORDS <- does not let us overload assignment operator}
{$MODE DELPHI}{$H+}
(*
Very basic implementation of modern tags in form of an advanced record.
Based on ALBs (and previously other people's) work.
http://svn.freepascal.org/cgi-bin/viewvc.cgi/trunk/packages/arosunits/src/tagsarray.pas?view=markup
*)
interface
// Some conditional code in case compiling for another platform.
{$IFDEF AROS}
uses
exec, utility;
{$ENDIF}
{$IFNDEF AROS}
Const
TAG_END = 0;
Type
IPTR = NativeUInt;
PTagItem = ^TTagItem;
TTagItem = record
ti_Tag : LongWord;
ti_Data : LongWord;
end;
{$ENDIF}
Type
TTagsList = array of TTagitem;
TArosTags = record
private
TagsList : TTagsList;
public
procedure Add(const Args: array of const);
procedure Clear;
// Assignment operators to TArosTags from another type
class operator := (a: Integer): TArosTags;
// Assignment operators from TArosTags to another type
class operator := (a: TArosTags): PTagItem;
end;
implementation
procedure TArosTags.Add(const args: array of const);
var
i : Integer;
ii : integer;
begin
ii := Length(Self.TagsList);
SetLength(Self.TagsList, Length(Self.TagsList) + (Length(Args) div 2));
for i := 0 to High(Args) do
begin
if (not Odd(i)) then
begin
self.TagsList[ii].ti_tag := IPTR(Args[i].vinteger);
end
else
begin
case Args[i].vtype of
vtinteger : Self.TagsList[ii].ti_data := IPTR(Args[i].vinteger);
vtboolean : Self.TagsList[ii].ti_data := IPTR(byte(Args[i].vboolean));
vtpchar : Self.TagsList[ii].ti_data := IPTR(Args[i].vpchar);
vtchar : Self.TagsList[ii].ti_data := IPTR(Args[i].vchar);
vtstring : Self.TagsList[ii].ti_data := IPTR(PChar(string(Args[i].vstring^)));
vtpointer : Self.TagsList[ii].ti_data := IPTR(Args[i].vpointer);
end;
inc(ii);
end;
end;
end;
procedure TArosTags.Clear;
begin
SetLength(Self.TagsList, 0);
end;
class operator TArosTags.implicit(a: Integer): TArosTags;
begin
// dummy function clear
Result.Clear;
end;
class operator TArosTags.Implicit(a: TArosTags): PTagItem;
var
i : Integer;
begin
// writeln('calling TArosTags Implicit assignment, length =', length(a.tagsList));
i := Length(a.TagsList);
(*
make sure last tag is TAG_END
Actually, this might not be a good idea if enduser expects to be adding
new tags later on.
In which case it would be better to make a copy of the tagslist first or
alternatively with adding tags first check if there's an end tag and
remove the tag before adding new tags
if (TagsList[i].ti_tag <> TAG_END) then Add([TAG_END, TAG_END]);
*)
if (a.TagsList[i].ti_tag <> TAG_END) then a.Add([TAG_END, TAG_END]);
result := @a.TagsList[0];
end;
end.
And some code to test a the TagItems.
program TestTagItems;
// A simple quick test for modern args
Procedure Test;
var
Items1 : TArosTags;
value : IPTR;
answer : IPTR;
begin
Items1.Add([1,1000,2,2000,3,3000, TAG_END]);
value := 666;
Answer := GetTagData(1, IPTR(@value), Items1);
writeln('answer = ', answer);
end;
Begin
Test;
end.
And when put to practice, it can look somewhat similar like:
Function GetAttrs(rp: PRastPort; const Tags: array of const): ULONG;
Var TagItems: TArosTags;
begin
TagItems := 0;
TagItems.Add(Tags);
Result := GetAttrsA(rp, TagItems);
TagItems := 0;
end;