Login | ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/fastphp/trunk/BrowserMain.pas
Revision: 61
Committed: Tue Feb 25 20:39:22 2020 UTC (4 weeks, 6 days ago) by daniel-marschall
Content type: text/x-pascal
File size: 10139 byte(s)
Log Message:
FastPHP Browser: Meta tags can now be used to change the window title, width and height

File Contents

# Content
1 unit BrowserMain;
2
3 {$Include 'FastPHP.inc'}
4
5 interface
6
7 uses
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
10 Windows, Messages, SysUtils, Variants, Classes, Graphics,
11 Controls, Forms, Dialogs, OleCtrls, SHDocVw, ExtCtrls, StrUtils,
12 StdCtrls, activex, UrlMon;
13
14 type
15 TForm2 = class(TForm)
16 WebBrowser1: TWebBrowser;
17 Timer1: TTimer;
18 procedure Timer1Timer(Sender: TObject);
19 procedure WebBrowser1BeforeNavigate2(ASender: TObject;
20 const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,
21 Headers: OleVariant; var Cancel: WordBool);
22 procedure WebBrowser1WindowClosing(ASender: TObject;
23 IsChildWindow: WordBool; var Cancel: WordBool);
24 strict private
25 function EmbeddedWBQueryService(const rsid, iid: TGUID; out Obj{: IInterface}): HRESULT;
26 end;
27
28 var
29 Form2: TForm2;
30
31 implementation
32
33 {$R *.dfm}
34
35 uses
36 WebBrowserUtils, FastPHPUtils, Functions, ShellAPI;
37
38 // 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 // TODO: Ajax gives Access Denied error... Create own security manager?
41 // TODO: History doesn't work?
42 // (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: 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: 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
49 type
50 TEmbeddedSecurityManager = class(TInterfacedObject, IInternetSecurityManager)
51 public
52 function GetSecuritySite(out ppSite: IInternetSecurityMgrSite): HResult; stdcall;
53 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 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 SetZoneMapping(dwZone: DWORD; lpszPattern: PWideChar; dwFlags: DWORD): HResult; stdcall;
58 function GetZoneMappings(dwZone: DWORD;out ppenumString: IEnumString; dwFlags: DWORD): HResult; stdcall;
59 function SetSecuritySite(pSite: IInternetSecurityMgrSite): HResult; stdcall;
60 end;
61
62 function TEmbeddedSecurityManager.SetSecuritySite(pSite: IInternetSecurityMgrSite): HResult; stdcall;
63 begin
64 Result := INET_E_DEFAULT_ACTION;
65 end;
66 function TEmbeddedSecurityManager.GetSecuritySite(
67 out ppSite: IInternetSecurityMgrSite): HResult; stdcall;
68 begin
69 Result := INET_E_DEFAULT_ACTION;
70 end;
71 function TEmbeddedSecurityManager.GetSecurityId(pwszUrl: LPCWSTR; pbSecurityId: Pointer;
72 var cbSecurityId: DWORD; dwReserved: DWORD): HResult; stdcall;
73 begin
74 Result := INET_E_DEFAULT_ACTION;
75 end;
76 function TEmbeddedSecurityManager.ProcessUrlAction(pwszUrl: LPCWSTR; dwAction: DWORD;
77 pPolicy: Pointer; cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD;
78 dwFlags, dwReserved: DWORD): HResult; stdcall;
79 begin
80 // Result := INET_E_DEFAULT_ACTION;
81
82 // TODO: Doesn't work... Cross-Domain is still not allowed.
83 PDWORD(pPolicy)^ := URLPOLICY_ALLOW;
84 Result := S_OK;
85 end;
86 function TEmbeddedSecurityManager.QueryCustomPolicy(pwszUrl: LPCWSTR; const guidKey: TGUID;
87 out pPolicy: Pointer; out cbPolicy: DWORD; pContext: Pointer; cbContext: DWORD;
88 dwReserved: DWORD): HResult; stdcall;
89 begin
90 // Result := INET_E_DEFAULT_ACTION;
91
92 // TODO: Doesn't work... Cross-Domain is still not allowed.
93 PDWORD(pPolicy)^ := URLPOLICY_ALLOW;
94 Result := S_OK;
95 end;
96 function TEmbeddedSecurityManager.SetZoneMapping(dwZone: DWORD; lpszPattern: PWideChar;
97 dwFlags: DWORD): HResult; stdcall;
98 begin
99 Result := INET_E_DEFAULT_ACTION;
100 end;
101 function TEmbeddedSecurityManager.GetZoneMappings(dwZone: DWORD;out ppenumString: IEnumString;
102 dwFlags: DWORD): HResult; stdcall;
103 begin
104 Result := INET_E_DEFAULT_ACTION;
105 end;
106 function TEmbeddedSecurityManager.MapUrlToZone(pwszUrl: LPCWSTR; out dwZone: DWORD; dwFlags: DWORD): HResult;
107 begin
108 dwZone := URLZONE_TRUSTED;
109 Result := S_OK;
110 end;
111
112 function TForm2.EmbeddedWBQueryService(const rsid, iid: TGUID; out Obj{: IInterface}): HRESULT;
113 var
114 sam: IInternetSecurityManager;
115 begin
116 Result := E_NOINTERFACE;
117
118 //rsid ==> Service Identifier
119 //iid ==> Interface identifier
120 if IsEqualGUID(rsid, IInternetSecurityManager) and IsEqualGUID(iid, IInternetSecurityManager) then
121 begin
122 sam := TEmbeddedSecurityManager.Create;
123 IInterface(Obj) := sam;
124 Result := S_OK;
125 end;
126 end;
127
128 procedure TForm2.Timer1Timer(Sender: TObject);
129 var
130 phpScript: string;
131 sl: TStringList;
132 begin
133 Timer1.Enabled := false;
134 phpScript := ParamStr(1);
135
136 // Remove Security
137 WebBrowser1.ServiceQuery := EmbeddedWBQueryService;
138
139 WebBrowser1.LoadHTML('<h1>FastPHP</h1>Running script... please wait...');
140
141 // TODO: nice HTML error/intro pages (as resource?)
142 if phpScript = '' then
143 begin
144 WebBrowser1.LoadHTML('<h1>FastPHP</h1>Please enter a PHP file to execute.');
145 Abort;
146 end;
147
148 if not FileExists(phpScript) then
149 begin
150 WebBrowser1.LoadHTML(Format('<h1>FastPHP</h1>File %s does not exist.', [phpScript]));
151 Abort;
152 end;
153
154 WebBrowser1.LoadHTML(RunPHPScript(phpScript), phpScript);
155
156 Application.ProcessMessages; // This is important, otherwise the metatags can't be read...
157
158 sl := TStringList.Create;
159 try
160 WebBrowser1.ReadMetaTags(sl);
161 // TODO: case insensitive
162 if sl.Values['fastphp_title'] <> '' then Caption := sl.Values['fastphp_title'];
163 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']);
165 // 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
167 finally
168 FreeAndNil(sl);
169 end;
170 end;
171
172 procedure TForm2.WebBrowser1BeforeNavigate2(ASender: TObject;
173 const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,
174 Headers: OleVariant; var Cancel: WordBool);
175 var
176 myURL, myUrl2, getData: string;
177 p: integer;
178 background: boolean;
179 ArgGet, ArgPost, ArgHeader: string;
180 begin
181 background := Pos('background|', URL) >= 1;
182
183 {$REGION 'Line number references (PHP errors and warnings)'}
184 if Copy(URL, 1, length(FASTPHP_GOTO_URI_PREFIX)) = FASTPHP_GOTO_URI_PREFIX then
185 begin
186 // TODO: maybe we could even open that file in the editor!
187 ShowMessage('This action only works in FastPHP editor.');
188 Cancel := true;
189 Exit;
190 end;
191 {$ENDREGION}
192
193 {$REGION 'Intelligent browser (executes PHP scripts)'}
194 if URL <> 'about:blank' then
195 begin
196 myUrl := URL;
197
198 myurl := StringReplace(myurl, 'background|', '', []);
199
200 p := Pos('?', myUrl);
201 if p >= 1 then
202 begin
203 getData := copy(myURL, p+1, Length(myURL)-p);
204 myURL := copy(myURL, 1, p-1);
205 end
206 else
207 begin
208 getData := '';
209 end;
210
211 myURL := StringReplace(myURL, 'http://wa.viathinksoft.de', '', []);
212
213 myURL := StringReplace(myURL, 'file:///', '', []);
214 myURL := StringReplace(myURL, '/', '\', [rfReplaceAll]);
215
216 // TODO: real myURL urldecode
217 myURL := StringReplace(myURL, '+', ' ', []);
218 myURL := StringReplace(myURL, '%20', ' ', []);
219 myURL := StringReplace(myURL, '%%', '%', []);
220
221 ArgHeader := '';
222 ArgHeader := MyVarToStr(Headers);
223 ArgHeader := StringReplace(ArgHeader, #13, '|CR|', [rfReplaceAll]);
224 ArgHeader := StringReplace(ArgHeader, #10, '|LF|', [rfReplaceAll]);
225
226 // *.xphp is ViaThinkSoft's extension associated to FastPHPBrowser
227 // 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
229 begin
230 if background then
231 begin
232 // TODO: how to detach the process?
233 ShellExecute(0, 'open', PChar(GetPHPExe), PChar('"'+myURL+'" "'+ArgGet+'" "'+ArgPost+'" "'+ArgHeader+'"'), PChar(ExtractFileDir(Application.ExeName)), SW_HIDE);
234 end
235 else
236 begin
237 // TODO: somehow prepend fastphp_server.inc.php (populates the $_GET and $_POST arrays)
238 // TODO: is there a maximal length for the command line?
239 ArgGet := MyVarToStr(getData);
240 ArgPost := MyVarToStr(PostData);
241
242 myUrl2 := myUrl;
243 myUrl2 := StringReplace(myUrl2, '\', '/', [rfReplaceAll]);
244 // TODO: real myURL urlencode
245 myUrl2 := StringReplace(myUrl2, '%', '%%', []);
246 //myUrl2 := StringReplace(myUrl2, ' ', '%20', []);
247 myUrl2 := StringReplace(myUrl2, ' ', '+', []);
248 myUrl2 := 'http://wa.viathinksoft.de/' + myUrl2;
249
250 // showmessage(myUrl2);
251 WebBrowser1.LoadHTML(GetDosOutput('"'+GetPHPExe+'" -f "'+myURL+'" -- "'+ArgGet+'" "'+ArgPost+'" "'+ArgHeader+'"', ExtractFileDir(Application.ExeName)), myUrl2);
252 end;
253 Cancel := true;
254 end;
255 end;
256 {$ENDREGION}
257 end;
258
259 procedure TForm2.WebBrowser1WindowClosing(ASender: TObject;
260 IsChildWindow: WordBool; var Cancel: WordBool);
261 begin
262 Close;
263 Cancel := true;
264 end;
265
266 end.