← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to components/lazutils/ttcache.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/lazutils/ttcache.pas
 
1
(*******************************************************************
 
2
 *
 
3
 *  ttcache.pas                                                 1.0
 
4
 *
 
5
 *    Generic object cache
 
6
 *
 
7
 *  Copyright 1996, 1997 by
 
8
 *  David Turner, Robert Wilhelm, and Werner Lemberg.
 
9
 *
 
10
 *  This file is part of the FreeType project, and may only be used
 
11
 *  modified and distributed under the terms of the FreeType project
 
12
 *  license, LICENSE.TXT. By continuing to use, modify or distribute
 
13
 *  this file you indicate that you have read the license and
 
14
 *  understand and accept it fully.
 
15
 *
 
16
 *
 
17
 *  This component defines and implement object caches.
 
18
 *
 
19
 *  An object class is a structure layout that encapsulate one
 
20
 *  given type of data used by the FreeType engine. Each object
 
21
 *  class is completely described by :
 
22
 *
 
23
 *    - a 'root' or 'leading' structure containing the first
 
24
 *      important fields of the class. The root structure is
 
25
 *      always of fixed size.
 
26
 *
 
27
 *      It is implemented as a simple C structure, and may
 
28
 *      contain several pointers to sub-tables that can be
 
29
 *      sized and allocated dynamically.
 
30
 *
 
31
 *      examples : TFace, TInstance, TGlyph & TExecution_Context
 
32
 *                 ( defined in 'ttobjs.h' )
 
33
 *
 
34
 *    - we make a difference between 'child' pointers and 'peer'
 
35
 *      pointers. A 'child' pointer points to a sub-table that is
 
36
 *      owned by the object, while a 'peer' pointer points to any
 
37
 *      other kind of data the object isn't responsible for.
 
38
 *
 
39
 *      An object class is thus usually a 'tree' of 'child' tables.
 
40
 *
 
41
 *    - each object class needs a constructor and a destructor.
 
42
 *
 
43
 *      A constructor is a function which receives the address of
 
44
 *      freshly allocated and zeroed object root structure and
 
45
 *      'builds' all the valid child data that must be associated
 
46
 *      to the object before it becomes 'valid'.
 
47
 *
 
48
 *      A destructor does the inverse job : given the address of
 
49
 *      a valid object, it must discards all its child data and
 
50
 *      zero its main fields (essentially the pointers and array
 
51
 *      sizes found in the root fields).
 
52
 *
 
53
 *
 
54
 *
 
55
 *
 
56
 *
 
57
 *
 
58
 *
 
59
 *
 
60
 *
 
61
 *
 
62
 *
 
63
 *
 
64
 ******************************************************************)
 
65
 
 
66
unit TTCache;
 
67
 
 
68
interface
 
69
 
 
70
uses TTTypes;
 
71
 
 
72
type
 
73
 
 
74
  (* Simple list node record. A List element is said to be 'unlinked' *)
 
75
  (* when it doesn't belong to any list                               *)
 
76
  (*                                                                  *)
 
77
  PList_Element = ^TList_Element;
 
78
  TList_Element = record
 
79
 
 
80
     next : PList_Element; (* Pointer to next element of list *)
 
81
     data : Pointer;       (* Pointer to the listed object    *)
 
82
  end;
 
83
 
 
84
 
 
85
  (* Simple singly-linked list record *)
 
86
  (* LIFO - style, no tail field      *)
 
87
  TSingle_List = PList_Element;
 
88
 
 
89
 
 
90
  TConstructor = function(  _object : Pointer;
 
91
                            _parent : Pointer  ) : TError;
 
92
 
 
93
  TDestructor = function( _object : Pointer ) : TError;
 
94
 
 
95
  PCache_Class = ^TCache_Class;
 
96
  TCache_Class = record
 
97
                   Object_Size : Int;
 
98
                   Idle_Limit  : Int;
 
99
                   Init        : TConstructor;
 
100
                   Done        : TDestructor;
 
101
                 end;
 
102
  (* A Cache class record holds the data necessary to define *)
 
103
  (* a cache kind.                                           *)
 
104
 
 
105
  PCache = ^TCache;
 
106
  TCache = record
 
107
             clazz      : PCache_Class;  (* 'class' reserved in VP & Delphi *)
 
108
             active     : TSingle_List;
 
109
             idle       : TSingle_List;
 
110
             idle_count : Int;
 
111
           end;
 
112
 
 
113
  (* An object cache holds two lists tracking the active and *)
 
114
  (* idle objects that are currently created and used by the *)
 
115
  (* engine. It can also be 'protected' by a mutex           *)
 
116
 
 
117
  function Cache_Create( var clazz : TCache_Class;
 
118
                         var cache : TCache        ) : TError;
 
119
  (* Initialize a new cache named 'cache', of class 'clazz', and   *)
 
120
  (* protected by the 'lock' mutex. Note that the mutex is ignored *)
 
121
  (* as the pascal version isn't thread-safe                       *)
 
122
 
 
123
  function Cache_Destroy( var cache : TCache ) : TError;
 
124
  (* Destroys a cache and all its listed objects *)
 
125
 
 
126
  function Cache_New( var cache      : TCache;
 
127
                      var new_object : Pointer;
 
128
                      parent_data    : Pointer ) : TError;
 
129
  (* Extracts a new object from the cache. *)
 
130
 
 
131
  function Cache_Done( var cache : TCache; obj : Pointer ) : TError;
 
132
  (* returns an object to the cache, or discards it depending *)
 
133
  (* on the cache class' "idle_limit" field                   *)
 
134
 
 
135
  (********************************************************)
 
136
  (*                                                      *)
 
137
  (* Two functions used to manage list elements           *)
 
138
  (*                                                      *)
 
139
  (* Note that they're thread-safe in multi-threaded      *)
 
140
  (* builds.                                              *)
 
141
  (*                                                      *)
 
142
 
 
143
  function  Element_New : PList_Element;
 
144
  (* Returns a new list element, either fresh or recycled *)
 
145
  (* Note : the returned element is unlinked              *)
 
146
 
 
147
  procedure Element_Done( element : PList_Element );
 
148
  (* Recycles or discards an element.                     *)
 
149
  (* Note : The element must be unlinked !!               *)
 
150
 
 
151
 
 
152
 
 
153
 
 
154
  function  TTCache_Init : TError;
 
155
 
 
156
  function  TTCache_Done : TError;
 
157
 
 
158
 
 
159
implementation
 
160
 
 
161
uses TTMemory;
 
162
 
 
163
const
 
164
  Null_Single_List = nil;
 
165
 
 
166
var
 
167
  Free_Elements : PList_Element;
 
168
 
 
169
(*******************************************************************
 
170
 *
 
171
 *  Function    :  Element_New
 
172
 *
 
173
 *  Description :  Gets a new ( either fresh or recycled ) list
 
174
 *                 element. The element is unlisted.
 
175
 *
 
176
 *  Notes  :  returns nil if out of memory
 
177
 *
 
178
 *****************************************************************)
 
179
 
 
180
  function Element_New : PList_Element;
 
181
  var
 
182
    element : PList_Element;
 
183
  begin
 
184
    (* LOCK *)
 
185
 
 
186
    if Free_Elements <> nil then
 
187
      begin
 
188
        element       := Free_Elements;
 
189
        Free_Elements := element^.next;
 
190
      end
 
191
    else
 
192
      begin
 
193
        Alloc( element, sizeof(TList_Element) );
 
194
        (* by convention, an allocated block is always zeroed *)
 
195
        (* the fields of element need not be set to NULL then *)
 
196
      end;
 
197
 
 
198
    (* UNLOCK *)
 
199
 
 
200
    Element_New := element;
 
201
  end;
 
202
 
 
203
(*******************************************************************
 
204
 *
 
205
 *  Function    :  Element_Done
 
206
 *
 
207
 *  Description :  recycles an unlisted list element
 
208
 *
 
209
 *  Notes  :  Doesn't check that the element is unlisted
 
210
 *
 
211
 *****************************************************************)
 
212
 
 
213
  procedure Element_Done( element : PList_Element );
 
214
  begin
 
215
    (* LOCK *)
 
216
 
 
217
    element^.next := Free_Elements;
 
218
    Free_Elements := element;
 
219
 
 
220
    (* UNLOCK *)
 
221
  end;
 
222
 
 
223
 
 
224
(*******************************************************************
 
225
 *
 
226
 *  Function    :  Cache_Create
 
227
 *
 
228
 *  Description :  Create a new cache object
 
229
 *
 
230
 *****************************************************************)
 
231
  function Cache_Create( var clazz : TCache_Class;
 
232
                         var cache : TCache       ) : TError;
 
233
  begin
 
234
    cache.clazz      := @clazz;
 
235
    cache.idle_count := 0;
 
236
    cache.active     := Null_Single_List;
 
237
    cache.idle       := Null_Single_List;
 
238
 
 
239
    Cache_Create := Success;
 
240
  end;
 
241
 
 
242
 
 
243
(*******************************************************************
 
244
 *
 
245
 *  Function    :  Cache_Destroy
 
246
 *
 
247
 *  Description :  Destroy a given cache object
 
248
 *
 
249
 *****************************************************************)
 
250
  function Cache_Destroy( var cache : TCache ) : TError;
 
251
  var
 
252
    destroy : TDestructor;
 
253
    current : PList_Element;
 
254
    next    : PList_Element;
 
255
  begin
 
256
    (* now destroy all active and idle listed objects *)
 
257
 
 
258
    destroy := cache.clazz^.done;
 
259
 
 
260
    (* active list *)
 
261
    current := cache.active;
 
262
    while current <> nil do
 
263
    begin
 
264
      next := current^.next;
 
265
      destroy( current^.data );
 
266
      Free( current^.data );
 
267
      Element_Done( current );
 
268
      current := next;
 
269
    end;
 
270
    cache.active := Null_SIngle_List;
 
271
 
 
272
    (* idle list *)
 
273
    current := cache.idle;
 
274
    while current <> nil do
 
275
    begin
 
276
      next := current^.next;
 
277
      destroy( current^.data );
 
278
      Free( current^.data );
 
279
      Element_Done( current );
 
280
      current := next;
 
281
    end;
 
282
    cache.idle := Null_Single_List;
 
283
 
 
284
    cache.clazz      := nil;
 
285
    cache.idle_count := 0;
 
286
 
 
287
    Cache_Destroy := Success;
 
288
  end;
 
289
 
 
290
 
 
291
(*******************************************************************
 
292
 *
 
293
 *  Function    :  Cache_New
 
294
 *
 
295
 *  Description :  Extracts one 'new' object from a cache
 
296
 *
 
297
 *  Notes  :  The 'parent_data' pointer is passed to the object's
 
298
 *            initialiser when the new object is created from
 
299
 *            scratch. Recycled objects do not use this pointer
 
300
 *
 
301
 *****************************************************************)
 
302
  function Cache_New( var cache      : TCache;
 
303
                      var new_object : Pointer;
 
304
                      parent_data    : Pointer ) : TError;
 
305
  var
 
306
    error   : TError;
 
307
    current : PList_Element;
 
308
    obj     : Pointer;
 
309
  label
 
310
    Fail;
 
311
  begin
 
312
    (* LOCK *)
 
313
    current := cache.idle;
 
314
    if current <> nil then
 
315
    begin
 
316
      cache.idle := current^.next;
 
317
      dec( cache.idle_count )
 
318
    end;
 
319
    (* UNLOCK *)
 
320
 
 
321
    if current = nil then
 
322
      begin
 
323
        (* if no object was found in the cache, create a new one *)
 
324
        obj:=nil;
 
325
        if Alloc( obj, cache.clazz^.object_size ) then exit;
 
326
 
 
327
        current := Element_New;
 
328
        if current = nil then goto Fail;
 
329
 
 
330
        current^.data := obj;
 
331
 
 
332
        error := cache.clazz^.init( obj, parent_data );
 
333
        if error then goto Fail;
 
334
      end;
 
335
 
 
336
    (* LOCK *)
 
337
    current^.next := cache.active;
 
338
    cache.active  := current;
 
339
    (* UNLOCK *)
 
340
 
 
341
    new_object := current^.data;
 
342
 
 
343
    Cache_New := Success;
 
344
    exit;
 
345
 
 
346
  Fail:
 
347
    Free( obj );
 
348
    Cache_New := Failure;
 
349
  end;
 
350
 
 
351
(*******************************************************************
 
352
 *
 
353
 *  Function    :  Cache_Done
 
354
 *
 
355
 *  Description :  Discards an object intro a cache
 
356
 *
 
357
 *****************************************************************)
 
358
 
 
359
  function Cache_Done( var cache : TCache; obj : Pointer ) : TError;
 
360
  var
 
361
    element : PList_Element;
 
362
    parent  : ^PList_Element;
 
363
  label
 
364
    Suite;
 
365
  begin
 
366
    Cache_Done := failure;
 
367
 
 
368
    (* find element in list *)
 
369
    (* LOCK *)
 
370
    parent  := @cache.active;
 
371
    element := parent^;
 
372
    while element <> nil do
 
373
    begin
 
374
      if element^.data = obj then
 
375
      begin
 
376
        parent^ := element^.next;
 
377
        (* UNLOCK *)
 
378
        goto Suite;
 
379
      end;
 
380
      parent  := @element^.next;
 
381
      element := parent^;
 
382
    end;
 
383
    (* UNLOCK *)
 
384
 
 
385
    (* Element wasn't found !! *)
 
386
    {$IFDEF FREETYPE_DEBUG}
 
387
    {$ENDIF}
 
388
    exit;
 
389
 
 
390
  Suite:
 
391
    if ( cache.idle_count >= cache.clazz^.idle_limit ) then
 
392
      begin
 
393
        (* destroy the object when the cache is full *)
 
394
        cache.clazz^.done( element^.data );
 
395
        Free( element^.data );
 
396
        Element_Done( element );
 
397
      end
 
398
    else
 
399
      begin
 
400
        (* simply add the object to the idle list *)
 
401
        (* LOCK *)
 
402
        element^.next := cache.idle;
 
403
        cache.idle    := element;
 
404
        inc( cache.idle_count );
 
405
        (* UNLOCK *)
 
406
      end;
 
407
 
 
408
    Cache_Done := Success;
 
409
  end;
 
410
 
 
411
 
 
412
  function  TTCache_Init : TError;
 
413
  begin
 
414
    Free_Elements := nil;
 
415
    TTCache_Init  := Success;
 
416
  end;
 
417
 
 
418
 
 
419
  function  TTCache_Done : TError;
 
420
  var
 
421
    current, next : PList_ELement;
 
422
  begin
 
423
    current := free_elements;
 
424
    while current <> nil do
 
425
    begin
 
426
      next := current^.next;
 
427
      Free( current );
 
428
      current := next;
 
429
    end;
 
430
    TTCache_Done := success;
 
431
  end;
 
432
 
 
433
end.