{****************************************************************************** gtklistsl.inc TGtkListStringList and TGtkCListStringList ****************************************************************************** ***************************************************************************** * * * 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. * * * ***************************************************************************** } {$IFOPT H+} {$DEFINE H_PLUS} {$ELSE} {$H+} {$UNDEF H_PLUS} {$ENDIF} {*************************************************************} { Default compare function } {*************************************************************} function DefaultCompareFunc(a, b : gpointer) : gint; cdecl; var AStr, BStr : PChar; begin gtk_label_get(PGtkLabel(PGtkBin(a)^.child), @AStr); gtk_label_get(PGtkLabel(PGtkBin(b)^.child), @BStr); //writeln('DefaultCompareFunc "',AStr,'" "',BStr,'"'); Result:= strcomp(AStr, BStr); end; {*************************************************************} { TGtkListStringList methods } {*************************************************************} {------------------------------------------------------------------------------ Method: TGtkListStringList.Create Params: Returns: ------------------------------------------------------------------------------} constructor TGtkListStringList.Create(List : PGtkList); begin inherited Create; if List = nil then raise Exception.Create( 'TGtkListStringList.Create Unspecified list widget'); FGtkList:= List; end; {------------------------------------------------------------------------------ Method: TGtkListStringList.SetSorted Params: Returns: ------------------------------------------------------------------------------} procedure TGtkListStringList.SetSorted(Val : boolean); begin if Val <> FSorted then begin FSorted:= Val; if FSorted then Sort; end; end; {------------------------------------------------------------------------------ Method: TGtkListStringList.Sort Params: Returns: ------------------------------------------------------------------------------} procedure TGtkListStringList.Sort; var sl: TStringList; begin // sort internally (sorting in the widget would be slow and unpretty ;) sl:=TStringList.Create; sl.Assign(Self); sl.Sort; // currently this is quicksort -> // Disadvantages: - worst case on sorted list // - not keeping order // ToDo: replace by mergesort and add customsort Assign(sl); sl.Free; end; {------------------------------------------------------------------------------ Method: TGtkListStringList.Assign Params: Returns: ------------------------------------------------------------------------------} procedure TGtkListStringList.Assign(Source : TPersistent); var Counter : integer; begin if (Source=Self) or (Source=nil) or ((Source is TGtkListStringList) and (TGtkListStringList(Source).FGtkList=FGtkList)) then exit; //writeln('[TGtkListStringList.Assign] A ',Source.Classname,' Self=',HexStr(Cardinal(Self),8),' Source=',HexStr(Cardinal(Source),8)); { Do not call inherited Assign as it does things we do not want to happen } if Source is TStrings then begin Clear; for Counter:= TStrings(Source).Count - 1 downto 0 do begin Insert(0, TStrings(Source)[Counter]); end; end else inherited Assign(Source); //writeln('[TGtkListStringList.Assign] END ',Source.Classname); end; {------------------------------------------------------------------------------ Method: TGtkListStringList.Get Params: Returns: ------------------------------------------------------------------------------} function TGtkListStringList.Get(Index : integer) : string; var Item : PChar; ALabel : PGtkWidget; ListItem : PGtkListItem; begin //writeln('[TGtkListStringList.Get] Index=',Index,' Count=',Count); if (Index < 0) or (Index >= Count) then raise Exception.Create('Out of bounds.') else begin if FGtkList=nil then begin Result:=''; exit; end; ListItem:= g_list_nth_data(FGtkList^.children, Index); ALabel:= PGtkBin(ListItem)^.child; if ALabel = nil then Result:= '' else begin Item:=nil; gtk_label_get (PGtkLabel(ALabel), @Item); Result:= StrPas(Item); end; end; end; {------------------------------------------------------------------------------ Method: TGtkListStringList.GetCount Params: Returns: ------------------------------------------------------------------------------} function TGtkListStringList.GetCount: integer; begin if FGtkList^.children = nil then Result:= 0 else Result:= g_list_length(FGtkList^.children); end; {------------------------------------------------------------------------------ Method: TGtkListStringList.Clear Params: Returns: ------------------------------------------------------------------------------} procedure TGtkListStringList.Clear; begin gtk_list_clear_items(FGtkList, 0, Count); end; {------------------------------------------------------------------------------ Method: TGtkListStringList.Delete Params: Returns: ------------------------------------------------------------------------------} procedure TGtkListStringList.Delete(Index : integer); begin gtk_list_clear_items(FGtkList, Index, Index + 1); end; {------------------------------------------------------------------------------ Method: TGtkListStringList.Insert Params: Returns: ------------------------------------------------------------------------------} procedure TGtkListStringList.Insert(Index : integer; const S : string); var li : PGtkWidget; l, m, r, cmp: integer; begin //writeln('[TGtkListStringList.Insert] Index=',Index,' Count=',Count,' ',S); if FSorted then begin l:=0; r:=Count-1; m:=l; while (l<=r) do begin m:=(l+r) shr 1; cmp:=AnsiCompareText(S,Strings[m]); if cmp<0 then r:=m-1 else if cmp>0 then l:=m+1 else break; end; if (m0) then inc(m); Index:=m; end; if (Index < 0) or (Index > Count) then raise Exception.Create('TGtkListStringList.Insert: Index '+IntToStr(Index) +' out of bounds. Count='+IntToStr(Count)); li:=gtk_list_item_new_with_label(PChar(S)); gtk_widget_show(li); gtk_list_insert_items(FGtkList, g_list_append(nil, li), Index); //writeln('[TGtkListStringList.Insert] END Index=',Index,' Count=',Count,' ',S,',',Count); end; {*************************************************************} { TGtkCListStringList methods } {*************************************************************} {------------------------------------------------------------------------------ Method: TGtkCListStringList.Create Params: Returns: ------------------------------------------------------------------------------} constructor TGtkCListStringList.Create(List : PGtkCList); begin inherited Create; if List = nil then raise Exception.Create('Unspecified list widget'); FGtkCList:= List; end; {------------------------------------------------------------------------------ Method: TGtkCListStringList.SetSorted Params: Returns: ------------------------------------------------------------------------------} procedure TGtkCListStringList.SetSorted(Val : boolean); begin if Val <> FSorted then begin FSorted:= Val; gtk_clist_set_auto_sort(FGtkCList, Val); if Val then Sort; end; end; {------------------------------------------------------------------------------ Method: TGtkCListStringList.Sort Params: Returns: ------------------------------------------------------------------------------} procedure TGtkCListStringList.Sort; begin gtk_clist_sort(FGtkCList); end; {------------------------------------------------------------------------------ Method: TGtkCListStringList.Assign Params: Returns: ------------------------------------------------------------------------------} procedure TGtkCListStringList.Assign(Source : TPersistent); var Counter : integer; begin { Do not call inherited Assign as it does things we do not want to happen } if Source is TStrings then begin Clear; for Counter:= TStrings(Source).Count - 1 downto 0 do InsertObject(0, TStrings(Source)[Counter], TStrings(Source).Objects[Counter]); end else inherited Assign(Source); end; {------------------------------------------------------------------------------ Method: TGtkCListStringList.Clear Params: Returns: ------------------------------------------------------------------------------} procedure TGtkCListStringList.Clear; begin gtk_clist_clear(FGtkCList); end; {------------------------------------------------------------------------------ Method: TGtkCListStringList.Delete Params: Returns: ------------------------------------------------------------------------------} procedure TGtkCListStringList.Delete(Index : integer); begin gtk_clist_remove(FGtkCList, Index); end; {------------------------------------------------------------------------------ Method: TGtkCListStringList.Get Params: Returns: ------------------------------------------------------------------------------} function TGtkCListStringList.Get(Index : integer) : string; var Item : PChar; begin if (Index < 0) or (Index >= Count) then raise Exception.Create('Out of bounds.') else begin Item := nil; gtk_clist_get_text(FGtkCList, Index, 0, @Item); Result:= StrPas(Item); end; end; {------------------------------------------------------------------------------ Method: TGtkCListStringList.GetCount Params: Returns: ------------------------------------------------------------------------------} function TGtkCListStringList.GetCount : integer; begin Result:= FGtkCList^.rows; end; {------------------------------------------------------------------------------ Method: TGtkCListStringList.GetObject Params: Returns: ------------------------------------------------------------------------------} function TGtkCListStringList.GetObject(Index: Integer): TObject; begin pointer(Result) := gtk_clist_get_row_data(FGtkCList, Index); end; {------------------------------------------------------------------------------ Method: TGtkCListStringList.Insert Params: Returns: ------------------------------------------------------------------------------} procedure TGtkCListStringList.Insert(Index : integer; const S : string); type TCSArr = record Arr: array[0..15] of PChar; Str: array[0..0] of Char; end; var CS: ^TCSArr; CSize: integer; K: integer; begin CSize := sizeof(TCSArr)+length(S)+1; GetMem(CS, CSize); FillChar(CS^, sizeof(TCSArr), 0); StrPCopy(CS^.Str, S); CS^.Arr[0] := @CS^.Str; for K := 1 to 15 do begin CS^.Arr[K] := StrScan(CS^.Arr[K-1], #9); if Assigned(CS^.Arr[K]) then begin CS^.Arr[K][0] := #0; inc(integer(CS^.Arr[K])); end else break; end; gtk_clist_insert(FGtkCList, Index, PPGChar(CS)); FreeMem(CS); end; {------------------------------------------------------------------------------ Method: TGtkCListStringList.PutObject Params: Returns: ------------------------------------------------------------------------------} procedure TGtkCListStringList.PutObject(Index: Integer; AObject: TObject); begin gtk_clist_set_row_data(FGtkCList, Index, AObject); end; {$IFDEF H_PLUS} {$UNDEF H_PLUS} {$ELSE} {$H-} {$ENDIF} { ============================================================================= $Log$ Revision 1.5 2002/05/10 06:05:57 lazarus MG: changed license to LGPL Revision 1.4 2001/11/27 15:06:13 lazarus MG: added multi language syntax hilighting Revision 1.3 2001/10/31 10:38:26 lazarus MG: fixed sorted customlistbox Revision 1.2 2001/09/30 08:34:52 lazarus MG: fixed mem leaks and fixed range check errors Revision 1.1 2000/07/13 10:28:29 michael + Initial import Revision 1.2 2000/04/13 21:25:16 lazarus MWE: ~ Added some docu and did some cleanup. Hans-Joachim Ott : * TMemo.Lines works now. + TMemo has now a property Scrollbar. = TControl.GetTextBuf revised :-) + Implementation for CListBox columns added * Bug in TGtkCListStringList.Assign corrected. Revision 1.1 2000/03/30 22:51:42 lazarus MWE: Moved from ../../lcl Revision 1.3 2000/03/04 00:05:21 lazarus MWE: added changes from Hans (HJO) }