/packages/fpgtk/src/fpglib.pp

  1{$mode objfpc}{$h+}
  2unit FPGlib;
  3
  4interface
  5
  6uses classes, glib;
  7
  8type
  9
 10  TLukForEachProcedure = procedure (item : pointer; data : pointer) of object;
 11
 12  TLList = class (TList)
 13  private
 14    FGSList : PGSList;
 15    FGList : PGList;
 16    FNotUpdating,
 17    FClassesChanged,FSlistChanged,FListChanged : Boolean;
 18    procedure FreeList;
 19    procedure FreeSList;
 20    function CreateGList : PGList;
 21    function GetTheGtkList : PGList;
 22    procedure SetGtkList (Value : PGList);
 23    function CreateGSList : PGSList;
 24    function GetTheGtkSList : PGSlist;
 25    procedure SetGtkSList (Value : PGSList);
 26    procedure BuildFromGtkList;
 27    procedure BuildFromGtkSList;
 28  protected
 29    procedure Notify (Ptr: Pointer; Action: TListNotification); override;
 30    function GetData (index : integer) : pointer; dynamic;
 31    function UngetData (data : pointer) : pointer; dynamic;
 32    // GetData needs to give the pointer to the data in the List or SList of GTK
 33    // UngetData needs to give the item in this list from the datapointer of GTK
 34  public
 35    constructor create;
 36    destructor destroy; override;
 37    function GetGtkList (buffered : boolean) : PGList;
 38    function GetGtkSList (buffered : boolean) : PGSlist;
 39    procedure BeginUpdate;  // Currently only changes in 1 list are possible
 40    procedure EndUpdate;    // without memory leaks and/or errors in the list
 41    procedure ForEach (Proc : TLukForEachprocedure; data : pointer);
 42    property GtkList : PGList read GetTheGtkList write SetGtkList;
 43    property GtkSList : PGSList read GetTheGtkSList write SetGtkSList;
 44  end;
 45
 46implementation
 47
 48{ TLList }
 49
 50procedure TLList.FreeList;
 51begin
 52  if FGList <> null then
 53    begin
 54    g_list_free (FGList);
 55    FGList := null;
 56    end;
 57end;
 58
 59procedure TLList.FreeSList;
 60begin
 61  if FGSList <> null then
 62    begin
 63    g_slist_free (FGSList);
 64    FGSlist := null;
 65    end;
 66end;
 67
 68procedure TLList.Notify(Ptr: Pointer; Action: TListNotification);
 69begin
 70  inherited;
 71  FClassesChanged := True;
 72end;
 73
 74constructor TLList.create;
 75begin
 76  inherited create;
 77  FClassesChanged := False;
 78  FListChanged := false;
 79  FSListChanged := False;
 80  FGList := null;
 81  FGSList := null;
 82  FNotUpdating := True;
 83end;
 84
 85destructor TLList.destroy;
 86begin
 87  FreeList;
 88  FreeSList;
 89  inherited Destroy;
 90end;
 91
 92function TLList.GetGtkList (buffered : boolean) : PGList;
 93begin
 94  if buffered then
 95    if FClasseschanged then
 96      result := CreateGList
 97    else if FSListChanged then
 98      begin
 99      BuildFromGtkSList;
100      result := CreateGList;
101      end
102    else
103      result := FGlist
104  else
105    result := CreateGList;
106end;
107
108function TLList.GetGtkSList (buffered : boolean) : PGSList;
109begin
110  if buffered then
111    if FClassesChanged then
112      result := CreateGSList
113    else if FListChanged then
114      begin
115      BuildFromGtkList;
116      result := CreateGSList;
117      end
118    else
119      result := FGSlist
120  else
121    result := CreateGSList;
122end;
123
124function TLList.CreateGList : PGList;
125var r : integer;
126begin
127  FreeList;
128  result := null;
129  for r := pred(count) downto 0 do
130    result := g_list_prepend (result, GetData(r));
131  FGList := result;
132end;
133
134function TLList.CreateGSList : PGSList;
135var r : integer;
136begin
137  FreeSList;
138  result := null;
139  for r := pred(count) downto 0 do
140    result := g_slist_prepend (result, GetData(r));
141  FGSList := result;
142end;
143
144function TLList.GetData (index : integer) : pointer;
145begin
146  result := items[index];
147end;
148
149function TLList.UngetData (data : pointer) : pointer;
150begin
151  result := data
152end;
153
154function TLList.GetTheGtkList : PGList;
155begin
156  result := GetGtkList (True);
157end;
158
159procedure TLList.SetGtkList (Value : PGList);
160begin
161  FGList := Value;
162  if FNotUpdating then
163    BuildFromGtkList
164  else
165    FListChanged := True;
166end;
167
168function TLList.GetTheGtkSList : PGSlist;
169begin
170  result := GetGtkSList (True);
171end;
172
173procedure TLList.SetGtkSList (Value : PGSList);
174begin
175  FGSlist := Value;
176  if FNotUpdating then
177    BuildFromGtkSList
178  else
179    FSListChanged := True;
180end;
181
182procedure TLList.BuildFromGtkList;
183var p : PGList;
184begin
185  clear;
186  p := FGList;
187  while p <> null do
188    begin
189    add (UngetData(p^.data));
190    p := p^.Next;
191    end;
192  FListChanged := False;
193  FSListChanged := False;
194  FClassesChanged := False;
195  FreeSList;
196end;
197
198procedure TLList.BuildFromGtkSList;
199var p :PGSList;
200begin
201  clear;
202  p := FGSList;
203  while p <> null do
204    begin
205    add (UngetData(p^.data));
206    p := p^.Next;
207    end;
208  FListChanged := False;
209  FSListChanged := False;
210  FClassesChanged := False;
211  FreeList;
212end;
213
214procedure TLList.BeginUpdate;
215begin
216  FNotUpdating := False;
217end;
218
219procedure TLList.EndUpdate;
220begin
221  FNotUpdating := True;
222  if FlistChanged then
223    BuildFromGtkSList
224  else if FSListChanged then
225    BuildFromGtkSList
226  else if FClassesChanged then
227    begin
228    FreeSList;
229    FreeList;
230    end;
231end;
232
233procedure TLList.ForEach (Proc : TLukForEachProcedure; data : pointer);
234var r: integer;
235begin
236  for r := 0 to pred(count) do
237    Proc (items[r], data);
238end;
239
240end.