diff --git a/.gitattributes b/.gitattributes index cac7a95118..7a130154df 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1689,6 +1689,7 @@ lcl/dirsel.lrs svneol=native#text/pascal lcl/dirsel.pas svneol=native#text/pascal lcl/dynamicarray.pas svneol=native#text/pascal lcl/dynhasharray.pp svneol=native#text/pascal +lcl/dynqueue.pas svneol=native#text/plain lcl/edbtnimg.lrs svneol=native#text/pascal lcl/editbtn.pas svneol=native#text/pascal lcl/extctrls.pp svneol=native#text/pascal diff --git a/lcl/alllclunits.pp b/lcl/alllclunits.pp index 7dc01c730b..920694a463 100644 --- a/lcl/alllclunits.pp +++ b/lcl/alllclunits.pp @@ -33,7 +33,7 @@ uses // resource strings LCLStrConsts, // base classes - FPCAdds, LazLinkedList, DynHashArray, LCLMemManager, AvgLvlTree, + FPCAdds, LazLinkedList, DynHashArray, LCLMemManager, AvgLvlTree, DynQueue, StringHashList, ExtendedStrings, DynamicArray, UTrace, TextStrings, // base types and base functions LCLProc, LCLType, LCLResCache, GraphMath, FileCtrl, LMessages, LResources, diff --git a/lcl/dynamicarray.pas b/lcl/dynamicarray.pas index 8523164a6d..f120bd387f 100644 --- a/lcl/dynamicarray.pas +++ b/lcl/dynamicarray.pas @@ -1,26 +1,21 @@ { + ***************************************************************************** + * * + * This file is part of the Lazarus Component Library (LCL) * + * * + * See the file COPYING.LCL, included in this distribution, * + * for details about the copyright. * + * * + * This program is distributed in the hope that it will be useful, * + * but WITHOUT ANY WARRANTY; without even the implied warranty of * + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * + * * + ***************************************************************************** - Dynamic array support for - TCustomGrid, TDrawGrid and TStringGrid for Lazarus - Copyright (C) 2002 Jesus Reyes Aguilar. - email: jesusrmx@yahoo.com.mx - - -THIS CONTROL IS FREEWARE - USE AS YOU WILL -If you release sourcecode that uses this control, please credit me -or leave this header intact. If you release a compiled application -that uses this code, please credit me somewhere in a little bitty -location so I can at least get bragging rights! - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - - -RELEASE DATE: 30-NOV-2002 -VERSION: 0.9.0 + Author: Jesus Reyes + Abstract: + Dynamic array support for TCustomGrid, TDrawGrid and TStringGrid } unit DynamicArray; diff --git a/lcl/dynqueue.pas b/lcl/dynqueue.pas new file mode 100644 index 0000000000..ff9b3fbdbc --- /dev/null +++ b/lcl/dynqueue.pas @@ -0,0 +1,428 @@ +{ + ***************************************************************************** + * * + * This file is part of the Lazarus Component Library (LCL) * + * * + * See the file COPYING.LCL, included in this distribution, * + * for details about the copyright. * + * * + * This program is distributed in the hope that it will be useful, * + * but WITHOUT ANY WARRANTY; without even the implied warranty of * + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * + * * + ***************************************************************************** + + Abstract: + A dynamic data queue to push and pop arbitrary data. +} +unit DynQueue; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils; + +type + TDynamicQueueItem = record + Size: integer; + Data: array[0..0] of integer; + end; + PDynamicQueueItem = ^TDynamicQueueItem; + ListOfPDynamicQueueItem = ^PDynamicQueueItem; + + { TDynamicDataQueue + A queue for arbitrary data. That means first in first out. + + Push: put data in the queue + Pop: fetch data from the queue (data is deleted from queue) + Top: read data in the queue (data remains in the queue) + + This queue maintains internally a ring queue for pointers to data chunks of + TDynamicQueueItem. It is optimised to reduce the amount of data movement. } + + TDynamicDataQueue = class + private + FItems: ListOfPDynamicQueueItem; // ring queue from FTopIndex to FLastIndex + FItemCapacity: integer; // length of ListOfPDynamicQueueItem + FTopIndex: integer; // first item in FItems + FLastIndex: integer; // last item in FItems + FMaximumBlockSize: integer; + FMinimumBlockSize: PtrInt; + FSize: int64; + FTopItemSpace: integer; // space in top item + FLastItemSpace: integer; // remaining space in last item + procedure SetMaximumBlockSize(const AValue: integer); + procedure SetMinimumBlockSize(const AValue: integer); + procedure GrowItems; + procedure AddItem(ItemSize: integer); + function CalculateItemSize(ItemSize: integer): integer; + function PushInternal(Source: PByte; AStream: TStream; Count: integer): integer;// add to end of queue + function PopTopInternal(Dest: PByte; AStream: TStream; Count: integer; KeepData: Boolean): integer;// read from start of queue, remove from queue + public + constructor Create; + destructor Destroy; override; + procedure Clear; + procedure ConsistencyCheck; + function Push(const Buffer; Count: integer): integer;// add to end of queue + function Push(AStream: TStream; Count: integer): integer;// add to end of queue + function Pop(var Buffer; Count: integer): integer; // read from start of queue, remove from queue + function Pop(AStream: TStream; Count: integer): integer;// read from start of queue, remove from queue + function Top(var Buffer; Count: integer): integer; // read from start of queue, keep data + function Top(AStream: TStream; Count: integer): integer;// read from start of queue, keep data + property Size: int64 read FSize; + property MinimumBlockSize: integer read FMinimumBlockSize write SetMinimumBlockSize; + property MaximumBlockSize: integer read FMaximumBlockSize write SetMaximumBlockSize; + end; + +implementation + +{ TDynamicDataQueue } + +procedure TDynamicDataQueue.SetMinimumBlockSize(const AValue: integer); +begin + if (FMinimumBlockSize=AValue) then exit; + FMinimumBlockSize:=AValue; + if FMinimumBlockSize<16 then FMinimumBlockSize:=16; + if FMaximumBlockSizenil then begin + SrcIndex:=FTopIndex; + repeat + NewItems[DestIndex]:=FItems[SrcIndex]; + if SrcIndex=FLastIndex then break; + inc(DestIndex); + inc(SrcIndex); + if SrcIndex=FItemCapacity then + SrcIndex:=0; + until false; + end; + FTopIndex:=0; + FLastIndex:=DestIndex; + FItems:=NewItems; +end; + +procedure TDynamicDataQueue.AddItem(ItemSize: integer); +var + NewIndex: Integer; + + procedure RaiseInconsistency; + begin + raise Exception.Create('TDynamicDataQueue.AddItem NewIndex='+IntToStr(NewIndex)); + end; + +begin + // check that there is space for the new item + NewIndex:=FLastIndex; + if (FItems<>nil) and (FItems[NewIndex]<>nil) then begin + inc(NewIndex); + if NewIndex>=FItemCapacity then + NewIndex:=0; + end; + if NewIndex=FTopIndex then begin + GrowItems; + NewIndex:=FLastIndex; + if FItems[NewIndex]<>nil then begin + inc(NewIndex); + if NewIndex>=FItemCapacity then + NewIndex:=0; + end; + end; + if (FItems=nil) or (FItems[NewIndex]<>nil) then RaiseInconsistency; + + FLastIndex:=NewIndex; + GetMem(FItems[FLastIndex],SizeOf(TDynamicQueueItem.Size)+ItemSize); + FItems[FLastIndex]^.Size:=Size; +end; + +function TDynamicDataQueue.CalculateItemSize(ItemSize: integer): integer; +begin + Result:=ItemSize; + if ResultMaximumBlockSize then + Result:=MaximumBlockSize; +end; + +function TDynamicDataQueue.PushInternal(Source: PByte; AStream: TStream; + Count: integer): integer; +var + CurCount: PtrInt; + NewItemSize: LongInt; + LastItem: PDynamicQueueItem; + Dest: Pointer; +begin + Result:=0; + if Count<=0 then exit; + while true do begin + while FLastItemSpace>0 do begin + // fill the last item + CurCount:=Count; + if CurCount>FLastItemSpace then + CurCount:=FLastItemSpace; + LastItem:=FItems[FLastIndex]; + Dest:=Pointer(@(LastItem^.Data))+LastItem^.Size-FLastItemSpace; + + // beware: read from a stream can raise an exception + if Source<>nil then + System.Move(Source[Result],Dest^,CurCount) + else + CurCount:=AStream.Read(Dest^,CurCount); + if CurCount<=0 then exit; + + // transfer succeeded + dec(FLastItemSpace,CurCount); // space decreased + inc(fSize,CurCount); // Queue increased + inc(Result,CurCount); // bytes transferred + dec(Count,CurCount); // less to transfer + if Count=0 then exit; + end; + // add new + NewItemSize:=CalculateItemSize(Count); + AddItem(NewItemSize); + FLastItemSpace:=NewItemSize; + end; +end; + +function TDynamicDataQueue.PopTopInternal(Dest: PByte; AStream: TStream; + Count: integer; KeepData: Boolean): integer; + + procedure RaiseInconsistencySizeNot0; + begin + raise Exception.Create('TDynamicDataQueue.PopTopInternal inconsistency size<>0'); + end; + + procedure RaiseInconsistencyEmptyItem; + begin + raise Exception.Create('TDynamicDataQueue.PopTopInternal inconsistency empty item'); + end; + + procedure RaiseInconsistencySizeNegative; + begin + raise Exception.Create('TDynamicDataQueue.PopTopInternal inconsistency size<0'); + end; + +var + Item: PDynamicQueueItem; + CurCount: Integer; + Source: PByte; + CurItemSize: LongInt; + ReadIndex: LongInt; + TransferredCount: LongInt; +begin + Result:=0; + if Count<=0 then exit; + ReadIndex:=FTopIndex; + + while Count>0 do begin + if FItems=nil then exit; // no data + + Item:=FItems[ReadIndex]; + CurItemSize:=Item^.Size; + if ReadIndex=FLastIndex then + dec(CurItemSize,FLastItemSpace); + CurCount:=CurItemSize; + if ReadIndex=FTopIndex then + dec(CurCount,FTopItemSpace); + if CurCount<=0 then + RaiseInconsistencyEmptyItem; + + // copy data from the TopItem + if CurCount>Count then + CurCount:=Count; + Source:=PByte(@Item^.Data); + if ReadIndex=FTopIndex then + inc(Source,FTopItemSpace); + + // beware: writing to a stream can raise an exception + if Dest<>nil then begin + System.Move(Source^,Dest^,CurCount); + TransferredCount:=CurCount; + end else + TransferredCount:=AStream.Write(Dest^,CurCount); + if TransferredCount<=0 then + exit; + + // transfer succeeded + inc(Result,TransferredCount); // bytes transferred + dec(Count,TransferredCount); // less to transfer + if (not KeepData) then begin + dec(FSize,TransferredCount); // Queue decreased + if FSize<0 then RaiseInconsistencySizeNegative; + + if (ReadIndex=FTopIndex) then begin + inc(FTopItemSpace,TransferredCount); // space in top item increased + + if (FTopItemSpace=CurItemSize) then begin + // item complete -> remove item + FreeMem(Item); + FItems[FTopIndex]:=nil; + if FTopIndex=FLastIndex then begin + // complete queue read + if Size<>0 then RaiseInconsistencySizeNot0; + Clear; + exit; + end; + + FTopItemSpace:=0; + inc(FTopIndex); + if FTopIndex=FItemCapacity then FTopIndex:=0; + end; + end; + end; + if Count=0 then exit; + + if TransferredCount=CurCount then begin + // next item + inc(ReadIndex); + if ReadIndex=FItemCapacity then ReadIndex:=0; + end; + end; +end; + +procedure TDynamicDataQueue.SetMaximumBlockSize(const AValue: integer); +begin + if FMaximumBlockSize=AValue then exit; + FMaximumBlockSize:=AValue; + if FMaximumBlockSizeFLastIndex do begin + FreeMem(FItems[FTopIndex]); + inc(FTopIndex); + if FTopIndex=FItemCapacity then + FTopIndex:=0; + end; + FTopIndex:=0; + FLastIndex:=0; + FSize:=0; + FreeMem(FItems); + FItems:=nil; + FItemCapacity:=0; + FTopItemSpace:=0; + FLastItemSpace:=0; +end; + +procedure TDynamicDataQueue.ConsistencyCheck; + + procedure Error(const Msg: string); + begin + raise Exception.Create('TDynamicDataQueue.ConsistencyCheck '+Msg); + end; + +var + i: LongInt; + RealSize: int64; +begin + if Size<0 then Error(''); + if (FItems=nil) then begin + if Size<>0 then Error(''); + end else begin + if Size=0 then Error(''); + if FTopIndex<0 then Error(''); + if FLastIndex<0 then Error(''); + if FTopIndex>=FItemCapacity then Error(''); + if FLastIndex>=FItemCapacity then Error(''); + + // check used items + RealSize:=0; + i:=FTopIndex; + repeat + if FItems[i]=nil then Error(''); + if FItems[i]^.Size<=0 then Error(''); + inc(RealSize,FItems[i]^.Size); + if i=FLastIndex then break; + inc(i); + if i=FItemCapacity then i:=0; + until false; + if RealSize<>Size then Error(''); + + // check unused items + inc(i); + if i=FItemCapacity then i:=0; + while (i<>FTopIndex) do begin + if FItems[i]<>nil then Error(''); + inc(i); + if i=FItemCapacity then i:=0; + end; + + // check space + if FLastItemSpace<0 then Error(''); + if FItems[FLastIndex]^.Size<=FLastItemSpace then Error(''); + if FTopItemSpace<0 then Error(''); + if FItems[FTopIndex]^.Size<=FTopItemSpace then Error(''); + if (FTopIndex=FLastIndex) + and (FTopItemSpace>=FItems[FTopIndex]^.Size-FLastItemSpace) then Error(''); + end; +end; + +end. + diff --git a/lcl/interfaces/gtk/gtkobject.inc b/lcl/interfaces/gtk/gtkobject.inc index f7e10e37a9..03ed953637 100644 --- a/lcl/interfaces/gtk/gtkobject.inc +++ b/lcl/interfaces/gtk/gtkobject.inc @@ -1422,8 +1422,15 @@ begin if FSStrikeOut in AFont.Style then DescOpts := DescOpts + ' strikethrough'; - PangoDescStr := PangoDescStr+DescOpts+' '+intToStr(AFont.Size); + PangoDescStr := PangoDescStr+DescOpts+' '+IntToStr(AFont.Size); + //DebugLn('TGtkWidgetSet.SetWidgetFont PangoDescStr="',PangoDescStr,'"'); font_desc:=pango_font_description_from_string(PChar(PangoDescStr)); + {Style:=gtk_widget_get_style(AWidget); + if Style<>nil then begin + font_desc:=Style^.font_desc; + + end;} + gtk_widget_modify_font(AWidget,font_desc); pango_font_description_free(font_desc); {$ENDIF}