unit Functions;
interface
uses
Windows, Messages, SysUtils, StrUtils, IniFiles, Classes, Forms, Variants, MsHTML,
SHDocVw, StdCtrls;
function GetDosOutput(CommandLine: string; Work: string = ''): string;
function StrIPos(const SubStr, S: string): Integer;
procedure WaitForBrowser(WB: TWebbrowser);
function LoadFileToStr(const FileName: TFileName): AnsiString;
function LastPos(const SubStr, S: string): integer;
function ParseCHM(chmFile: string): boolean;
procedure BrowseURL(WebBrowser1: TWebBrowser; url: string);
procedure BrowseContent(WebBrowser1: TWebBrowser; html: string);
function IsTextHTML(s: string): boolean;
function GetWordUnderCaret(AMemo: TMemo): string;
function IsValidPHPExe(const exeFile: string): boolean;
implementation
function GetDosOutput(CommandLine: string; Work: string = ''): string;
var
SA: TSecurityAttributes;
SI: TStartupInfo;
PI: TProcessInformation;
StdOutPipeRead, StdOutPipeWrite: THandle;
WasOK: Boolean;
Buffer: array[0..255] of AnsiChar;
BytesRead: Cardinal;
WorkDir: string;
Handle: Boolean;
begin
if Work = '' then Work := ExtractFilePath(ParamStr(0));
Result := '';
with SA do begin
nLength := SizeOf(SA);
bInheritHandle := True;
lpSecurityDescriptor := nil;
end;
CreatePipe(StdOutPipeRead, StdOutPipeWrite, @SA, 0);
try
with SI do
begin
FillChar(SI, SizeOf(SI), 0);
cb := SizeOf(SI);
dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
wShowWindow := SW_HIDE;
hStdInput := GetStdHandle(STD_INPUT_HANDLE); // don't redirect stdin
hStdOutput := StdOutPipeWrite;
hStdError := StdOutPipeWrite;
end;
WorkDir := Work;
Handle := CreateProcess(nil, PChar('cmd.exe /C "' + CommandLine + '"'),
nil, nil, True, 0, nil,
PChar(WorkDir), SI, PI);
CloseHandle(StdOutPipeWrite);
if Handle then
try
repeat
WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);
if BytesRead > 0 then
begin
Buffer[BytesRead] := #0;
Result := Result + Buffer;
end;
until not WasOK or (BytesRead = 0);
WaitForSingleObject(PI.hProcess, INFINITE);
finally
CloseHandle(PI.hThread);
CloseHandle(PI.hProcess);
end;
finally
CloseHandle(StdOutPipeRead);
end;
end;
function StrIPos(const SubStr, S: string): Integer;
begin
Result := Pos(UpperCase(SubStr), UpperCase(S));
end;
procedure WaitForBrowser(WB: TWebbrowser);
begin
while (WB.Busy)
and not (Application.Terminated) do
begin
Application.ProcessMessages;
Sleep(100);
end;
end;
function LoadFileToStr(const FileName: TFileName): AnsiString;
var
FileStream : TFileStream;
begin
Result:= '';
FileStream:= TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
if FileStream.Size>0 then begin
SetLength(Result, FileStream.Size);
FileStream.Read(Result[1], FileStream.Size);
end;
finally
FileStream.Free;
end;
end;
function LastPos(const SubStr, S: string): integer;
var
I, J, K: integer;
begin
Result := 0;
I := Length(S);
K := Length(SubStr);
if (K = 0) or (K > I) then
Exit;
while (Result = 0) and (I >= K) do
begin
J := K;
if S[I] = SubStr[J] then
begin
while (J > 1) and (S[I + J - K - 1] = SubStr[J - 1]) do
Dec(J);
if J = 1 then
Result := I - K + 1;
end;
Dec(I);
end;
end;
function ParseCHM(chmFile: string): boolean;
var
test, candidate, candidate2: string;
p, p2, q: integer;
i: integer;
good: Boolean;
ini: TMemIniFile;
domain: string;
sl: TStringList;
symbolCount: Integer;
sl2: TStrings;
outFile: string;
begin
// TODO: problem: mysqli::commit has /res/mysqli.commit.html -> keyword is NOT commit alone
outFile := ChangeFileExt(chmFile, '.ini');
DeleteFile(outFile);
test := LoadFileToStr(chmFile);
if Pos('/php_manual_', test) = -1 then
begin
result := false;
exit;
end;
p := 0;
ini := TMemIniFile.Create(outFile);
try
ini.WriteString('_Info_', 'Source', chmFile);
ini.WriteString('_Info_', 'Generated', DateTimeToStr(Now));
ini.WriteString('_Info_', 'GeneratorVer', '1.0');
ini.WriteString('_Info_', 'Signature', '$ViaThinkSoft$');
{$REGION 'Excludes'}
// TODO: more excludes
ini.WriteBool('_HelpExclude_', 'about', true);
ini.WriteBool('_HelpExclude_', 'apache', true);
{$ENDREGION}
while true do
begin
Application.ProcessMessages;
p := PosEx('/res/', Test, p+1);
if p = 0 then break;
p2 := PosEx('.html', Test, p);
if p = 0 then break;
candidate := copy(Test, p+5, p2-p-5);
if candidate = '' then continue;
if Length(candidate) > 50 then continue;
good := true;
for i := p+5 to p2-1 do
begin
if ord(test[i]) < 32 then
begin
good := false;
break;
end;
if not (test[i] in ['a'..'z', 'A'..'Z', '.', '-', '_', '0'..'9']) then
begin
ini.WriteInteger('_Errors_', 'Contains unexpected character! ' + candidate, ini.ReadInteger('_Errors_', 'Contains unexpected character! ' + candidate, 0)+1);
good := false;
break;
end;
end;
if good then
begin
candidate2 := LowerCase(StringReplace(candidate, '-', '_', [rfReplaceAll]));
q := LastPos('.', candidate2);
domain := copy(candidate2, 1, q-1);
if domain = '' then continue;
candidate2 := copy(candidate2, q+1, Length(candidate2)-q);
ini.WriteInteger('_Category_', domain, ini.ReadInteger('_Category_', domain, 0)+1);
ini.WriteString(domain, candidate2, '/res/'+candidate+'.html');
if not ini.ReadBool('_HelpExclude_', domain, false)
and (candidate2 <> 'configuration')
and (candidate2 <> 'constants')
and (candidate2 <> 'installation')
and (candidate2 <> 'requirements')
and (candidate2 <> 'resources')
and (candidate2 <> 'setup') then
begin
if ini.ReadString('_HelpWords_', candidate2, '') <> '' then
begin
ini.WriteInteger('_Conflicts_', candidate2, ini.ReadInteger('_Conflicts_', candidate2, 0)+1);
end;
ini.WriteString('_HelpWords_', candidate2, '/res/'+candidate+'.html');
end;
end;
end;
sl := TStringList.Create;
sl2 := TStringList.Create;
try
ini.ReadSections(sl);
ini.WriteInteger('_Info_', 'TotalDomains', sl.Count);
symbolCount := 0;
for domain in sl do
begin
ini.ReadSection(domain, sl2);
Inc(symbolCount, sl2.Count)
end;
ini.WriteInteger('_Info_', 'TotalSymbols', symbolCount);
finally
sl.Free;
sl2.Free;
end;
ini.UpdateFile;
result := true;
finally
ini.Free;
end;
end;
procedure BrowseURL(WebBrowser1: TWebBrowser; url: string);
var
BrowserFlags : olevariant;
MyTargetFrameName : olevariant;
MyPostaData : olevariant;
MyHeaders : olevariant;
begin
{ Flags:
Constant Value Meaning
NavOpenInNewWindow $01 Open the resource or file in a new window.
NavNoHistory $02 Do not add the resource or file to the history list. The new page replaces the current page in the list.
NavNoReadFromCache $04 Do not read from the disk cache for this navigation.
NavNoWriteToCache $08 Do not write the results of this navigation to the disk cache.
NavAllowAutosearch $10 If the navigation fails, the Web browser attempts to navigate common root domains (.com, .org, and so on). If this still fails, the URL is passed to a search engine.
}
BrowserFlags := $02;
MyTargetFrameName := null;
MyPostaData := null;
MyHeaders := null;
WebBrowser1.Silent := true; // no JavaScript errors
Webbrowser1.Navigate(url, BrowserFlags,MyTargetFrameName,MyPostaData,MyHeaders);
WaitForBrowser(WebBrowser1);
end;
procedure BrowseContent(WebBrowser1: TWebBrowser; html: string);
var
BrowserFlags : olevariant;
MyTargetFrameName : olevariant;
MyPostaData : olevariant;
MyHeaders : olevariant;
Doc: Variant;
begin
{ Flags:
Constant Value Meaning
NavOpenInNewWindow $01 Open the resource or file in a new window.
NavNoHistory $02 Do not add the resource or file to the history list. The new page replaces the current page in the list.
NavNoReadFromCache $04 Do not read from the disk cache for this navigation.
NavNoWriteToCache $08 Do not write the results of this navigation to the disk cache.
NavAllowAutosearch $10 If the navigation fails, the Web browser attempts to navigate common root domains (.com, .org, and so on). If this still fails, the URL is passed to a search engine.
}
if WebBrowser1.Document = nil then
begin
BrowserFlags := $02 + $04 + $08 + $10;
MyTargetFrameName := null;
MyPostaData := null;
MyHeaders := null;
Webbrowser1.Navigate('about:blank', BrowserFlags,MyTargetFrameName,MyPostaData,MyHeaders);
WaitForBrowser(WebBrowser1);
end;
Doc := WebBrowser1.Document;
Doc.Clear;
Doc.Write(html);
Doc.Close;
WaitForBrowser(WebBrowser1);
end;
function IsTextHTML(s: string): boolean;
function _Tag(const tag: string): integer;
begin
result := 0;
if (StrIPos('<'+tag+'>', s) > 0) then Inc(result);
if (StrIPos('</'+tag+'>', s) > 0) then Inc(result);
if (StrIPos('<'+tag+' />', s) > 0) then Inc(result);
if (StrIPos('<'+tag+' ', s) > 0) then Inc(result);
end;
var
score: integer;
begin
score := _Tag('html') + _Tag('body') + _Tag('p') + _Tag('a') + _Tag('b') +
_Tag('i') + _Tag('u') + _Tag('li') + _Tag('ol') + _Tag('ul') +
_Tag('img') + _Tag('div') + _Tag('hr') + _Tag('code') +
_Tag('pre') + _Tag('blockquote') + _Tag('span');
result := score >= 2;
end;
// Template: http://stackoverflow.com/questions/6339446/delphi-get-the-whole-word-where-the-caret-is-in-a-memo
function GetWordUnderCaret(AMemo: TMemo): string;
function ValidChar(c: char): boolean;
begin
result := c in ['a'..'z', 'A'..'Z', '0'..'9', '_'];
end;
var
Line : Integer;
Column : Integer;
LineText: string;
InitPos : Integer;
EndPos : Integer;
begin
//Get the caret position
Line := AMemo.Perform(EM_LINEFROMCHAR,AMemo.SelStart, 0) ;
Column := AMemo.SelStart - AMemo.Perform(EM_LINEINDEX, Line, 0) ;
//Validate the line number
if AMemo.Lines.Count-1 < Line then Exit;
//Get the text of the line
LineText := AMemo.Lines[Line];
// Column zeigt auf das Zeichen LINKS vom Cursor!
InitPos := Column;
if not ValidChar(LineText[InitPos]) then Inc(InitPos);
while (InitPos-1 >= 1) and ValidChar(LineText[InitPos-1]) do Dec(InitPos);
EndPos := Column;
while (EndPos+1 <= Length(LineText)) and ValidChar(LineText[EndPos+1]) do Inc(EndPos);
//Get the text
Result := Copy(LineText, InitPos, EndPos - InitPos + 1);
end;
function IsValidPHPExe(const exeFile: string): boolean;
var
cont: string;
begin
cont := LoadFileToStr(exeFile);
result := (Pos('php://stdout', cont) >= 0) or
(Pos('PHP_SELF', cont) >= 0);
end;
end.