{*******************************************************}
{                                                       }
{       nrCommLib Communication Library for Delphi      }
{       some system routines (VCL)                      }
{       Copyright (c) 1997-2011 Roman Novgorodov        }
{       v9.27                                           }
{       last update: 1  Jan 2010                        }
{                                                       }
{       e-mail:noro@deepsoftware.com                    }
{       DeepSoftware                                    }
{       http://www.deepsoftware.com/                    }
{                                                       }
{*******************************************************}
{$I nrcommlib.inc}
unit nrsysutils;
interface

{$IFDEF GEN3}
type
  TReplaceFlags = set of (rfReplaceAll, rfIgnoreCase);

  function StringReplace(const S, OldPattern, NewPattern: string;
                         Flags: TReplaceFlags): string;
{$ENDIF}

{$IFNDEF GEN6}
{$IFNDEF GEN5}
  procedure FreeAndNil(var Obj);
{$ENDIF}
  procedure DecodeDateTime(aDate:TDateTime; var aY,aM,aD,aH,aMin,aSec,aDSec:word);
{$ENDIF}

  function IntToOct(I:cardinal):string;
  function OctToInt(S:string):integer;

  procedure nrEnterThreadCritical;
  procedure nrLeaveThreadCritical;

  function MatchPatternSimple(InpStr,Pattern:PChar) :Boolean;

  function GUIDToString(const GUID: TGUID): string;
  function EncodeDateTime(aY,aM,aD,aH,aMin,aSec,aMil:word):TDateTime;

  function GetDequotedString( s:string ): string;

{$IFNDEF GEN6}
  function DirectoryExists(const Directory: string): Boolean;
  function ForceDirectories(Dir: string): Boolean;
  function ExcludeTrailingPathDelimiter(const S: string): string;
  function IncludeTrailingPathDelimiter(const S: string): string;

  function CreateGUID(out Guid: TGUID): cardinal;
  function StringToGUID(const S: string): TGUID;
{$ENDIF}

  function ReplaceStrangeChars(s:string):string;

  procedure RunProcess(hWnd:cardinal; aCmd:string; aDir:string; flWait,flHide:boolean);

implementation
uses sysutils, windows {$IFDEF GEN6},SyncObjs{$ENDIF};

{$IFNDEF GEN6}
Type
  TCriticalSection=class
  private
    fCSect: TRTLCriticalSection;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Enter;
    procedure Leave;
  end;
{$ENDIF}


{$IFNDEF GEN6}

constructor TCriticalSection.Create;
begin
  inherited Create;
  InitializeCriticalSection(fCSect);
end;
destructor TCriticalSection.Destroy;
begin
  DeleteCriticalSection(fCSect);
  inherited Destroy;
end;

procedure TCriticalSection.Enter;
begin
  EnterCriticalSection(fCSect);
end;

procedure TCriticalSection.Leave;
begin
  LeaveCriticalSection(fCSect);
end;

procedure DecodeDateTime(aDate:TDateTime; var aY,aM,aD,aH,aMin,aSec,aDSec:word);
begin
  DecodeDate(aDate,aY,aM,aD);
  DecodeTime(aDate,aH,aMin,aSec,aDSec);
end;

{$ENDIF}

function IntToOct(I:cardinal):string;
begin
  Result:='';
  while I<>0 do begin
    Result:=Char(Byte(I and 7)+$30)+Result;
    I:=I shr 3;
  end;
end;

function OctToInt(S:string):integer;
var i:integer;
begin
  Result := 0;
  for i := 1 to Length(s) do
    //if s[i] in ['0' .. '7'] then
    if (s[i] >= '0') and (s[i] <= '7') then
         Result := (Result shl 3) + (Byte(S[i]) - $30)
       else begin
         Result := 0;
         break;
       end;
end;

{$IFDEF GEN3}
function StringReplace(const S, OldPattern, NewPattern: string;
  Flags: TReplaceFlags): string;
var
  SearchStr, Patt, NewStr: string;
  Offset: Integer;
begin
  if rfIgnoreCase in Flags then
  begin
    SearchStr := AnsiUpperCase(S);
    Patt := AnsiUpperCase(OldPattern);
  end else
  begin
    SearchStr := S;
    Patt := OldPattern;
  end;
  NewStr := S;
  Result := '';
  while SearchStr <> '' do
  begin
    Offset := AnsiPos(Patt, SearchStr);
    if Offset = 0 then
    begin
      Result := Result + NewStr;
      Break;
    end;
    Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;
    NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
    if not (rfReplaceAll in Flags) then
    begin
      Result := Result + NewStr;
      Break;
    end;
    SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
  end;
end;

{$ENDIF}

{$IFNDEF GEN5}
{$IFNDEF GEN6}
procedure FreeAndNil(var Obj);
var
  P: TObject;
begin
  P := TObject(Obj);
  TObject(Obj) := nil;
  P.Free;
end;
{$ENDIF}
{$ENDIF}

var CSection:TCriticalSection;

procedure nrEnterThreadCritical;
begin
  CSection.Enter;
end;

procedure nrLeaveThreadCritical;
begin
  CSection.Leave;
end;

function MatchPatternSimple(InpStr,Pattern:PChar) :Boolean;
begin
  Result := False;
  while(True) do
  begin
    case Pattern[0] of
      #0 :begin //End of pattern reached.
            Result := (InpStr[0] = #0); //TRUE if end of InpStr.
            Exit;
          end;

      '*':begin //Match zero or more occurances of any char.
            if(Pattern[1] = #0)then
            begin //Match any number of trailing chars.
              Result := True;
              Exit;
            end else Inc(Pattern);

            while(InpStr[0] <> #0)do
            begin //Try to match any substring of InpStr.
              if(MatchPatternSimple(InpStr,Pattern))then
              begin
                Result := True;
                Exit;
              end;

              //Continue testing next char...
              Inc(InpStr);
            end;
          end;

      '?':begin //Match any one char.
            if(InpStr[0] = #0)then
            begin
              Result := False;
              Exit;
            end;

            //Continue testing next char...
            Inc(InpStr);
            Inc(Pattern);
          end;

     else begin //Match given single char.
            if(InpStr[0] <> Pattern[0])then
            begin
              Result := False;
              Break;
            end;
            //Continue testing next char...
            Inc(InpStr);
            Inc(Pattern);
          end;
    end;
  end;
end;

function GUIDToString(const GUID: TGUID): string;
begin
  Result :=  Format('{%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x}', 
       [GUID.D1, GUID.D2, GUID.D3, GUID.D4[0], GUID.D4[1], GUID.D4[2], GUID.D4[3],
        GUID.D4[4], GUID.D4[5], GUID.D4[6], GUID.D4[7]]);
end;

function EncodeDateTime(aY,aM,aD,aH,aMin,aSec,aMil:word):TDateTime;
begin
  Result :=  EncodeDate(aY,aM,aD) + EncodeTime(aH,aMin,aSec,aMil);
end;

function GetDequotedString( s:string ): string;
var len:integer;
    ch:char;
begin
  len := Length(s);
  Result := s;
  if len < 2 then exit;
  ch := s[1];
  if ((ch = '"') or (ch = '''')) and (ch = s[len])
    then Result := Copy(s,2,len-2);
end;

{$IFNDEF GEN6}
function DirectoryExists(const Directory: string): Boolean;
var
  Code: Integer;
begin
  Code := GetFileAttributes(PChar(Directory));
  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;

function ExcludeTrailingPathDelimiter(const S: string): string;
begin
  Result := S;
  if IsPathDelimiter(Result, Length(Result)) then
    SetLength(Result, Length(Result)-1);
end;

function IncludeTrailingPathDelimiter(const S: string): string;
begin
  Result := S;
  if not IsPathDelimiter(Result, Length(Result)) then
    Result := Result + '\';
end;

function ForceDirectories(Dir: string): Boolean;
begin
  Result := False;
  if Dir = '' then exit;
  Dir := ExcludeTrailingPathDelimiter(Dir);
  if (Length(Dir) < 3) or DirectoryExists(Dir)
    or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
  Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);
end;

function CoCreateGuid(out guid: TGUID): cardinal; stdcall; external 'ole32.dll' name 'CoCreateGuid';

function CreateGUID(out Guid: TGUID): cardinal;
begin
  Result := CoCreateGuid(Guid);
end;

function CLSIDFromString(psz: PWideChar; out clsid: TGUID): HResult; stdcall;
  external 'ole32.dll' name 'CLSIDFromString';

function StringToGUID(const S: string): TGUID;
begin
  if not Succeeded(CLSIDFromString(PWideChar(WideString(S)), Result)) 
    then raise Exception.Create('!!!!');
end;


{$ENDIF}

function ReplaceStrangeChars(s:string):string;
begin
  Result := StringReplace(s,'\??\','',[rfReplaceAll]);
  Result := StringReplace(Result,'_??_','',[rfReplaceAll]);
  Result := Trim(StringReplace(Result,'#','\',[rfReplaceAll]));
end;

procedure RunProcess(hWnd:cardinal; aCmd:string; aDir:string; flWait,flHide:boolean);
var siProcess:TStartupInfo;
    piProcess:TProcessInformation;
    codeError:dword;
begin
  ZeroMemory(@siProcess,SizeOf(TStartupInfo));
  siProcess.cb:=SizeOf(TStartupInfo);
  if flHide then begin
    siProcess.dwFlags:=STARTF_USESHOWWINDOW;
    siProcess.wShowWindow:=SW_HIDE;
  end;

  if CreateProcess(Nil,Pchar(aCmd),Nil,Nil,False, 0,Nil,PChar(aDir),siProcess,piProcess)
    then begin
      codeError := 0;
      if flWait then begin
        WaitForSingleObject(piProcess.hThread,INFINITE);
        WaitForSingleObject(piProcess.hProcess,INFINITE);
        GetExitCodeProcess(piProcess.hProcess, codeError);
      end;
      CloseHandle(piProcess.hThread);
      CloseHandle(piProcess.hProcess);
      SetLastError(codeError);
    end;
end;


initialization
  CSection:=TCriticalSection.Create;

finalization
  CSection.Free;

end.
