SRL Archive - Test corner

Hey,

I started this some time ago for the competition Waddo started, but I didn't feel like making a form for it. It is a script parser with some examples on how to use it. It contains a formatter, analyser, obfuscator and highlighter.

program Formatter;

const
  FileIn = 'C:\Program Files\SCAR 3.14\scripts\Test.scar'; //File to process
  FileOut = 'C:\Program Files\SCAR 3.14\scripts\Test.txt'; //Output file for formatter/obfuscator
  Mode = 1;             //1: formatter; 2: analyser; 3: obfuscator; 4: highlighter;
  KeepComments = False; //Keep comments while formatting
  CompressWS = False;   //Compress white space - Set true if you're getting errors
  
const
  clKeyword = clBlack;
  clString = clFuchsia;
  clInteger = clNavy;
  clComment = clGreen;
  
function StringToChars(s: string): string; //Idea from Ron
var
  i: Integer;
begin
  Result := '';
  if (Length(s) <= 2) then
    Result := #39#39
  else
    for i := 2 to Length(s) - 1 do
      Result := Result + '#' + IntToStr(Ord(s[i]));
end;

function ExtendInteger(Int: Integer): string;
var
  i, c, q1, q2: Integer;
begin
  i := 0;
  c := -1;
  Result := '(';
  while (i < 3) and (c <> Int) do
  begin
    q1 := 0;
    q2 := 0;
    while (q1 = 0) do
      q1 := Random(Max(Int, 10));
    while (q2 = 0) do
      q2 := Random(Max(Int, 10));
    if (Random(15) = 0) then
      q1 := -q1;
    if (Random(15) = 0) then
      q2 := -q2;
    if (Result = '(') then
    begin
      c := q1 + q2;
      Result := Result + '('+IntToStr(q1)+'+'+IntToStr(q2)+')';
    end
    else
      case Random(4) of
        0:
          begin
            c := c + (q1 + q2);
            Result := Result + '+('+IntToStr(q1)+'+'+IntToStr(q2)+')';
          end;
        1:
          begin
            c := c - (q1 - q2);
            Result := Result + '-('+IntToStr(q1)+'-'+IntToStr(q2)+')';
          end;
        2:
          begin
            c := c + (q1 * q2);
            Result := Result + '+('+IntToStr(q1)+'*'+IntToStr(q2)+')';
          end;
        3:
          begin
            c := c - (q1 / q2);
            Result := Result + '-('+IntToStr(q1)+'/'+IntToStr(q2)+')';
          end;
      end;
    Inc(i);
  end;
  if (c <> Int) then
  begin
    q1 := Int - c;
    Result := Result + '+' + IntToStr(q1);
  end;
  Result := Result + ')';
end;

function RandomCase(s: string): string;
var
  i: Integer;
begin
  Result := s;
  for i := 1 to Length(s) do
    if (Random(3) = 1) then
      case s[i] of
        'a'..'z': Result[i] := Chr(Ord(s[i]) - 32);
        'A'..'Z': Result[i] := Chr(Ord(s[i]) + 32);
      end;
end;

function StringHash(const Value: string): Integer;
var
  i, x: Integer;
begin
  Result := 0;
  Value := UpperCase(Value);
  for i := 1 to Length(Value) do
  begin
    x := Ord(Value[i]);
    Result := ((((Result + x) shl i) xor $ff) * x) shr 4;
  end;
end;

const
  tkConst        = 99194018;
  tkType         = 33489835;
  tkVar          = 302492;
  tkBegin        = 206891307;
  tkEnd          = 422887;
  tkArray        = 241981220;
  tkSet          = 408192;
  tkRecord       = 154572379;
  tkIf           = 9113;
  tkThen         = 27389149;
  tkElse         = 34909855;
  tkWhile        = 246933539;
  tkFor          = 516020;
  tkTo           = 10916;
  tkDownto       = 196948847;
  tkDo           = 12477;
  tkWith         = 31996795;
  tkRepeat       = 117892746;
  tkUntil        = 29229899;
  tkCase         = 24377488;
  tkOf           = 9445;
  tkGoto         = 42051300;
  tkLabel        = 81388075;
  tkProcedure    = 91883435;
  tkFunction     = 150673595;
  tkNil          = 373079;
  tkAnd          = 420541;
  tkOr           = 10818;
  tkNot          = 439860;
  tkXor          = 469321;
  tkDiv          = 504470;
  tkMod          = 352779;
  tkExternal     = 100911611;
  tkStdcall      = 110854811;
  tkCdecl        = 150234651;
  tkRaise        = 68853785;
  tkTry          = 504179;
  tkExcept       = 71323914;
  tkOn           = 10369;
  tkFinally      = 252725930;
  tkAs           = 12984;
  tkIn           = 9998;
  tkIs           = 13191;
  tkOut          = 472998;
  tkProgram      = 73755563;
  tkShr          = 412495;
  tkShl          = 382541;
  tkForward      = 244372219;
  tkString       = -12;
  tkPlus         = -13;
  tkBraceOpen    = -14;
  tkBraceClose   = -15;
  tkColon        = -16;
  tkSemiColon    = -17;
  tkDot          = -18;
  tkComma        = -19;
  tkBracketOpen  = -20;
  tkBracketClose = -21;
  tkEquation     = -22;
  tkChar         = -23;
  tkCompDir      = -24;
  tkInclude      = -25;
  tkAssignment   = -26;
  tkInteger      = -27;
  tkFloat        = -28;
  tkHex          = -29;
  tkLineComment  = -30;
  tkComment      = -31;
  tkDivide       = -32;
  tkMultiply     = -33;
  tkMinus        = -34;
  tkNull         = -999;

var
  RunPos, TokenID: Integer;
  Token, Script, NewScript: string;
  AllowComments, ReturnComments: Boolean;

procedure AddComment; forward;

procedure NextToken;
var
  OldRun, t: Integer;
begin
  OldRun := RunPos;
  Token := '';
  TokenId := tkNull;
  while (RunPos <= Length(Script)) do
    case Script[RunPos] of
      'a'..'z', 'A'..'Z', '0'..'9', '_': Inc(RunPos);
      else Break;
    end;
  if (RunPos = OldRun) and (RunPos < Length(Script)) then
  begin
    case Script[RunPos] of
      #9, #32, #13, #10:
        begin
          Inc(RunPos);
          NextToken;
          Exit;
        end;
      #39:
        begin
          Inc(RunPos);
          t := PosEx(#39, Script, RunPos);
          if (t > 0) then
            TokenID := tkString
          else
            Exit;
          RunPos := t + 1;
        end;
      '(':
        begin
          if (RunPos < Length(Script)) then
            if (Script[RunPos + 1] <> '*') then
              TokenID := tkBraceOpen
            else
            begin
              t := PosEx('*)', Script, RunPos);
              if (t <= 0) then
                Exit;
              RunPos := t + 2;
              TokenID := tkComment;
            end;
        end;
      '{':
        begin
          if (RunPos < Length(Script)) then
            if (Script[RunPos + 1] = '$') then
              TokenID := tkCompDir
            else if (RunPos + 1 + Length('.include ') < Length(Script)) then
              if (UpperCase(Copy(Script, RunPos + 1, Length('.include '))) = '.INCLUDE ') then
                  TokenID := tkInclude;
          t := PosEx('}', Script, RunPos);
          if (t <= 0) then
            Exit;
          RunPos := t + 1;
          if (TokenID = tkNull) then
            TokenID := tkComment;
        end;
      '/':
        begin
          if (RunPos < Length(Script)) then
            if (Script[RunPos + 1] = '/') then
            begin
              t := PosEx(#13, Script, RunPos);
              if (t <= 0) then
                Exit;
              RunPos := t;
              TokenID := tkLineComment;
            end;
          if (TokenID = tkNull) then
            TokenID := tkDivide;
        end;
      ':':
        begin
          if (RunPos < Length(Script)) then
             if (Script[RunPos + 1] <> '=') then
               TokenID := tkColon
             else
             begin
               IncEx(RunPos, 2);
               TokenID := tkAssignment;
             end;
        end;
      ')': TokenID := tkBraceClose;
      ';': TokenID := tkSemiColon;
      '+': TokenID := tkPlus;
      '-': TokenID := tkMinus;
      '*': TokenID := tkMultiply;
      '.': TokenID := tkDot;
      ',': TokenID := tkComma;
      '[': TokenID := tkBracketOpen;
      ']': TokenID := tkBracketClose;
      '>', '<', '=':
        begin
          if (RunPos < Length(Script)) and (Script[RunPos] <> '=') then
             if (Script[RunPos + 1] = '=') or ((Script[RunPos] = '<') and (Script[RunPos + 1] = '>')) then
               IncEx(RunPos, 2);
          TokenID := tkEquation;
        end;
      '#':
        begin
          Inc(RunPos);
          while (RunPos <= Length(Script)) do
            case Script[RunPos] of
              '0'..'9': Inc(RunPos);
              else Break;
            end;
          if (RunPos > (OldRun + 1)) then
            TokenID := tkChar;
        end;
      '$':
        begin
          Inc(RunPos);
          while (RunPos <= Length(Script)) do
            case Script[RunPos] of
              '0'..'9', 'a'..'f', 'A'..'F': Inc(RunPos);
              else Break;
            end;
          TokenID := tkHex;
        end;
    end;
    if (RunPos = OldRun) then
      Inc(RunPos);
  end
  else if (RunPos > Length(Script)) then
    Exit;
  Token := Copy(Script, OldRun, RunPos - OldRun);
  if ((TokenID = tkLineComment) or (TokenID = tkComment)) and (not ReturnComments) then
  begin
    if AllowComments then
      AddComment;
    NextToken;
    Exit;
  end;
  if (GetNumbers(Token) = Token) {(StrToIntDef(Token, -1) > -1)} and (RunPos < Length(Script)) then
  begin
    TokenID := tkInteger;
    if (Script[RunPos] = '.') then
    begin
      Inc(RunPos);
      while (RunPos <= Length(Script)) do
        case Script[RunPos] of
          '0'..'9': Inc(RunPos);
          else Break;
        end;
      TokenID := tkFloat;
      Token := Copy(Script, OldRun, RunPos - OldRun);
    end;
  end;
  if (TokenID = tkNull) and (Token <> '') then
    TokenID := StringHash(Token);
end;

type
  tInType = (None, InFunc, InFuncDecl, InVar);

var
  LastAsSpace, FirstInLine, LastWasKeyword, LastWasChar, LastWasComment: Boolean;
  BeginCount: Integer;
  InType: tInType;
  
  Keywords: TIntegerArray;
  Indents: array [0..500] of Byte;
  InDent, ElseIndent: ShortInt;

procedure NewLine;
begin
  NewScript := NewScript + #13#10;
  FirstInLine := True;
end;

procedure AddComment;
begin
  case TokenID of
    tkComment:
      begin
        if (not LastWasComment) and (InType <> InFunc) and (not FirstInLine) then
          NewLine;
        if (InType <> InFunc) then
          NewLine
        else if (not FirstInLine) then
          NewLine;
        NewScript := NewScript + Token;
      end;
    tkLineComment:
      begin
        if (not FirstInLine) then
          NewLine;
        NewScript := NewScript + StringOfChar(' ', 2 * (Indents[InDent] + ElseIndent)) + Token;
      end;
  end;
  
  FirstInLine := False;
  LastAsSpace := False;
  LastWasKeyword := False;
  LastWasChar := False;
  LastWasComment := True;
end;

procedure Add;
var
  IsKeyword: Boolean;
begin
  IsKeyword := InIntArray(Keywords, TokenID) or (LowerCase(Token) = 'string');
  if LastWasComment and (not FirstInLine) then
    NewLine;
  LastWasComment := False;
  if FirstInLine then
    if (TokenID = tkInclude) then
      NewScript := NewScript + '  '
    else if (TokenID = tkEnd) or (TokenID = tkUntil) then
      NewScript := NewScript + StringOfChar(' ', 2 * (Indents[InDent] + ElseIndent - 1))
    else
      NewScript := NewScript + StringOfChar(' ', 2 * (Indents[InDent] + ElseIndent));
  if IsKeyWord then
  begin
    if (FirstInLine or LastAsSpace) and (TokenID <> tkAssignment) then
      NewScript := NewScript + LowerCase(Token)
    else
      NewScript := NewScript + ' ' + LowerCase(Token);
    LastAsSpace := False;
  end
  else case TokenID of
    tkBraceOpen, tkBracketOpen:
      begin
        if LastWasKeyword then
          NewScript := NewScript + ' ' + Token
        else
          NewScript := NewScript + Token;
        LastAsSpace := True;
      end;
    tkDot:
      begin
        NewScript := NewScript + Token;
        LastAsSpace := True;
      end;
    tkChar:
      begin
        if LastWasChar or FirstInLine or LastAsSpace then
          NewScript := NewScript + Token
        else
          NewScript := NewScript + ' ' + Token;
        LastAsSpace := False;
      end;
    tkComma:
      begin
        NewScript := NewScript + Token;
        FirstInLine := False;
        LastAsSpace := False;
        LastWasKeyword := True;
        LastWasChar := False;
        Exit;
      end;
    tkColon, tkSemiColon, tkBraceClose, tkBracketClose:
      begin
        NewScript := NewScript + Token;
        LastAsSpace := False;
      end;
    tkEquation, tkDivide, tkMultiply, tkMinus, tkPlus:
      begin
        NewScript := NewScript + ' ' + Token;
        FirstInLine := False;
        LastAsSpace := False;
        LastWasKeyword := True;
        LastWasChar := False;
        Exit;
      end;
    else
    begin
      if FirstInLine or LastAsSpace then
        NewScript := NewScript + Token
      else
        NewScript := NewScript + ' ' + Token;
      LastAsSpace := False;
    end;
  end;

  FirstInLine := False;
  LastWasKeyword := IsKeyword;
  LastWasChar := (TokenID = tkChar);
end;

function CharsToString(a: array of ShortInt): string;
var
  i: Integer;
  LastWasChar: Boolean;
begin
  Result := '';
  LastWasChar := True;
  for i := 0 to High(a) do
    if (a[i] > -1) then
    begin
      if InRange(a[i], 32, 126) and (a[i] <> 39) then
      begin
        if LastWasChar then
          Result := Result + #39 + Chr(a[i])
        else
          Result := Result + Chr(a[i]);
        LastWasChar := False;
      end
      else
      begin
        if LastWasChar then
          Result := Result + '#' + IntToStr(a[i])
        else
          Result := Result + #39 + '#' + IntToStr(a[i]);
        LastWasChar := True;
      end;
    end;
  if (not LastWasChar) then
    Result := Result + #39;
end;

procedure ProcessChars;
var
  cChar: Integer;
  Chars: array of ShortInt;
  s: string;
begin
  SetLength(Chars, 1);
  cChar := 0;
  Chars[0] := StrToIntDef(Copy(Token, 2, Length(Token) - 1), -1);
  NextToken;
  while (TokenID = tkChar) do
  begin
    Inc(cChar);
    SetLength(Chars, cChar + 1);
    Chars[cChar] := StrToIntDef(Copy(Token, 2, Length(Token) - 1), -1);
    NextToken;
  end;
  cChar := TokenID;
  s := Token;
  Token := CharsToString(Chars);
  TokenID := tkString;
  Add;
  TokenID := cChar;
  Token := s;
end;

procedure ProcessScript;
var
  BraceCount: Integer;
begin
  Keywords := [tkConst, tkType, tkVar, tkBegin, tkEnd, tkArray, tkSet, tkRecord,
               tkIf, tkThen, tkElse, tkWhile, tkFor, tkTo, tkDownto, tkDo, tkWith,
               tkRepeat, tkUntil, tkCase, tkOf, tkGoto, tkLabel, tkProcedure,
               tkFunction, tkNil, tkAnd, tkOr, tkNot, tkXor, tkDiv, tkMod, {}tkAssignment{},
               tkExternal, tkStdcall, tkCdecl, tkRaise, tkTry, tkExcept, tkOn,
               tkFinally, tkAs, tkIn, tkIs, tkOut, tkProgram, tkShr, tkShl, tkForward];
  RunPos := 1;
  InDent := 0;
  BeginCount := 0;
  InType := None;
  FirstInLine := True;
  AllowComments := KeepComments;
  ReturnComments := False;
  NextToken;
  while (TokenID <> tkNull) do
  begin
    case TokenID of
      tkChar:
        begin
          ProcessChars;
          Continue;
        end;
      tkInclude:
        begin
          if (not FirstInLine) then
            NewLine;
          Add;
          NewLine;
        end;
      tkCompDir:
        begin
          Add;
          NewLine;
        end;
      tkProcedure, tkFunction:
        begin
          InDent := 0;
          ElseIndent := 0;
          NewLine;
          Add;
          NextToken;
          Writeln(Token);
          Add;
          InType := InFuncDecl;
        end;
      tkBraceOpen:
        begin
          if (InType = InVar) then
            LastWasKeyword := True;
          Add;
          NextToken;
          BraceCount := 1;
          while (TokenID <> tkNull) and (BraceCount > 0) do
          begin
            if (TokenID = tkBraceOpen) then
              Inc(BraceCount)
            else if (TokenID = tkBraceClose) then
              Dec(BraceCount)
            else if (TokenID = tkChar) then
            begin
              ProcessChars;
              Continue;
            end;
            Add;
            NextToken;
          end;
          Continue;
        end;
      tkDo, tkThen:
        begin
          Add;
          NextToken;
          if (TokenID = tkBegin) then
            Continue
          else if (TokenID = tkTry) or (TokenID = tkRepeat) then
          begin
            Inc(ElseIndent);
            Continue;
          end
          else
          begin
            Inc(ElseIndent);
            NewLine;
            Add;
          end;
        end;
      tkElse:
        begin
          if (not FirstInLine) then
            NewLine;
          if (ElseIndent > 0) then
            Dec(ElseIndent);
          Add;
          NextToken;
          if (TokenID = tkBegin) or (TokenID = tkIf) then
            Continue
          else if (TokenID = tkTry) or (TokenID = tkRepeat) then
          begin
            Inc(ElseIndent);
            Continue;
          end
          else
          begin
            Inc(ElseIndent);
            NewLine;
            Add;
          end;
        end;
      tkColon:
        begin
          Add;
          if (InType = InFunc) and (BeginCount > 1) then
          begin
            NextToken;
            if InIntArray(Keywords, TokenID) then
            begin
              Inc(ElseIndent);
              NewLine;
            end;
            Continue;
          end;
        end;
      tkOf:
        begin
          if (InType = InVar) or (InType = InFuncDecl) then
            LastAsSpace := False;
          Add;
          if (InType <> InVar) and (InType <> InFuncDecl) then
          begin
            Inc(BeginCount);
            Inc(InDent);
            Indents[InDent] := Indents[InDent - 1] + ElseIndent + 1;
            NewLine;
            ElseIndent := 0;
          end;
        end;
      tkBegin, tkRepeat:
        begin
          if (InType <> InFunc) or (BeginCount = 0) then
          begin
            Indent := 0;
            ElseIndent := 0;
          end;
          if (not FirstInLine) or (InType = None) then
            NewLine;
          Add;
          Inc(BeginCount);
          Inc(InDent);
          Indents[InDent] := Indents[InDent - 1] + ElseIndent + 1;
          NewLine;
          ElseIndent := 0;
          InType := InFunc;
        end;
      tkTry:
        begin
          if (not FirstInLine) then
            NewLine;
          Add;
          Inc(BeginCount);
          Inc(InDent);
          Indents[InDent] := Indents[InDent - 1] + ElseIndent + 1;
          NewLine;
          ElseIndent := 0;
        end;
      tkExcept, tkFinally:
        begin
          if (not FirstInLine) then
            NewLine;
          ElseIndent := -1;
          Add;
          ElseIndent := 0;
          NewLine;
        end;
      tkEnd, tkUntil:
        begin
          if (BeginCount > 0) then
            Dec(BeginCount);
          if (BeginCount = 0) and (InType = InFunc) then
            InType := None;
          if (not FirstInLine) then
            NewLine;
          ElseIndent := 0;
          Add;
          if (Indent > 0) then
            Dec(Indent);
          if (TokenID = tkEnd) then
          begin
            NextToken;
            if (TokenID <> tkSemiColon) and (TokenID <> tkDot) then
              NewLine;
            Continue;
          end;
        end;
      tkVar, tkType, tkLabel, tkConst:
        begin
          InDent := 0;
          ElseIndent := 0;
          if (InType <> InFuncDecl) then
            NewLine
          else if (not FirstInLine) then
            NewLine;
          InType := InVar;
          Add;
          Inc(InDent);
          Indents[InDent] := Indents[InDent - 1] + ElseIndent + 1;
          NewLine;
        end;
      tkRecord:
        begin
          ElseIndent := 0;
          InType := InVar;
          Add;
          Inc(InDent);
          Indents[InDent] := Indents[InDent - 1] + ElseIndent + 1;
          NewLine;
        end;
      tkSemiColon:
        begin
          if (not FirstInLine) then
          begin
            Add;
            NextToken;
            if (TokenID = tkExternal) or (TokenID = tkForward) then
              InType := None
            else
            begin
              ElseIndent := 0;
              NewLine;
            end;
            Continue;
          end;
        end;
      else
        Add;
    end;
    NextToken;
  end;
end;

procedure AddObfuscate;
begin
  case TokenID of
    tkString:
      begin
        Token := StringToChars(Token);
        TokenID := tkChar;
      end;
    tkInteger: Token := ExtendInteger(StrToInt(Token));
  end;
  Add;
end;

procedure Obfuscate;
var
  BraceCount: Integer;
begin
  Keywords := [tkConst, tkType, tkVar, tkBegin, tkEnd, tkArray, tkSet, tkRecord,
               tkIf, tkThen, tkElse, tkWhile, tkFor, tkTo, tkDownto, tkDo, tkWith,
               tkRepeat, tkUntil, tkCase, tkOf, tkGoto, tkLabel, tkProcedure,
               tkFunction, tkNil, tkAnd, tkOr, tkNot, tkXor, tkDiv, tkMod, {}tkAssignment{},
               tkExternal, tkStdcall, tkCdecl, tkRaise, tkTry, tkExcept, tkOn,
               tkFinally, tkAs, tkIn, tkIs, tkOut, tkProgram, tkShr, tkShl, tkForward];
  RunPos := 1;
  BeginCount := 0;
  InType := None;
  FirstInLine := True;
  AllowComments := False;
  ReturnComments := False;
  NextToken;
  while (TokenID <> tkNull) do
  begin
    case TokenID of
      tkInclude:
        begin
          if (not FirstInLine) then
            NewLine;
          AddObfuscate;
          NewLine;
        end;
      tkProcedure, tkFunction:
        begin
          AddObfuscate;
          NextToken;
          WriteLn(Token);
          AddObfuscate;
          InType := InFunc;
        end;
      tkBraceOpen:
        begin
          if (InType = InVar) then
            LastWasKeyword := True;
          AddObfuscate;
          NextToken;
          BraceCount := 1;
          while (TokenID <> tkNull) and (BraceCount > 0) do
          begin
            if (TokenID = tkBraceOpen) then
              Inc(BraceCount)
            else if (TokenID = tkBraceClose) then
              Dec(BraceCount);
            AddObfuscate;
            NextToken;
          end;
          Continue;
        end;
      else
        AddObfuscate;
    end;
    NextToken;
  end;
end;

var
  f: TForm;
  r: TRichEdit;
  PALL: Boolean;
  
procedure ParseIt(OffSet: Integer; s: string);
var
  sStart, sLen: Integer;
  t: Integer;
begin
  t := GetTickCount;
  Keywords := [tkConst, tkType, tkVar, tkBegin, tkEnd, tkArray, tkSet, tkRecord,
               tkIf, tkThen, tkElse, tkWhile, tkFor, tkTo, tkDownto, tkDo, tkWith,
               tkRepeat, tkUntil, tkCase, tkOf, tkGoto, tkLabel, tkProcedure,
               tkFunction, tkNil, tkAnd, tkOr, tkNot, tkXor, tkDiv, tkMod, tkExternal,
               tkStdcall, tkCdecl, tkRaise, tkTry, tkExcept, tkOn, tkFinally, tkAs,
               tkIn, tkIs, tkOut, tkProgram, tkShr, tkShl, tkForward];
  Script := s + '}*)' + #39#13;
  RunPos := 1;
  AllowComments := True;
  ReturnComments := True;
  LastWasComment := False;
  NextToken;
  with r do
  begin
    //Lines.BeginUpdate;
    sStart := SelStart;
    sLen := SelLength;
    SelStart := OffSet - 1;
    SelLength := Length(s) + 2;
    SelAttributes.Style := [];
    SelAttributes.Color := clBlack;
    
    while (TokenID <> tkNull) do
    begin
      SelStart := RunPos - Length(Token) - 2 + OffSet;
      SelLength := Length(Token);
      
      if InIntArray(Keywords, TokenID) or (LowerCase(Token) = 'string') then
      begin
        SelAttributes.Style := [fsBold];
        SelAttributes.Color := clKeyword;
        NextToken;
        Continue;
      end;
      
      case TokenID of
        tkString:
          begin
            SelAttributes.Style := [];
            SelAttributes.Color := clString;
          end;
        tkInteger:
          begin
            SelAttributes.Style := [];
            SelAttributes.Color := clInteger;
          end;
        tkComment:
          begin
            if (not Pall) and (Token[1] = '{') then
               SelLength := SelLength + 1;
            SelAttributes.Style := [];
            SelAttributes.Color := clComment;
          end;
        tkLineComment:
          begin
            if (not PALL) then
              SelLength := SelLength - 2;
            SelAttributes.Style := [];
            SelAttributes.Color := clComment;
          end;
        {else
        begin
          SelAttributes.Style := [];
          SelAttributes.Color := clBlack;
        end;}
      end;
      NextToken;
    end;
    SelStart := sStart;
    SelLength := sLen;
    //Lines.EndUpdate;
  end;
  WriteLn('ParseIt took: '+IntToStr(GetTickCount - t)+'ms');
end;

function MinNoZero(a, b: Integer): Integer; //Idea from Ron
begin
  Result := a;
  if (a <= 0) or ((b > 0) and (b < a)) then
    Result := b;
end;

function InComment(p: Integer): string;
var
  a, b, sStart, sLen: Integer;
  t: string;
begin
  Result := '';
  with r do
  begin
    t := Lines.Text;
    //Lines.BeginUpdate;
    sStart := SelStart;
    sLen := SelLength;
  
    a := MinNoZero(Pos('{', t), Pos('(*', t));
    while (a > 0) do
    begin
      if (a > p) then
        Break;
      SelStart := a;
      SelLength := 1;
      if (SelAttributes.Color <> clString) then
      begin
        case t[a] of
          '{': b := PosEx('}', t, a + 1);
          '(': b := PosEx('*)', t, a + 1);
        end;
        if ((p < b) or (b <= 0)) then
        begin
          case t[a] of
            '{': Result := '{';
            '(': Result := '(*';
          end;
          Break;
        end;
        a := MinNoZero(PosEx('{', t, b), PosEx('(*', t, b));
        Continue;
      end;
      
      a := MinNoZero(PosEx('{', t, a + 1), PosEx('(*', t, a + 1));
    end;
    
    SelStart := sStart;
    SelLength := sLen;
    //Lines.EndUpdate;
  end;
end;

procedure ParseLine;
var
  cLine, LineStart: Integer;
  s, t: string;
begin
  with r do
  begin
    cLine := Perform($00C9, SelStart, 0);
    s := Lines[cLine];
    Delete(s, Length(s) - 1, 2);
    if (Trim(s) = '') then
      Exit;
    LineStart := Perform($00BB, cLine, 0);
      
    t := InComment(LineStart);
    if (t <> '') then
    begin
      Insert(InComment(LineStart), s, 1);
      LineStart := LineStart - Length(t);
    end;
    ParseIt(LineStart + 1, s);
  end;
end;

procedure OnChange(Sender: TObject);
var
  Mask: Integer;
begin
  with r do
  begin
    Mask := Perform($0400 + 69, 0, 0); //EM_SETEVENTMASK
    Perform($000B, 0, 0); //WM_SetRedraw
    Lines.BeginUpdate;

     if PALL then
       ParseIt(1, Lines.Text)
     else
       ParseLine;
    PALL := False;
  
    Lines.EndUpdate;
    Perform($000B, 1, 0);
    Invalidate;
    Perform($0400 + 69, 0, Mask);
  end;
end;

procedure OnKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  with r do
  begin
    if (ssShift in Shift) then
    begin
      if ((Key = 221) or (Key = 219)) then
        PALL := True
      else
    
      if (Key = 57) then
      begin
        if (SelStart > 0) and (SelStart < GetTextLen) then
          if (Lines.Text[SelStart + 1] = '*') then
            PALL := True;
      end
      else
    
      if (Key = 56) then
      begin
        if (SelStart > 0) then
          if (Lines.Text[SelStart] = '(') then
            PALL := True;
      end
    end
    else

    if (Key = 86) and (ssCtrl in Shift) then
      PALL := True
    else

    if (SelLength > 0) then
    begin
      if ((Pos('{', SelText) > 0) and (Pos('}', SelText) <= 0)) or
         ((Pos('(*', SelText) > 0) and (Pos('*)', SelText) <= 0)) then
        PALL := True;
    end
    else

    if (Key = 8) then
    begin
      if (SelStart > 0) then
        if (Lines.Text[SelStart] = '{') or (Lines.Text[SelStart] = '}') then
          PALL := True;
      if (not PALL) and (SelStart > 1) and (SelStart < GetTextLen) then
        if ((Lines.Text[SelStart] = '*') and (Lines.Text[SelStart - 1] = '(')) or
           ((Lines.Text[SelStart] = '(') and (Lines.Text[SelStart + 1] = '*')) or
           ((Lines.Text[SelStart] = '*') and (Lines.Text[SelStart + 1] = ')')) or
           ((Lines.Text[SelStart] = ')') and (Lines.Text[SelStart - 1] = '*')) then
          PALL := True;
    end
    else

    if (Key = 46) then
    begin
      SelLength := 1;
      if (SelStart > 0) and (SelStart < GetTextLen) then
        if (Lines.Text[SelStart + 1] = '{') or (Lines.Text[SelStart + 1] = '}') then
          PALL := True;
      if (not PALL) and (SelStart > 0) and (SelStart < GetTextLen - 1) then
        if ((Lines.Text[SelStart + 1] = '(') and (Lines.Text[SelStart + 2] = '*')) or
           ((Lines.Text[SelStart]     = '(') and (Lines.Text[SelStart + 1] = '*')) or
           ((Lines.Text[SelStart + 1] = '*') and (Lines.Text[SelStart + 2] = ')')) or
           ((Lines.Text[SelStart]     = '*') and (Lines.Text[SelStart + 1] = ')')) then
          PALL := True;
    end
    else
      PALL := False;
  end;
end;

procedure LoadForm;
begin
  f := CreateForm;
  with f do
  begin
    Position := poDesktopCenter;
    ClientWidth := 600;
    ClientHeight := 400;
    Caption := 'Syntax Highligter';
  end;

  r := TRichEdit.Create(f);
  with r do
  begin
    Align := alClient;
    Parent := f;
    Font.Name := 'Courier New';
    Font.Size := 10;
    ScrollBars := ssBoth;
    HideScrollBars := False;
    WordWrap := False;
    OnChange := @OnChange;
    OnKeyDown := @OnKeyDown;
  end;

  f.ShowModal;
end;

procedure Analyze;
var
  Strings, Integers, Comments: array[0..1] of Int64;
  KeywordCount, Functions, Vars, Includes: Integer;
begin
  Keywords := [tkConst, tkType, tkVar, tkBegin, tkEnd, tkArray, tkSet, tkRecord,
               tkIf, tkThen, tkElse, tkWhile, tkFor, tkTo, tkDownto, tkDo, tkWith,
               tkRepeat, tkUntil, tkCase, tkOf, tkGoto, tkLabel, tkProcedure,
               tkFunction, tkNil, tkAnd, tkOr, tkNot, tkXor, tkDiv, tkMod, tkExternal,
               tkStdcall, tkCdecl, tkRaise, tkTry, tkExcept, tkOn, tkFinally, tkAs,
               tkIn, tkIs, tkOut, tkProgram, tkShr, tkShl, tkForward];
  RunPos := 1;
  AllowComments := True;
  ReturnComments := True;
  LastWasComment := False;
  NextToken;
  while (TokenID <> tkNull) do
  begin
    if InIntArray(Keywords, TokenID) or (LowerCase(Token) = 'string') then
      Inc(KeywordCount);

    case TokenID of
      tkFunction, tkProcedure:
        begin
          Inc(Functions);
        end;
      tkInclude:
        begin
          Inc(Includes);
        end;
      tkVar, tkConst, tkType, tkLabel:
        begin
          Inc(Vars);
        end;
      tkString:
        begin
          Strings[0] := Strings[0] + 1;
          Strings[1] := Strings[1] + Length(Token);
        end;
      tkInteger:
        begin
          Integers[0] := Integers[0] + 1;
          Integers[1] := Integers[1] + StrToIntDef(Token, 0);
        end;
      tkComment:
        begin
          Comments[0] := Comments[0] + 1;
          Comments[1] := Comments[1] + Length(Token);
        end;
      tkLineComment:
        begin
          Comments[0] := Comments[0] + 1;
          Comments[1] := Comments[1] + Length(Token) - 1;
        end;
    end;
    NextToken;
  end;
  WriteLn('This script contains:');
  WriteLn(IntToStr(Functions)+' functions/procedures,');
  WriteLn(IntToStr(Includes)+' includes,');
  WriteLn(IntToStr(KeywordCount)+' keywords,');
  WriteLn(IntToStr(Vars)+' var/const/type/label sections,');
  WriteLn(Int64ToStr(Strings[0])+' strings (with a total length of '+Int64ToStr(Strings[1])+'),');
  WriteLn(Int64ToStr(Integers[0])+' integers (with a total value of '+Int64ToStr(Integers[1])+'),');
  WriteLn(Int64ToStr(Comments[0])+' comments (with a total length of '+Int64ToStr(Comments[1])+').');
end;

function IsCharWhiteSpaceOrNull(c: Char): Boolean;
begin
  case c of
    #0, #9, #10, #11, #12, #13, #32: Result := True;
    else Result := False;
  end;
end;

function CompressWhiteSpace(const Str: string): string;
var
  i, Len, NextResultChar: Integer;
  CheckChar, NextChar: Char;
begin
  Len := Length(Str);
  NextResultChar := 1;
  SetLength(Result, Len);

  for i := 1 to Len do
  begin
    CheckChar := Str[i];
    if (i < Len) then
      NextChar := Str[i + 1]
    else
      NextChar := #0;
    case CheckChar of
      #9, {#10, #13,} #32:
        begin
          if IsCharWhiteSpaceOrNull(NextChar) or (NextResultChar = 1) then
            Continue
          else
          begin
            Result[NextResultChar] := #32;
            Inc(NextResultChar);
          end;
        end;
      else
        begin
          Result[NextResultChar] := Str[i];
          Inc(NextResultChar);
        end;
    end;
  end;
  if (Len > 0) then
    SetLength(Result, NextResultChar - 1);
end;

var
  s: TStringList;
  v: TVariantArray;
begin
  s := TStringList.Create;
  LoadFromFile(s, FileIn);
  //1: formatter; 2: analyser; 3: obfuscator; 4: highlighter;
  Script := s.Text;
  if CompressWS then
    Script := CompressWhiteSpace(Script);
  case Mode of
    1:
      begin
        try
          ProcessScript;
        except end;
        s.Text := NewScript;
        SaveToFile(s, FileOut);
      end;
    2: Analyze;
    3:
      begin
        Obfuscate;
        s.Text := RandomCase(NewScript);
        SaveToFile(s, FileOut);
      end;
    4: ThreadSafeCall('LoadForm', v);
    else
      WriteLn('Unknown Mode: '+IntToStr(Mode));
  end;
  s.Free;
end.

~Nielsie95

Woo amazing stuff nielsie im formatting all my scripts with this :)

THANKS SOO MUCH!

Good job Nielsie!
~Eerik~

Nielsie, you just ..

Hm.
You know when the awesomeness of a person you've never met amazes you near the point where you get speechless?
I've felt it more and more that way with every of your last releases.


And, I don't really know if this is ontopic or not, (nor do I care) but could you just show me that syntax highlighter code in Delphi?

I'm kinda having (had, when I had my pc >: ) problems with my compiler, it didn't allow some files to be opened, hence disallowing me to see that exact part.

I'm sorry for making all those demands, and I fully understand if you don't want to.

Did you only finish this because i told you i was planning on making one? :p.

Same thing happened with the syntax highlighter. I decided to make one, and then you pump out a better and complete one, lol.

/me decides not to tell Nielsie95 any of his future ideas :p.

Nice job. It is sad how it says "SCAR 3.14" though ;)

Great work.

Nice stuff :).

Thanks all :)

From: EvilChicken!
And, I don't really know if this is ontopic or not, (nor do I care) but could you just show me that syntax highlighter code in Delphi?

I think you're looking for SynEdit.

From: Dan Cardin
Did you only finish this because i told you i was planning on making one? :p.

Same thing happened with the syntax highlighter. I decided to make one, and then you pump out a better and complete one, lol.

/me decides not to tell Nielsie95 any of his future ideas :p.

I finished this script almost 3 weeks ago and I only know you're continuing your SCAR Notepad. :p About the Syntax Highlighter is true though ;)

From: Hy71194
Nice job. It is sad how it says "SCAR 3.14" though ;)

It says 3.14, but you'll have to read it as 3.15b.

awsome!

good release for srl members!

Aw, this was my idea. I just never finished.

Not to mention, I don't have to skill todo it.

Gratz, great release. :)

methinks it would be nifty if you made a basic form with open, save, new. and a debug box to show your outputting stuff. Shouldnt be hard and would make the whole script a bit neater and better looking.

You will never format my code. :f:

Does it get rid of capital bold words and smexy double spaces?

If so I'm with Wizzup :p

Haha, nicee love it!

I'm not sure what it does, could someone explain with few examples all modes?

//1: formatter; 2: analyser; 3: obfuscator; 4: highlighter;

1: Standardizes any scripts with horrible standards.
2: Analyzes the functions and procedures one has in a script. E.g.

33 functions/procedures,
2 includes,
590 keywords,
35 var/const/type/label sections,
228 strings (with a total length of 5826),
358 integers (with a total value of 62694080),
36 comments (with a total length of 8004).

3: Obsfucators try to stop humans from easily reading the script. This one removes all enters and spaces, makes all strings hexadecimels and .. well, see for yourself.

3: Run it, and a form will come up. It bolds, makes stuff green like SCAR does. Not much use, but.. Well, a tribute to Niels Scriptz0r skills.

it's good but it fails formatting my script, it does half a script then just strings it all together xDDD

Can you link me to your script?

yay it works
ty nielsie

oh and before anyone says it "i want to give feedback as i have been spending 30 mins trying to find a woorking obfuscator and i got directed to here"

i can now sell me script X)

~shut

I keep getting this error when I try to obfuse or analyze my script.

[Runtime Error] : Exception: Access violation at address 0050D52D in module 'scar.exe'. Write of address 03C66FE4 in line 200 in script C:\Program Files\SCAR 3.15b\Scripts\Obfuser.scar

Try setting CompressWS True.

wow 1stt ime i used this to set the standerdonmy cuzin script and mine for the standerds it is wicked.

what is the anylizer for??

Analyzer:

48 functions/procedures,
2 includes,
986 keywords,
50 var/const/type/label sections,
260 strings (with a total length of 3290),
609 integers (with a total value of 147107073),
12 comments (with a total length of 1599).

Heh, that's my current Nautilus. [unreleased]

as ive said before, i think you need to limit multiline comments to maybe 5 lines if they're missing an ending } or else it will be quite slow when highlighting a whole script. Also it seems your multiline ones dont work quite right.

two things that dont work(you may need to type it out to get what im getting instead of copy and paste)

{.hakllo

asdfa
dfa

asdfgdfgdfg}asdfasdf


---------------------------------------------

{dfgsdfgsdfg


adfasdf}

asdfasdfsdf

What exactly is it that you are getting? I think they are highlighting fine here.

Are we running the same script? :p

Anyone here has the same problems as Dan?

Thanks Neils, it worked.

Could someone convert this to an extension? Would be win, win!

From: mastaraymond
Could someone convert this to an extension? Would be win, win!

You mean something like this? ;)

The structure is all there, but a few functions need to be ported over. Someone with more knowledge of the functions in simba shouldn't have much trouble.

to be honest, I also don't know if I did the menus right either :redface: I guess we'll find out

Ah, I really wish this would still work :( Update pwease :)?

From: nickrules
You mean something like this? ;)

The structure is all there, but a few functions need to be ported over. Someone with more knowledge of the functions in simba shouldn't have much trouble.

to be honest, I also don't know if I did the menus right either :redface: I guess we'll find out

I'll update this in a bit, we have functions for extensions to grab the current scripts text, and to open a new script from string.

E: Uploaded my version. Removed Analyse and Highlight. (Useless functions to me)
The Obfuscater is pretty useless as well >..>
The Formater works very well!!

From: Dgby714
I'll update this in a bit, we have functions for extensions to grab the current scripts text, and to open a new script from string.

E: Uploaded my version. Removed Analyse and Highlight. (Useless functions to me)
The Obfuscater is pretty useless as well >..>
The Formater works very well!!

It seems to strip comments though, that's not really useful.. :p

E:

AllowComments := False;
ReturnComments := False;  

Love the crazy maths functions, any way to turn off the random caps?

You could change the RandomCase function to just let it return the input, but there is no easy setting :)