paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-10 03:35:58 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL: in case of index out of bounds error, the message shows the upperbound instead of the count of the list (bug #10367)

Browse Source 
git-svn-id: trunk@13201 -
This commit is contained in:
vincents 2007-12-07 13:00:20 +00:00
parent 41fa02b136
commit 01a956df63
25 changed files with 63 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
lcl/extctrls.pp
View File

@ -796,6 +796,7 @@ type
procedure Clicked(Sender: TObject);
procedure DoClick(Index: integer);
procedure ItemsChanged (Sender : TObject);
procedure RaiseIndexOutOfBounds(Index: integer );
procedure SetAutoFill(const AValue: boolean);
procedure SetChecked(Index: integer; const AValue: boolean);
procedure SetCheckEnabled(Index: integer; const AValue: boolean);

14
lcl/include/customcheckgroup.inc
View File

@ -57,6 +57,12 @@ begin
OwnerFormDesignerModified(Self);
end;
procedure TCustomCheckGroup.RaiseIndexOutOfBounds(Index: integer ) ;
begin
raise Exception.CreateFmt(rsIndexOutOfBounds,
[ClassName, Index, FItems.Count - 1]);
end;
procedure TCustomCheckGroup.SetAutoFill(const AValue: boolean);
begin
if FAutoFill=AValue then exit;
@ -144,7 +150,7 @@ end;
function TCustomCheckGroup.GetCheckEnabled(Index: integer): boolean;
begin
if (Index < -1) or (Index >= FItems.Count) then
raise Exception.CreateFmt(rsIndexOutOfBounds,[ClassName,Index,FItems.Count]);
RaiseIndexOutOfBounds(Index);
Result:=TCheckBox(FButtonList[Index]).Enabled;
end;
@ -152,7 +158,7 @@ procedure TCustomCheckGroup.SetCheckEnabled(Index: integer;
const AValue: boolean);
begin
if (Index < -1) or (Index >= FItems.Count) then
raise Exception.CreateFmt(rsIndexOutOfBounds,[ClassName,Index,FItems.Count]);
RaiseIndexOutOfBounds(Index);
TCheckBox(FButtonList[Index]).Enabled:=AValue;
end;
@ -170,14 +176,14 @@ end;
function TCustomCheckGroup.GetChecked(Index: integer): boolean;
begin
if (Index < -1) or (Index >= FItems.Count) then
raise Exception.CreateFmt(rsIndexOutOfBounds,[ClassName,Index,FItems.Count]);
RaiseIndexOutOfBounds(Index);
Result:=TCheckBox(FButtonList[Index]).Checked;
end;
procedure TCustomCheckGroup.SetChecked(Index: integer; const AValue: boolean);
begin
if (Index < -1) or (Index >= FItems.Count) then
raise Exception.CreateFmt(rsIndexOutOfBounds,[ClassName,Index,FItems.Count]);
RaiseIndexOutOfBounds(Index);
// disable OnClick
TCheckBox(FButtonList[Index]).OnClick:=nil;
// set value

22
lcl/include/customlistbox.inc
View File

@ -163,6 +163,11 @@ begin
Result := FTopIndex;
end;
procedure TCustomListBox.RaiseIndexOutOfBounds(AIndex: integer);
begin
Exception.CreateFmt(rsIndexOutOfBounds, [ClassName, AIndex, FItems.Count-1]);
end;
procedure TCustomListBox.SetColumns(const AValue: Integer);
begin
if (FColumns = AValue) or (AValue < 0) then
@ -513,13 +518,13 @@ begin
//DebugLn('[TCustomListBox.GetItemIndex] END ');
end;
procedure TCustomListBox.SetItemIndex(Val : integer);
procedure TCustomListBox.SetItemIndex(AIndex : integer);
begin
if (Val >= FItems.Count) then
raise Exception.CreateFmt(rsIndexOutOfBounds,[ClassName,Val,FItems.Count]);
if Val<0 then Val:=-1;
//DebugLn('[TCustomListBox.SetItemIndex] A ',FItems.ClassName,' ',dbgs(Val));
FItemIndex:=Val;
if (AIndex >= FItems.Count) then
RaiseIndexOutOfBounds(AIndex);
if AIndex<0 then AIndex:=-1;
//DebugLn('[TCustomListBox.SetItemIndex] A ',FItems.ClassName,' ',dbgs(AIndex));
FItemIndex:=AIndex;
if HandleAllocated and ([csLoading,csDestroying]*ComponentState=[]) then
SendItemIndex;
DoSelectionChange(false);
@ -531,9 +536,8 @@ end;
------------------------------------------------------------------------------}
procedure TCustomListBox.CheckIndex(const AIndex: Integer);
begin
if (AIndex < 0)
or (AIndex >= Items.Count)
then raise Exception.CreateFmt(rsIndexOutOfBounds,[ClassName, AIndex, Items.Count]);
if (AIndex < 0) or (AIndex >= Items.Count) then
RaiseIndexOutOfBounds(AIndex);
end;
{------------------------------------------------------------------------------

2
lcl/include/menuitem.inc
View File

@ -408,7 +408,7 @@ end;
function TMenuItem.GetItem(Index: Integer): TMenuItem;
begin
if FItems = nil then
raise EMenuError.CreateFmt(rsIndexOutOfBounds,[ClassName,Index,0]);
raise EMenuError.CreateFmt(rsIndexOutOfBounds,[ClassName,Index,-1]);
Result := TMenuItem(FItems[Index]);
end;

2
lcl/include/radiogroup.inc
View File

@ -335,7 +335,7 @@ begin
FItemIndex:=Value
else begin
if (Value < -1) or (Value >= FItems.Count) then
raise Exception.CreateFmt(rsIndexOutOfBounds,[ClassName,Value,FItems.Count]);
raise Exception.CreateFmt(rsIndexOutOfBounds,[ClassName,Value,FItems.Count-1]);
if (HandleAllocated) then
begin

4
lcl/include/treeview.inc
View File

@ -1021,14 +1021,14 @@ end;
function TTreeNode.GetItems(AnIndex: Integer): TTreeNode;
begin
if (AnIndex<0) or (AnIndex>=Count) then
TreeNodeErrorFmt(rsIndexOutOfBounds,[ClassName, AnIndex, Count]);
TreeNodeErrorFmt(rsIndexOutOfBounds,[ClassName, AnIndex, Count-1]);
Result:=FItems[AnIndex];
end;
procedure TTreeNode.SetItems(AnIndex: Integer; AValue: TTreeNode);
begin
if (AnIndex<0) or (AnIndex>=Count) then
TreeNodeErrorFmt(rsIndexOutOfBounds, [ClassName, AnIndex, Count]);
TreeNodeErrorFmt(rsIndexOutOfBounds, [ClassName, AnIndex, Count-1]);
Items[AnIndex].Assign(AValue);
end;

4
lcl/languages/lclstrconsts.ca.po
View File

@ -38,8 +38,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr "Avís: S'han deixat %s enllaços a missatge LM_PAINT/LM_GtkPAINT, sense eliminar"
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s índex %d fora de límits 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s índex %d fora de límits 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

4
lcl/languages/lclstrconsts.de.po
View File

@ -41,8 +41,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr "WARNUNG: Es sind %s nicht entfernte LM_PAINT/LM_GtkPAINT-Meldungs-Links übrig."
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s Index %s außerhalb des Bereichs 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s Index %s außerhalb des Bereichs 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

4
lcl/languages/lclstrconsts.es.po
View File

@ -37,8 +37,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr " ADVERTENCIA: Hay %s mensajes de enlaces LM_PAINT/LM_GtkPAINT sin eliminar"
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s Índice %d fuera de límites 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s Índice %d fuera de límites 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

2
lcl/languages/lclstrconsts.fi.po
View File

@ -27,7 +27,7 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr ""
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr ""
#: lclstrconsts:rsisalreadyassociatedwith

4
lcl/languages/lclstrconsts.fr.po
View File

@ -39,8 +39,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr " ATTENTION : Il y a %s non enlevé LM_PAINT/LM_GtkPAINT liens de message."
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s Index %d hors des limites 0-%d "
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s Index %d hors des limites 0 .. %d "
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

4
lcl/languages/lclstrconsts.id.po
View File

@ -40,8 +40,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr " PERINGATAN: ada %s tersisa link pesan LM_PAINT/LM_GtkPAINT tidak dihapus."
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s Indeks %d di luar jangkauan 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s Indeks %d di luar jangkauan 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

4
lcl/languages/lclstrconsts.it.po
View File

@ -37,8 +37,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr "Attenzione: esistono ancora %s collegamenti a messaggi LM_GtkPAINT."
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s indice %d fuori dai limiti 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s indice %d fuori dai limiti 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

4
lcl/languages/lclstrconsts.lt.po
View File

@ -40,8 +40,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr " Perspėjimas: liko %s nepašalintos nuorodos į LM_PAINT/LM_GtkPAINT pranešimus."
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s indeksas %d peržengia ribas 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s indeksas %d peržengia ribas 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

4
lcl/languages/lclstrconsts.nl.po
View File

@ -38,8 +38,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr " WAARSCHUWING: Er zijn %s LM_PAINT/LM_GtkPAINT berichten niet verwijderd."
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s Index %d valt buiten de grenzen 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s Index %d valt buiten de grenzen 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

4
lcl/languages/lclstrconsts.pb.po
View File

@ -27,8 +27,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr " AVISO: Há %s vínculos não removido de mensagem LM_PAINT/LM_GtkPAINT à esquerda."
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s Indice %s fora do limite 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s Indice %s fora do limite 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

4
lcl/languages/lclstrconsts.pl.po
View File

@ -42,8 +42,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr " UWAGA: Pozostały %s nieusunięte dowiązania do LM_PAINT/LM_GtkPAINT."
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s Indeks %d przekracza zakres 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s Indeks %d przekracza zakres 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

4
lcl/languages/lclstrconsts.pliso.po
View File

@ -38,8 +38,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr " UWAGA: Pozosta³y %s nieusuniête dowi±zania do LM_PAINT/LM_GtkPAINT."
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s Indeks %d przekracza zakres 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s Indeks %d przekracza zakres 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

4
lcl/languages/lclstrconsts.plwin.po
View File

@ -38,8 +38,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr " UWAGA: Pozosta³y %s nieusuniête dowi¹zania do LM_PAINT/LM_GtkPAINT."
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s Indeks %d przekracza zakres 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s Indeks %d przekracza zakres 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

2
lcl/languages/lclstrconsts.po
View File

@ -403,7 +403,7 @@ msgid "Error creating device context for %s.%s"
msgstr ""
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr ""
#: lclstrconsts:rsunknownpictureextension

4
lcl/languages/lclstrconsts.ru.po
View File

@ -38,8 +38,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr " ВНИМАНИЕ: Найдено %s неудалённых LM_PAINT/LM_GtkPAINT ссылок на сообщение."
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s Индекс %d вне диапазона 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s Индекс %d вне диапазона 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

4
lcl/languages/lclstrconsts.ua.po
View File

@ -27,8 +27,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr " УВАГА: Знайдено %s не видалених LM_PAINT/LM_GtkPAINT посилань на повідомлення."
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s Індекс %d поза діапазоном 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s Індекс %d поза діапазоном 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

4
lcl/languages/lclstrconsts.zh-cn.po
View File

@ -40,8 +40,8 @@ msgid " WARNING: There are %s unremoved LM_PAINT/LM_GtkPAINT message links left.
msgstr "警告:There are %s unremoved LM_PAINT/LM_GtkPAINT message links left."
#: lclstrconsts:rsindexoutofbounds
msgid "%s Index %d out of bounds 0-%d"
msgstr "%s 索引 %d 超过限制 0-%d"
msgid "%s Index %d out of bounds 0 .. %d"
msgstr "%s 索引 %d 超过限制 0 .. %d"
#: lclstrconsts:rsisalreadyassociatedwith
msgid "%s is already associated with %s"

2
lcl/lclstrconsts.pas
View File

@ -173,7 +173,7 @@ ResourceString
rsAControlCanNotHaveItselfAsParent = 'A control can''t have itself as parent';
lisLCLResourceSNotFound = 'Resource %s not found';
rsErrorCreatingDeviceContext = 'Error creating device context for %s.%s';
rsIndexOutOfBounds = '%s Index %d out of bounds 0-%d';
rsIndexOutOfBounds = '%s Index %d out of bounds 0 .. %d';
rsUnknownPictureExtension = 'Unknown picture extension';
rsBitmaps = 'Bitmaps';
rsPixmap = 'Pixmap';

3
lcl/stdctrls.pp
View File

@ -471,6 +471,7 @@ type
FTopIndex: integer;
function GetCount: Integer;
function GetTopIndex: Integer;
procedure RaiseIndexOutOfBounds(AIndex: integer);
procedure SetColumns(const AValue: Integer);
procedure SetTopIndex(const AValue: Integer);
procedure UpdateSelectionMode;
@ -495,7 +496,7 @@ type
function GetCachedDataSize: Integer; virtual; // returns the amount of data needed per item
function GetCachedData(const AIndex: Integer): Pointer;
procedure SetExtendedSelect(Val: boolean); virtual;
procedure SetItemIndex(Val: integer); virtual;
procedure SetItemIndex(AIndex: integer); virtual;
procedure SetItems(Value: TStrings); virtual;
procedure SetItemHeight(Value: Integer);
procedure SetMultiSelect(Val: boolean); virtual;