I'm trying to execute this code (this is a minimal sample in order to use CreateOleObject) from inside of a dwscript
function GetFileVersion(const FileName: string): string;
var
V : OleVariant;
begin
V := CreateOleObject('Scripting.FileSystemObject');
Result := V.GetFileVersion(FileName);
end;
So far i tried this
{$APPTYPE CONSOLE}
{$R *.res}
uses
SysUtils,
ComObj,
ActiveX,
dwsComp,
dwsCompiler,
dwsExprs,
dwsCoreExprs;
procedure Execute;
var
LScript: TDelphiWebScript;
LUnit: TdwsUnit;
LProg: IdwsProgram;
LExec: IdwsProgramExecution;
begin
LScript := TDelphiWebScript.Create(NIL);
LUnit := TdwsUnit.Create(NIL);
try
LUnit.UnitName := 'Foo';
LUnit.Script := LScript;
// compile a simple script
LProg := LScript.Compile(
'function GetFileVersion(const FileName: string): string;'+sLineBreak+
'var'+sLineBreak+
' V : Variant;'+sLineBreak+
'begin'+sLineBreak+
' V := CreateOleObject(''Scripting.FileSystemObject'');'+sLineBreak+
' Result := V.GetFileVersion(FileName);'+sLineBreak+
'end;'+sLineBreak+
''+sLineBreak+
'PrintLn(GetFileVersion(''Foo''));'+sLineBreak+
''
);
if LProg.Msgs.HasErrors then begin
Writeln(LProg.Msgs.AsInfo);
Exit;
end;
try
LExec := LProg.Execute;
except
on E: Exception do
WriteLn(E.Message + sLineBreak + LExec.Msgs.AsInfo );
end;
Writeln(LExec.Result.ToString);
finally
LScript.Free;
end;
end;
begin
try
Execute;
Readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
But i'm getting this error message
Syntax Error: Unknown name "CreateOleObject" [line: 5, column: 8]
the question is how i can execute the CreateOleObject function using dwscript?
UPDATE
Following the Linas suggestions I could finally resolve the issue.
This is a sample working application
uses
SysUtils,
ComObj,
ActiveX,
dwsComp,
dwsCompiler,
dwsExprs,
dwsComConnector,
dwsCoreExprs;
procedure Execute;
var
LScript: TDelphiWebScript;
LUnit: TdwsUnit;
LProg: IdwsProgram;
LExec: IdwsProgramExecution;
LdwsComConnector : TdwsComConnector;
begin
LScript := TDelphiWebScript.Create(NIL);
LdwsComConnector:=TdwsComConnector.Create(nil);
LdwsComConnector.Script:=LScript;
LUnit := TdwsUnit.Create(NIL);
try
LUnit.UnitName := 'Foo';
LUnit.Script := LScript;
// compile a simple script
LProg := LScript.Compile(
'function GetFileVersion(const FileName: string): string;'+sLineBreak+
'var'+sLineBreak+
' V : OleVariant;'+sLineBreak+
'begin'+sLineBreak+
' V := CreateOleObject(''Scripting.FileSystemObject'');'+sLineBreak+
' Result := VarToStr(V.GetFileVersion(FileName));'+sLineBreak+
'end;'+sLineBreak+
''+sLineBreak+
'PrintLn(GetFileVersion(''C:\Bar\Foo.exe''));'+sLineBreak+
''
);
if LProg.Msgs.HasErrors then begin
Writeln(LProg.Msgs.AsInfo);
Exit;
end;
try
LExec := LProg.Execute;
except
on E: Exception do
WriteLn(E.Message + sLineBreak + LExec.Msgs.AsInfo );
end;
Writeln(LExec.Result.ToString);
finally
LScript.Free;
LdwsComConnector.Free;
end;
end;
begin
try
CoInitialize(nil);
try
Execute;
Readln;
finally
CoUninitialize;
end;
except
on E:Exception do
Writeln(E.Classname, ':', E.Message);
end;
end.
This can be accomplished in two ways.
1 way: You must drop TdwsComConnector (from unit dwsComConnector) to your data module or form (or create it manually) and assign your script instance to it. e.g.:
dwsComConnector1.Script := LScript;
2 way:
interface
uses
dwsFunctions, dwsSymbols, dwsExprs;
type
TCreateOleObjectFunc = class(TInternalFunction)
procedure Execute(info : TProgramInfo); override;
end;
implementation
uses
OleAuto;
{ TCreateOleObjectFunc }
procedure TCreateOleObjectFunc.Execute(info : TProgramInfo);
begin
Info.ResultAsVariant := CreateOleObject(Info.ValueAsString['ClassName']);
end;
initialization
RegisterInternalFunction(TCreateOleObjectFunc, 'CreateOleObject', ['ClassName', cString], cVariant, True);
This will expose CreateOleObject function to DWScript so you could use it.
Also you should declare your V as OleVariant instead of Variant and change the line to Result := VarToStr(V.GetFileVersion(FileName)); to make it work properly.
Related
How can I extract domain suffix without entering http:// or https://?
For example, if I enter stackoverflow.com, I want to get the result of com.
I have this function, but I must enter http:// to get the result.
Is there any way to skip entering http:// and https://?
procedure TForm1.Button2Click(Sender: TObject);
function RatChar(S:String; C: Char):Integer;
var
i : Integer;
begin
i := Length(S);
//while (S[i] <> C) and (i > 0) do
while (i > 0) and (S[i] <> C) do
Dec(i);
Result := i;
end;
var
uri: TIdURI;
i: Integer;
begin
uri := TidURI.Create(Edit2.Text);
try
//Memo1.Lines.Add(uri.Protocol);
//Memo1.Lines.Add(uri.Host);
i := RatChar(uri.Host, '.');
Memo1.Lines.Add(Copy(uri.Host, i+1, Length(uri.Host)));
Memo1.Lines.Add(uri.Document);
finally
uri.Free;
end;
end;
uses
System.SysUtils;
var
u : string;
arr: TArray<string>;
begin
try
u := 'https://stackoverflow.com/questions/71166883/how-to-extract-domain-suffix';
arr := u.Split(['://'], TStringSplitOptions.ExcludeEmpty);
u := arr[High(arr)]; //stackoverflow.com/questions/71166883/how-to-extract-domain-suffix';
arr := u.Split(['/'], TStringSplitOptions.ExcludeEmpty);
u := arr[0]; //stackoverflow.com
arr := u.Split(['.'], TStringSplitOptions.ExcludeEmpty);
u := arr[High(arr)]; //com
writeln('Top-Level-Domain: ', u);
readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
According to suggestion Extracting top-level and second-level domain from a URL using regex it should run like this in Delphi:
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils, System.RegularExpressions;
var
url,
rePattern: string;
rMatch : TMatch;
rGroup : TGroup;
arr : TArray<string>;
begin
try
url := 'https://www.answers.com/article/1194427/8-habits-of-extraordinarily likeable-people';
//url := 'https://stackoverflow.com/questions/71166883/how-to-extract-domain-suffix';
rePattern := '^(?:https?:\/\/)(?:w{3}\.)?.*?([^.\r\n\/]+\.)([^.\r\n\/]+\.[^.\r\n\/]{2,6}(?:\.[^.\r\n\/]{2,6})?).*$';
rMatch := TRegEx.Match(url, rePattern);
if rMatch.Success then
begin
rGroup := rMatch.Groups.Item[pred(rMatch.Groups.Count)];
arr := rGroup.Value.Split(['.']);
writeln('Top-Level-Domain: ', arr[High(arr)]);
end
else
writeln('Sorry');
readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
However, this regular expression only works when www. is supplied.
In production we sometimes have Exception of type "Access denied".
The call stack is from this line
vXML.SaveToFile(Filename);
where vXML is IXMLDocument.
Problem here is that Filename is not logged.
I tried this small testprogram.
implementation
uses
xmldoc, Unit12;
{$R *.dfm}
procedure TForm11.FormShow(Sender: TObject);
const
cnFile = 'C:\Program Files (x86)\test.xml';
var
vXML: TAttracsXMLDoc;
begin
vXML := TAttracsXMLDoc.Create(nil);
try
vXML.Active := True;
// Process vXML
vXML.SaveToFile(cnFile);
finally
vXML.Free;
end;
end;
And other unit
unit Unit12;
interface
uses
xmldoc,
xml.xmldom,
Xml.XMLIntf;
type
TAttracsXMLDoc = class(TXMLDocument)
procedure SaveToFile(const AFileName: DOMString); override;
end;
implementation
uses
Sysutils;
procedure TAttracsXMLDoc.SaveToFile(const AFileName: DOMString);
begin
try
inherited SaveToFile(AFileName);
except
on E: Exception do
begin
E.Message := E.Message + ' ' + AFileName + ' cannot be saved';
raise;
end;
end;
end;
end.
It works as intended. But problem is that interface IXMLDocument is not used anymore. I want to use code like this:
procedure TForm11.FormShow(Sender: TObject);
const
cnFile = 'C:\Program Files (x86)\test.xml';
var
vXML: IXMLDocument;
begin
vXML := NewXMLDocument;
// Process vXML
vXML.SaveToFile(cnFile);
end;
And with minimum changes on existing code catch exception above with a clear error of reason. What is the best path ?
Simply replace NewXMLDocument() with TAttracsXMLDoc, then you will get the behavior you want:
function NewAttracsXMLDocument: IXMLDocument;
begin
Result := TAttracsXMLDoc.Create(nil);
end;
procedure TForm11.FormShow(Sender: TObject);
const
cnFile = 'C:\Program Files (x86)\test.xml';
var
vXML: IXMLDocument;
begin
vXML := NewAttracsXMLDocument; //NewXMLDocument;
// Process vXML
vXML.SaveToFile(cnFile);
end;
I'd like to create an aspect-aware interfaced dependency-injected object through the means of the Spring/4D framework. My issue is, that I don't know how to combine both parts. The general idea is the following:
Create the aspect layer object and hold two interfaces to it: one to pass as the dependency to the object (IAspect) and one to weave in as aspect into the object (IInterceptor):
Temp := TAspect.Create;
Aspect := Temp as IAspect;
Interceptor := Temp as IInterceptor;
Create the interfaced dependency-injected object:
Instance := TInstance.Create(Aspect) {as IInstance};
Weave in the aspect:
Result := TProxyGenerator.CreateInterfaceProxyWithTarget(Instance, [Interceptor]);
To solve this, I think of registering a factory with a custom constructor along these lines:
Aspect := Resolve<IAspect>;
Interceptor := Aspect as IInterceptor;
Instance := InstanceFactory(Aspect); // InstanceFactory := Resolve<IInstanceFactory>;
Result := TProxyGenerator.CreateInterfaceProxyWithTarget(Instance, [Interceptor]);
My issue is, how would I register this with the Container: TContainer from Spring?
Example: The program below behaves like I want and demonstrates through which aspect layers the GetValue call runs. The custom object creation hapens in the $Region in the main routine. How would I need to refactor this program to use the DI container from the Spring/4D framework, yet keep the custom construction of an aspect-aware object?
program Project1;
{$AppType Console}
{$R *.res}
uses
System.SysUtils,
Spring,
Spring.Interception;
type
IAspect = interface
['{AF8E19F6-176D-490E-A475-4682336CAB89}']
function GetSetting: String;
procedure SetSetting(const Value: String);
property Setting: String read GetSetting write SetSetting;
end;
TAspect = class (TInterfacedObject, IInterceptor, IAspect)
strict private
FSetting: String;
function GetSetting: String;
procedure SetSetting(const Value: String);
procedure Intercept(const Invocation: IInvocation);
public
constructor Create;
end;
IThingy = interface (IInvokable)
function GetAspect: IAspect;
function GetValue: String;
procedure SetValue(const Value: String);
property InstanceAspect: IAspect read GetAspect;
property Value: String read GetValue write SetValue;
end;
TThingy = class (TInterfacedObject, IThingy)
strict private
FInstanceAspect: IAspect;
FClassAspect: IAspect;
FValue: String;
function GetAspect: IAspect;
function GetValue: String;
procedure SetValue(const Value: String);
public
constructor Create(const InstanceAspect, ClassAspect: IAspect);
end;
{ TAspect }
constructor TAspect.Create;
begin
inherited;
FSetting := ' intercepted by class aspect';
end;
function TAspect.GetSetting: String;
begin
Result := FSetting;
end;
procedure TAspect.Intercept(
const Invocation: IInvocation);
begin
Invocation.Proceed;
if Invocation.Method.Name = 'GetValue' then
Invocation.Result := TValue.From<String>(Invocation.Result.AsString + FSetting);
end;
procedure TAspect.SetSetting(
const Value: String);
begin
FSetting := Value;
end;
{ TThingy }
constructor TThingy.Create(const InstanceAspect, ClassAspect: IAspect);
begin
inherited Create;
FInstanceAspect := InstanceAspect;
FClassAspect := ClassAspect;
FValue := 'Value';
end;
function TThingy.GetAspect: IAspect;
begin
Result := FInstanceAspect;
end;
function TThingy.GetValue: String;
begin
Result := FValue;
end;
procedure TThingy.SetValue(const Value: String);
begin
FValue := Value;
end;
{ Main }
procedure Main;
var
Temp: TInterfacedObject;
ClassAspect: IAspect;
ClassInterceptor: IInterceptor;
InstanceAspect: IAspect;
InstanceInterceptor: IInterceptor;
Thingy1: IThingy;
Thingy2: IThingy;
begin
{$Region 'How to do this with the Spring DI container?'}
Temp := TAspect.Create;
ClassAspect := Temp as IAspect;
ClassInterceptor := Temp as IInterceptor;
Temp := TAspect.Create;
InstanceAspect := Temp as IAspect;
InstanceInterceptor := Temp as IInterceptor;
Thingy1 := TThingy.Create(InstanceAspect, ClassAspect);
Thingy1 := TProxyGenerator.CreateInterfaceProxyWithTarget(Thingy1, [ClassInterceptor, InstanceInterceptor]);
Temp := TAspect.Create;
InstanceAspect := Temp as IAspect;
InstanceInterceptor := Temp as IInterceptor;
Thingy2 := TThingy.Create(InstanceAspect, ClassAspect);
Thingy2 := TProxyGenerator.CreateInterfaceProxyWithTarget(Thingy2, [ClassInterceptor, InstanceInterceptor]);
{$EndRegion}
Thingy1.InstanceAspect.Setting := ' intercepted by instance aspect 1';
Thingy2.InstanceAspect.Setting := ' intercepted by instance aspect 2';
Thingy1.Value := 'Value 1';
Thingy2.Value := 'Value 2';
WriteLn(Format('Thingy1.Value: %s', [Thingy1.Value]));
WriteLn(Format('Thingy2.Value: %s', [Thingy2.Value]));
end;
begin
try
Main;
except
on E: Exception do
WriteLn(E.ClassName, ': ', E.Message);
end;
if DebugHook <> 0 then
begin
WriteLn('Press enter...');
ReadLn;
end;
end.
Output:
Thingy1.Value: Value 1 intercepted by instance aspect 1 intercepted by class aspect
Thingy2.Value: Value 2 intercepted by instance aspect 2 intercepted by class aspect
Press enter...
I am not completely sure what exactly you are trying to achieve but here it how to setup the container to get the result you are looking for. What does not work yet is contextual injection (making decisions during the resolve process that are based on the currently built object graph) - this is something we are planning to implement in the future.
program Project1;
{$AppType Console}
{$R *.res}
uses
System.SysUtils,
Spring,
Spring.Container,
Spring.Interception;
type
IThingy = interface (IInvokable)
['{FD337CC6-03EB-4384-A027-E993AB687BF0}']
function GetValue: String;
procedure SetValue(const Value: String);
property Value: String read GetValue write SetValue;
end;
TThingy = class (TInterfacedObject, IThingy)
strict private
FValue: String;
function GetValue: String;
procedure SetValue(const Value: String);
end;
{ TThingy }
function TThingy.GetValue: String;
begin
Result := FValue;
end;
procedure TThingy.SetValue(const Value: String);
begin
FValue := Value;
end;
type
TClassInterceptor = class(TInterfacedObject, IInterceptor)
procedure Intercept(const Invocation: IInvocation);
end;
TInstanceInterceptor = class(TInterfacedObject, IInterceptor)
private
class var InstanceCount: Integer;
var FNo: Integer;
procedure Intercept(const Invocation: IInvocation);
public
constructor Create;
end;
{ Main }
procedure Main;
var
Thingy1: IThingy;
Thingy2: IThingy;
begin
GlobalContainer.RegisterType<TClassInterceptor,TClassInterceptor>.AsSingleton;
GlobalContainer.RegisterType<TInstanceInterceptor>('instance');
GlobalContainer.RegisterType<IThingy, TThingy>.InterceptedBy<TClassInterceptor>.InterceptedBy('instance');
GlobalContainer.Build;
Thingy1 := GlobalContainer.Resolve<IThingy>;
Thingy2 := GlobalContainer.Resolve<IThingy>;
Thingy1.Value := 'Value 1';
Thingy2.Value := 'Value 2';
WriteLn(Format('Thingy1.Value: %s', [Thingy1.Value]));
WriteLn(Format('Thingy2.Value: %s', [Thingy2.Value]));
end;
procedure TClassInterceptor.Intercept(const Invocation: IInvocation);
begin
Invocation.Proceed;
if Invocation.Method.Name = 'GetValue' then
Invocation.Result := TValue.From<String>(Invocation.Result.AsString + ' intercepted by class aspect');
end;
constructor TInstanceInterceptor.Create;
begin
Inc(InstanceCount);
FNo := InstanceCount;
end;
procedure TInstanceInterceptor.Intercept(const Invocation: IInvocation);
begin
Invocation.Proceed;
if Invocation.Method.Name = 'GetValue' then
Invocation.Result := TValue.From<String>(Invocation.Result.AsString + ' intercepted by instance aspect ' + IntToStr(FNo));
end;
begin
try
Main;
except
on E: Exception do
WriteLn(E.ClassName, ': ', E.Message);
end;
if DebugHook <> 0 then
begin
WriteLn('Press enter...');
ReadLn;
end;
end.
I have created this unit containing a class derived from TXmlIniFile:
unit PAXMLIniFile;
interface
uses
System.SysUtils,
System.IniFiles,
Xml.XmlDoc,
Xml.XMLIntf,
Xml.XMLIniFile;
type
TMyStandaloneXmlIniFile = class(TXmlIniFile)
strict private
FDocument: IXMLDocument;
FFileName: string;
public
constructor Create(const AFileName: string);
procedure UpdateFile; override;
end;
implementation
constructor TMyStandaloneXmlIniFile.Create(const AFileName: string);
begin
if FileExists(AFileName) then
FDocument := LoadXMLDocument(AFileName)
else
begin
FDocument := NewXMLDocument;
FDocument.Options := FDocument.Options + [doNodeAutoIndent];
end;
if FDocument.DocumentElement = nil then
FDocument.DocumentElement := FDocument.CreateNode('Sections');
TCustomIniFile(Self).Create(AFileName);
FFileName := AFileName;
inherited Create(FDocument.DocumentElement);
end;
procedure TMyStandaloneXmlIniFile.UpdateFile;
begin
FDocument.SaveToFile(FFileName);
end;
end.
Now whenever I call the UpdateFile method I get an error message "Wrong parameter". What is wrong here?
Here is the test program:
program BonkersTest;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils, PAXMLIniFile, Winapi.ActiveX;
var
MyStandaloneXmlIniFile: TMyStandaloneXmlIniFile;
MyXmlFile: string;
begin
try
CoInitialize(nil);
MyXmlFile := ChangeFileExt(ParamStr(0), '.xml');
MyStandaloneXmlIniFile := TMyStandaloneXmlIniFile.Create(MyXmlFile);
try
MyStandaloneXmlIniFile.WriteString('Section1', 'Ident1', 'Value1');
MyStandaloneXmlIniFile.UpdateFile;
finally
MyStandaloneXmlIniFile.Free;
end;
CoUninitialize;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
hello am doing a program in delphi console, xe2 delphi and indy for using sockets and the problem is that I have all the code done but when I connect to the server I receive no response to the ping pong.
the code is as follows:
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils, idTCPClient;
var
irc: TIdTCPClient;
code: string;
begin
try
irc := TIdTCPClient.Create(nil);
irc.Host := 'irc.freenode.net';
irc.Port := 6667;
irc.Connect;
irc.Socket.Write('NICK tester');
irc.Socket.Write('USER tester 1 1 1 1');
irc.Socket.Write('JOIN #tester');
if irc.Socket.Connected = True then
begin
Writeln('Yeah');
while (1 = 1) do
begin
code := irc.Socket.ReadString(9999);
if not(code = '') then
begin
Writeln(code);
end;
end;
end
else
begin
Writeln('Nay');
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
anyone can help me?
You are not sending a CRLF after each command you send. Use TIdIOHander.WriteLn() instead of TIdIOHandler.Write().
Also, your call to TIdIOHandler.ReadString() will not exit until exactly 9999 bytes have been received. That is not what you actually want to happen. IRC is a line-based protocol. You should be using TIdIOHandler.ReadLn() instead of TIdIOHandler.ReadString().
Try something more like this instead:
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils, idTCPClient;
var
irc: TIdTCPClient;
code: string;
begin
try
irc := TIdTCPClient.Create(nil);
try
irc.Host := 'irc.freenode.net';
irc.Port := 6667;
try
irc.Connect;
except
Writeln('Nay');
Exit;
end;
Writeln('Yeah');
irc.IOHandler.WriteLn('NICK tester');
irc.IOHandler.WriteLn('USER tester 1 1 1 1');
irc.IOHandler.WriteLn('JOIN #tester');
repeat
code := irc.IOHandler.ReadLn;
Writeln('[Recv] ' + code);
if TextStartsWith(code, 'PING ') then
begin
Fetch(code);
irc.IOHandler.WriteLn('PONG ' + code);
Writeln('[Sent] PONG ' + code);
end;
until False;
finally
irc.Free;
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
With that being said, you should be using the TIdIRC component instead. Try this:
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils, idIRC, idContext, idGlobal;
procedure IrcRaw(ASelf: Pointer; ASender: TIdContext; AIn: Boolean; const AMessage: String);
begin
Writeln(iif(AIn, '[Recv] ', '[Sent] ') + AMessage);
end;
var
irc: TIdIRC;
m: TMethod;
begin
try
irc := TIdIRC.Create(nil);
try
irc.Host := 'irc.freenode.net';
irc.Port := 6667;
irc.Nickname := 'tester';
irc.Username := 'tester';
m.Code := #IrcRaw;
m.Data := irc;
irc.OnRaw := TIdIRCRawEvent(m);
try
irc.Connect;
except
Writeln('Nay');
Exit;
end;
Writeln('Yeah');
irc.Join('#tester');
repeat
Sleep(10);
until SomeCondition;
finally
irc.Free;
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.