Using Rad Studio 10 Seattle, DUnitX and TestInsight, I would need to show some texts in the console or any log screen. How can it be done? I have not been able to find it in the web.
procedure CreateRunner;
var fn : TFileName;
begin
runner := TDUnitX.CreateRunner;
runner.UseRTTI := True;
fn := IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName)) + 'dUnitX.Log';
ConsoleLogger := TDUnitXConsoleLogger.Create(false);
TextFileLogger:= TDUnitXTextFileLogger.Create(fn);
nunitLogger := TDUnitXXMLNUnitFileLogger.Create(TDUnitX.Options.XMLOutputFile);
runner.AddLogger(ConsoleLogger );
runner.AddLogger(TextFileLogger);
runner.AddLogger(nunitLogger);
end;
Here's how to add log messages, fragments copied from https://github.com/VSoftTechnologies/DUnitX/blob/d5861ce0de6a9fbfdc8c158b0b1c8614082c188d/Examples/DUnitX.Examples.General.pas
[TestFixture('ExampleFixture1','General Example Tests')]
TMyExampleTests = class
public
[Test]
procedure LogMessageTypes;
end;
procedure TMyExampleTests.LogMessageTypes;
begin
TDUnitX.CurrentRunner.Log(TLogLevel.Information, 'Information');
TDUnitX.CurrentRunner.Log(TLogLevel.Warning, 'Warning');
TDUnitX.CurrentRunner.Log(TLogLevel.Error, 'Error');
end;
If you want to have a less convoluted syntax, you can always add an interposer for the Assert class like so
Assert = class(DUnitX.Assert.Assert) //Or (DunitX.Assert.Ex.Assert)
public
class procedure Log(const message: string);
end;
class procedure Assert.Log(const message: string);
begin
TDUnitX.CurrentRunner.Log(TLogLevel.Information, message);
end;
https://github.com/jsf3rd/DUnitX.git/trunk/Examples
var
runner : ITestRunner;
logger : ITestLogger;
begin
try
//Create the runner
runner := TDUnitX.CreateRunner;
runner.UseRTTI := True;
//tell the runner how we will log things
if TDUnitX.Options.ConsoleMode <> TDunitXConsoleMode.Off then
begin
logger := TDUnitXConsoleLogger.Create(TDUnitX.Options.ConsoleMode = TDunitXConsoleMode.Quiet);
runner.AddLogger(logger);
end;
//Run tests
results := runner.Execute;
System.Write('Done.. press <Enter> key to quit.');
System.Readln;
except
on E: Exception do
System.Writeln(E.ClassName, ': ', E.Message);
end;
Related
I have a Mailitem and make a reply for that.
Now I register an OnSend EventHandler and display the Item with modal FALSE.
Everything works as desired.
My Problem is that I don't know how to free the MailItem.
If I display the Item modal I can free it in the finally block at the end of the function,
but if I display the Item non-modal, my eventhanlder (AOnSend) clearly will never be called, cause the mailitem with the registered handler is thrown away.
But to simply not call MailItem.Free will produce a Mem-Leak, so my Question: How to correctly free this MailItem?
function InternalReply(AFolder, AMailID, ASender, ACC: String; AWithoutTo: TList<String>; AModal: Boolean; AOnSend: TMailItemSend; var AErrorText: String; AReplyAll: Boolean = FALSE): Boolean; overload;
var AOutlookApplication: TOutlookApplication;
ANewInstance: Boolean;
AMAPIFolder: MAPIFolder;
AMailItem: MailItem;
AMail: TMailItem;
begin
AErrorText := '';
AOutlookApplication := Nil;
AMailItem := Nil;
AMail := TMailItem.Create(Nil);
try
try
Result := OpenOutlookInstance(AOutlookApplication, ANewInstance, AErrorText);
if Result then begin
AMAPIFolder := IntGetFolderByName(AOutlookApplication, UpperCase(AFolder), AErrorText);
if Assigned(AMAPIFolder) then begin
Result := IntGetMailFromMAPIFolderByID(AOutlookApplication, AMAPIFolder, AMailID, AMailItem, AErrorText);
if Result and Assigned(AMailItem) then begin
AMailItem := AMailItem.ReplyAll;
if Assigned(AOnSend) then begin
AMail.ConnectTo(AMailItem);
AMail.OnSend := AOnSend;
end;
if Assigned(AMailItem) then begin
...
AMailItem.Display(AModal);
end
else begin
Result := TRUE;
end;
end
else begin
Result := FALSE;
AErrorText := AErrorText + ' Mail not found! MailID: ' + AMailID;
end;
end
else begin
Result := FALSE;
AErrorText := AErrorText + ' Folder not found! Name: ' + AFolder;
end;
CloseOutlookInstance(AOutlookApplication, ANewInstance, AErrorText);
end;
except
on E: Exception do begin
Result := FALSE;
AErrorText := AErrorText + ' ' + 'Reply: Internal Error! Message: ' + E.Message;
end;
end;
finally
AMail.Free // IF I DO THIS THEN I LOSE MY HANDLER
end;
end;
You can use a global object container for this purpose: TObjectList.
When you create a new mail, add it to the container.
In the OnSend eventhandler, you can remove the mail from the container.
If you work like this, you can have multiple mails open at the same time:
uses
Contnrs,
...
var
Mails : TObjectList;
...
// create the container at application startup
// do not forget to free the container at application termination
Mails := TObjectList.Create;
...
// create mail
function InternalReply()
...
if Assigned(AOnSend) then begin
AMail.ConnectTo(AMailItem);
AMail.OnSend := AOnSend;
// add it to the container
Mails.Add(AMail);
end;
...
end;
// in your OnSend handler, remove mail from the list
// this will automatically free the mail
procedure AOnSend(Sender: TObject; var Cancel: WordBool);
begin
...
Mails.Remove(Sender); // sender is our Mail object
end;
This program raises an I/O 104 error on EoF when first entering the while loop.
The purpose of the program is to look up if a username is already taken. The existing usernames are stored in a text file.
procedure TForm1.btnRegisterClick(Sender: TObject);
begin
sCUser := edtUserName.Text;
AssignFile(tNames, 'Names.txt');
begin
try
Reset(tNames);
except
ShowMessage('File not found');
Exit;
end;
end;
rewrite(tNames);
while not EoF(tNames) do // I get a I/O 104 Error here `
begin
Readln(tNames, sLine);
iPosComme := Pos(',', sLine);
sUser := Copy(sLine, 1, iPosComme - 1);
Delete(sLine, 1, iPosComme - 1);
if sCUser = sUser then begin
ShowMessage('Username taken');
end
else
begin
rewrite(tNames);
Writeln(tNames, sCUser + ',' + '0');
CloseFile(tNames);
end;
end;
end;
Remove the call to Rewrite()before Eof(). Even if you were not getting an IO error, your code would still fail because Rewrite() closes the file you opened with Reset() and then it creates a new bank file, so Eof() would always be True.
Update: error 104 is file not open for input, which means Reset() is not opening the file but is not raising an exception (which sounds like an RTL bug if Eof() is raising an exception, indicating that {I+} is active).
In any case, using AssignFile() and related routines is the old way to do file I/O. You should use newer techniques, like FileOpen() with FileRead(), TFileStream with TStreamReader, TStringList, etc...
Update: your loop logic is wrong. You are comparing only the first line. If it does not match the user, you are wiping out the file, writing the user to a new file, closing the file, and then continuing the loop. EoF() will then fail at that point. You need to rewrite your loop to the following:
procedure TForm1.btnRegisterClick(Sender: TObject
var
SCUser, sUser: String;
tNames: TextFile;
iPosComme: Integer;
Found: Boolean;
begin
sCUser := edtUserName.Text;
AssignFile(tNames,'Names.txt');
try
Reset(tNames);
except
ShowMessage('File not found');
Exit;
end;
try
Found := False;
while not EoF(tNames) do
begin
Readln(tNames,sLine);
iPosComme := Pos(',', sLine);
sUser := Copy(sLine ,1,iPosComme -1);
if sCUser = sUser then
begin
ShowMessage('Username taken') ;
Found := True;
Break;
end;
end;
if not Found then
Writeln(tNames,sCUser + ',0');
finally
CloseFile(tNames);
end;
end;
For the sake of completeness, this Version works for me, but it is hard to guess what the code is intended to do. Especially the while loop seems a bit displaced, since the file will contain exactly one line after the rewrite-case has ben hit once.
program wtf;
{$APPTYPE CONSOLE}
{$I+}
uses
SysUtils;
procedure Sample( sCUser : string);
var sUser, sLine : string;
iPosComme : Integer;
tnames : textfile;
begin
AssignFile(tNames,'Names.txt');
try
Reset(tNames);
except
Writeln('File not found');
Exit;
end;
while not EoF(tNames) do
begin
Readln(tNames,sLine);
iPosComme := Pos(',', sLine);
sUser := Copy(sLine ,1,iPosComme -1);
Delete( sLine,1, iPosComme -1);
if sCuser = sUser then begin
Writeln('Username taken') ;
end
else begin
Rewrite(tNames);
Writeln(tNames,sCUser + ',' + '0');
CloseFile(tNames);
Break; // file has been overwritten and closed
end;
end;
end;
begin
try
Sample('foobar');
except
on E: Exception do Writeln(E.ClassName, ': ', E.Message);
end;
end.
I wrote a version of this method that uses the newer TStreamReader and TStreamWriter classes.
This won't work with Delphi 7 of course, it's just to show how this could be done in newer versions of Delphi.
The code was heavily inspired by Remys answer.
procedure TForm1.btnRegisterClick(Sender: TObject);
var
Stream: TStream;
Reader: TStreamReader;
Writer: TStreamWriter;
Columns: TStringList;
UserName: string;
Found: Boolean;
FileName: string;
Encoding: TEncoding;
begin
FileName := ExpandFileName('Names.txt'); // An absolute path would be even better
UserName := edtUsername.Text;
Found := False;
Encoding := TEncoding.Default; // or another encoding, e.g. TEncoding.Unicode for Unicode
Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
Reader := TStreamReader.Create(Stream, Encoding);
try
Columns := TStringList.Create;
try
Columns.Delimiter := ',';
Columns.StrictDelimiter := True; // or False, depending on the file format
while not Reader.EndOfStream do
begin
Columns.DelimitedText := Reader.ReadLine;
if Columns.Count > 0 then
begin
if AnsiSameStr(Columns[0], UserName) then // or AnsiSameText if UserName is not case-sensitive
begin
ShowMessage('Username taken') ;
Found := True;
Break;
end;
end;
end;
finally
Columns.Free;
end;
finally
Reader.Free;
end;
finally
Stream.Free;
end;
if not Found then
begin
Writer := TStreamWriter.Create(FileName, True, Encoding);
try
// Warning: This will cause problems when the file does not end with a new line
Writer.WriteLine(UserName + ',0');
finally
Writer.Free;
end;
end;
end;
If performance and memory usage are not a concern:
procedure TForm1.btnRegisterClick(Sender: TObject);
var
Rows: TStringList;
Columns: TStringList;
UserName: string;
Found: Boolean;
FileName: string;
Encoding: TEncoding;
Row: string;
begin
FileName := ExpandFileName('Names.txt'); // An absolute path would be even better
UserName := edtUsername.Text;
Found := False;
Encoding := TEncoding.Default; // or another encoding, e.g. TEncoding.Unicode for Unicode
Rows := TStringList.Create;
try
Rows.LoadFromFile(FileName, Encoding);
Columns := TStringList.Create;
try
Columns.Delimiter := ',';
Columns.StrictDelimiter := True; // or False, depending on the file format
for Row in Rows do
begin
Columns.DelimitedText := Row;
if Columns.Count > 0 then
begin
if AnsiSameStr(Columns[0], UserName) then // or AnsiSameText if UserName is not case-sensitive
begin
ShowMessage('Username taken') ;
Found := True;
Break;
end;
end;
end;
finally
Columns.Free;
end;
if not Found then
begin
Rows.Add(UserName + ',0');
Rows.SaveToFile(FileName, Encoding);
end;
finally
Rows.Free;
end;
end;
This solution can be adapted to Delphi 7 by removing the Encoding variable.
If it's part of a bigger database it should be stored in a real database management system rather than a text file.
I am in the process of coding a console application that will create a firewall exception for my main app called Client.exe which uploads a few documents to our servers via FTP. I borrowed RRUZ code from Delphi 7 Windows Vista/7 Firewall Exception Network Locations my code looks like this:
program ChangeFW;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
ComObj;
var
ExecName: string;
procedure AddExceptionToFirewall(Const Caption, Executable: String);
const
NET_FW_PROFILE2_DOMAIN = 1;
NET_FW_PROFILE2_PRIVATE = 2;
NET_FW_PROFILE2_PUBLIC = 4;
NET_FW_IP_PROTOCOL_TCP = 6;
NET_FW_ACTION_ALLOW = 1;
var
fwPolicy2 : OleVariant;
RulesObject : OleVariant;
Profile : Integer;
NewRule : OleVariant;
begin
Profile := NET_FW_PROFILE2_PRIVATE OR NET_FW_PROFILE2_PUBLIC;
fwPolicy2 := CreateOleObject('HNetCfg.FwPolicy2');
RulesObject := fwPolicy2.Rules;
NewRule := CreateOleObject('HNetCfg.FWRule');
NewRule.Name := Caption;
NewRule.Description := Caption;
NewRule.Applicationname := Executable;
NewRule.Protocol := NET_FW_IP_PROTOCOL_TCP;
NewRule.Enabled := TRUE;
NewRule.Profiles := Profile;
NewRule.Action := NET_FW_ACTION_ALLOW;
RulesObject.Add(NewRule);
end;
begin
try
{ TODO -oUser -cConsole Main : Insert code here }
ExecName := GetCurrentDir + '\' + 'Client.exe';
AddExceptionToFirewall('SIP Inventory',ExecName);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
When I execute the application I get the following error message:
EOIeSysError: Coinitialize has not been called, ProgID: “HNetCfg.FwPolicy2”
Any idea what I am doing wrong? Could you please point me in the right direction? Thank you so very much.
If you want to use COM - objects you will have to call CoInitialize with corresponding CoUninitialize.
In a usual application this will be already done.
As far as your program is a console program you will have to call it on your own.
.....
CoInitialize(nil);
try
try
{ TODO -oUser -cConsole Main : Insert code here }
ExecName := GetCurrentDir + '\' + 'Client.exe';
AddExceptionToFirewall('SIP Inventory',ExecName);
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
finally
CoUninitialize;
end;
.....
I am consuming a WSDL and when I try to execute one of the methods i am getting the error
.. raised exception class EPropertyConvertError with message 'Invalid
property element: System'
Any ideas what causes this?
Here is the code I am running (cEPS_* are constants defined earlier in the code):
procedure TForm1.Button1Click(Sender: TObject);
var
Headers : ISOAPHeaders;
aResult: c_ExpressPSAPI.Response;
begin
try
FEPS_SoapService := c_ExpressPSAPI.GetExpressSoap();
FEPS_Headers := (FEPS_SoapService as ISOAPHeaders);
FEPS_Application := c_ExpressPSAPI.Application.Create();
FEPS_Application.ApplicationID := cEPS_ApplicationID;
FEPS_Application.ApplicationName := cEPS_ApplicationName;
FEPS_Credentials := c_ExpressPSAPI.Credentials.Create();
FEPS_Credentials.AccountID := cEPS_AccountID;
FEPS_Credentials.AccountToken := cEPS_AccountToken;
FEPS_Credentials.AcceptorID := cEPS_AcceptorID;
FEPS_Credentials.NewAccountToken := '';
aResult := c_ExpressPSAPI.Response.Create;
aResult := FEPS_SoapService.HealthCheck(FEPS_Credentials, FEPS_Application);
except
on E : ERemotableException do
ShowMessage(E.ClassName + ' error raised, with message : ' + E.FaultDetail + ' :: '
+ E.Message);
end;
end;
And here is the WSDL code:
ExpressSoap = interface(IInvokable)
['{83D77575-DBDE-3A05-D048-60B2F6BCDFE6}']
function HealthCheck(const credentials: Credentials; const application: Application): Response; stdcall;
Please consider this record:
Type
TStudent = record
Name:String;
Age: Integer;
Class:String;
end;
I have a class TSchool that has the following function:
function AddStudent(LStudent:TStudent):Boolean;
I want to use this class (TSchool) in the dwsunit, and this function too, but i can't figure out how to send the record type as parameter.
This is how far i've reached:
procedure TForm1.dwsUnitClassesTSchoolMethodsAddStudentEval(Info: TProgramInfo;
ExtObject: TObject);
begin
Info.ResultAsBoolean:=(ExtObject as TSchool).AddStudent(Info.Vars['LStudent'].Value);
end;
but this is not working, it keeps on giving me error about incompatible types.
I have also defined in the dwsunit a record TSchool, but this didn't work either.
Any Help is appreciated.
I don't have Delphi 2010 at my disposal now, but I do have Delphi XE(it should work in D2010 also), so here's what works for me, you can of course modify to fit your needs:
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils
,Windows
,dwsComp
,dwsCompiler
,dwsExprs
,dwsCoreExprs
,dwsRTTIExposer
,Generics.Collections
;
// required
{$RTTI EXPLICIT METHODS([vcPublic, vcPublished]) PROPERTIES([vcPublic, vcPublished])}
{M+}
type
// student definition
TStudent = record
Name: string;
Age: Integer;
AClass: string;
end;
// student list, we use generics
TStudentList = class(TList<TStudent>);
// school class
TSchool = class(TObject)
private
FStudentList: TStudentList;
published
constructor Create;
destructor Destroy; override;
published
procedure AddStudent(AStudent: TStudent);
function GetStudentCount: Integer;
function GetStudent(Index: Integer): TStudent;
end;
{ TSchool }
procedure TSchool.AddStudent(AStudent: TStudent);
begin
FStudentList.Add(AStudent);
end;
constructor TSchool.Create;
begin
FStudentList := TStudentList.Create;
end;
function TSchool.GetStudentCount: Integer;
begin
Result := FStudentList.Count;
end;
function TSchool.GetStudent(Index: Integer): TStudent;
begin
Result := FStudentList[ Index ];
end;
destructor TSchool.Destroy;
begin
FStudentList.Free;
inherited;
end;
procedure TestRecords;
var
LScript: TDelphiWebScript;
LUnit: TdwsUnit;
LProg: IdwsProgram;
LExec: IdwsProgramExecution;
begin
LScript := TDelphiWebScript.Create(NIL);
LUnit := TdwsUnit.Create(NIL);
try
LUnit.UnitName := 'MySuperDuperUnit';
LUnit.Script := LScript;
// expose TStudent record to the script
LUnit.ExposeRTTI(TypeInfo(TStudent));
// expose TSchool class to script
LUnit.ExposeRTTI(TypeInfo(TSchool));
// compile a simple script
LProg := LScript.Compile(
'var LSchool := TSchool.Create;'#$D#$A +
'var LStudent: TStudent;'#$D#$A +
'var Index: Integer;'#$D#$A +
'for Index := 0 to 10 do begin'#$D#$A +
'LStudent.Name := Format(''Student #%d'', [Index]);'#$D#$A +
'LStudent.Age := 10 + Index;'#$D#$A +
'LStudent.AClass := ''a-4'';'#$D#$A +
'LSchool.AddStudent( LStudent );'#$D#$A +
'end;'#$D#$A +
'PrintLn(Format(''There are %d students in school.'', [LSchool.GetStudentCount]));'#$D#$A +
'LStudent := LSchool.GetStudent( 5 );'#$D#$A +
'PrintLn(''6th student info:'');'#$D#$A +
'PrintLn(Format(''Name: %s''#$D#$A''Age: %d''#$D#$A''AClass: %s'', [LStudent.Name, LStudent.Age, LStudent.Aclass]));'
);
if LProg.Msgs.HasErrors then begin
Writeln(LProg.Msgs.AsInfo);
Exit;
end;
try
LExec := LProg.Execute;
except
on E: Exception do
WriteLn(E.Message + #$D#$A + LExec.Msgs.AsInfo );
end;
Writeln(LExec.Result.ToString);
finally
LScript.Free;
end;
end;
begin
try
Writeln('press enter to begin');
Readln;
TestRecords;;
Readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.