dws2mflibfuncs.pas

script language

function ExecAndWait(const Filename, Params, Dir: string; WindowState: Word):
  Boolean;
var
  SUInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
  CmdLine: string;
  PD: PChar;
begin
  CmdLine := '"' + Filename + '" ' + Params;

  FillChar(SUInfo, SizeOf(SUInfo), #0);
  with SUInfo do
  begin
    cb := SizeOf(SUInfo);
    dwFlags := STARTF_USESHOWWINDOW;
    wShowWindow := WindowState;
  end;

  if Dir = '' then
    PD := nil
  else
    PD := PChar(Dir);

  Result := CreateProcess(PChar(Filename), PChar(CmdLine), nil, nil, False,
    CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil,
    PD, SUInfo, ProcInfo);
  if Result then
    WaitForSingleObject(ProcInfo.hProcess, INFINITE);
end;

function GetCPUSpeed: Double;
const
  DelayTime = 500;
var
  TimerHi,
    TimerLo: DWORD;
  PriorityClass,
    Priority: Integer;
begin
  PriorityClass := GetPriorityClass(GetCurrentProcess);
  Priority := GetThreadPriority(GetCurrentThread);

  SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
  SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL);

  Sleep(10);
  asm
        dw 310Fh // rdtsc
        mov TimerLo, eax
        mov TimerHi, edx
  end;
  Sleep(DelayTime);
  asm
        dw 310Fh // rdtsc
        sub eax, TimerLo
        sbb edx, TimerHi
        mov TimerLo, eax
        mov TimerHi, edx
  end;

  SetThreadPriority(GetCurrentThread, Priority);
  SetPriorityClass(GetCurrentProcess, PriorityClass);

  Result := TimerLo / (1000.0 * DelayTime);
end;

function GetCRC32FromString(S: string): Integer;
begin
{$WARNINGS OFF}
  Result := not CRC32Calc(Byte(S[1]), $FFFFFFFF, Length(S));
{$WARNINGS ON}
end;

function GetCRC32FromFile(FileName: string): Integer;
var
  CRC: Integer;
  InFile: file;
  Len: Integer;
  Buffer: array[0..BUFLEN - 1] of Byte;
  LastMode: Byte;
begin
  Result := 0;
  if FileExists(FileName) then
  begin
    LastMode := FileMode;
    try
      FileMode := 0;
      AssignFile(InFile, FileName);
      try
        Reset(InFile, 1);
        try
{$WARNINGS OFF}
          CRC := $FFFFFFFF;
{$WARNINGS ON}
          while True do
          begin
            BlockRead(InFile, Buffer, BUFLEN, Len);
            if Len = 0 then
              Break;
            CRC := CRC32Calc(Buffer, CRC, Len);
          end;
          Result := not CRC;
        finally
          CloseFile(InFile);
        end;
      except
        ;
      end;
    finally
      FileMode := LastMode;
    end;
  end;
end;

function ChangeTokenValue(str, name, value, delim: string): string;
var
  SL: TStringList;
  i: Integer;
begin
  Result := str;
  SL := GetTokenList(str, delim, False, False, False);
  try
    if SL.Count > 0 then
    begin
      for i := 0 to SL.Count - 1 do
      begin
        if SL.Names[i] = name then
        begin
          SL[i] := name + '=' + value;
          Result := GetStringFromList(SL, delim[1]);
          Exit;
        end;
      end;
    end;
  finally
    SL.Free;
  end;
end;

procedure FormatColumns(sl: TStringList; delim: Char; space: string; adjust:
  Integer);
var
  ColWidths: array of Integer;
  Cols: Integer;
  TempSL: TStringList;
  S: string;
  i,
    j: Integer;
begin
  if not Assigned(SL) then
    Exit;
  Cols := 0;
  for i := 0 to sl.Count - 1 do
  begin
    TempSL := GetTokenList(SL[i], delim, False, False, False);
    try
      if Cols < TempSL.Count then
      begin
        SetLength(ColWidths, TempSL.Count);
        for j := Cols to High(ColWidths) do
          ColWidths[j] := 0;
        Cols := TempSL.Count;
      end;
      for j := 0 to TempSL.Count - 1 do
        if ColWidths[j] < Length(TempSL[j]) then
          ColWidths[j] := Length(TempSL[j]);
    finally
      TempSL.Free;
    end;
  end;
  if Cols <= 1 then
    Exit;
  for i := 0 to sl.Count - 1 do
  begin
    TempSL := GetTokenList(SL[i], delim, False, False, False);
    try
      for j := 0 to TempSL.Count - 1 do
      begin
        S := TempSL[j];
        if (j < 32) and ((adjust shr j) and 1 = 1) then
          S := StringOfChar(' ', ColWidths[j] - Length(S)) + S
        else
          S := S + StringOfChar(' ', ColWidths[j] - Length(S));
        if j < TempSL.Count - 1 then
          S := S + space;
        TempSL[j] := S;
      end;
      SL[i] := GetStringFromList(TempSL, #0);
    finally
      TempSL.Free;
    end;
  end;
end;

function GetStringFromList(sl: TStringList; delim: Char): string;
var
  i: Integer;
begin
  Result := '';
  for i := 0 to sl.Count - 1 do
  begin
    if (Result <> '') and (delim <> #0) then
      Result := Result + delim;
    Result := Result + sl[i];
  end;
end;

function GetTokenList(str, delim: string; repeater, ignorefirst, ignorelast:
  Boolean): TStringList;
var
  LastDelim: Char;
  S: string;
  p: Integer;
  i: Integer;
begin
  Result := TStringList.Create;
  S := '';
  LastDelim := #0;

  for i := 1 to Length(str) do
  begin
    p := Pos(str[i], delim);
    if p > 0 then
    begin
      if (i = 1) and ignorefirst then
      begin
        LastDelim := str[i];
        Continue;
      end;
      if repeater and (str[i] = LastDelim) then
        Continue;
      Result.Add(S);
      S := '';
      LastDelim := str[i];
    end
    else
    begin
      S := S + str[i];
      LastDelim := #0;
    end;
  end;
  if (S <> '') or not ignorelast then
    Result.Add(S);
end;

function PosX(substr, s: string): Integer;
var
  ls,
    lsub,
    i,
    j,
    p: Integer;
begin
  Result := 0;
  ls := Length(s);
  lsub := Length(substr);
  if (ls = 0) or (lsub = 0) then
    Exit;

  i := 1;
  while (i <= ls) and (s[i] = substr[1]) do
  begin
    if lsub > 1 then
    begin
      p := i - 1;
      if p + lsub > ls then
        Break;
      for j := 2 to lsub do
        if s[p + j] <> substr[j] then
          Break;
      Inc(i, lsub);
    end
    else
      Inc(i);
  end;
  if i <= ls then
    Result := i;
end;

function ANSI2OEM(s: string): string;
begin
  Result := s;
  CharToOem(PChar(Result), PChar(Result));
end;

function OEM2ANSI(s: string): string;
begin
  Result := s;
  OemToChar(PChar(Result), PChar(Result));
end;

function Translate(s: string; tout, tin: string; fill: Char; f: Boolean): string;
var
  zeichen: string;
  zeichpos: Integer;
  max: Integer;
  laenge: Integer;
  loop: Integer;
  loop2: Integer;
begin
  try
    laenge := Length(s);
    if laenge = 0 then
      Exit;

    if Length(tin) = 0 then
    begin
      if fill = #0 then
      begin
        s := AnsiUpperCase(s);
        Exit;
      end
      else
      begin
        for loop := 1 to laenge do
          s[loop] := fill;
        Exit;
      end;
    end;

    max := Length(tout);

    SetLength(zeichen, 1);

    loop := 1;
    while loop <= laenge do
    begin
      zeichen[1] := s[loop];
      zeichpos := Pos(zeichen, tin);
      if zeichpos <> 0 then
      begin
        if zeichpos > max then
        begin
          if fill = #0 then
          begin
            Dec(laenge);
            for loop2 := loop to laenge do
              s[loop2] := s[loop2 + 1];
            SetLength(s, laenge);
            if laenge = 0 then
              Exit;
          end
          else
          begin
            s[loop] := fill;
            Inc(loop);
          end;
        end
        else
        begin
          s[loop] := tout[zeichpos];
          Inc(loop);
        end;
      end
      else
        Inc(loop);
    end;
  finally
    Result := s;
  end;
end;

function _brktcmp(range: string; zeich: char): Boolean;
var
  inv: Boolean;
  bpos: Integer;
  hpos: Integer;
begin
  inv := False;
  bpos := 2;
  result := False;

  if range[bpos] = '~' then
  begin
    Inc(bpos);
    inv := True;
  end;

  while (result = False) and (range[bpos] <> ']') do
  begin
    if range[bpos] = '\' then
      Inc(bpos);

    if range[bpos + 1] = '-' then
    begin
      hpos := bpos + 2;
      if range[hpos] = '\' then
        Inc(hpos);

      if (range[bpos] <= zeich) and (zeich <= range[hpos]) then
        result := True;
      bpos := hpos;
    end
    else if range[bpos] = zeich then
      result := True;
    Inc(bpos);
  end;

  if inv then
    result := (result = False);
end;

function CmpWC(source, wc: string; cf: Boolean): Boolean;
var
  afterstar: Integer;
  p: Integer;
  s: Integer;
begin
  afterstar := 0;
  p := 1;
  s := 1;
  result := True;

  if cf then
  begin
    Source := AnsiUpperCase(source);
    wc := AnsiUpperCase(wc);
  end;

  if Length(source) = 0 then
  begin
    SetLength(source, 1);
    source[1] := #0;
  end;
  if Length(wc) = 0 then
  begin
    SetLength(wc, 1);
    wc[1] := #0;
  end;

  while result and (wc[p] <> #0) and (source[s] <> #0) do
  begin
    case wc[p] of
      '?':
        begin
          if source[s] <> #0 then
          begin
            Inc(p);
            Inc(s);
            if afterstar > 0 then
              Dec(afterstar);
          end
          else
            result := False;
        end;
      '+':
        begin
          if source[s] <> #0 then
          begin
            Inc(p);
            Inc(s);
            Inc(afterstar);
          end
          else
            result := False;
        end;
      '*':
        begin
          Inc(p);
          Inc(afterstar);
        end;
      '[':
        begin
          if afterstar > 0 then
          begin
            result := _brktcmp(Copy(wc, p, Length(wc)), source[s]);
            while (source[s] <> #0) and result do
            begin
              result := _brktcmp(Copy(wc, p, Length(wc)), source[s]);
              Inc(s);
            end;
            while CmpWC(Copy(source, s, Length(source)), Copy(wc, p, Length(wc)),
              False) = False do
            begin
              Inc(s);
              if source[s] = #0 then
              begin
                result := False;
                Exit;
              end;
            end;
            result := True;
            Exit;
          end
          else
          begin
            if _brktcmp(Copy(wc, p, Length(wc)), source[s]) = False then
            begin
              result := False;
              Exit;
            end;
            Inc(s);
          end;

          while wc[p] <> ']' do
          begin
            if wc[p] = '\' then
              Inc(p);
            Inc(p);
          end;
          Inc(p);
        end;
    else
      if wc[p] = '\' then
        Inc(p);
      if afterstar > 0 then
      begin
        while (source[s] <> #0) and (wc[p] <> source[s]) do
          Inc(s);
        if (source[s] = #0) then
        begin
          result := False;
          Exit;
        end;
        while CmpWC(Copy(source, s, Length(source)), Copy(wc, p, Length(wc)), False)
          = False do
        begin
          Inc(s);
          if source[s] = #0 then
          begin
            result := False;
            Exit;
          end;
        end;
        result := True;
        Exit;
      end
      else
      begin
        if wc[p] <> source[s] then
        begin
          result := False;
          Exit;
        end;
        Inc(p);
        Inc(s);
      end;
    end;
  end;

  while (afterstar > 0) and (source[s] <> #0) do
    Inc(s);
  while wc[p] = '*' do
    Inc(p);
  if result and ((wc[p] <> #0) or (source[s] <> #0)) then
    result := False;
end;

function IncWC(source, wc: string; cf: Boolean; var ebene: Integer): string;
var
  afterstar: Integer;
  p: Integer;
  s: Integer;
  pat: Integer;
begin
  afterstar := 0;
  p := 1;
  s := 1;
  pat := p;
  result := source;

  Inc(ebene);
  if ebene = 0 then