Procedure fires without being called - delphi

Is it possible, in delphi, that a procedure fires without being called?
I have two completly different procedure. First one is a click on popup menu. The second one is a function which i defined to split a string.
And i don't call my split method in my click of popup menu but it fires anyway and i can't find why. Debugger just says he can't read adress 00000001 but i don't even want him to read cause i don't call this procedure in any of my popup options. Does anyone have any idea of why it could fire by its own?
I can edit code if you want but idk it will be usefull as both procedure arent linked x)
CODE
procedure TBDDTool.pmDeleteColumnClick(Sender: TObject);
var
i: integer;
sListColNames : string;
begin
fileModified := true;
sListColNames := '';
//Increment undo number
Inc(undoNum);
if undoNum = 11 then
begin
for i := 0 to Length(UndoArray) - 1 do
begin
if i < Length(UndoArray)-1 then
UndoArray[i] := UndoArray[i+1];
end;
undoNum := UndoNum -1;
end;
//Add action to the array of undo actions
undoArray[undoNum] := 'Deleted column:' + IntToStr(sgFilePreview.Col)
+'$'+aSourceData[0,sgFilePreview.Col] + '#deleted';
pmUndo.Enabled := true;
if (Pos('#primarykeypk', aSourceData[0, sgFilePreview.Col]) <> 0) then
begin
aSourceData[0,sgFilePreview.Col] := COPY(aSourceData[0,sgFilePreview.Col], 0, Pos('#primarykey', aSourceData[0, sgFilePreview.Col])-1);
pmPrimaryKey.Enabled := true;
end;
if (Pos('#', aSourceData[0, sgFilePreview.Col]) <> 0) then
aSourceData[0,sgFilePreview.Col] := COPY(aSourceData[0,sgFilePreview.Col], 0, Pos('#', aSourceData[0, sgFilePreview.Col])-1);
for i := 0 to Length(aSourceData[0])-1 do
begin
if aSourceData[0,i] = sgFilePreview.Cells[sgFilePreview.Col, 0] then
begin
aSourceData[0,i] := aSourceData[0,i] + '#deleted';
Break;
end;
end;
//just set col width to 0 to hide it but we need the index
sgFilePreview.ColWidths[sgFilePreview.Col] := 0;
end;
//Custom split method
function TBDDTool.Explode(const Separator, s: String;
Limit: Integer): TStringDynArray;
var
SepLen: Integer;
F, P: PChar;
ALen, Index: Integer;
begin
SetLength(Result,0);
//if the word passed is empty there's no need to continue
if (S = '') or (Limit < 0) then Exit;
if Separator = '' then
begin
SetLength(Result, 1);
Result[0] := S;
Exit;
end;
//Set to the length of the separator
SepLen := Length(Separator);
ALen := Limit;
SetLength(Result, ALen);
Index := 0;
P := PChar(s);
While P^ <> #0 do
begin
F := P;
P := AnsiStrPos(P,PChar(Separator));
if (P = nil) OR ((Limit > 0) AND (Index = Limit -1)) then P := StrEnd(F);
if Index >= ALen then
begin
Inc(ALen,5);
SetLength(Result, ALen);
end;
SetString(Result[Index], F, P-F);
INC(Index);
if p^ <> #0 then Inc(P,SepLen);
end;
if index < ALen then SetLength(Result, Index);
end;
The explode functions is called when i click delet option (from a popup menu). But i don't call the explode function in my delete procedure. The break happens on while P^ <> #0 line

Is it possible, in delphi, that a procedure fires without being called?
Generally speak, it is not possible. If code executes, something in the system made it execute.
However, it is possible that you have somehow corrupted memory. That in turn may lead to you calling one function and the corruption leading to a different function being called.
In order to debug this I suggest that you first of all inspect the call stack when the unexpected function begins executing. That should tell you how the execution reached that point. If that's not enough to explain things, cut your code down to the bare minimum that produces the problem. It's harder to find problems when there's lots of code. By cutting down to a minimum, you'll make it easier to see what has gone wrong.

Related

Crash when deleting Graphics32 layers

I've hit an issue when trying to delete layers using Graphics32. It seems that unless you delete layers in reverse order (from the last added to the first) an exception is thrown. I created the simplest application to test this and it is repeatable every time.
I created a simple form with a TImgView32 component (properties all at default) then a button which does the following:
procedure TMainForm.btnDeleteTestClick(Sender: TObject);
var
Layer1: TCustomLayer;
Layer2: TCustomLayer;
begin
Layer1 := TCustomLayer.Create(ImageView.Layers);
Layer2 := TCustomLayer.Create(ImageView.Layers);
Layer1.Free;
Layer2.Free;
end;
If I reverse the order (Layer2.Free then Layer1.Free) it works fine, but this way round it crashes every time. It's also the same whether I use TCustomLayer, TPositionedLayer, TBitmapLayer, or whatever.
I've traved the error and the fault seems to originate here:
function TPointerMap.Delete(BucketIndex, ItemIndex: Integer): PData;
begin
with FBuckets[BucketIndex] do begin
Result := Items[ItemIndex].Data;
if FCount = 0 then Exit;
Dec(Count);
if Count = 0 then SetLength(Items, 0)
else if (ItemIndex < Count) then
Move(Items[ItemIndex + 1], Items[ItemIndex], (Count - ItemIndex - 1) * SizeOf(TPointerBucketItem));
end;
Dec(FCount);
end;
Any idea what is causing this or if I'm doing something wrong? I'm running Delphi XE, by the way.
Here's the code for TCustomLayer.Destroy
destructor TCustomLayer.Destroy;
var
I: Integer;
begin
if Assigned(FFreeNotifies) then
begin
for I := FFreeNotifies.Count - 1 downto 0 do
begin
TCustomLayer(FFreeNotifies[I]).Notification(Self);
if FFreeNotifies = nil then Break;
end;
FFreeNotifies.Free;
FFreeNotifies := nil;
end;
SetLayerCollection(nil); <<-- bug, see below.
inherited; <<---- See note below.
end;
Notice that there's a bug in SetLayerCollection.
Buggy code
procedure TCustomLayer.SetLayerCollection(Value: TLayerCollection);
begin
if FLayerCollection <> Value then begin
if Assigned(FLayerCollection) then begin
if FLayerCollection.MouseListener = Self then
FLayerCollection.MouseListener := nil;
FLayerCollection.RemoveItem(Self);
end;
if Assigned(Value) then Value.InsertItem(Self);
end;
/// FLayerCollection is never set!
end;
The line SetLayerCollection(nil); does not actually set the LayerCollection!
The internal FLayerCollection can suffer from a use after free condition, which is possibly what's happening to you.
Change the code for SetLayerCollection like so:
Bug fix
procedure TCustomLayer.SetLayerCollection(Value: TLayerCollection);
begin
if FLayerCollection <> Value then begin
if Assigned(FLayerCollection) then begin
if FLayerCollection.MouseListener = Self then begin
FLayerCollection.MouseListener := nil;
end;
FLayerCollection.RemoveItem(Self);
end;
if Assigned(Value) then begin
Value.InsertItem(Self)
end;
FLayerCollection:= Value; // add this line.
end;
end;
Note
My hypothesis is that the following snippet causes the error:
SetLayerCollection(nil);
inherited;
SetLayerCollection(value); leaves FLayerCollection unchanged.
The inherited destructor somehow calls something having to do with LayerCollection.
Let me know if this fixes the error.
I've filed a new issue: https://github.com/graphics32/graphics32/issues/13
Update: issue is off by one error in TPointerMap.Delete
The actual issue is here:
https://github.com/graphics32/graphics32/issues/14
The code for TPointerMap.Delete is incorrect:
function TPointerMap.Delete(BucketIndex, ItemIndex: Integer): PData;
begin
with FBuckets[BucketIndex] do
begin
Result := Items[ItemIndex].Data;
if FCount = 0 then Exit; <<-- error: how can result be valid if count = 0?
Dec(Count);
if Count = 0 then
SetLength(Items, 0)
else
if (ItemIndex < Count) then
//Oops off by 1 error! ---------------------------------------VVVVV
Move(Items[ItemIndex + 1], Items[ItemIndex], (Count - ItemIndex - 1) * SizeOf(TPointerBucketItem));
end;
Dec(FCount); <<-- The use of with makes this statement confusing.
end;
The code should be changed as follows:
function TPointerMap.Delete(BucketIndex, ItemIndex: Integer): PData;
var
Bucket: TPointerBucket ;
begin
if FCount = 0 then Exit(nil);
//Perhaps add some code to validate BucketIndex & ItemIndex?
Assert(BucketIndex < Length(FBuckets));
Bucket:= FBuckets[BucketIndex];
if ItemIndex >= Bucket.
Assert(ItemIndex < Length(Bucket.Items));
Result := Bucket.Items[ItemIndex].Data;
Dec(Bucket.Count);
if Bucket.Count = 0 then
SetLength(Bucket.Items, 0)
else
/// assume array like so: 0 1 2 3 4 , itemindex = 0
/// result should be 1 2 3 4
/// move(1,0,4) (because 4 items should be moved.
/// Thus move (itemindex+1, intemindex, count-itemindex)
if (ItemIndex < Bucket.Count) then
Move(Items[ItemIndex + 1], Items[ItemIndex], (Bucket.Count - ItemIndex) * SizeOf(TPointerBucketItem));
end;
Dec(FCount);
end;

Writing all instances of strings between two other strings to logfile

After looking at Delphi extract string between to 2 tags and trying the code given there by Andreas Rejbrand I realized that I needed a version that wouldn't stop after one tag - my goal is to write all the values that occur between two strings in several .xml files to a logfile.
<screen> xyz </screen> blah blah <screen> abc </screen>
-> giving a logfile with
xyz
abc
... and so on.
What I tried was to delete a portion of the text read by the function, so that when the function repeated, it would go to the next instance of the desired string and then write that to the logfile too until there were no matches left - the boolean function would be true and the function could stop - below the slightly modified function as based on the version in the link.
function ExtractText(const Tag, Text: string): string;
var
StartPos1, StartPos2, EndPos: integer;
i: Integer;
mytext : string;
bFinished : bool;
begin
bFinished := false;
mytext := text;
result := '';
while not bFinished do
begin
StartPos1 := Pos('<' + Tag, mytext);
if StartPos1 = 0 then bFinished := true;
EndPos := Pos('</' + Tag + '>', mytext);
StartPos2 := 0;
for i := StartPos1 + length(Tag) + 1 to EndPos do
if mytext[i] = '>' then
begin
StartPos2 := i + 1;
break;
end;
if (StartPos2 > 0) and (EndPos > StartPos2) then
begin
result := result + Copy(mytext, StartPos2, EndPos - StartPos2);
delete (mytext, StartPos1, 1);
end
So I create the form and assign a logfile.
procedure TTagtextextract0r.FormCreate(Sender: TObject);
begin
Edit2.Text:=(TDirectory.GetCurrentDirectory);
AssignFile(LogFile, 'Wordlist.txt');
ReWrite(LogFile);
CloseFile(Logfile);
end;
To then get the files in question, I click a button which then reads them.
procedure TTagtextextract0r.Button3Click(Sender: TObject);
begin
try
sD := TDirectory.GetCurrentDirectory;
Files:= TDirectory.GetFiles(sD, '*.xml');
except
exit
end;
j:=Length(Files);
for k := 0 to j-1 do
begin
Listbox2.Items.Add(Files[k]);
sA:= TFile.ReadAllText(Files[k]);
iL:= Length(sA);
AssignFile(LogFile, 'Wordlist.txt');
Append(LogFile);
WriteLn(LogFile, (ExtractText('screen', sA)));
CloseFile (LogFile);
end;
end;
end.
My problem is that without the boolean loop in the function, the application only writes the one line per file and then stops but with the boolean code the application gets stuck in an infinite loop - but I can't quite see where the loop doesn't end. Is it perhaps that the "WriteLn" command can't then output the result of the function? If it can't, I don't know how to get a new line for every run of the function - what am I doing wrong here?
First you need to get a grip on debugging
Look at this post for a briefing on how to pause and debug a program gone wild.
Also read Setting and modifying breakpoints to learn how to use breakpoints. If you would have stepped through your code, you would soon have seen where you go wrong.
Then to your problem:
In older Delphi versions (up to Delphi XE2) you could use the PosEx() function (as suggested in comments), which would simplify the code in ExtractText() function significantly. From Delphi XE3 the System.Pos() function has been expanded with the same functionality as PosEx(), that is, a third parameter Offset: integer
Since you are on Delphi 10 Seattle you can use interchangeably either System.StrUtils.PosEx() or System.Pos().
System.StrUtils.PosEx
PosEx() returns the index of SubStr in S, beginning the search at
Offset
function PosEx(const SubStr, S: string; Offset: Integer = 1): Integer; inline; overload;
The implementation of ExtractText() could look like this (with PosEx()):
function ExtractText(const tag, text: string): string;
var
startPos, endPos: integer;
begin
result := '';
startPos := 1;
repeat
startPos := PosEx('<'+tag, text, startpos);
if startPos = 0 then exit;
startPos := PosEx('>', text, startPos)+1;
if startPos = 1 then exit;
endPos := PosEx('</'+tag+'>', text, startPos);
if endPos = 0 then exit;
result := result + Copy(text, startPos, endPos - startPos) + sLineBreak;
until false;
end;
I added sLineBreak (in unit System.Types) after each found text, otherwise it should work as you intended it (I believe).

How do I load a chess board into program once saved?

I have a procedure that saves a chess board into a text file. I am trying to read the board back in to the program once saved. When I call this procedure I get this error.
Code which I have for loading in board.
Procedure LoadBoard(Var Board : Tboard);
var
fptr:text;
i,j,x:integer;
line:string;
load:char;
begin
Write('Do you want a load a game? (Enter Y for yes)');
Readln(load);
If (Ord(load) >= 97) and (Ord(load) <= 122)
Then load := Chr(Ord(load) - 32);
if load='Y' then
begin
assignfile(fptr,'SBoard.txt');
reset(fptr);
i:=1;
repeat
readln(fptr,line);
j:=1;
x:=1;
repeat
begin
if (line[x]<>',') and (line[x+1]<>',')
then
begin
Board[i,j][1]:=line[x];
Board[i,j][2]:=line[x+1];
end;
if line[x]=','
then
j:=j+1;
x:=x+1;
end;
until j=9;
i:=i+1;
until i=9;
close(fptr);
end;
end;
You get the Access Violation exception because the string members in your Board array are empty (length is zero) and therefore have no accessible character positions.
To fix your present code, you should use SetLength() on each string member before you assign content to the character positions. You have not shown what the strings contain, so only you know what the set length should be.
On the other hand, in previous answer to your questions you have been adviced several other methods to save your chess board. You should review those and possibly choose one of them. It would also be polite to respond to those answers and maybe tell why you did not select them. Maybe we were not able to explain the benefits.
You are over complicating things by using a Text file and saving your board line by line.
I think you should use a TStringList for saving and loading :
Const
BoardDimension = 8;
BoardFileName = 'SBoard.txt';
Type
TBoard = Array [1 .. BoardDimension, 1 .. BoardDimension] Of String;
procedure SaveBoard(Board: TBoard);
var
i, j: Integer;
Line, BoardFile: TStringList;
begin
BoardFile := TStringList.Create;
Line := TStringList.Create;
for i := 1 to BoardDimension do
begin
Line.Clear;
for j := 1 to BoardDimension do
Line.Add(Board[i, j]);
BoardFile.Add(Line.CommaText);
end;
Line.Free;
BoardFile.SaveToFile(BoardFileName);
BoardFile.Free;
end;
procedure LoadBoard(Board: TBoard);
var
i, j: Integer;
Line, BoardFile: TStringList;
begin
if not FileExists(BoardFileName) then
exit; // Show error message
BoardFile := TStringList.Create;
BoardFile.LoadFromFile(BoardFileName);
Line := TStringList.Create;
for i := 1 to BoardDimension do
begin
Line.CommaText := BoardFile[i];
for j := 1 to BoardDimension do
Board[i, j] := Line[j];
end;
Line.Free;
BoardFile.Free;
end;
And if you want to test the load an save proceudre you could do it like this :
procedure Test;
var
Board: TBoard;
BoardA: TBoard;
i, j: Integer;
begin
randomize;
for i := 1 to BoardDimension do
for j := 1 to BoardDimension do
Board[i, j] := Random(500).ToString;
SaveBoard(Board); //Save Board
LoadBoard(BoardA); //Load the file into a NEW board
for i := 1 to BoardDimension do //Comapre the two boards
for j := 1 to BoardDimension do
if Board[i,j] <> BoardA[i,j] then
raise Exception.Create('Wrong file format');
end;

out parameter and "ShowMessage" function

I have a function declare like this :
function execProc(ProcName,InValues:PChar;out OutValues:PChar):integer; //The "OutValues" is a out parameter.
And I call this function like this:
procedure TForm1.Button6Click(Sender: TObject);
var
v:integer;
s:pchar;
begin
Memo1.Clear;
v := execProc(pchar('PROC_TEST'),pchar('aaa'),s);
showmessage(inttostr(v)); //mark line
Memo1.Lines.Add(strpas(s));
end;
when i delete the mark line(showmessage(inttostr(v))),i will have a correct result display in the Memo1,but if i keep use the showmessage(), the memo1 will dispaly an error string : "Messag" ,Why?
Thanks for any help!
function execProc(ProcName,InValues:PChar;out OutValues:PChar):integer;
var
str: TStrings;
InValue,OutValue: string;
i,j,scount: integer;
begin
Result := -100;
i := 0;
j := 0;
str := TStringList.Create;
try
sCount := ExtractStrings(['|'], [], InValues, str);
with kbmMWClientStoredProc1 do
begin
Close;
Params.Clear;
StoredProcName := StrPas(ProcName);
FieldDefs.Updated := False;
FieldDefs.Update;
for i := 0 to Params.Count - 1 do
begin
if (Params[i].ParamType = ptUnknown) or
(Params[i].ParamType = ptInput) or
(Params[i].ParamType = ptInputOutput) then
begin
inc(j);
InValue := str[j-1];
Params[i].Value := InValue;
end;
end;
try
ExecProc;
for i := 0 to Params.Count - 1 do
begin
if (Params[i].ParamType = ptOutput) or
(Params[i].ParamType = ptInputOutput) then
OutValue := OutValue + '|' + Params[i].AsString;
end;
OutValues := PChar(Copy(OutValue,2,Length(OutValue)-1));
Result := 0;
except
on E:Exception do
begin
if E.Message = 'Connection lost.' then Result := -101;//服务器连接失败
if E.Message = 'Authorization failed.' then Result := -102;//身份验证失败
Writelog(E.Message);
end;
end;
end;
finally
str.Free;
end;
end;
The problem is in the design of your interface and the use of PChar.
OutValues := PChar(Copy(OutValue,2,Length(OutValue)-1));
This is implemented by making an implicit, hidden, local string variable which holds the value
Copy(OutValue,2,Length(OutValue)-1)
When the function returns, that string variable is destroyed and so OutValues points at deallocated memory. Sometimes your program appears to work but that's really just down to chance. Any small change can disturb that, as you have observed.
The problem is easy enough to fix. Simply use string parameters rather than PChar. This will make the code easier to read as well as making it work correctly.
function execProc(ProcName, InValues: string; out OutValues: string): integer;

Word blocks in TMemo

I am trying to make a basic Hex viewer out of a TMemo, I know this is probably not ideal but it will be only me personally using it so that does not really matter.
(1)
Firstly, suppose a Memo is filled with Hex information like so:
How could I get a count of all the text blocks shown, ignoring the white space? So using the image the result in this case would be 28.
This is what I tried and I know it is completely wrong as I am accessing the Memo lines but I don't know how to access each character.
I cant seem to solve this simple problem :(
function CountWordBlocks(Memo: TMemo): Integer;
var
i: Integer;
vCount: Integer;
begin
for i := 0 to Memo.Lines.Count - 1 do
begin
if Length(Memo.Lines.Strings[i]) = 2 then
begin
Inc(vCount);
end;
end;
Result := vCount;
end;
Here is the code I am using to display the Hex values in the Memo:
procedure ReadFileAsHex(const AFileName: string; ADestination: TStrings);
var
fs: TFileStream;
buff: Byte;
linecount: Byte;
line: string;
begin
linecount := 0;
line := '';
fs := TFileStream.Create(AFileName, fmOpenRead);
try
ADestination.BeginUpdate;
try
while fs.Position < fs.Size do
begin
fs.Read(buff, 1);
line := line + IntToHex(buff, 2) + ' ';
Inc(linecount);
if linecount = 16 then
begin
ADestination.Add(line);
line := '';
linecount := 0;
end;
end;
if Length(line) <> 0 then
ADestination.Add(line);
finally
ADestination.EndUpdate;
end;
finally
fs.Free;
end;
end;
(2)
If I click onto the Memo and a text block is under the cursor, how could I know which number the selected block is out of all the others?
So using the same first image, the caret is at the top line next to 68, so the result would be 3 as it is the third text block out of 28.
This should be so easy but I cannot think clearly, I don't have the right programming mind yet and so really struggle with basic logic and solving problems!
(3)
Finally I would like to select a block at runtime by passing a block number value. I tried this without much success:
procedure FindBlock(Memo: TMemo; BlockNumber: Integer);
var
i: Integer;
txt: string;
ThisWhite, PrevWhite: boolean;
vRead: Integer;
begin
txt := Memo.Text;
vRead:= 0;
PrevWhite := True;
for i := 1 to Length(txt) do
begin
ThisWhite := Character.IsWhiteSpace(txt[i]);
if PrevWhite and not ThisWhite then
begin
Inc(vRead);
PrevWhite := False;
end;
PrevWhite := ThisWhite;
if vRead = BlockNumber then
begin
Memo.SelStart := vRead;
Memo.SetFocus;
Exit;
end;
end;
end;
(1)
This works:
function TForm1.CountBlocks: integer;
var
i: Integer;
txt: string;
ThisWhite, PrevWhite: boolean;
begin
txt := Memo1.Text;
result:= 0;
PrevWhite := true;
for i := 1 to Length(txt) do
begin
ThisWhite := Character.IsWhiteSpace(txt[i]);
if PrevWhite and not ThisWhite then
begin
inc(result);
PrevWhite := false;
end;
PrevWhite := ThisWhite;
end;
end;
However, it can be optimized if more detailed information about the memo contents is available. For instance, if you know that each line consists of four blocks, then the number of blocks is simply 4*Memo1.Lines.Count. My code above will even accept blocks of different width.
(2)
Simply replace
for i := 1 to Length(txt) do
by
for i := 1 to Memo1.SelStart + 1 do
Since you are in control of the formatting of your lines, and the lines have a fixed format, it is very easy to calculate the number of bytes being displayed without resorting to looping through the individual lines one a time. Every line displays 3 characters per byte, and every line other than the last line displays 16 bytes, thus 48 characters per complete 16-byte line. Use those facts to your advantage to calculate the number of bytes based on the number of complete 16-byte lines present, and then you can add on the number of remaining bytes from just the last line:
function CountWordBlocks(Memo: TMemo): Integer;
var
Count: Integer;
begin
Count := Memo.Lines.Count;
if Count > 0 then
Result := (16 * (Count-1)) + (Length(Memo.Lines[Count-1]) div 3);
else
Result := 0;
end;
You can do something similar to translate a character offset within the Memo into a work block number:
function GetCurrentWordBlock(Memo: TMemo): Integer;
var
SelStart, LineStart, LineNum: Integer
begin
Result := 0;
SelStart := Memo.SelStart;
if SelStart < 0 then Exit;
LineStart := Memo.Perform(EM_LINEINDEX, SelStart, 0);
if LineStart < 0 then Exit;
LineNum := Memo.Perform(EM_LINEFROMCHAR, LineStart, 0);
Result := (16 * LineNum) + ((SelStart - LineStart) div 3) + 1;
end;
To select a given block number, you can do this:
procedure FindBlock(Memo: TMemo; BlockNumber: Integer);
var
LineNum, LineStart: Integer;
begin
if BlockNumber < 1 then Exit;
LineNum = (BlockNumber - 1) div 16;
LineStart = Memo.Perform(EM_LINEINDEX, LineNum, 0);
if LineStart < 0 then Exit;
Memo.SelStart = LineStart + (((BlockNumber - 1) - (16 * LineNum)) * 3);
Memo.SelLength := 2;
Memo.SetFocus;
end;

Resources