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.

1. 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).
2. for another reason beyond me, the code completely crashes when passed a NULL, and compiler does not warn on compilation.
3. compiler keeps complaining about uninitialized variables, which is technically correct but, which is highly annoying.
4. 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).
5. 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. (V002 was added 16 oct 2014).

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

  v001 - initial release
  v002 - corrected some serious flaw(s) when given args was empty or in case only one arg was given
         (index ii out of bounds). Now code should be able to account for odd number of args given
       - implemented smarter GetTagPtr.
       - Added additional (missing) types and constants for other platforms and corrected some wrong
         Type definition.
*)



interface



// Some conditional code in case compiling for another platform.
{$IFDEF AROS}
uses
  exec, utility;
{$ENDIF}
  
{$IFNDEF AROS}
Const
  TAG_DONE   = 0;           // terminates array of TagItems. ti_Data unused
  TAG_END    = TAG_DONE;
  TAG_IGNORE = 1;           // ignore this item, not END of array
  TAG_MORE   = 2;           // ti_Data is pointer to another array of TagItems 
                            // note that this tag terminates the current array
  TAG_SKIP   = 3;           // skip this AND the next ti_Data items

Type
  IPTR       = NativeUInt;

  Tag        = LongWord;
  PTag       = ^Tag;

  PTagItem   = ^TTagItem;
  TTagItem   = record
    ti_Tag   : Tag;
    ti_Data  : IPTR;
  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;
  LArgs           : Integer;
  ArrayItemsToAdd : Integer;
begin
  // make sure there's something there that can be added to begin with
  LArgs := Length(Args);
  if ( LArgs > 0) then
  begin
    // Get Index of the first item in array to add Args to
    ii := Length(Self.TagsList);
  
    // Calculate #items that needs to be added to TagsList array to be able to 
    // accomodate the #Args passed
    If odd(LArgs)
    then ArrayItemsToAdd := ((LArgs div 2) + 1)
    else ArrayItemsToAdd := (LArgs div 2);

    // set new length = old length + ArrayItems to add
    SetLength(Self.TagsList, Length(Self.TagsList) + ArrayItemsToAdd);
 
    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;  
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;
  ThisTag : Tag;
begin
  // writeln('calling TArosTags Implicit assignment, length =', length(a.tagsList));

  i := Length(a.TagsList);
  If (i = 0) then
  begin
    Result := Nil;
  end
  else
  begin
    ThisTag := a.TagsList[i-1].ti_tag;
  
    (*
      in case the tagarray is not properly terminated, we do it instead.
      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 (ThisTag <> TAG_END) and (ThisTag <> TAG_MORE)
    then a.Add([TAG_END]);
    
    Result := @a.TagsList[0];
  end;
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;