Subversion Repositories fastphp

unit Functions;

interface

uses

  Windows, Messages, SysUtils, StrUtils, IniFiles, Classes, Forms, Variants, MsHTML,

  StdCtrls, SynEdit, ActiveX;

type

  TContentCallBack = procedure(Content: string) of object;

function GetDosOutput(CommandLine: string; Work: string = ''; ContentCallBack: TContentCallBack=nil): string;

function StrIPos(const SubStr, S: string): Integer;

function LoadFileToStr(const FileName: TFileName): AnsiString;

function LastPos(const SubStr, S: string): integer;

function IsTextHTML(s: string): boolean;

function GetWordUnderPos(AMemo: TSynEdit; Line, Column: integer): string;

function GetWordUnderCaret(AMemo: TSynEdit): string;

function MyVarToStr(v: Variant): string;

function FileSystemCaseSensitive: boolean;

function HighColorWindows: boolean;

function GetTempDir: string;

function GetSpecialFolder(const aCSIDL: Integer): string;

function GetMyDocumentsFolder: string;

implementation

uses

  ShlObj; // Needed for the CSIDL constants

function GetDosOutput(CommandLine: string; Work: string = ''; ContentCallBack: TContentCallBack=nil): 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;

            if Assigned(ContentCallBack) then ContentCallBack(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;

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 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;

  procedure _Check(const tag: string; pair: boolean);

  begin

    if (pair and (_Tag(tag) >= 2)) or (not pair and (_Tag(tag) >= 1)) then result := true;

  end;

begin

  result := false;

  _Check('html', true);

  _Check('body', true);

  _Check('p', false{end tag optional});

  _Check('a', true);

  _Check('b', true);

  _Check('i', true);

  _Check('u', true);

  _Check('li', false{end tag optional});

  _Check('ol', true);

  _Check('ul', true);

  _Check('img', false);

  _Check('div', false);

  _Check('hr', false);

  _Check('code', true);

  _Check('pre', true);

  _Check('blockquote', true);

  _Check('span', true);

  _Check('br', false);

end;

// Template: http://stackoverflow.com/questions/6339446/delphi-get-the-whole-word-where-the-caret-is-in-a-memo

function GetWordUnderPos(AMemo: TSynEdit; Line, Column: integer): string;

  function ValidChar(c: char): boolean;

  begin

    {$IFDEF UNICODE}

    result := CharInSet(c, ['a'..'z', 'A'..'Z', '0'..'9', '_']);

    {$ELSE}

    result := c in ['a'..'z', 'A'..'Z', '0'..'9', '_'];

    {$ENDIF}

  end;

var

   LineText: string;

   InitPos : Integer;

   EndPos  : Integer;

begin

   //Validate the line number

   if AMemo.Lines.Count-1 < Line then Exit;

   //Get the text of the line

   LineText := AMemo.Lines[Line];

   if LineText = '' then

   begin

     result := '';

     exit;

   end;

   // 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 GetWordUnderCaret(AMemo: TSynEdit): string;

var

   Line    : Integer;

   Column  : Integer;

begin

   //Get the caret position

   (*

   if AMemo is TMemo then

   begin

     Line   := AMemo.Perform(EM_LINEFROMCHAR,AMemo.SelStart, 0);

     Column := AMemo.SelStart - AMemo.Perform(EM_LINEINDEX, Line, 0);

   end;

   if AMemo is TSynEdit then

   begin

   *)

     Line := AMemo.CaretY-1;

     Column := AMemo.CaretX-1;

   (*

   end;

   *)

   result := GetWordUnderPos(AMemo, Line, Column);

end;

function MyVarToStr(v: Variant): string;

var

  _Lo, _Hi, i: integer;

begin

  if VarIsNull(v) then

  begin

    result := '';

  end

  else if VarIsArray(v) then

  begin

    _Lo := VarArrayLowBound(v, 1);

    _Hi := VarArrayHighBound(v, 1);

    result := '';

    for i := _Lo to _Hi do

    begin

      if v[i] = 0 then break;

      result := result + chr(integer(v[i]));

    end;

  end

  else

  begin

    // At least try it...

    result := VarToStr(v);

  end;

end;

function FileSystemCaseSensitive: boolean;

begin

  // TODO: This code is not very reliable. At MAC OSX, the file system HFS can be switched

  //       between case sensitivity and insensitivity.

  {$IFDEF LINUX}

  exit(true);

  {$ELSE}

  result := false;

  exit;

  {$ENDIF}

end;

function HighColorWindows: boolean;

var

  ver: Cardinal;

  dwMajorVersion, dwMinorVersion: integer;

begin

  ver := GetVersion();

  dwMajorVersion := Lo(ver);

  dwMinorVersion := Hi(ver);

  // Gradient fitting in:

  // 5.1 = XP

  // 5.2 = Windows Server 2003

  // 6.0 = Vista

  // 6.1 = Win7

  result := ((dwMajorVersion = 5) and (dwMinorVersion >= 1)) or

            ((dwMajorVersion = 6) and (dwMinorVersion <= 1));

end;

function GetTempDir: string;

var

  Dir: string;

  Len: DWord;

begin

  SetLength(Dir,MAX_PATH);

  Len:=GetTempPath(MAX_PATH, PChar(Dir));

  if Len>0 then

  begin

    SetLength(Dir,Len);

    Result:=Dir;

  end

  else

    RaiseLastOSError;

end;

function SHGetFolderPath(hwnd: HWND; csidl: Integer; hToken: THandle;

  dwFlags: DWord; pszPath: LPWSTR): HRESULT; stdcall;

  external 'SHFolder.dll' name 'SHGetFolderPathW';

function GetSpecialFolder(const aCSIDL: Integer): string;

var

  FolderPath: array[0 .. MAX_PATH] of Char;

begin

  SetLastError(ERROR_SUCCESS);

  if SHGetFolderPath(0, aCSIDL, 0, 0, @FolderPath) = S_OK then

    Result := FolderPath;

end;

function GetMyDocumentsFolder: string;

begin

  Result := GetSpecialFolder(CSIDL_PERSONAL);

end;

end.