unit DataClasses;

// from https://mitjastachowiak.de/components/pascal/dataclasses.pas

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Controls, StdCtrls, ExtCtrls, Forms, dialogs, Graphics, xmlUtil;

type
  TDataClass = class;

  {
   TDataItem
   Each DataItem is linked with one XML-element. This element must exist before
   and gets not destroyed, when the item is destroyed in general but when the item
   is actively removed by clicking the remove button. Each item has a title-Value per default.
  }
  TDataItem = class(TPanel)
    strict private
      destroyXML : Boolean;  // if true, TDataItem.destroy will also destroy the xml-element.
    private
      _prev, _next : TDataItem;
      _parent      : TDataClass;
      _xmlEl       : XML.TElement; // the xml element belonging to this item
      function readTitle : String; inline;
      procedure doClick(Sender : TObject); // when the item is clicked (activated)
      procedure remove(keepXML:Boolean=false);   // removes an item and it's xml-element from the parent. Does not destroy the item! Does not call TDataClass.onRemove!
    protected
      butRem     : TButton; // button for removing the current item
      butMod     : TButton; // button for opening additional GUI for changing item parameters
      titleEl    : TLabel; // the title label
      procedure writeTitle(v : String); virtual;  // sets the title
      procedure indexChanged; virtual;  // can be overridden to trigger index change
      procedure afterInsertion; virtual; // can be overridden to trigger the insertion of an item into the class list. Is not called, when the item is moved in the class.
      procedure writeParent(P : TDataClass); virtual; // sets P as the parent class of this item. Does not set P's xmlEl as the parent of P's xmlEl!
    public
      constructor create(theXml:XML.TElement); virtual; reintroduce;
      procedure activate; virtual;  // marks/selects this item
      procedure deactivate; virtual; // unmarks/deselects this item
      procedure removeAndDestroy(Sender : TObject); // Removes and destroyes the item and it's xml-element
      function index : integer;   // returns the current index of this item
      property next : TDataItem read _Next; // next item
      property prev : TDataItem read _Prev; // previous item
      procedure insertAfter(Pr : TDataItem; keepXML : Boolean = false); // inserts this item in the class of P behind P
      procedure insertFirst(P : TDataClass; keepXML : Boolean = false); // inserts this item as the first item in the class P
      procedure appendTo(P : TDataClass); // inserts this item as the last one in class P
      procedure moveUp;  // moves the item one position up in the current class
      property title : String read ReadTitle write WriteTitle;
      property parent : TDataClass read _Parent; // the parent class of this item
      procedure edit(Sender : TObject); virtual; // when the butMod was clicked
      property xmlEl : XML.TElement read _xmlEl;
      destructor destroy; override;
  end;

  {
   TDataClass
   Represents a list of elements.
   Is always linked with an XML-element (list), but this element can be changed
   without creating a new instance of TDataClass. TDataClass will never destroy
   it's XML-element! The xml-element must not be destroyed while it is linked
   with the data class!
   Items are stored in a linked list chain (not array).
  }
  TDataClass = class(TPanel)
   type
     TAddButtonDisplay = (BOTTOM, RIGHT, NONE);
     TDataItemCLass = class of TDataItem;
     TTagnameListItem = record
      tagName : ShortString;
      objType : TDataItemClass;
     end;
   strict private
     titleEl    : TLabel;   // the title of the list
     _clearing  : Boolean;
     itemTypes  : Array of TTagnameListItem; // list of availlable item classes
     function readTitle : String; inline;
     procedure writeTitle(v : String); inline;
     function getItem(i : Cardinal) : TDataItem;
     procedure replaceXML(newXML : XML.TElement);
     function readSortable : Boolean;
     procedure writeSortable(v : Boolean);
     procedure writeItemIndex(v : integer);
     procedure newItem(Sender : TObject); // when the addbut was clicked
     procedure writeAddButtonDisplay(v:TAddButtonDisplay);
   private
     _first     : TDataItem;  // first item
     _last      : TDataItem;  // last item
     _xmlEl     : XML.TElement; // the xml-element representing the list
     _active    : TDataItem; // current active element
     _itemIndex : integer; // current index of the active element
   protected
     box     : TScrollBox;  // the box containing all the items
     addBut  : TButton; // button for adding new items
     butUp   : TButton;  // button for moving items up
     butDown : TButton;  // button for moving items down
     procedure switchItems(I1, I2 : TDataItem); virtual; // moves I2 up - special functionality for some derived classes, which may require items not to be moved by more than one index at once
   public
     deleteQuestion : String;  // this message will be displayed in the confirmation dialog, which pops up, when the user deletes one item
     onSelect : procedure(Sender : TObject) of object;  // when an item is activated or deactivated
     onRemove : procedure(Sender : TDataClass; Item : TDataItem) of object;
     onAfterRemove : procedure(Sender : TObject) of object;
     onAfterCreateItem : procedure(item:TDataItem) of object;
     insertBeforeSelection : Boolean; // if true, items created by the addBut will be inserted before the selected item, if false at the end
     defaultTagName : ShortString; // items created by the addBut will have this tagName
     constructor create(_owner:TComponent); reintroduce;
     procedure itemUp(Sender : TObject); // moves the selected item down
     procedure itemDown(Sender : TObject); // moves the selected item up
     procedure clear;    // removes and destroys all items
     function count : integer; // number of items in this class
     property xmlEl : XML.TElement read _xmlEl write replaceXML;
     property clearing : Boolean read _clearing;
     property title : String read ReadTitle write WriteTitle;
     property items[i : Cardinal] : TDataItem read GetItem; // an array-like representation of the item list (slow!)
     property itemIndex : integer read _ItemIndex write writeItemIndex;
     procedure addItemType(tagName:ShortString; objType:TDataItemClass);
     property addButtonDisplay : TAddButtonDisplay write writeAddButtonDisplay;
     property last : TDataItem read _Last;
     property first : TDataItem read _First;
     property sortable : Boolean read readSortable write writeSortable;   // if true, the Up/Down-Buttons are visible and the user can reorder items
     function addItem(el:XML.TElement; keepXML:Boolean=false) : TDataItem;  // creates the TDataItem representing the given element. The element can be child node of the class xmlEl. Otherwise el will be appended as a child node to class xmlEl.
     destructor destroy; override;
  end;

implementation

constructor TDataItem.create(theXml:XML.TElement);
begin
  inherited create(nil);
  _xmlEl := theXml;
  _prev := nil;
  _next := nil;
  _parent := nil;
  destroyXML := false;
  titleEl := TLabel.Create(self);
  titleEl.Parent := self;
  titleEl.AnchorParallel(akLeft, 4, self);
  titleEl.AnchorParallel(akTop, 2, self);
  titleEl.Caption := xmlEl.getAttribute('title');
  butRem := TButton.Create(self);
  butRem.Parent := self;
  butRem.Caption := '-';
  butRem.Width := ButRem.Height;
  butRem.Anchors := [akTop, akBottom, akRight];
  butRem.AnchorParallel(akTop, 2, self);
  butRem.AnchorParallel(akRight, 2, self);
  butRem.AnchorParallel(akBottom, 2, self);
  butRem.OnClick := @removeAndDestroy;
  butMod := TButton.Create(self);
  butMod.Parent := self;
  butMod.Caption := '...';
  butMod.Width := butMod.Height;
  butMod.Anchors := [akTop, akBottom, akRight];
  butMod.AnchorParallel(akTop, 2, self);
  butMod.AnchorToNeighbour(akRight, 2, ButRem);
  butMod.AnchorParallel(akBottom, 2, self);
  butMod.OnClick := @edit;
  self.Height := titleEl.Height + 6;
  titleEl.OnClick := @doClick;
  self.OnClick := @doClick;
end;

procedure TDataItem.doClick(Sender : TObject);
begin
  Activate;
end;

procedure TDataItem.edit(Sender : TObject);
begin // to be overridden
end;

function TDataItem.index : integer;
var
  el : TDataItem;
begin
  if (parent = nil) then Result := -1
  else begin
    el := self;
    Result := 0;
    while (el.prev <> nil) do begin
      el := el.prev;
      Result += 1;
    end;
  end;
end;

procedure TDataItem.activate;
begin
  if (parent = nil) or (parent._active = self) then exit;
  parent._itemIndex := -1;
  if (parent._active <> nil) then parent._active.deactivate;
  self.Color := clBlue;
  parent._active := self;
  parent._itemIndex := index;
  if (parent.onSelect <> nil) then parent.onSelect(parent);
end;

procedure TDataItem.deactivate;
begin
  self.Color := clDefault;
  parent._active := nil;
  if (parent._itemIndex <> -1) then begin
    parent._itemIndex := -1;
    if (parent.onSelect <> nil) then parent.onSelect(parent);
  end;
end;

function TDataItem.readTitle : String; inline;
begin
  Result := titleEl.Caption;
end;

procedure TDataItem.writeTitle(v : String); inline;
begin
  titleEl.Caption := v;
  xmlEl.setAttribute('title', v);
end;

procedure TDataItem.indexChanged;
begin // To be overridden
end;

procedure TDataItem.afterInsertion;
begin // To be overridden
end;

procedure TDataItem.writeParent(p : TDataClass);
begin
  _parent := p;
  if (P <> nil) then begin
    setParent(p.box);
    visible := true;
    anchorParallel(akLeft, 0, p.box);
    anchorParallel(akRight, 0, p.box);
  end else visible := false;
  indexChanged;
end;

procedure TDataItem.remove(keepXML: Boolean);
var
  p : TDataClass;
  it : TDataItem;
begin
  if (parent <> nil) and (not keepXML) then parent.xmlEl.removeChild(self.xmlEl);
  it := self.next;
  if (prev <> nil) then prev._next := self.next
  else if (parent <> nil) then parent._first := self.next;
  if (self.next <> nil) then begin
    self.next._prev := self.prev;
    if (self.prev = nil) then self.next.AnchorParallel(akTop, 0, parent)
    else self.next.AnchorToNeighbour(akTop, 0, self.prev); end
  else if (parent <> nil) then parent._last := prev;
  _prev := nil;
  _next := nil;
  p := parent;
  if (p <> nil) and (parent._active = self) then p._active := nil;
  writeParent(nil);
  while (it <> nil) do begin
    it.indexChanged;
    it := it.Next;
  end;
end;

procedure TDataItem.removeAndDestroy(Sender : TObject);
var p : TDataClass;
begin
  p := parent;
  if (p <> nil) and (Parent.DeleteQuestion <> '') then if (MessageDlg('Löschen', Parent.DeleteQuestion, mtConfirmation, [mbYes, mbNo], 0) = mrNo) then exit;
  if (p <> nil) and (p.onRemove <> nil) then p.onRemove(p, self);
  remove(false);
  if (p <> nil) and (p.onAfterRemove <> nil) then p.onAfterRemove(p);
  destroyXML := true;
  Application.ReleaseComponent(self); // self.free
end;

procedure TDataItem.insertAfter(Pr : TDataItem; keepXML : Boolean = false);
var oldParent : TDataClass;
begin
  oldParent := Parent;
  remove(keepXML);
  if (not keepXML) then
    if (Pr.next <> nil) then Pr.parent.xmlEl.insertChildBefore(self.xmlEl, Pr.next.xmlEl)
    else Pr.parent.xmlEl.appendChild(self.xmlEl);
  if (parent <> Pr.parent) then _parent := Pr.parent;
  if (Pr.next <> nil) then Pr.next.AnchorToNeighbour(akTop, 0, nil);
  _prev := Pr;
  _next := Pr.next;
  AnchorToNeighbour(akTop, 0, self.prev);
  Pr._Next := self;
  if (self.next <> nil) then begin
    self.next._Prev := self;
    self.next.AnchorToNeighbour(akTop, 0, self);
  end else parent._last := self;
  writeParent(_parent);
  Pr := parent._last;
  while (Pr <> nil) do begin
    Pr.indexChanged;
    if (Pr = self) then break;
    Pr := Pr.prev;
  end;
  if (oldParent <> Parent) then afterInsertion;
end;

procedure TDataItem.insertFirst(P : TDataClass; keepXML : Boolean = false);
var
  it : TDataItem;
  oldParent : TDataClass;
begin
  oldParent := Parent;
  remove(keepXML);
  if (not keepXML) then P.xmlEl.insertChildBefore(self.xmlEl, P.xmlEl.firstChild);
  _parent := P;
  _next := parent._first;
  AnchorParallel(akTop, 0, parent.box);
  parent._first := self;
  if (next <> nil) then begin
    next._prev := self;
    Next.AnchorToNeighbour(akTop, 0, self);
  end;
  if (parent._last = nil) then parent._last := self;
  writeParent(_parent);
  it := parent._last;
  while (it <> nil) do begin
    it.indexChanged;
    if (it = self) then break;
    it := it.Prev;
  end;
  if (oldParent <> Parent) then afterInsertion;
end;

procedure TDataItem.moveUp;
var
  neighbour : TDataItem;
begin
  neighbour := self.Prev;
  if (neighbour = nil) then exit;
  parent.xmlEl.insertChildBefore(self.xmlEl, neighbour.xmlEl);
  neighbour._next := self._next;
  self._prev := neighbour._prev;
  neighbour._prev := self;
  self._next := neighbour;
  if (neighbour._next <> nil) then neighbour._next._prev := neighbour;
  if (self._prev <> nil) then self._prev._next := self;
  if (prev = nil) then begin
    AnchorParallel(akTop, 0, parent.box);
    parent._first := self;
  end else AnchorToNeighbour(akTop, 0, prev);
  neighbour.AnchorToNeighbour(akTop, 0, self);
  if (neighbour._next <> nil) then neighbour._next.AnchorToNeighbour(akTop, 0, neighbour)
  else parent._last := neighbour;
  self.indexChanged;
  neighbour.indexChanged;
  self.indexChanged; // second repetition, because in first change, neighbour's index wasn't updated, which may result in conflicting indexes (Think of file renaming...)
end;

procedure TDataItem.appendTo(P : TDataClass);
begin
 if (P.last = nil) then insertFirst(P)
 else insertAfter(P.last);
end;

destructor TDataItem.destroy;
begin
  remove(true);
  if (destroyXML) then xmlEl.Destroy;
  inherited;
end;

 


constructor TDataClass.create(_owner: TComponent);
begin
  _first := nil;
  _last := nil;
  _active := nil;
  _itemIndex := -1;
  _clearing := false;
  _xmlEl := nil; // gets written in the end of the constructor
  onSelect := nil;
  onRemove := nil;
  onAfterRemove := nil;
  onAfterCreateItem := nil;
  inherited create(_owner);
  insertBeforeSelection := false;
  deleteQuestion := 'Sind Sie sicher, dass Sie die diesen Datensatz löschen möchten?';
  titleEl := TLabel.Create(self);
  titleEl.parent := self;
  titleEl.AnchorParallel(akLeft, 2, self);
  titleEl.AnchorParallel(akTop, 2, self);
  addBut := TButton.Create(self);
  addBut.Parent := self;
  addBut.Caption := '+';
  addBut.AutoSize := true;
  addBut.AnchorParallel(akLeft, 2, self);
  addBut.AnchorParallel(akBottom, 2, self);
  addBut.Anchors := [akLeft, akBottom];
  addBut.OnClick := @NewItem;
  addBut.Enabled := false;
  butUp := TButton.Create(self);
  butUp.Parent := self;
  butUp.Caption := '↑';
  butUp.AutoSize := true;
  butUp.AnchorToNeighbour(akLeft, 2, addBut);
  butUp.AnchorParallel(akBottom, 2, self);
  butUp.Anchors := [akLeft, akBottom];
  butUp.OnClick := @ItemUp;
  butUp.Visible := false;
  butDown := TButton.Create(self);
  butDown.Parent := self;
  butDown.Caption := '↓';
  butDown.AutoSize := true;
  butDown.AnchorToNeighbour(akLeft, 2, butUp);
  butDown.AnchorParallel(akBottom, 2, self);
  butDown.Anchors := [akLeft, akBottom];
  butDown.OnClick := @itemDown;
  butDown.Visible := false;
  box := TScrollBox.Create(self);
  box.Parent := self;
  box.AnchorParallel(akLeft, 2, self);
  box.AnchorParallel(akRight, 2, self);
  box.AnchorToNeighbour(akTop, 2, titleEl);
  box.AnchorToNeighbour(akBottom, 2, addBut);
end;

procedure TDataClass.newItem(Sender : TObject);
var
  el : XML.TElement;
  it : TDataItem;
begin
  el := XML.TElement.Create(defaultTagName);
  if (insertBeforeSelection) and (_active <> nil) then xmlEl.insertChildBefore(el, _active.xmlEl)
  else xmlEl.appendChild(el);
  it := addItem(el);
  if (assigned(onAfterCreateItem)) then onAfterCreateItem(it);
end;

function TDataClass.addItem(el: XML.TElement; keepXML : Boolean = false) : TDataItem;
var
  it : TDataItem;
  i : integer;
label foundTagName;
begin
  if (el.parentElement <> xmlEl) then xmlEl.appendChild(el);
  // search predecessor of the new element
  it := self.Last;
  for i := xmlEl.childNodes.count-1 downto 0 do begin
    if (it = nil) then break;
    if (xmlEl.childNodes[i] = it.xmlEl) then it := it.prev;
    if (xmlEl.childNodes[i] = el) then break;
  end;
  // create new item
  for i := 0 to Length(itemTypes)-1 do
    if (itemTypes[i].tagname = el.tagName) then
      goto foundTagName;
  raise Exception.Create('There is no known Class to create item for tag name "'+el.tagName+'"!');
  foundTagName:
  result := itemTypes[i].objtype.Create(el);
  // insert new item
  if (it = nil) then result.InsertFirst(self, keepXML)
  else result.insertAfter(it, keepXML);
end;

function TDataClass.readTitle : String; inline;
begin
  result := titleEl.Caption;
end;

procedure TDataClass.writeTitle(v : String); inline;
begin
  titleEl.Caption := v;
  xmlEl.setAttribute('title', v);
end;

function TDataClass.getItem(i : Cardinal) : TDataItem;
begin
  result := _first;
  while (i > 0) and (result <> nil) do begin
    result := result.next;
    i := i - 1;
  end;
end;

procedure TDataClass.writeAddButtonDisplay(v: TAddButtonDisplay);
begin
  case (v) of
   RIGHT: begin
     box.anchorParallel(akBottom, 2, self);
     addBut.AnchorParallel(akRight, 2, self);
     addBut.AnchorParallel(akTop, 0, box);
     addBut.anchors := [akTop, akRight];
     box.AnchorToNeighbour(akRight, 2, addBut);
     addBut.visible := true;
   end;
   BOTTOM: begin
     box.anchorParallel(akRight, 2, self);
     addBut.AnchorParallel(akBottom, 2, self);
     addBut.AnchorParallel(akLeft, 0, box);
     addBut.anchors := [akBottom, akLeft];
     box.AnchorToNeighbour(akBottom, 2, addBut);
     addBut.visible := true;
   end;
   NONE: begin
     addBut.visible := false;
   end;
  end;
end;

procedure TDataClass.replaceXML(newXML: XML.TElement);
var i : integer;
begin
  while (first <> nil) do first.destroy;
  _xmlEl := newXML;
  addBut.Enabled := false;
  if (xmlEl = nil) then exit;
  addBut.Enabled := true;
  writeTitle(xmlEl.getAttribute('title'));
  for i := 0 to xmlEl.childNodes.count-1 do
    if (xmlEl.childNodes[i].nodeType = ELEMENT_NODE) then
      addItem(XML.TElement(xmlEl.childNodes[i]), true);
end;

function TDataClass.readSortable : Boolean;
begin
  result := butUp.Visible;
end;

procedure TDataClass.writeSortable(v : Boolean);
begin
  butUp.Visible := v;
  butDown.Visible := v;
end;

function TDataClass.count : integer;
begin
  if (_last = nil) then result := 0
  else result := _last.index + 1;
end;

procedure TDataClass.addItemType(tagName: ShortString; objType: TDataItemClass);
var i : integer;
begin
  i := Length(itemTypes);
  SetLength(itemTypes, i+1);
  itemTypes[i].tagName := tagName;
  itemTypes[i].objType := objType;
end;

procedure TDataClass.switchItems(I1, I2 : TDataItem);  // I1 und I2 müssen hintereinander stehen!
begin
 if (I1.next <> I2) then raise Exception.Create('I1 and I2 not in series!');
 I1.remove(false);
 I1.insertAfter(I2);
end;

procedure TDataClass.itemUp(Sender : TObject);
var
  it   : TDataItem;
  prev : TDataItem;
begin
  if (_active = nil) then exit;
  it := _active;
  prev := it.prev;
  if (prev = nil) then exit;
  it.moveUp;
  it.activate;
end;

procedure TDataClass.itemDown(Sender : TObject);
var
  it   : TDataItem;
  next : TDataItem;
begin
  if (_active = nil) then exit;
  it := _active;
  next := it.next;
  if (next = nil) then exit;
  next.moveUp;
  it.activate;
end;

procedure TDataClass.writeItemIndex(v : integer);
begin
  if (v >= 0) then getItem(v).activate
  else if (_active <> nil) then _active.deactivate;
end;

procedure TDataClass.clear;
var el : XML.TElement;
begin
  _clearing := true;
  while (first <> nil) do begin
    el := first.xmlEl;
    first.destroy;
    el.destroy;
  end;
  _clearing := false;
end;

destructor TDataClass.destroy;
begin
  while (first <> nil) do first.destroy;
  inherited;
end;

end.