WebSVN – fastphp – Diff – /trunk/BrowserMain.pas


unit BrowserMain;
 
{$Include 'FastPHP.inc'}
 
interface
 
uses
  // TODO: "{$IFDEF USE_SHDOCVW_TLB}_TLB{$ENDIF}" does not work with Delphi 10.2
  //       so you have to change the reference SHDocVw / SHDocVw_TLB yourself
  Windows, Messages, SysUtils, Variants, Classes, Graphics,
  Controls, Forms, Dialogs, OleCtrls, SHDocVw, ExtCtrls, StrUtils,
  StdCtrls, activex, UrlMon;
 
type
  TForm2 = class(TForm)
    WebBrowser1: TWebBrowser;
    Timer1: TTimer;
    OpenDialog3: TOpenDialog;
    procedure Timer1Timer(Sender: TObject);
    procedure WebBrowser1BeforeNavigate2(ASender: TObject;
      const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,
      Headers: OleVariant; var Cancel: WordBool);
    procedure WebBrowser1WindowClosing(ASender: TObject;
      IsChildWindow: WordBool; var Cancel: WordBool);
  strict private
    function EmbeddedWBQueryService(const rsid, iid: TGUID; out Obj{: IInterface}): HRESULT;
  end;
 
var
  Form2: TForm2;
 
implementation
 
{$R *.dfm}
 
uses
  WebBrowserUtils, FastPHPUtils, Functions, ShellAPI;
 
// TODO: Add a lot of nice stuff to let the PHP script communicate with this host application
//       For example, allow window resizing etc.  (See Microsoft HTA for inspiration)
// TODO: Ajax gives Access Denied error... Create own security manager?
// TODO: History doesn't work?
// (All these ToDos: Also fix in the Editor)
// TODO: kann man eventuell auch php dateien aus einer DLL rausziehen? das wäre TOLL!!!!
// TODO: headers... cookies...
// TODO: WebBrowser1BeforeNavigate2 mit einem DLL-callback, sodass entwickler ihre eigenen fastphp:// links machen können, z.B. um DLL-Funktionen aufzurufen! (auch in JavaScript ansteuerbar?)
// TODO: let the website decide if the window is maximized etc, as well as it's caption, size and icon
// TODO: Pass parameters (argv) to PHP
 
type
  TEmbeddedSecurityManager = class(TInterfacedObject, IInternetSecurityManager)
  public
    function GetSecuritySite(out ppSite: IInternetSecurityMgrSite): HResult; stdcall;
    function MapUrlToZone(pwszUrl: LPCWSTR; out dwZone: DWORD; dwFlags: DWORD): HResult; stdcall;
    function GetSecurityId(pwszUrl: LPCWSTR; pbSecurityId: Pointer; var cbSecurityId: DWORD; dwReserved: DWORD): HResult; stdcall;
    function ProcessUrlAction(pwszUrl: LPCWSTR; dwAction: DWORD; pPolicy: Pointer; cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD; dwFlags, dwReserved: DWORD): HResult; stdcall;
    function QueryCustomPolicy(pwszUrl: LPCWSTR; const guidKey: TGUID; out pPolicy: Pointer; out cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD; dwReserved: DWORD): HResult; stdcall;
    function SetZoneMapping(dwZone: DWORD; lpszPattern: PWideChar; dwFlags: DWORD): HResult; stdcall;
    function GetZoneMappings(dwZone: DWORD;out ppenumString: IEnumString; dwFlags: DWORD): HResult; stdcall;
    function SetSecuritySite(pSite: IInternetSecurityMgrSite): HResult; stdcall;
  end;
 
function TEmbeddedSecurityManager.SetSecuritySite(pSite: IInternetSecurityMgrSite): HResult; stdcall;
begin
  Result := INET_E_DEFAULT_ACTION;
end;
function TEmbeddedSecurityManager.GetSecuritySite(
  out ppSite: IInternetSecurityMgrSite): HResult; stdcall;
begin
  Result := INET_E_DEFAULT_ACTION;
end;
function TEmbeddedSecurityManager.GetSecurityId(pwszUrl: LPCWSTR; pbSecurityId: Pointer;
  var cbSecurityId: DWORD; dwReserved: DWORD): HResult; stdcall;
begin
  Result := INET_E_DEFAULT_ACTION;
end;
function TEmbeddedSecurityManager.ProcessUrlAction(pwszUrl: LPCWSTR; dwAction: DWORD;
  pPolicy: Pointer; cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD;
  dwFlags, dwReserved: DWORD): HResult; stdcall;
begin
  // Result := INET_E_DEFAULT_ACTION;
 
  // TODO: Doesn't work... Cross-Domain is still not allowed.
  PDWORD(pPolicy)^ := URLPOLICY_ALLOW;
  Result := S_OK;
end;
function TEmbeddedSecurityManager.QueryCustomPolicy(pwszUrl: LPCWSTR; const guidKey: TGUID;
  out pPolicy: Pointer; out cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD;
  dwReserved: DWORD): HResult; stdcall;
begin
  // Result := INET_E_DEFAULT_ACTION;
 
  // TODO: Doesn't work... Cross-Domain is still not allowed.
  PDWORD(pPolicy)^ := URLPOLICY_ALLOW;
  Result := S_OK;
end;
function TEmbeddedSecurityManager.SetZoneMapping(dwZone: DWORD; lpszPattern: PWideChar;
  dwFlags: DWORD): HResult; stdcall;
begin
  Result := INET_E_DEFAULT_ACTION;
end;
function TEmbeddedSecurityManager.GetZoneMappings(dwZone: DWORD;out ppenumString: IEnumString;
  dwFlags: DWORD): HResult; stdcall;
begin
  Result := INET_E_DEFAULT_ACTION;
end;
function TEmbeddedSecurityManager.MapUrlToZone(pwszUrl: LPCWSTR; out dwZone: DWORD; dwFlags: DWORD): HResult;
begin
  dwZone := URLZONE_TRUSTED;
  Result := S_OK;
end;
 
function TForm2.EmbeddedWBQueryService(const rsid, iid: TGUID; out Obj{: IInterface}): HRESULT;
var
  sam: IInternetSecurityManager;
begin
  Result := E_NOINTERFACE;
 
  //rsid ==> Service Identifier
  //iid ==> Interface identifier
  if IsEqualGUID(rsid, IInternetSecurityManager) and IsEqualGUID(iid, IInternetSecurityManager) then
  begin
      sam := TEmbeddedSecurityManager.Create;
      IInterface(Obj) := sam;
      Result := S_OK;
  end;
end;
 
procedure TForm2.Timer1Timer(Sender: TObject);
var
  phpScript: string;
  sl: TStringList;
resourcestring
  SRunningScriptPleaseWait = 'Running script... please wait...';
  SPleaseEnterPHPScript = 'Please enter a PHP file to execute.';
  SFileDoesNotExist = 'File %s does not exist.';
  SFastPHP = 'ViaThinkSoft FastPHP';
begin
  Timer1.Enabled := false;
  phpScript := ParamStr(1);
 
  // Remove Security
  WebBrowser1.ServiceQuery := EmbeddedWBQueryService;
 
  WebBrowser1.LoadHTML('<h1>'+SFastPHP+'</h1>'+SRunningScriptPleaseWait);
 
  // TODO: nice HTML error/intro pages (as resource?)
  if phpScript = '' then
  begin
    WebBrowser1.LoadHTML('<h1>'+SFastPHP+'</h1>'+SPleaseEnterPHPScript);
    if not OpenDialog3.Execute then
    begin
      Abort;
    end;
    phpScript := OpenDialog3.FileName;
  end;
 
  if not FileExists(phpScript) then
  begin
    WebBrowser1.LoadHTML(Format('<h1>'+SFastPHP+'</h1>'+SFileDoesNotExist, [phpScript]));
    Abort;
  end;
 
  WebBrowser1.LoadHTML(RunPHPScript(phpScript), phpScript);
 
  Application.ProcessMessages; // This is important, otherwise the metatags can't be read...
 
  sl := TStringList.Create;
  try
    WebBrowser1.ReadMetaTags(sl);
    // TODO: case insensitive
    if sl.Values['fastphp_title'] <> '' then Caption := sl.Values['fastphp_title'];
    if sl.Values['fastphp_width'] <> '' then ClientWidth := StrToInt(sl.Values['fastphp_width']);
    if sl.Values['fastphp_height'] <> '' then ClientHeight := StrToInt(sl.Values['fastphp_height']);
    // TODO: Add more attributes, like HTA applications had
    // TODO: Additionally implement "HTA:APPLICATION" element, see https://docs.microsoft.com/en-us/previous-versions//ms536495%28v%3dvs.85%29
  finally
    FreeAndNil(sl);
  end;
end;
 
procedure TForm2.WebBrowser1BeforeNavigate2(ASender: TObject;
  const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
var
  myURL, myUrl2, getData: string;
  p: integer;
  background: boolean;
  ArgGet, ArgPost, ArgHeader: string;
resourcestring
  SOnlyWorksInEditor = 'This action only works in FastPHP editor.';
begin
  background := Pos('background|', URL) >= 1; // do not translate
 
  {$REGION 'Line number references (PHP errors and warnings)'}
  if Copy(URL, 1, length(FASTPHP_GOTO_URI_PREFIX)) = FASTPHP_GOTO_URI_PREFIX then
  begin
    // TODO: maybe we could even open that file in the editor!
    ShowMessage(SOnlyWorksInEditor);
    Cancel := true;
    Exit;
  end;
  {$ENDREGION}
 
  {$REGION 'Intelligent browser (executes PHP scripts)'}
  if URL <> 'about:blank' then
  begin
    myUrl := URL;
 
    myurl := StringReplace(myurl, 'background|', '', []); // do not translate
 
    p := Pos('?', myUrl);
    if p >= 1 then
    begin
      getData := copy(myURL, p+1, Length(myURL)-p);
      myURL := copy(myURL, 1, p-1);
    end
    else
    begin
      getData := '';
    end;
 
    myURL := StringReplace(myURL, 'http://wa.viathinksoft.de', '', []);
 
    myURL := StringReplace(myURL, 'file:///', '', []);
    myURL := StringReplace(myURL, '/', '\', [rfReplaceAll]);
 
    // TODO: real myURL urldecode
    myURL := StringReplace(myURL, '+', ' ', []);
    myURL := StringReplace(myURL, '%20', ' ', []);
    myURL := StringReplace(myURL, '%%', '%', []);
 
    ArgHeader := '';
    ArgHeader := MyVarToStr(Headers);
    ArgHeader := StringReplace(ArgHeader, #13, '|CR|', [rfReplaceAll]);
    ArgHeader := StringReplace(ArgHeader, #10, '|LF|', [rfReplaceAll]);
 
    // *.xphp is ViaThinkSoft's extension associated to FastPHPBrowser
    // This allows the "executable PHP scripts" to be executed via double click.--
    if FileExists(myURL) and (EndsText('.xphp', myURL) or EndsText('.php', myURL) or EndsText('.php3', myURL) or EndsText('.php4', myURL) or EndsText('.php5', myURL) or EndsText('.phps', myURL)) then
    begin
      if background then
      begin
        // TODO: how to detach the process?
        ShellExecute(0, 'open', PChar(GetPHPExe), PChar('"'+myURL+'" "'+ArgGet+'" "'+ArgPost+'" "'+ArgHeader+'"'), PChar(ExtractFileDir(Application.ExeName)), SW_HIDE);
      end
      else
      begin
        // TODO: somehow prepend fastphp_server.inc.php (populates the $_GET and $_POST arrays)
        // TODO: is there a maximal length for the command line?
        ArgGet := MyVarToStr(getData);
        ArgPost := MyVarToStr(PostData);
 
        myUrl2 := myUrl;
        myUrl2 := StringReplace(myUrl2, '\', '/', [rfReplaceAll]);
        // TODO: real myURL urlencode
        myUrl2 := StringReplace(myUrl2, '%', '%%', []);
        //myUrl2 := StringReplace(myUrl2, ' ', '%20', []);
        myUrl2 := StringReplace(myUrl2, ' ', '+', []);
        myUrl2 := 'http://wa.viathinksoft.de/' + myUrl2;
 
        // showmessage(myUrl2);
        WebBrowser1.LoadHTML(GetDosOutput('"'+GetPHPExe+'" -f "'+myURL+'" -- "'+ArgGet+'" "'+ArgPost+'" "'+ArgHeader+'"', ExtractFileDir(Application.ExeName)), myUrl2);
      end;
      Cancel := true;
    end;
  end;
  {$ENDREGION}
end;
 
procedure TForm2.WebBrowser1WindowClosing(ASender: TObject;
  IsChildWindow: WordBool; var Cancel: WordBool);
begin
  Close;
  Cancel := true;
end;
 
end.
 

Rev 61	Rev 91
1	unit BrowserMain;	1	unit BrowserMain;
2		2
3	{$Include 'FastPHP.inc'}	3	{$Include 'FastPHP.inc'}
4		4
5	interface	5	interface
6		6
7	uses	7	uses
8	// TODO: "{$IFDEF USE_SHDOCVW_TLB}_TLB{$ENDIF}" does not work with Delphi 10.2	8	// TODO: "{$IFDEF USE_SHDOCVW_TLB}_TLB{$ENDIF}" does not work with Delphi 10.2
9	// so you have to change the reference SHDocVw / SHDocVw_TLB yourself	9	// so you have to change the reference SHDocVw / SHDocVw_TLB yourself
10	Windows, Messages, SysUtils, Variants, Classes, Graphics,	10	Windows, Messages, SysUtils, Variants, Classes, Graphics,
11	Controls, Forms, Dialogs, OleCtrls, SHDocVw, ExtCtrls, StrUtils,	11	Controls, Forms, Dialogs, OleCtrls, SHDocVw, ExtCtrls, StrUtils,
12	StdCtrls, activex, UrlMon;	12	StdCtrls, activex, UrlMon;
13		13
14	type	14	type
15	TForm2 = class(TForm)	15	TForm2 = class(TForm)
16	WebBrowser1: TWebBrowser;	16	WebBrowser1: TWebBrowser;
17	Timer1: TTimer;	17	Timer1: TTimer;
-		18	OpenDialog3: TOpenDialog;
18	procedure Timer1Timer(Sender: TObject);	19	procedure Timer1Timer(Sender: TObject);
19	procedure WebBrowser1BeforeNavigate2(ASender: TObject;	20	procedure WebBrowser1BeforeNavigate2(ASender: TObject;
20	const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,	21	const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,
21	Headers: OleVariant; var Cancel: WordBool);	22	Headers: OleVariant; var Cancel: WordBool);
22	procedure WebBrowser1WindowClosing(ASender: TObject;	23	procedure WebBrowser1WindowClosing(ASender: TObject;
23	IsChildWindow: WordBool; var Cancel: WordBool);	24	IsChildWindow: WordBool; var Cancel: WordBool);
24	strict private	25	strict private
25	function EmbeddedWBQueryService(const rsid, iid: TGUID; out Obj{: IInterface}): HRESULT;	26	function EmbeddedWBQueryService(const rsid, iid: TGUID; out Obj{: IInterface}): HRESULT;
26	end;	27	end;
27		28
28	var	29	var
29	Form2: TForm2;	30	Form2: TForm2;
30		31
31	implementation	32	implementation
32		33
33	{$R *.dfm}	34	{$R *.dfm}
34		35
35	uses	36	uses
36	WebBrowserUtils, FastPHPUtils, Functions, ShellAPI;	37	WebBrowserUtils, FastPHPUtils, Functions, ShellAPI;
37		38
38	// TODO: Add a lot of nice stuff to let the PHP script communicate with this host application	39	// TODO: Add a lot of nice stuff to let the PHP script communicate with this host application
39	// For example, allow window resizing etc. (See Microsoft HTA for inspiration)	40	// For example, allow window resizing etc. (See Microsoft HTA for inspiration)
40	// TODO: Ajax gives Access Denied error... Create own security manager?	41	// TODO: Ajax gives Access Denied error... Create own security manager?
41	// TODO: History doesn't work?	42	// TODO: History doesn't work?
42	// (All these ToDos: Also fix in the Editor)	43	// (All these ToDos: Also fix in the Editor)
43	// TODO: kann man eventuell auch php dateien aus einer DLL rausziehen? das wäre TOLL!!!!	44	// TODO: kann man eventuell auch php dateien aus einer DLL rausziehen? das wäre TOLL!!!!
44	// TODO: headers... cookies...	45	// TODO: headers... cookies...
45	// TODO: WebBrowser1BeforeNavigate2 mit einem DLL-callback, sodass entwickler ihre eigenen fastphp:// links machen können, z.B. um DLL-Funktionen aufzurufen! (auch in JavaScript ansteuerbar?)	46	// TODO: WebBrowser1BeforeNavigate2 mit einem DLL-callback, sodass entwickler ihre eigenen fastphp:// links machen können, z.B. um DLL-Funktionen aufzurufen! (auch in JavaScript ansteuerbar?)
46	// TODO: let the website decide if the window is maximized etc, as well as it's caption, size and icon	47	// TODO: let the website decide if the window is maximized etc, as well as it's caption, size and icon
47	// TODO: Pass parameters (argv) to PHP	48	// TODO: Pass parameters (argv) to PHP
48		49
49	type	50	type
50	TEmbeddedSecurityManager = class(TInterfacedObject, IInternetSecurityManager)	51	TEmbeddedSecurityManager = class(TInterfacedObject, IInternetSecurityManager)
51	public	52	public
52	function GetSecuritySite(out ppSite: IInternetSecurityMgrSite): HResult; stdcall;	53	function GetSecuritySite(out ppSite: IInternetSecurityMgrSite): HResult; stdcall;
53	function MapUrlToZone(pwszUrl: LPCWSTR; out dwZone: DWORD; dwFlags: DWORD): HResult; stdcall;	54	function MapUrlToZone(pwszUrl: LPCWSTR; out dwZone: DWORD; dwFlags: DWORD): HResult; stdcall;
54	function GetSecurityId(pwszUrl: LPCWSTR; pbSecurityId: Pointer; var cbSecurityId: DWORD; dwReserved: DWORD): HResult; stdcall;	55	function GetSecurityId(pwszUrl: LPCWSTR; pbSecurityId: Pointer; var cbSecurityId: DWORD; dwReserved: DWORD): HResult; stdcall;
55	function ProcessUrlAction(pwszUrl: LPCWSTR; dwAction: DWORD; pPolicy: Pointer; cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD; dwFlags, dwReserved: DWORD): HResult; stdcall;	56	function ProcessUrlAction(pwszUrl: LPCWSTR; dwAction: DWORD; pPolicy: Pointer; cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD; dwFlags, dwReserved: DWORD): HResult; stdcall;
56	function QueryCustomPolicy(pwszUrl: LPCWSTR; const guidKey: TGUID; out pPolicy: Pointer; out cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD; dwReserved: DWORD): HResult; stdcall;	57	function QueryCustomPolicy(pwszUrl: LPCWSTR; const guidKey: TGUID; out pPolicy: Pointer; out cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD; dwReserved: DWORD): HResult; stdcall;
57	function SetZoneMapping(dwZone: DWORD; lpszPattern: PWideChar; dwFlags: DWORD): HResult; stdcall;	58	function SetZoneMapping(dwZone: DWORD; lpszPattern: PWideChar; dwFlags: DWORD): HResult; stdcall;
58	function GetZoneMappings(dwZone: DWORD;out ppenumString: IEnumString; dwFlags: DWORD): HResult; stdcall;	59	function GetZoneMappings(dwZone: DWORD;out ppenumString: IEnumString; dwFlags: DWORD): HResult; stdcall;
59	function SetSecuritySite(pSite: IInternetSecurityMgrSite): HResult; stdcall;	60	function SetSecuritySite(pSite: IInternetSecurityMgrSite): HResult; stdcall;
60	end;	61	end;
61		62
62	function TEmbeddedSecurityManager.SetSecuritySite(pSite: IInternetSecurityMgrSite): HResult; stdcall;	63	function TEmbeddedSecurityManager.SetSecuritySite(pSite: IInternetSecurityMgrSite): HResult; stdcall;
63	begin	64	begin
64	Result := INET_E_DEFAULT_ACTION;	65	Result := INET_E_DEFAULT_ACTION;
65	end;	66	end;
66	function TEmbeddedSecurityManager.GetSecuritySite(	67	function TEmbeddedSecurityManager.GetSecuritySite(
67	out ppSite: IInternetSecurityMgrSite): HResult; stdcall;	68	out ppSite: IInternetSecurityMgrSite): HResult; stdcall;
68	begin	69	begin
69	Result := INET_E_DEFAULT_ACTION;	70	Result := INET_E_DEFAULT_ACTION;
70	end;	71	end;
71	function TEmbeddedSecurityManager.GetSecurityId(pwszUrl: LPCWSTR; pbSecurityId: Pointer;	72	function TEmbeddedSecurityManager.GetSecurityId(pwszUrl: LPCWSTR; pbSecurityId: Pointer;
72	var cbSecurityId: DWORD; dwReserved: DWORD): HResult; stdcall;	73	var cbSecurityId: DWORD; dwReserved: DWORD): HResult; stdcall;
73	begin	74	begin
74	Result := INET_E_DEFAULT_ACTION;	75	Result := INET_E_DEFAULT_ACTION;
75	end;	76	end;
76	function TEmbeddedSecurityManager.ProcessUrlAction(pwszUrl: LPCWSTR; dwAction: DWORD;	77	function TEmbeddedSecurityManager.ProcessUrlAction(pwszUrl: LPCWSTR; dwAction: DWORD;
77	pPolicy: Pointer; cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD;	78	pPolicy: Pointer; cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD;
78	dwFlags, dwReserved: DWORD): HResult; stdcall;	79	dwFlags, dwReserved: DWORD): HResult; stdcall;
79	begin	80	begin
80	// Result := INET_E_DEFAULT_ACTION;	81	// Result := INET_E_DEFAULT_ACTION;
81		82
82	// TODO: Doesn't work... Cross-Domain is still not allowed.	83	// TODO: Doesn't work... Cross-Domain is still not allowed.
83	PDWORD(pPolicy)^ := URLPOLICY_ALLOW;	84	PDWORD(pPolicy)^ := URLPOLICY_ALLOW;
84	Result := S_OK;	85	Result := S_OK;
85	end;	86	end;
86	function TEmbeddedSecurityManager.QueryCustomPolicy(pwszUrl: LPCWSTR; const guidKey: TGUID;	87	function TEmbeddedSecurityManager.QueryCustomPolicy(pwszUrl: LPCWSTR; const guidKey: TGUID;
87	out pPolicy: Pointer; out cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD;	88	out pPolicy: Pointer; out cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD;
88	dwReserved: DWORD): HResult; stdcall;	89	dwReserved: DWORD): HResult; stdcall;
89	begin	90	begin
90	// Result := INET_E_DEFAULT_ACTION;	91	// Result := INET_E_DEFAULT_ACTION;
91		92
92	// TODO: Doesn't work... Cross-Domain is still not allowed.	93	// TODO: Doesn't work... Cross-Domain is still not allowed.
93	PDWORD(pPolicy)^ := URLPOLICY_ALLOW;	94	PDWORD(pPolicy)^ := URLPOLICY_ALLOW;
94	Result := S_OK;	95	Result := S_OK;
95	end;	96	end;
96	function TEmbeddedSecurityManager.SetZoneMapping(dwZone: DWORD; lpszPattern: PWideChar;	97	function TEmbeddedSecurityManager.SetZoneMapping(dwZone: DWORD; lpszPattern: PWideChar;
97	dwFlags: DWORD): HResult; stdcall;	98	dwFlags: DWORD): HResult; stdcall;
98	begin	99	begin
99	Result := INET_E_DEFAULT_ACTION;	100	Result := INET_E_DEFAULT_ACTION;
100	end;	101	end;
101	function TEmbeddedSecurityManager.GetZoneMappings(dwZone: DWORD;out ppenumString: IEnumString;	102	function TEmbeddedSecurityManager.GetZoneMappings(dwZone: DWORD;out ppenumString: IEnumString;
102	dwFlags: DWORD): HResult; stdcall;	103	dwFlags: DWORD): HResult; stdcall;
103	begin	104	begin
104	Result := INET_E_DEFAULT_ACTION;	105	Result := INET_E_DEFAULT_ACTION;
105	end;	106	end;
106	function TEmbeddedSecurityManager.MapUrlToZone(pwszUrl: LPCWSTR; out dwZone: DWORD; dwFlags: DWORD): HResult;	107	function TEmbeddedSecurityManager.MapUrlToZone(pwszUrl: LPCWSTR; out dwZone: DWORD; dwFlags: DWORD): HResult;
107	begin	108	begin
108	dwZone := URLZONE_TRUSTED;	109	dwZone := URLZONE_TRUSTED;
109	Result := S_OK;	110	Result := S_OK;
110	end;	111	end;
111		112
112	function TForm2.EmbeddedWBQueryService(const rsid, iid: TGUID; out Obj{: IInterface}): HRESULT;	113	function TForm2.EmbeddedWBQueryService(const rsid, iid: TGUID; out Obj{: IInterface}): HRESULT;
113	var	114	var
114	sam: IInternetSecurityManager;	115	sam: IInternetSecurityManager;
115	begin	116	begin
116	Result := E_NOINTERFACE;	117	Result := E_NOINTERFACE;
117		118
118	//rsid ==> Service Identifier	119	//rsid ==> Service Identifier
119	//iid ==> Interface identifier	120	//iid ==> Interface identifier
120	if IsEqualGUID(rsid, IInternetSecurityManager) and IsEqualGUID(iid, IInternetSecurityManager) then	121	if IsEqualGUID(rsid, IInternetSecurityManager) and IsEqualGUID(iid, IInternetSecurityManager) then
121	begin	122	begin
122	sam := TEmbeddedSecurityManager.Create;	123	sam := TEmbeddedSecurityManager.Create;
123	IInterface(Obj) := sam;	124	IInterface(Obj) := sam;
124	Result := S_OK;	125	Result := S_OK;
125	end;	126	end;
126	end;	127	end;
127		128
128	procedure TForm2.Timer1Timer(Sender: TObject);	129	procedure TForm2.Timer1Timer(Sender: TObject);
129	var	130	var
130	phpScript: string;	131	phpScript: string;
131	sl: TStringList;	132	sl: TStringList;
-		133	resourcestring
-		134	SRunningScriptPleaseWait = 'Running script... please wait...';
-		135	SPleaseEnterPHPScript = 'Please enter a PHP file to execute.';
-		136	SFileDoesNotExist = 'File %s does not exist.';
-		137	SFastPHP = 'ViaThinkSoft FastPHP';
132	begin	138	begin
133	Timer1.Enabled := false;	139	Timer1.Enabled := false;
134	phpScript := ParamStr(1);	140	phpScript := ParamStr(1);
135		141
136	// Remove Security	142	// Remove Security
137	WebBrowser1.ServiceQuery := EmbeddedWBQueryService;	143	WebBrowser1.ServiceQuery := EmbeddedWBQueryService;
138		144
139	WebBrowser1.LoadHTML('<h1>FastPHP</h1>Running script... please wait...');	145	WebBrowser1.LoadHTML('<h1>'+SFastPHP+'</h1>'+SRunningScriptPleaseWait);
140		146
141	// TODO: nice HTML error/intro pages (as resource?)	147	// TODO: nice HTML error/intro pages (as resource?)
142	if phpScript = '' then	148	if phpScript = '' then
143	begin	149	begin
144	WebBrowser1.LoadHTML('<h1>FastPHP</h1>Please enter a PHP file to execute.');	150	WebBrowser1.LoadHTML('<h1>'+SFastPHP+'</h1>'+SPleaseEnterPHPScript);
-		151	if not OpenDialog3.Execute then
-		152	begin
145	Abort;	153	Abort;
146	end;	154	end;
-		155	phpScript := OpenDialog3.FileName;
-		156	end;
147		157
148	if not FileExists(phpScript) then	158	if not FileExists(phpScript) then
149	begin	159	begin
150	WebBrowser1.LoadHTML(Format('<h1>FastPHP</h1>File %s does not exist.', [phpScript]));	160	WebBrowser1.LoadHTML(Format('<h1>'+SFastPHP+'</h1>'+SFileDoesNotExist, [phpScript]));
151	Abort;	161	Abort;
152	end;	162	end;
153		163
154	WebBrowser1.LoadHTML(RunPHPScript(phpScript), phpScript);	164	WebBrowser1.LoadHTML(RunPHPScript(phpScript), phpScript);
155		165
156	Application.ProcessMessages; // This is important, otherwise the metatags can't be read...	166	Application.ProcessMessages; // This is important, otherwise the metatags can't be read...
157		167
158	sl := TStringList.Create;	168	sl := TStringList.Create;
159	try	169	try
160	WebBrowser1.ReadMetaTags(sl);	170	WebBrowser1.ReadMetaTags(sl);
161	// TODO: case insensitive	171	// TODO: case insensitive
162	if sl.Values['fastphp_title'] <> '' then Caption := sl.Values['fastphp_title'];	172	if sl.Values['fastphp_title'] <> '' then Caption := sl.Values['fastphp_title'];
163	if sl.Values['fastphp_width'] <> '' then ClientWidth := StrToInt(sl.Values['fastphp_width']);	173	if sl.Values['fastphp_width'] <> '' then ClientWidth := StrToInt(sl.Values['fastphp_width']);
164	if sl.Values['fastphp_height'] <> '' then ClientHeight := StrToInt(sl.Values['fastphp_height']);	174	if sl.Values['fastphp_height'] <> '' then ClientHeight := StrToInt(sl.Values['fastphp_height']);
165	// TODO: Add more attributes, like HTA applications had	175	// TODO: Add more attributes, like HTA applications had
166	// TODO: Additionally implement "HTA:APPLICATION" element, see https://docs.microsoft.com/en-us/previous-versions//ms536495%28v%3dvs.85%29	176	// TODO: Additionally implement "HTA:APPLICATION" element, see https://docs.microsoft.com/en-us/previous-versions//ms536495%28v%3dvs.85%29
167	finally	177	finally
168	FreeAndNil(sl);	178	FreeAndNil(sl);
169	end;	179	end;
170	end;	180	end;
171		181
172	procedure TForm2.WebBrowser1BeforeNavigate2(ASender: TObject;	182	procedure TForm2.WebBrowser1BeforeNavigate2(ASender: TObject;
173	const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,	183	const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,
174	Headers: OleVariant; var Cancel: WordBool);	184	Headers: OleVariant; var Cancel: WordBool);
175	var	185	var
176	myURL, myUrl2, getData: string;	186	myURL, myUrl2, getData: string;
177	p: integer;	187	p: integer;
178	background: boolean;	188	background: boolean;
179	ArgGet, ArgPost, ArgHeader: string;	189	ArgGet, ArgPost, ArgHeader: string;
-		190	resourcestring
-		191	SOnlyWorksInEditor = 'This action only works in FastPHP editor.';
180	begin	192	begin
181	background := Pos('background\|', URL) >= 1;	193	background := Pos('background\|', URL) >= 1; // do not translate
182		194
183	{$REGION 'Line number references (PHP errors and warnings)'}	195	{$REGION 'Line number references (PHP errors and warnings)'}
184	if Copy(URL, 1, length(FASTPHP_GOTO_URI_PREFIX)) = FASTPHP_GOTO_URI_PREFIX then	196	if Copy(URL, 1, length(FASTPHP_GOTO_URI_PREFIX)) = FASTPHP_GOTO_URI_PREFIX then
185	begin	197	begin
186	// TODO: maybe we could even open that file in the editor!	198	// TODO: maybe we could even open that file in the editor!
187	ShowMessage('This action only works in FastPHP editor.');	199	ShowMessage(SOnlyWorksInEditor);
188	Cancel := true;	200	Cancel := true;
189	Exit;	201	Exit;
190	end;	202	end;
191	{$ENDREGION}	203	{$ENDREGION}
192		204
193	{$REGION 'Intelligent browser (executes PHP scripts)'}	205	{$REGION 'Intelligent browser (executes PHP scripts)'}
194	if URL <> 'about:blank' then	206	if URL <> 'about:blank' then
195	begin	207	begin
196	myUrl := URL;	208	myUrl := URL;
197		209
198	myurl := StringReplace(myurl, 'background\|', '', []);	210	myurl := StringReplace(myurl, 'background\|', '', []); // do not translate
199		211
200	p := Pos('?', myUrl);	212	p := Pos('?', myUrl);
201	if p >= 1 then	213	if p >= 1 then
202	begin	214	begin
203	getData := copy(myURL, p+1, Length(myURL)-p);	215	getData := copy(myURL, p+1, Length(myURL)-p);
204	myURL := copy(myURL, 1, p-1);	216	myURL := copy(myURL, 1, p-1);
205	end	217	end
206	else	218	else
207	begin	219	begin
208	getData := '';	220	getData := '';
209	end;	221	end;
210		222
211	myURL := StringReplace(myURL, 'http://wa.viathinksoft.de', '', []);	223	myURL := StringReplace(myURL, 'http://wa.viathinksoft.de', '', []);
212		224
213	myURL := StringReplace(myURL, 'file:///', '', []);	225	myURL := StringReplace(myURL, 'file:///', '', []);
214	myURL := StringReplace(myURL, '/', '\', [rfReplaceAll]);	226	myURL := StringReplace(myURL, '/', '\', [rfReplaceAll]);
215		227
216	// TODO: real myURL urldecode	228	// TODO: real myURL urldecode
217	myURL := StringReplace(myURL, '+', ' ', []);	229	myURL := StringReplace(myURL, '+', ' ', []);
218	myURL := StringReplace(myURL, '%20', ' ', []);	230	myURL := StringReplace(myURL, '%20', ' ', []);
219	myURL := StringReplace(myURL, '%%', '%', []);	231	myURL := StringReplace(myURL, '%%', '%', []);
220		232
221	ArgHeader := '';	233	ArgHeader := '';
222	ArgHeader := MyVarToStr(Headers);	234	ArgHeader := MyVarToStr(Headers);
223	ArgHeader := StringReplace(ArgHeader, #13, '\|CR\|', [rfReplaceAll]);	235	ArgHeader := StringReplace(ArgHeader, #13, '\|CR\|', [rfReplaceAll]);
224	ArgHeader := StringReplace(ArgHeader, #10, '\|LF\|', [rfReplaceAll]);	236	ArgHeader := StringReplace(ArgHeader, #10, '\|LF\|', [rfReplaceAll]);
225		237
226	// *.xphp is ViaThinkSoft's extension associated to FastPHPBrowser	238	// *.xphp is ViaThinkSoft's extension associated to FastPHPBrowser
227	// This allows the "executable PHP scripts" to be executed via double click.--	239	// This allows the "executable PHP scripts" to be executed via double click.--
228	if FileExists(myURL) and (EndsText('.xphp', myURL) or EndsText('.php', myURL) or EndsText('.php3', myURL) or EndsText('.php4', myURL) or EndsText('.php5', myURL) or EndsText('.phps', myURL)) then	240	if FileExists(myURL) and (EndsText('.xphp', myURL) or EndsText('.php', myURL) or EndsText('.php3', myURL) or EndsText('.php4', myURL) or EndsText('.php5', myURL) or EndsText('.phps', myURL)) then
229	begin	241	begin
230	if background then	242	if background then
231	begin	243	begin
232	// TODO: how to detach the process?	244	// TODO: how to detach the process?
233	ShellExecute(0, 'open', PChar(GetPHPExe), PChar('"'+myURL+'" "'+ArgGet+'" "'+ArgPost+'" "'+ArgHeader+'"'), PChar(ExtractFileDir(Application.ExeName)), SW_HIDE);	245	ShellExecute(0, 'open', PChar(GetPHPExe), PChar('"'+myURL+'" "'+ArgGet+'" "'+ArgPost+'" "'+ArgHeader+'"'), PChar(ExtractFileDir(Application.ExeName)), SW_HIDE);
234	end	246	end
235	else	247	else
236	begin	248	begin
237	// TODO: somehow prepend fastphp_server.inc.php (populates the $_GET and $_POST arrays)	249	// TODO: somehow prepend fastphp_server.inc.php (populates the $_GET and $_POST arrays)
238	// TODO: is there a maximal length for the command line?	250	// TODO: is there a maximal length for the command line?
239	ArgGet := MyVarToStr(getData);	251	ArgGet := MyVarToStr(getData);
240	ArgPost := MyVarToStr(PostData);	252	ArgPost := MyVarToStr(PostData);
241		253
242	myUrl2 := myUrl;	254	myUrl2 := myUrl;
243	myUrl2 := StringReplace(myUrl2, '\', '/', [rfReplaceAll]);	255	myUrl2 := StringReplace(myUrl2, '\', '/', [rfReplaceAll]);
244	// TODO: real myURL urlencode	256	// TODO: real myURL urlencode
245	myUrl2 := StringReplace(myUrl2, '%', '%%', []);	257	myUrl2 := StringReplace(myUrl2, '%', '%%', []);
246	//myUrl2 := StringReplace(myUrl2, ' ', '%20', []);	258	//myUrl2 := StringReplace(myUrl2, ' ', '%20', []);
247	myUrl2 := StringReplace(myUrl2, ' ', '+', []);	259	myUrl2 := StringReplace(myUrl2, ' ', '+', []);
248	myUrl2 := 'http://wa.viathinksoft.de/' + myUrl2;	260	myUrl2 := 'http://wa.viathinksoft.de/' + myUrl2;
249		261
250	// showmessage(myUrl2);	262	// showmessage(myUrl2);
251	WebBrowser1.LoadHTML(GetDosOutput('"'+GetPHPExe+'" -f "'+myURL+'" -- "'+ArgGet+'" "'+ArgPost+'" "'+ArgHeader+'"', ExtractFileDir(Application.ExeName)), myUrl2);	263	WebBrowser1.LoadHTML(GetDosOutput('"'+GetPHPExe+'" -f "'+myURL+'" -- "'+ArgGet+'" "'+ArgPost+'" "'+ArgHeader+'"', ExtractFileDir(Application.ExeName)), myUrl2);
252	end;	264	end;
253	Cancel := true;	265	Cancel := true;
254	end;	266	end;
255	end;	267	end;
256	{$ENDREGION}	268	{$ENDREGION}
257	end;	269	end;
258		270
259	procedure TForm2.WebBrowser1WindowClosing(ASender: TObject;	271	procedure TForm2.WebBrowser1WindowClosing(ASender: TObject;
260	IsChildWindow: WordBool; var Cancel: WordBool);	272	IsChildWindow: WordBool; var Cancel: WordBool);
261	begin	273	begin
262	Close;	274	Close;
263	Cancel := true;	275	Cancel := true;
264	end;	276	end;
265		277
266	end.	278	end.
267		279

Subversion Repositories fastphp

fastphp/trunk/BrowserMain.pas – Rev 61 → 91