ObfPas Current

program PasObf;

{$mode objfpc}{$H+}

uses
  SysUtils, Classes, StrUtils;

type
  TTokenKind = (tkIdent, tkString, tkWhitespace, tkComment, tkSymbol, tkNumber, tkOther);

  TToken = record
    Kind: TTokenKind;
    Text: string;
    InInterface: Boolean;
    InUses: Boolean;
    InConstBlock: Boolean; // Flag to track if inside a const or resourcestring block
  end;

  TTokenArray = array of TToken;
  TStrArray   = array of string;

  { Simple case-insensitive string set (sorted TStringList wrapper) }
  TStrSet = class
  private
    S: TStringList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(const v: string);
    function Has(const v: string): Boolean;
    procedure Clear;
  end;

var
  // Global variable to hold the randomly generated name for the decryption function
  GXorStrFuncName: string;
  // Global variable to hold the generated polymorphic function code
  GPolymorphicFuncCode: string;

constructor TStrSet.Create;
begin
  S := TStringList.Create;
  S.CaseSensitive := False;
  S.Sorted := True;
  S.Duplicates := dupIgnore;
end;

destructor TStrSet.Destroy;
begin
  S.Free;
  inherited Destroy;
end;

procedure TStrSet.Add(const v: string);
begin
  if v <> '' then S.Add(v);
end;

function TStrSet.Has(const v: string): Boolean;
begin
  Result := (v <> '') and (S.IndexOf(v) >= 0);
end;

procedure TStrSet.Clear;
begin
  S.Clear;
end;

function MakeStrArray(const A: array of string): TStrArray;
var
  i: Integer;
begin
  Result := nil; // Initialize result
  SetLength(Result, Length(A));
  for i := Low(A) to High(A) do
    Result[i] := LowerCase(A[i]);
end;

var
  PascalKeywords: TStrArray;

procedure InitKeywords;
begin
  // A more comprehensive list of keywords for Delphi/FPC
  PascalKeywords := MakeStrArray([
    'and','array','as','asm','begin','case','class','const','constructor',
    'destructor','div','do','downto','else','end','except','exports','file',
    'finalization','finally','for','function','goto','if','implementation',
    'in','inherited','initialization','inline','interface','is','label','library',
    'mod','nil','not','object','of','or','out','packed','procedure','program',
    'property','raise','record','repeat','resourcestring','set','shl','shr',
    'string','then','threadvar','to','try','type','unit','until','uses',
    'var','while','with','xor','specialize','generic','on','helper','result',
    'true','false','default','abstract','overload','override','reintroduce',
    'virtual','cdecl','stdcall','safecall','register','far','near','private',
    'protected','public','published','pchar','forspecificcpu','foreachcpu',
    'input','PBOOL','integer','PDWORD',
    // extras commonly treated as keywords across Delphi/FPC modes:
    'absolute','external','operator','deprecated','platform','experimental',
    'strict','sealed','final','static','message','pascal','export'
  ]);
end;

var
  // CLI options
  GRoot: string = '';
  GInplace: Boolean = False;
  GSeed: LongInt = 0;
  GSeedGiven: Boolean = False;
  GSkipNamesArg: string = '';
  GXorKey: string = ''; // Key for string encryption

  // working sets
  PublicNames : TStrSet = nil;
  DeclaredHere: TStrSet = nil;
  SkipNames   : TStrSet = nil;

function IsKeyword(const S: string): Boolean;
var
  L: string;
  i: Integer;
begin
  L := LowerCase(S);
  for i := Low(PascalKeywords) to High(PascalKeywords) do
    if L = PascalKeywords[i] then
      Exit(True);
  Result := False;
end;

function IsIdentStart(const C: Char): Boolean; inline;
begin
  Result := (C = '_') or (C in ['A'..'Z','a'..'z']);
end;

function IsIdentChar(const C: Char): Boolean; inline;
begin
  Result := IsIdentStart(C) or (C in ['0'..'9']);
end;

procedure SplitExtPasFiles(const Root: string; List: TStrings; Recursive: Boolean = True);
var
  SR: TSearchRec;
  Sub: string;
begin
  if FindFirst(IncludeTrailingPathDelimiter(Root) + '*', faAnyFile, SR) = 0 then
  try
    repeat
      if (SR.Name = '.') or (SR.Name = '..') then Continue;
      if (SR.Attr and faDirectory) <> 0 then
      begin
        if Recursive then
        begin
          Sub := IncludeTrailingPathDelimiter(Root) + SR.Name;
          SplitExtPasFiles(Sub, List, True);
        end;
      end
      else
      begin
        if AnsiEndsText('.pas', SR.Name) or AnsiEndsText('.pp', SR.Name) then
          List.Add(IncludeTrailingPathDelimiter(Root) + SR.Name);
      end;
    until FindNext(SR) <> 0;
  finally
    FindClose(SR);
  end;
end;

procedure AddToken(var Tokens: TTokenArray; var Count: Integer; Kind: TTokenKind;
                   const Text: string; InInterface, InUses, InConstBlock: Boolean);
begin
  if Count >= Length(Tokens) then
    SetLength(Tokens, Length(Tokens) * 2 + 256);
  Tokens[Count].Kind := Kind;
  Tokens[Count].Text := Text;
  Tokens[Count].InInterface := InInterface;
  Tokens[Count].InUses := InUses;
  Tokens[Count].InConstBlock := InConstBlock;
  Inc(Count);
end;

procedure LexFile(const Content: string; out Tokens: TTokenArray; out Count: Integer);
var
  i, n: Integer;
  ch: Char;
  buf: string;
  inInterface, inUses, inConstBlock, inResourceStringBlock: Boolean;
  isConstContext: Boolean; // Temporary variable to resolve expression

  function Peek(offset: Integer): Char;
  var idx: Integer;
  begin
    idx := i + offset;
    if (idx >= 1) and (idx <= n) then Result := Content[idx] else Result := #0;
  end;

  procedure FlushBuf(kind: TTokenKind);
  begin
    if buf <> '' then
    begin
      isConstContext := inConstBlock or inResourceStringBlock;
      AddToken(Tokens, Count, kind, buf, inInterface, inUses, isConstContext);
      buf := '';
    end;
  end;

  procedure AddSym(const s: string);
  begin
    FlushBuf(tkOther);
    isConstContext := inConstBlock or inResourceStringBlock;
    AddToken(Tokens, Count, tkSymbol, s, inInterface, inUses, isConstContext);
  end;

begin
  Count := 0;
  SetLength(Tokens, 1024);
  i := 1; n := Length(Content);
  buf := '';
  inInterface := False;
  inUses := False;
  inConstBlock := False;
  inResourceStringBlock := False;
  while i <= n do
  begin
    ch := Content[i];

    // whitespace
    if ch in [#9, #10, #13, ' '] then
    begin
      FlushBuf(tkOther);
      buf := '';
      repeat
        buf := buf + ch;
        Inc(i);
        if i > n then Break;
        ch := Content[i];
      until not (ch in [#9,#10,#13,' ']);
      isConstContext := inConstBlock or inResourceStringBlock;
      AddToken(Tokens, Count, tkWhitespace, buf, inInterface, inUses, isConstContext);
      buf := '';
      Continue;
    end;

    // // comment
    if (ch = '/') and (Peek(1) = '/') then
    begin
      FlushBuf(tkOther);
      buf := '//';
      Inc(i, 2);
      while (i <= n) and not (Content[i] in [#10, #13]) do
      begin
        buf := buf + Content[i];
        Inc(i);
      end;
      isConstContext := inConstBlock or inResourceStringBlock;
      AddToken(Tokens, Count, tkComment, buf, inInterface, inUses, isConstContext);
      buf := '';
      Continue;
    end;

    // { } comment
    if ch = '{' then
    begin
      FlushBuf(tkOther);
      buf := '{';
      Inc(i);
      while (i <= n) and (Content[i] <> '}') do
      begin
        buf := buf + Content[i];
        Inc(i);
      end;
      if (i <= n) and (Content[i] = '}') then
      begin
        buf := buf + '}';
        Inc(i);
      end;
      isConstContext := inConstBlock or inResourceStringBlock;
      AddToken(Tokens, Count, tkComment, buf, inInterface, inUses, isConstContext);
      buf := '';
      Continue;
    end;

    // (* *) comment
    if (ch = '(') and (Peek(1) = '*') then
    begin
      FlushBuf(tkOther);
      buf := '(*';
      Inc(i, 2);
      while (i <= n) and not ((Content[i] = '*') and (Peek(1) = ')')) do
      begin
        buf := buf + Content[i];
        Inc(i);
      end;
      if (i <= n-1) then
      begin
        buf := buf + '*)';
        Inc(i, 2);
      end;
      isConstContext := inConstBlock or inResourceStringBlock;
      AddToken(Tokens, Count, tkComment, buf, inInterface, inUses, isConstContext);
      buf := '';
      Continue;
    end;

    // 'string'
    if ch = '''' then
    begin
      FlushBuf(tkOther);
      buf := '''';
      Inc(i);
      while i <= n do
      begin
        ch := Content[i];
        buf := buf + ch;
        Inc(i);
        if ch = '''' then
        begin
          if (i <= n) and (Content[i] = '''') then
          begin
            // doubled quote inside string; consume it into buffer
            buf := buf + Content[i];
            Inc(i);
            Continue;
          end
          else
            Break;
        end;
      end;
      isConstContext := inConstBlock or inResourceStringBlock;
      AddToken(Tokens, Count, tkString, buf, inInterface, inUses, isConstContext);
      buf := '';
      Continue;
    end;

    // identifier
    if IsIdentStart(ch) then
    begin
      FlushBuf(tkOther);
      buf := '';
      while (i <= n) and IsIdentChar(Content[i]) do
      begin
        buf := buf + Content[i];
        Inc(i);
      end;

      // section state
      if AnsiSameText(buf, 'interface') then
      begin
        inInterface := True; inUses := False;
      end
      else if AnsiSameText(buf, 'implementation') then
      begin
        inInterface := False; inUses := False; inConstBlock := False; inResourceStringBlock := False;
      end
      else if AnsiSameText(buf, 'uses') then
        inUses := True
      else if AnsiSameText(buf, 'const') then
        inConstBlock := True
      else if AnsiSameText(buf, 'resourcestring') then
        inResourceStringBlock := True
      else if AnsiSameText(buf, 'var') or AnsiSameText(buf, 'type') or AnsiSameText(buf, 'begin') or AnsiSameText(buf, 'procedure') or AnsiSameText(buf, 'function') then
      begin
        inConstBlock := False;
        inResourceStringBlock := False;
      end;

      isConstContext := inConstBlock or inResourceStringBlock;
      AddToken(Tokens, Count, tkIdent, buf, inInterface, inUses, isConstContext);
      buf := '';
      Continue;
    end;

    // number (supports $hex and decimal with '.')
    if (ch in ['0'..'9']) or ((ch = '$') and (Peek(1) in ['0'..'9','A'..'F','a'..'f'])) then
    begin
      FlushBuf(tkOther);
      buf := '';
      // A bit more robust number parsing to avoid consuming dots from ranges (..)
      if ch = '$' then
      begin
        buf := buf + ch;
        Inc(i);
        while (i <= n) and (Content[i] in ['0'..'9','A'..'F','a'..'f']) do
        begin
          buf := buf + Content[i];
          Inc(i);
        end;
      end else
      begin
        while (i <= n) and (Content[i] in ['0'..'9']) do
        begin
          buf := buf + Content[i];
          Inc(i);
        end;
        if (i <= n) and (Content[i] = '.') and (Peek(1) <> '.') then
        begin
          buf := buf + Content[i];
          Inc(i);
          while (i <= n) and (Content[i] in ['0'..'9']) do
          begin
            buf := buf + Content[i];
            Inc(i);
          end;
        end;
      end;
      isConstContext := inConstBlock or inResourceStringBlock;
      AddToken(Tokens, Count, tkNumber, buf, inInterface, inUses, isConstContext);
      buf := '';
      Continue;
    end;

    // punctuation & operators (multi-char first)
    if (ch = '.') and (Peek(1) = '.') then begin AddSym('..'); Inc(i,2); Continue; end;
    if (ch = '<') and (Peek(1) = '=') then begin AddSym('<='); Inc(i,2); Continue; end;
    if (ch = '>') and (Peek(1) = '=') then begin AddSym('>='); Inc(i,2); Continue; end;
    if (ch = '<') and (Peek(1) = '>') then begin AddSym('<>'); Inc(i,2); Continue; end;
    if (ch = ':') and (Peek(1) = '=') then begin AddSym(':='); Inc(i,2); Continue; end;

    // default: single char symbol
    if ch in [';', ':', '+','-','*','/','(',')','[',']','{','}','^','@',',','.','<','>','='] then
    begin
      AddSym(ch);
      Inc(i);
      Continue;
    end;

    // other unknown char: accumulate as tkOther
    buf := buf + ch;
    Inc(i);
  end;
  FlushBuf(tkOther);
  SetLength(Tokens, Count);
end;

function Lower(const s: string): string; inline; begin Result := LowerCase(s); end;

function NearestLeftSymbol(const Tokens: TTokenArray; idx: Integer): string;
begin
  Result := '';
  while idx > 0 do
  begin
    Dec(idx);
    if Tokens[idx].Kind in [tkWhitespace, tkComment] then Continue;
    if Tokens[idx].Kind = tkSymbol then Exit(Tokens[idx].Text)
    else Exit('');
  end;
end;

function NearestRightSymbol(const Tokens: TTokenArray; idx: Integer): string;
begin
  Result := '';
  while idx < High(Tokens) do
  begin
    Inc(idx);
    if Tokens[idx].Kind in [tkWhitespace, tkComment] then Continue;
    if Tokens[idx].Kind = tkSymbol then Exit(Tokens[idx].Text)
    else Exit('');
  end;
end;

function NextNonWsTokenKind(const Tokens: TTokenArray; idx: Integer): TTokenKind;
begin
  while idx < High(Tokens) do
  begin
    Inc(idx);
    if Tokens[idx].Kind in [tkWhitespace, tkComment] then Continue
    else Exit(Tokens[idx].Kind);
  end;
  Result := tkOther;
end;

function NextNonWsText(const Tokens: TTokenArray; idx: Integer): string;
begin
  while idx < High(Tokens) do
  begin
    Inc(idx);
    if Tokens[idx].Kind in [tkWhitespace, tkComment] then Continue
    else Exit(Tokens[idx].Text);
  end;
  Result := '';
end;

function IsModuleDecl(const Tokens: TTokenArray; idx: Integer): Boolean;
var
  j: Integer;
  lcText: string;
begin
  Result := False;
  j := idx - 1;
  // Skip whitespace and comments between the identifier and the potential keyword.
  while (j >= 0) and (Tokens[j].Kind in [tkWhitespace, tkComment]) do
  begin
    Dec(j);
  end;

  if (j >= 0) and (Tokens[j].Kind = tkIdent) then
  begin
    lcText := LowerCase(Tokens[j].Text);
    if (lcText = 'unit') or (lcText = 'program') or (lcText = 'library') then
      Exit(True);
  end;

  if (j >= 0) and (Tokens[j].Kind = tkSymbol) and (Tokens[j].Text = '.') then
  begin
    Dec(j);
    while (j >= 0) and (Tokens[j].Kind in [tkWhitespace, tkComment]) do Dec(j);
    if (j >= 0) and (Tokens[j].Kind = tkIdent) then
    begin
        lcText := LowerCase(Tokens[j].Text);
        if (lcText = 'unit') or (lcText = 'program') or (lcText = 'library') then
          Exit(True);
    end;
  end;
end;

function IsUnitNameInUses(const Tokens: TTokenArray; idx: Integer): Boolean; inline;
begin
  Result := Tokens[idx].InUses;
end;

function IsTypeDeclName(const Tokens: TTokenArray; idx: Integer): Boolean;
var
  rightSym, nxtText: string;
  nxtKind: TTokenKind;
begin
  Result := False;
  rightSym := NearestRightSymbol(Tokens, idx);
  if rightSym <> '=' then Exit(False);
  nxtKind := NextNonWsTokenKind(Tokens, idx);
  nxtText := LowerCase(NextNonWsText(Tokens, idx));
  if (nxtKind = tkSymbol) and (nxtText = '(') then Exit(True);
  if (nxtKind = tkIdent) and ((nxtText = 'record') or (nxtText = 'class') or
                              (nxtText = 'object') or (nxtText = 'set') or
                              (nxtText = 'interface')) then
    Exit(True);
end;

function IsDeclName(const Tokens: TTokenArray; idx: Integer): Boolean;
var
  j: Integer;
  prevWord, lcText: string;
begin
  Result := False;
  if Assigned(PublicNames) and PublicNames.Has(Tokens[idx].Text) then
      Exit(False);

  if IsKeyword(Tokens[idx].Text) then Exit(False);
  if IsModuleDecl(Tokens, idx) then Exit(False);
  if IsUnitNameInUses(Tokens, idx) then Exit(False);

  // Check for `name: type` or `name = value` patterns in declarations
  if (NearestRightSymbol(Tokens, idx) = ':') or
     ((NearestRightSymbol(Tokens, idx) = '=') and not IsTypeDeclName(Tokens, idx)) then
  begin
    // It's a declaration. Let's find the keyword that started this block.
    j := idx - 1;
    while j >= 0 do
    begin
      if Tokens[j].Kind = tkIdent then
      begin
        prevWord := LowerCase(Tokens[j].Text);
        if (prevWord = 'var') or (prevWord = 'const') or (prevWord = 'resourcestring') or
           (prevWord = 'threadvar') or (prevWord = 'type') or
           (prevWord = 'function') or (prevWord = 'procedure') or
           (prevWord = 'property') then
        begin
          Exit(True);
        end;
      end;
      // Stop searching if we hit a block-ending symbol like a semicolon or another begin/end
      if (Tokens[j].Kind = tkSymbol) and (Tokens[j].Text = ';') then Break;
      if (Tokens[j].Kind = tkIdent) then
      begin
        lcText := LowerCase(Tokens[j].Text);
        if (lcText = 'begin') or (lcText = 'end') or (lcText = 'implementation') then Break;
      end;
      Dec(j);
    end;
  end;

  Result := False;
end;

function IsProtectedNameEverywhere(const id: string): Boolean; inline;
begin
  Result := (Assigned(PublicNames) and PublicNames.Has(id))
         or (Assigned(SkipNames) and SkipNames.Has(id));
end;

function IsRenameCandidateUse(const Tokens: TTokenArray; idx: Integer): Boolean;
var
  id: string;
begin
  id := Tokens[idx].Text;
  if id = '' then Exit(False);
  if not Assigned(DeclaredHere) then Exit(False);
  if not DeclaredHere.Has(id) then Exit(False);
  if IsKeyword(id) then Exit(False);
  if IsModuleDecl(Tokens, idx) then Exit(False);
  if IsUnitNameInUses(Tokens, idx) then Exit(False);
  if IsProtectedNameEverywhere(id) then Exit(False);
  Result := True;
end;

function RandAlphaNum: Char;
const
  Chars = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
begin
  Result := Chars[Random(Length(Chars)) + 1];
end;

function GenName(Len: Integer): string;
var
  i: Integer;
begin
  if Len < 1 then Len := 8;
  Result := Chr(Ord('a') + Random(26));
  for i := 2 to Len do
    Result := Result + RandAlphaNum;
end;

function NextObfName(const Seen: TStrings): string;
begin
  repeat
    Result := GenName(10);
  until Seen.IndexOf(Result) < 0;
  Seen.Add(Result);
end;

procedure InitSkipList;
const
  HardSkips: array[0..5] of string = (
    'SetDefaultDllDirectoriesNT', 'AddDllDirectoryNT', 'RemoveDllDirectoryNT',
    'SetDefaultDllDirectories', 'AddDllDirectory', 'RemoveDllDirectory'
  );
  BuiltInFuncs: array[0..58] of string = (
    'Abs', 'Addr', 'Append', 'ArcTan', 'Assign', 'BlockRead', 'BlockWrite',
    'Break', 'Chr', 'Close', 'Concat', 'Continue', 'Copy', 'Cos', 'Dec',
    'Delete', 'Dispose', 'Eof', 'Eoln', 'Erase', 'Exit', 'Exp', 'FilePos',
    'FileSize', 'FillChar', 'Flush', 'Frac', 'FreeMem', 'GetMem', 'Halt',
    'Hi', 'High', 'Inc', 'Insert', 'Int', 'IOResult', 'Length', 'Ln', 'Lo',
    'Low', 'Max', 'Min', 'Move', 'New', 'Odd', 'Ord', 'Pi', 'Pos', 'Pred',
    'Ptr', 'Random', 'Randomize', 'Read', 'ReadLn', 'ReWrite', 'Rename',
    'Reset', 'Round', 'RunError'
  );
  BuiltInFuncs2: array[0..19] of string = (
    'Seek', 'SeekEof', 'SeekEoln', 'SetLength', 'SetTextBuf', 'Sin', 'SizeOf',
    'Sqr', 'Sqrt', 'Str', 'Succ', 'Trunc', 'UpCase', 'Val', 'Write', 'WriteLn',
    'TObject', 'Self', 'Result', 'inherited'
  );
  PascalTypes: array[0..27] of string = (
    'Integer', 'LongInt', 'ShortInt', 'Byte', 'Word', 'Cardinal', 'SmallInt',
    'Real', 'Single', 'Double', 'Extended', 'Comp', 'Currency', 'Boolean',
    'LongBool', 'Char', 'String', 'PChar', 'PPChar', 'Pointer', 'AnsiString',
    'WideString', 'Int64', 'QWord', 'THandle', 'TFarProc', 'PtrInt', 'PtrUInt'
  );
  WinApiTypes: array[0..40] of string = (
    'HANDLE', 'HWND', 'DWORD', 'WORD', 'BOOL', 'LPSTR', 'LPCSTR', 'LPWSTR',
    'LPCWSTR', 'HMODULE', 'HINSTANCE', 'HRGN', 'HDC', 'HGDIOBJ', 'HICON',
    'HBRUSH', 'HPEN', 'HFONT', 'HBITMAP', 'HMENU', 'LONG', 'UINT', 'LPARAM',
    'WPARAM', 'LRESULT', 'LPVOID', 'LPCVOID', 'PBYTE', 'DWORD_PTR',
    'ULONG_PTR', 'SIZE_T', 'TImageInfo', 'TImageData', 'TPoint', 'TRect',
    'TLogFontA', 'TLogFontW', 'TLogFont', 'TIconInfo', 'TBitmap', 'TMessage'
  );
  CInterOpTypes: array[0..18] of string = (
    'cint', 'cuint', 'cchar', 'cschar', 'cuchar', 'cshort', 'cushort',
    'clong', 'culong', 'clonglong', 'culonglong', 'cfloat', 'cdouble',
    'pcchar', 'pccchar', 'cint64', 'cuint64', 'cpointer', 'c UCS2char'
  );
  ElfTypes: array[0..11] of string = (
    'TElfIdent', 'TElf32Hdr', 'TElf64Hdr', 'TElf32SectHdr', 'TElf64SectHdr',
    'TElf32Symbol', 'TElf64Symbol', 'PElf32Hdr', 'PElf64Hdr', 'PElf32SectHdr',
    'PElf64SectHdr', 'PElf32Symbol'
  );

var
  item: string;
begin
  if not Assigned(SkipNames) then Exit;

  for item in HardSkips do SkipNames.Add(item);
  for item in BuiltInFuncs do SkipNames.Add(item);
  for item in BuiltInFuncs2 do SkipNames.Add(item);
  for item in PascalTypes do SkipNames.Add(item);
  for item in WinApiTypes do SkipNames.Add(item);
  for item in CInterOpTypes do SkipNames.Add(item);
  for item in ElfTypes do SkipNames.Add(item);
end;

procedure CollectIdentifierLikeStrings(const Files: TStrings);
var
  f, i, Count: Integer;
  FS: TFileStream;
  SS: TStringStream;
  Content, s: string;
  Tokens: TTokenArray;
  ok: Boolean;
  k: Integer;
begin
  Tokens := nil;
  if not Assigned(SkipNames) then Exit;
  for f := 0 to Files.Count - 1 do
  begin
    FS := TFileStream.Create(Files[f], fmOpenRead or fmShareDenyNone);
    try
      SS := TStringStream.Create('');
      try
        SS.CopyFrom(FS, FS.Size);
        Content := SS.DataString;
      finally
        SS.Free;
      end;
    finally
      FS.Free;
    end;

    LexFile(Content, Tokens, Count);

    for i := 0 to Count - 1 do
      if (Tokens[i].Kind = tkString) then
      begin
        s := Tokens[i].Text;
        if (Length(s) >= 2) and (s[1] = '''') and (s[Length(s)] = '''') then
        begin
          s := StringReplace(Copy(s, 2, Length(s)-2), '''''', '''', [rfReplaceAll]);
          ok := (Length(s) > 0) and IsIdentStart(s[1]);
          if ok then
            for k := 2 to Length(s) do
              if not IsIdentChar(s[k]) then
              begin
                ok := False;
                Break;
              end;
          if ok then
            SkipNames.Add(s);
        end;
      end;
  end;
end;

procedure CollectWrapperVarsFromGetProcAddress(const Files: TStrings);
var
  f, i, n, j: Integer;
  FS: TFileStream;
  SS: TStringStream;
  Content: string;
  Tokens: TTokenArray;
  lhs: string;
begin
  Tokens := nil;
  if not Assigned(SkipNames) then Exit;
  for f := 0 to Files.Count - 1 do
  begin
    FS := TFileStream.Create(Files[f], fmOpenRead or fmShareDenyNone);
    try
      SS := TStringStream.Create('');
      try
        SS.CopyFrom(FS, FS.Size);
        Content := SS.DataString;
      finally
        SS.Free;
      end;
    finally
      FS.Free;
    end;

    LexFile(Content, Tokens, n);

    i := 0;
    while i < n do
    begin
      // Pattern: varName := GetProcAddress(...)
      if (Tokens[i].Kind = tkIdent) then
      begin
        lhs := Tokens[i].Text;
        j := i + 1;
        while (j < n) and (Tokens[j].Kind in [tkWhitespace, tkComment]) do Inc(j);
        if (j + 1 < n) and (Tokens[j].Kind = tkSymbol) and (Tokens[j].Text = ':=') then
        begin
          j := j + 1;
          while (j < n) and (Tokens[j].Kind in [tkWhitespace, tkComment]) do Inc(j);
          if (j < n) and (Tokens[j].Kind = tkIdent) and AnsiSameText(Tokens[j].Text, 'GetProcAddress') then
          begin
            SkipNames.Add(lhs);
            i := j; // Skip forward
            Continue;
          end;
        end;
      end;
      Inc(i);
    end;
  end;
end;

procedure CollectTypeNames(const Files: TStrings);
var
  f, i, Count: Integer;
  FS: TFileStream;
  SS: TStringStream;
  Content: string;
  Toks: TTokenArray;
  rightSym: string;
  j: Integer;
begin
  Toks := nil;
  if not Assigned(SkipNames) then Exit;
  for f := 0 to Files.Count - 1 do
  begin
    FS := TFileStream.Create(Files[f], fmOpenRead or fmShareDenyNone);
    try
      SS := TStringStream.Create('');
      try
        SS.CopyFrom(FS, FS.Size);
        Content := SS.DataString;
      finally
        SS.Free;
      end;
    finally
      FS.Free;
    end;

    LexFile(Content, Toks, Count);

    for i := 1 to Count - 1 do
      if (Toks[i].Kind = tkIdent) then
      begin
        // Find previous non-whitespace token
        j := i - 1;
        while (j > 0) and (Toks[j].Kind in [tkWhitespace, tkComment]) do Dec(j);

        if (Toks[j].Kind = tkIdent) and (LowerCase(Toks[j].Text) = 'type') then
        begin
          rightSym := NearestRightSymbol(Toks, i);
          if rightSym = '=' then
            SkipNames.Add(Toks[i].Text);
        end;
      end;
  end;
end;

procedure CollectAllPublicNames(const Files: TStrings);
var
  f, i, Count, j: Integer;
  FS: TFileStream;
  SS: TStringStream;
  Content: string;
  Tokens: TTokenArray;
  lcText: string;
begin
  Tokens := nil;
  if not Assigned(PublicNames) then Exit;
  PublicNames.Clear;

  for f := 0 to Files.Count - 1 do
  begin
    FS := TFileStream.Create(Files[f], fmOpenRead or fmShareDenyNone);
    try
      SS := TStringStream.Create('');
      try
        SS.CopyFrom(FS, FS.Size);
        Content := SS.DataString;
      finally
        SS.Free;
      end;
    finally
      FS.Free;
    end;

    LexFile(Content, Tokens, Count);

    for i := 0 to Count - 1 do
    begin
      if not Tokens[i].InInterface then Continue;
      if Tokens[i].Kind <> tkIdent then Continue;

      // Simple heuristic: if an identifier in the interface section is part of
      // a declaration (followed by : or =), it's public.
      // This is broad but safer than complex parsing.
      j := i + 1;
      while (j < Count) and (Tokens[j].Kind in [tkWhitespace, tkComment]) do Inc(j);
      if j < Count then
      begin
        if (Tokens[j].Kind = tkSymbol) and ((Tokens[j].Text = ':') or (Tokens[j].Text = '=')) then
          PublicNames.Add(Tokens[i].Text);
      end;

      // Also consider procedure/function names public
      j := i - 1;
      while (j >= 0) and (Tokens[j].Kind in [tkWhitespace, tkComment]) do Dec(j);
      if j >= 0 then
      begin
        if (Tokens[j].Kind = tkIdent) then
        begin
          lcText := LowerCase(Tokens[j].Text);
          if (lcText = 'procedure') or (lcText = 'function') then
            PublicNames.Add(Tokens[i].Text);
        end;
      end;
    end;
  end;
end;

procedure BuildDeclaredHere(const Tokens: TTokenArray; DeclaredHere: TStrSet);
var
  i: Integer;
begin
  if DeclaredHere<>nil then DeclaredHere.Clear;
  for i := 0 to High(Tokens) do
  begin
    if (Tokens[i].Kind = tkIdent) and IsDeclName(Tokens, i) then
      DeclaredHere.Add(Tokens[i].Text);
  end;
end;

procedure CollectDeclaredHere(const Files: TStrings);
var
  f, i, Count: Integer;
  FS: TFileStream;
  SS: TStringStream;
  Content: string;
  Tokens: TTokenArray;
begin
  Tokens := nil;
  if not Assigned(DeclaredHere) then Exit;
  DeclaredHere.Clear;

  for f := 0 to Files.Count - 1 do
  begin
    FS := TFileStream.Create(Files[f], fmOpenRead or fmShareDenyNone);
    try
      SS := TStringStream.Create('');
      try
        SS.CopyFrom(FS, FS.Size);
        Content := SS.DataString;
      finally
        SS.Free;
      end;
    finally
      FS.Free;
    end;

    LexFile(Content, Tokens, Count);

    for i := 0 to Count - 1 do
      if (Tokens[i].Kind = tkIdent) and IsDeclName(Tokens, i) then
        DeclaredHere.Add(Tokens[i].Text);
  end;
end;

procedure BuildMap(const Files: TStrings; MapOrig, MapNew: TStrings);
var
  f, i, Count: Integer;
  FS: TFileStream;
  SS: TStringStream;
  Content: string;
  Tokens: TTokenArray;
  NewNames: TStringList;
  LowerToIdx: TStringList;
  idLower, newName: string;
begin
  Tokens := nil;
  NewNames := TStringList.Create;
  LowerToIdx := TStringList.Create;
  try
    LowerToIdx.CaseSensitive := False;
    LowerToIdx.Sorted := True;
    LowerToIdx.Duplicates := dupIgnore;

    for f := 0 to Files.Count - 1 do
    begin
      FS := TFileStream.Create(Files[f], fmOpenRead or fmShareDenyNone);
      try
        SS := TStringStream.Create('');
        try
          SS.CopyFrom(FS, FS.Size);
          Content := SS.DataString;
        finally
          SS.Free;
        end;
      finally
        FS.Free;
      end;

      LexFile(Content, Tokens, Count);

      for i := 0 to Count - 1 do
        if (Tokens[i].Kind = tkIdent)
           and not IsKeyword(Tokens[i].Text)
           and not IsModuleDecl(Tokens, i)
           and not IsUnitNameInUses(Tokens, i)
           and not IsProtectedNameEverywhere(Tokens[i].Text) then
        begin
          idLower := Lower(Tokens[i].Text);
          if LowerToIdx.IndexOf(idLower) < 0 then
            LowerToIdx.Add(idLower);
        end;
    end;

    for i := 0 to LowerToIdx.Count - 1 do
    begin
      newName := NextObfName(NewNames);
      MapOrig.Add(LowerToIdx[i]);
      MapNew.Add(newName);
    end;
  finally
    NewNames.Free;
    LowerToIdx.Free;
  end;
end;

function LookupNewName(const OrigLower: string; MapOrig, MapNew: TStrings; out NewName: string): Boolean;
var
  i: Integer;
begin
  i := MapOrig.IndexOf(OrigLower);
  Result := (i >= 0);
  if Result then NewName := MapNew[i];
end;

function EncryptStringForPascal(const s: string; const Key: string): string;
var
  i: Integer;
  encryptedByte: Byte;
begin
  if s = '' then Exit('[]'); // Return empty byte array for empty string
  if Key = '' then
  begin
    // No key, just format as byte array
    Result := '[';
    for i := 1 to Length(s) do
    begin
      Result := Result + IntToStr(Ord(s[i]));
      if i < Length(s) then Result := Result + ', ';
    end;
    Result := Result + ']';
    Exit;
  end;

  Result := '[';
  for i := 1 to Length(s) do
  begin
    encryptedByte := Ord(s[i]) xor Ord(Key[((i-1) mod Length(Key)) + 1]);
    Result := Result + IntToStr(encryptedByte);
    if i < Length(s) then Result := Result + ', ';
  end;
  Result := Result + ']';
end;

function IsCaseLabel(const Tokens: TTokenArray; idx: Integer): Boolean;
var
  j: Integer;
begin
  Result := False;
  if idx >= High(Tokens) then Exit(False);
  j := idx + 1;
  while j <= High(Tokens) do
  begin
    if Tokens[j].Kind in [tkWhitespace, tkComment] then
    begin
      Inc(j);
      continue;
    end;

    if (Tokens[j].Kind = tkSymbol) and (Tokens[j].Text = ':') then
      Result := True;

    break;
  end;
end;

function IsGUID(const s: string): Boolean;
begin
  Result := (Length(s) > 2) and (s[1] = '{') and (s[Length(s)] = '}');
end;

procedure RewriteFile(const InPath: string; const OutPath: string;
                      MapOrig, MapNew: TStrings);
var
  Content: string;
  FS: TFileStream;
  SS: TStringStream;
  Tokens: TTokenArray;
  Count, i, j, parenIdx, implementationLine, injectionPoint: Integer;
  outBuf, repl, rawString, actualString, prevIdent, lcText, lineText: string;
  needsPChar, needsPWideChar, isExternalDecl, stringWasEncrypted: Boolean;
  SL: TStringList;
begin
  FS := TFileStream.Create(InPath, fmOpenRead or fmShareDenyNone);
  try
    SS := TStringStream.Create('');
    try
      SS.CopyFrom(FS, FS.Size);
      Content := SS.DataString;
    finally
      SS.Free;
    end;
  finally
    FS.Free;
  end;

  LexFile(Content, Tokens, Count);
  BuildDeclaredHere(Tokens, DeclaredHere);

  outBuf := '';
  stringWasEncrypted := False;

  for i := 0 to Count - 1 do
  begin
    case Tokens[i].Kind of
      tkIdent:
      begin
        repl := Tokens[i].Text;
        if IsRenameCandidateUse(Tokens, i) then
          if LookupNewName(Lower(Tokens[i].Text), MapOrig, MapNew, repl) then
            ; // repl set
        outBuf := outBuf + repl;
      end;
      tkString:
      begin
        rawString := Tokens[i].Text;

        if rawString = '''%%XOR_KEY%%''' then
        begin
          outBuf := outBuf + '''' + StringReplace(GXorKey, '''', '''''', [rfReplaceAll]) + '''';
        end
        else if (Length(rawString) > 2) and (rawString[1] = '''') and (not Tokens[i].InConstBlock) then
        begin
          j := i - 1;
          isExternalDecl := False;
          while j >= 0 do
          begin
            if Tokens[j].Kind in [tkWhitespace, tkComment] then
            begin
              Dec(j);
              continue;
            end;
            if Tokens[j].Kind = tkIdent then
            begin
              lcText := LowerCase(Tokens[j].Text);
              if (lcText = 'external') or (lcText = 'name') then
                isExternalDecl := True;
            end;
            break;
          end;

          if isExternalDecl then
          begin
            outBuf := outBuf + Tokens[i].Text;
            continue;
          end;

          actualString := StringReplace(Copy(rawString, 2, Length(rawString) - 2), '''''', '''', [rfReplaceAll]);

          if (Length(actualString) <= 1) or IsCaseLabel(Tokens, i) or IsGUID(actualString) then
          begin
            outBuf := outBuf + Tokens[i].Text;
          end
          else
          begin
            stringWasEncrypted := True;

            prevIdent := '';
            parenIdx := -1;
            for j := i-1 downto 0 do
            begin
              if Tokens[j].Kind = tkSymbol then
              begin
                if Tokens[j].Text = '(' then
                begin
                  parenIdx := j;
                  break;
                end;
                if (Tokens[j].Text = ';') or (Tokens[j].Text = ':=') or (Tokens[j].Text = '=') then break;
              end;
            end;

            if parenIdx > 0 then
            begin
              for j := parenIdx - 1 downto 0 do
              begin
                if Tokens[j].Kind in [tkWhitespace, tkComment] then continue;
                if Tokens[j].Kind = tkIdent then
                begin
                  prevIdent := Lower(Tokens[j].Text);
                end;
                break;
              end;
            end;

            needsPChar := (prevIdent = 'loadlibrary') or (prevIdent = 'getprocaddress') or (prevIdent = 'getmodulehandle') or (prevIdent = 'outputdebugstringa') or (prevIdent = 'outputdebugstring');
            needsPWideChar := (Length(prevIdent) > 1) and (LowerCase(prevIdent[Length(prevIdent)]) = 'w');

            if needsPWideChar then
                outBuf := outBuf + 'PWideChar(WideString(' + GXorStrFuncName + '(' + EncryptStringForPascal(actualString, GXorKey) + ')))'
            else if needsPChar then
                outBuf := outBuf + 'PAnsiChar(' + GXorStrFuncName + '(' + EncryptStringForPascal(actualString, GXorKey) + '))'
            else
                outBuf := outBuf + GXorStrFuncName + '(' + EncryptStringForPascal(actualString, GXorKey) + ')';
          end;
        end
        else
        begin
          outBuf := outBuf + Tokens[i].Text;
        end;
      end;
    else
      outBuf := outBuf + Tokens[i].Text;
    end;
  end;

  if stringWasEncrypted then
  begin
    SL := TStringList.Create;
    try
      SL.Text := outBuf;
      implementationLine := -1;
      for i := 0 to SL.Count - 1 do
      begin
        if Trim(LowerCase(SL[i])) = 'implementation' then
        begin
          implementationLine := i;
          break;
        end;
      end;

      injectionPoint := -1;

      if implementationLine > -1 then // It's a Unit file
      begin
        injectionPoint := implementationLine + 1; // Default to line after 'implementation'
        for i := implementationLine + 1 to SL.Count - 1 do
        begin
          lineText := Trim(LowerCase(SL[i]));
          if lineText = '' then continue;
          if StartsText('{', lineText) or StartsText('//', lineText) or StartsText('(*', lineText) then continue;

          if StartsText('uses', lineText) then
          begin
            for j := i to SL.Count - 1 do
            begin
              if Pos(';', SL[j]) > 0 then
              begin
                injectionPoint := j + 1;
                break;
              end;
            end;
          end
          else
          begin
             injectionPoint := i;
          end;
          break;
        end;
      end
      else // It's a Program file (no 'implementation' section)
      begin
        // Find the last declaration block before 'begin'
        for i := 0 to SL.Count - 1 do
        begin
          lineText := Trim(LowerCase(SL[i]));
          if (lineText = 'var') or (lineText = 'const') or (lineText = 'type') or (lineText = 'begin') then
          begin
            injectionPoint := i;
            break;
          end;
        end;
      end;

      if injectionPoint > -1 then
      begin
        SL.Insert(injectionPoint, GPolymorphicFuncCode + #13#10);
        outBuf := SL.Text;
        WriteLn('Injector: Polymorphic runtime function injected into ', ExtractFileName(InPath));
      end;
    finally
      SL.Free;
    end;
  end;

  with TStringStream.Create(outBuf) do
  try
    SaveToFile(OutPath);
  finally
    Free;
  end;
end;


procedure RewriteAll(const Files: TStrings; MapOrig, MapNew: TStrings; Inplace: Boolean);
var
  f: Integer;
  outPath, bakPath: string;
begin
  for f := 0 to Files.Count - 1 do
  begin
    if Inplace then
    begin
      outPath := Files[f];
      bakPath := outPath + '.bak';
      if FileExists(bakPath) then DeleteFile(bakPath);
      if not RenameFile(outPath, bakPath) then
        raise Exception.Create('Failed to backup ' + outPath);
      try
        WriteLn('Rewriting: ', ExtractFileName(outPath));
        RewriteFile(bakPath, outPath, MapOrig, MapNew);
        DeleteFile(bakPath);
      except
        on E: Exception do
        begin
          WriteLn('ERROR rewriting ', ExtractFileName(outPath), ': ', E.Message);
          if FileExists(bakPath) then
          begin
            if FileExists(outPath) then DeleteFile(outPath);
            RenameFile(bakPath, outPath); // Restore backup on failure
          end;
          raise;
        end;
      end;
    end
    else
    begin
      outPath := ChangeFileExt(Files[f], '.obf' + ExtractFileExt(Files[f]));
      WriteLn('Rewriting ', ExtractFileName(Files[f]), ' to ', ExtractFileName(outPath));
      RewriteFile(Files[f], outPath, MapOrig, MapNew);
    end;
  end;
end;

procedure SaveMapCsv(const Root: string; MapOrig, MapNew: TStrings);
var
  i: Integer;
  S: TStringList;
begin
  S := TStringList.Create;
  try
    S.Add('original_lower,new_name');
    for i := 0 to MapOrig.Count - 1 do
      S.Add(MapOrig[i] + ',' + MapNew[i]);
    S.SaveToFile(IncludeTrailingPathDelimiter(Root) + 'obf_map.csv');
  finally
    S.Free;
  end;
end;

procedure ParseArgs;
var
  i: Integer;
  a, v: string;
begin
  for i := 1 to ParamCount do
  begin
    a := ParamStr(i);
    if AnsiStartsText('--root=', a) then
      GRoot := Copy(a, 8, MaxInt)
    else if AnsiSameText(a, '--inplace') then
      GInplace := True
    else if AnsiStartsText('--skip-names=', a) then
      GSkipNamesArg := Copy(a, 14, MaxInt)
    else if AnsiStartsText('--seed=', a) then
    begin
      v := Copy(a, 8, MaxInt);
      try
        GSeed := StrToInt(v);
        GSeedGiven := True;
      except
        on E: Exception do
        begin
          WriteLn('Invalid --seed value: ', v);
          Halt(1);
        end;
      end;
    end
    else if (a='-h') or (a='--help') then
    begin
      WriteLn('PasObf - simple Pascal identifier obfuscator (declaration-based)');
      WriteLn('  --root=PATH         Root folder to process (recursively)');
      WriteLn('  --inplace           Overwrite files (default: write .obf copies)');
      WriteLn('  --seed=N            PRNG seed for deterministic mapping');
      WriteLn('  --skip-names=...    Comma-separated list of names to protect');
      Halt(0);
    end;
  end;

  if GRoot = '' then
  begin
    WriteLn('Usage: PasObf --root=PATH [options]');
    Halt(1);
  end;
end;

function GeneratePolymorphicXorStr: string;
var
  funcName, keyVar, loopVar, junkVar: string;
  junkCode: string;
  sl: TStringList;
begin
  // Generate random names for the function and its variables
  funcName := 'fn_' + GenName(8);
  GXorStrFuncName := funcName; // Store globally for RewriteFile
  keyVar   := 'k_' + GenName(6);
  loopVar  := 'i_' + GenName(6);
  junkVar  := 'j_' + GenName(6);

  // Create some useless "junk" code to alter the function's signature
  case Random(3) of
    0: junkCode := '    ' + junkVar + ' := ' + junkVar + ' + ' + loopVar + ' and $FF;';
    1: junkCode := '    ' + junkVar + ' := (' + junkVar + ' * 3) xor ' + loopVar + ';';
    2: junkCode := '    ' + junkVar + ' := ' + junkVar + ' - ' + loopVar + ';';
  end;

  sl := TStringList.Create;
  try
    sl.Add('function ' + funcName + '(const s: array of Byte): string;');
    sl.Add('const');
    sl.Add('  ' + keyVar + ' = ''%%XOR_KEY%%'';');
    sl.Add('var');
    sl.Add('  ' + loopVar + ', ' + junkVar + ': Integer;');
    sl.Add('begin');
    sl.Add('  ' + junkVar + ' := 0;');
    sl.Add('  SetLength(Result, Length(s));');
    sl.Add('  if Length(' + keyVar + ') = 0 then');
    sl.Add('  begin');
    sl.Add('    for ' + loopVar + ' := 0 to High(s) do Result[' + loopVar + '+1] := Chr(s['+ loopVar +']);');
    sl.Add('    Exit;');
    sl.Add('  end;');
    sl.Add('  for ' + loopVar + ' := 0 to High(s) do');
    sl.Add('  begin');
    sl.Add('    Result[' + loopVar + '+1] := Chr(s[' + loopVar + '] xor Ord(' + keyVar + '[(' + loopVar + ' mod Length(' + keyVar + ')) + 1]));');
    sl.Add(junkCode);
    sl.Add('  end;');
    sl.Add('end;');
    Result := sl.Text;
  finally
    sl.Free;
  end;
end;

var
  Files: TStringList;
  MapOrig, MapNew: TStringList;
  Response: string;
  namesToSkip: TStringList;
  aName: string;
  i: Integer;

begin
  InitKeywords;
  ParseArgs;
  if GSeedGiven then RandSeed := GSeed else Randomize;

  // Generate a random XOR key for this run
  SetLength(GXorKey, 16);
  for i := 1 to Length(GXorKey) do
    GXorKey[i] := Chr(Random(94) + 33); // Printable ASCII chars

  // Generate the polymorphic function ONCE for this run
  GPolymorphicFuncCode := GeneratePolymorphicXorStr;

  if GInplace then
  begin
    WriteLn('WARNING: The --inplace flag will overwrite your files in place.');
    WriteLn('           A .bak is created then removed on success.');
    Write('Proceed? [y/N]: ');
    ReadLn(Response);
    if not (AnsiSameText(Response, 'y') or AnsiSameText(Response, 'yes')) then
      Halt(0);
  end;

  PublicNames  := TStrSet.Create;
  DeclaredHere := TStrSet.Create;
  SkipNames    := TStrSet.Create;
  Files := TStringList.Create;
  MapOrig := TStringList.Create;
  MapNew := TStringList.Create;
  namesToSkip := TStringList.Create;

  try
    // The name is now random, but we add the base name to the skip list
    // to avoid renaming any legitimate functions that happen to be called 'XorStr'.
    SkipNames.Add('XorStr');

    if GSkipNamesArg <> '' then
    begin
      namesToSkip.CommaText := GSkipNamesArg;
      for aName in namesToSkip do
        SkipNames.Add(aName);
    end;

    SplitExtPasFiles(GRoot, Files, True);
    if Files.Count = 0 then
    begin
      WriteLn('No .pas/.pp files found under ', GRoot);
      Halt(2);
    end;

    WriteLn('Collecting names to protect from obfuscation...');
    InitSkipList;
    CollectIdentifierLikeStrings(Files);
    CollectWrapperVarsFromGetProcAddress(Files);
    CollectTypeNames(Files);
    CollectAllPublicNames(Files);
    WriteLn('Collecting all declared identifiers...');
    CollectDeclaredHere(Files);
    WriteLn('Building obfuscation map...');
    BuildMap(Files, MapOrig, MapNew);

    if not GInplace then
      SaveMapCsv(GRoot, MapOrig, MapNew);

    RewriteAll(Files, MapOrig, MapNew, GInplace);

    WriteLn('Done.');
    WriteLn('String literals were encrypted with key: ', GXorKey);
    if not GInplace then
      WriteLn('Map written to ', IncludeTrailingPathDelimiter(GRoot), 'obf_map.csv');
  finally
    PublicNames.Free;
    DeclaredHere.Free;
    SkipNames.Free;
    Files.Free;
    MapOrig.Free;
    MapNew.Free;
    namesToSkip.Free;
  end;
end.