Subversion Repositories fastphp

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.