excunmangle.pas

一个异常处理的类

unit ExcUnmangle;

{$ASSERTIONS OFF}

{$D-,L-,Y-} // turn off all debug-info
{$R-}       // turn off range checking
{$H+}       // huge strings
{$Q-}       // OVERFLOWCHECKS OFF


{ -------------------------- } interface { -------------------------- }

uses
  SysUtils;

const
        UM_UNKNOWN       = $00000000;

        UM_FUNCTION      = $00000001;
        UM_CONSTRUCTOR   = $00000002;
        UM_DESTRUCTOR    = $00000003;
        UM_OPERATOR      = $00000004;
        UM_CONVERSION    = $00000005;

        UM_DATA          = $00000006;
        UM_THUNK         = $00000007;
        UM_TPDSC         = $00000008;
        UM_VTABLE        = $00000009;
        UM_VRDF_THUNK    = $0000000a;

        UM_KINDMASK      = $000000ff;

        (* Modifier (is it a member, template?). *)

        UM_QUALIFIED     = $00000100;
        UM_TEMPLATE      = $00000200;

        UM_VIRDEF_FLAG   = $00000400;
        UM_FRIEND_LIST   = $00000800;
        UM_CTCH_HNDL_TBL = $00001000;
        UM_OBJ_DEST_TBL  = $00002000;
        UM_THROW_LIST    = $00004000;
        UM_EXC_CTXT_TBL  = $00008000;
        UM_LINKER_PROC   = $00010000;
        UM_SPECMASK      = $0001fc00;

        UM_MODMASK       = $00ffff00;

        (* Some kind of error occurred. *)

        UM_BUFOVRFLW     = $01000000;
        UM_HASHTRUNC     = $02000000;
        UM_ERROR         = $04000000;

        UM_ERRMASK       = $3f000000;

        (* This symbol is not a mangled name. *)

        UM_NOT_MANGLED   = $40000000;

function _UnMangle( Src,Dest: PChar; MaxLen: Integer;
                    QualP,BaseP: PChar; doArgs,IsDelphi: Boolean ): Longint;


{ -------------------------- } implementation { -------------------------- }

type
  EFinishUnmangle = class(Exception);

type
  TParamEntry = record
    targpos: PChar;
    len: Integer;
  end;

  trans = record
    name: PChar;
    symbol: PChar;
  end;

const
  DELPHI4_COMPAT 	= 	1;
  MAXBUFFLEN            =       8192;      (* maximum output length *)
  PTABLE_LEN 		=	36;
  CONTENT_LEN 		=	250;
  QUALIFIER : Char	=	'@';
  ARGLIST   : Char	=	'$';
  TMPLCODE  : Char	=	'%';

(* unmangle(src, dest, maxlen, qualP, baseP, doArgs): Longword

   This is the main entry-point for the unmangler code.  To use it, pass
   the following arguments:

      src      the source buffer, NULL terminated, which contains
               the mangled name.  If this pointer is NULL, unmangle()
        will return UM_NOT_MANGLED.

      dest     the destination buffer.  If this pointer is NULL,
               unmangle() will return UM_ERROR.

      maxlen   the maximum number of bytes which should be output
               to the destination buffer.  Remember to account for
        the NULL that will be output at the end of the mangled
        name.

        It is impossible to know beforehand exactly how long a
        mangled name should be, but due to restrictions in the
        length of linker names, imposed by the OMF format, a
        buffer of at least 2K bytes or longer should always be
        sufficient.

        If the size of the buffer is insufficient, unmangle()
        will return with the flag UM_BUFOVRFLW set in the return
        code.  Any other flags set in the return code will
        reflect whatever information unmangle() was able to
        determine before the overflow occurred.

      qualP    if non-NULL, this argument should point to the address
               of a buffer large enough to contain the qualifier part
               of the unmangled name.  For example, if the unmangled
        name is "foo::bar::baz", then the qualifier would be
        "foo::bar".

        Thus, this buffer should always be at least as large as
        the destination buffer, in order to ensure that memory
        overwrites never occur.

      baseP    if non-NULL, this argument should point to the address
               of a buffer large enough to contain the basename part
        of the unmangled name.  For example, if the unmangled
        name is "foo::bar::baz", then the basename would be
        "baz".  See the documentation of "qualP" for further
        notes on the required length of this buffer.

      doArgs   if this argument is non-0 (aka TRUE), it means that
               when unmangling a function name, its arguments should
        also be unmangled as part of the output name.
        Otherwise, only the name will be unmangled, and not
        the arguments.

   The return code of this function contains a series of flags, some of
   which are mutually exclusive, and some of which represent the status
   of the unmangled name.  These flags are:

        UM_NOT_MANGLED   If the return value equals this flag, then
                  it is the only flag which will be set, all
    other values being irrelevant.

      The kind of symbol (mutually exclusive)

 UM_UNKNOWN       Symbol of unknown type
 UM_FUNCTION      Global function, or member function
 UM_CONSTRUCTOR   Class donstructor function
 UM_DESTRUCTOR    Class destructor function
 UM_OPERATOR      Global operator, or member operator
 UM_CONVERSION    Member conversion operator
 UM_DATA          Class static data member
 UM_THUNK         (16-bit only, no longer used)
 UM_TPDSC         Type descriptor object (RTTI)
 UM_VTABLE        Class virtual table
 UM_VRDF_THUNK    Virtual table thunk (special)

 UM_KINDMASK      This mask can be used to exclude all other
                  flags from the return type, except the
    symbol kind.

      Modifiers (not mutually exclusive)

 UM_QUALIFIED     A member symbol, either of a class or of a
                  namespace
 UM_TEMPLATE      A template specialization symbol

      Modifiers (mutually exclusive)

 UM_VIRDEF_FLAG   Virdef flag (special)
 UM_FRIEND_LIST   Friend list (special)
 UM_CTCH_HNDL_TBL Catch handler table (exception handling)
 UM_OBJ_DEST_TBL  Object destructor table (exception handling)
 UM_THROW_LIST    Throw list (exception handling)
 UM_EXC_CTXT_TBL  Exception context table (exception handling)
 UM_LINKER_PROC   Special linker procedure (#pragma package)

 UM_SPECMASK      Special flags mask.  Use this to extract only
                  these special, mutually exclusive, flags.

 UM_MODMASK       This mask can be used to access any of the
                  symbol modifiers, whether mutually exclusive
    or not.

      Error flags (not mutually exclusive)

 UM_BUFOVRFLW     The output buffer has been overflowed
 UM_HASHTRUNC     The input name was truncated by a hash code
 UM_ERROR         Some other error has occurred

 UM_ERRMASK       Use this mask to examine only the error flags

   Note on exceptional conditions: Sometimes a mangled name does not
   have the correct format.  This can happen if garbage code is passed
   in, or a mangled name from a different, or older product, is used.
   In this case, you will notice a number enclosed in curly-braces at
   the point in the name where the fault was detected.

   For example, a false name like "@foo@$z" will generate an error like
   "foo::begin853end...", because "$z" does not represent a valid special
   function name.  In this case, the number 853 represents the line in
   UM.C where the error was found.

   If you are debugging a problem with unmangling in a case where
   examining the mangled name under the debugger is not convenient, you
   can tell the unmangler to output the mangled form of the name in the
   output buffer by setting the environment variable SHOW_TROUBLED_NAME
   to any textual value.  In that case, the output buffer for the
   example above would contain the string "foo::begin853: @foo@$zend".

   Lastly, this code is subject to change at any time.  Although Inprise
   intends to keep the API and function signature intact from release to
   release, nothing is guaranteed.  Making this source code visible in
   no wise implies any guarantee as to its functionality or accuracy.
   Caveat Programmor.
*)

function _UnMangle( src,dest: PChar; maxlen: Integer; qualP,baseP: PChar; doArgs,IsDelphi: Boolean ): Longint;
var
 source: PChar;  (* current input source *)
 srcbase: PChar;  (* beginning of input source *)
 srcindx: Integer;  (* beginning of input source *)
 target: PChar;  (* current output location *)
 targbase: PChar;  (* beginning of output *)
 namebase: PChar;  (* beginning of 'name' *)
 targend: PChar;  (* end of output *)
 qualend: PChar;  (* qualified part of name *)
 prevqual: PChar;  (* qualified part of name *)
 basename: PChar;  (* base part of name *)
 base_end: PChar;  (* end of base name *)
 set_qual: Boolean;  (* setup the qualifier name? *)
 adjust_quals: Boolean; (* adjust the qualifier pos? *)
 kind: Cardinal;
 buff: array[0..MAXBUFFLEN-1] of Char;
 vtbl_flags: array[0..256-1] of Char;

(* The mangler, when mangling argument types, will create backreferences
   if the type has already been seen.  These take the form t?, where ?
   can be either 0-9, or a-z. *)

// ---------------------------------------------------------------------------

function input: Char;
begin
  if srcindx > CONTENT_LEN then
    begin
      kind := kind or UM_HASHTRUNC;
      raise EFinishUnmangle.Create('');
    end
  else
    Result := source^;
end;

function advance: Char;
begin
  Inc(source);
  Inc(srcindx);
  Result := input;
end;

procedure backup;
begin
  Dec(source);
  Dec(srcindx);
end;

procedure _overflow;
begin
  target^ := #0;
  kind := kind or UM_BUFOVRFLW;
  raise EFinishUnmangle.Create('');
end;

procedure copy_char( c: Char );
begin
  if target <> targend then
    begin
      target^ := c;
      Inc(target);
    end
  else
    _overflow;
end;

procedure copy_class_delimiter;
begin
  if IsDelphi then copy_char('.')
  else
    begin
      copy_char(':');
      copy_char(':');
    end;
end;

procedure copy_string( p: PChar; len: Integer );
begin
 if len = 0 then len := strlen(p);

 if len <= targend - target then
   begin
    Move( p^, target^, len );
    Inc(target,len);
   end
 else
   begin
    len := targend - target;
    Move( p^, target^, len );
    Inc(target,len);
    target^ := #0;
    kind := kind or UM_BUFOVRFLW;
    raise EFinishUnmangle.Create('');
   end
end;


const
  table: array[0..42] of trans = (
   (name: 'add';  symbol: '+'  ), (name: 'adr'; symbol: '&' ),  (name: 'and' ; symbol: '&' ),
   (name: 'asg';  symbol: '='  ),  (name: 'land'; symbol: '&&' ), (name: 'lor' ; symbol: '||' ),
   (name: 'call'; symbol: '()' ), (name: 'cmp' ; symbol: '~' ), (name: 'fnc' ; symbol: '()' ),
   (name: 'dec';  symbol: '--' ), (name: 'dele'; symbol: 'delete' ), (name: 'div' ; symbol: '/' ),
   (name: 'eql';  symbol: '==' ), (name: 'geq' ; symbol: '>=' ), (name: 'gtr' ; symbol: '>' ),
   (name: 'inc';  symbol: '++' ), (name: 'ind' ; symbol: '*' ), (name: 'leq' ; symbol: '<=' ),
   (name: 'lsh';  symbol: '<<' ), (name: 'lss' ; symbol: '<' ), (name: 'mod' ; symbol: '%' ),
   (name: 'mul';  symbol: '*'  ), (name: 'neq' ; symbol: '!=' ), (name: 'new' ; symbol: 'new' ),
   (name: 'not';  symbol: '!'  ), (name: 'or'  ; symbol: '|' ), (name: 'rand'; symbol: '&=' ),
   (name: 'rdiv'; symbol: '/=' ), (name: 'rlsh'; symbol: '<<=' ), (name: 'rmin'; symbol: '-=' ),
   (name: 'rmod'; symbol: '%=' ), (name: 'rmul'; symbol: '*=' ), (name: 'ror' ; symbol: '|=' ),
   (name: 'rplu'; symbol: '+=' ), (name: 'rrsh'; symbol: '>>=' ), (name: 'rsh' ; symbol: '>>' ),
   (name: 'rxor'; symbol: '^=' ), (name: 'subs'; symbol: '[]' ), (name: 'sub' ; symbol: '-' ),
   (name: 'xor';  symbol:  '^' ), (name: 'arow'; symbol: '->'),  (name: 'nwa';  symbol: 'new[]' ),
   (name: 'dla'; symbol: 'delete[]' )
  );

procedure copy_op( src: PChar );
var
  i: Integer;
begin
  for i := Low(table) to High(table) do
    if StrComp(table[i].name, src ) = 0 then
      begin
        copy_string(table[i].symbol, 0);
        Exit;
      end;
  (* not found -> error (presumably truncated) *)
  raise EFinishUnmangle.Create('');
end;

procedure copy_until1( end1: Char );
var
  c: Char;
begin
 c := input;
 while (c <> #0) and (c <> end1) do
   begin
     copy_char(c);
     c := advance;
   end;
end;

procedure copy_until2( end1,end2: Char );
var
  c: Char;
begin
 c := input;
 while (c <> #0) and (c <> end1) and (c <> end2) do
   begin
     copy_char(c);
     c := advance;
   end;
end;

procedure copy_name(tmplname: Boolean); forward;
procedure copy_args(argsend: char; tmplargs: Boolean); forward;
procedure copy_type(start: PChar; arglvl: Boolean); forward;

procedure copy_return_type( start,callconv,regconv: PChar; process_return: Integer );
var
  ret_type: PChar;
  ret_len: Integer;
begin
  (* Process the return type of a function, and shuffle the output
     text around so it looks like the return type came first.  *)

  ret_type := target;

  if process_return <> 0 then
    begin
      copy_type(target, False);
      copy_char(' ');
     end;

  if callconv <> nil then copy_string(callconv, 0);
  if regconv  <> nil then copy_string(regconv, 0);

  ret_len  := target - ret_type;

  (* Set up the return type to have a space after it. *)

  assert(ret_len < MAXBUFFLEN);
  StrLCopy(buff, ret_type, ret_len);
  StrMove(start + ret_len, start, ret_type - start);
  StrMove(start, buff, ret_len);

  (* If we are inserting this return type at the very beginning of
           a string, it means the location of all the qualifier names is
           about to move. *)

  if adjust_quals then
    begin
      if namebase <> nil then Inc(namebase, ret_len);
      if qualend  <> nil then Inc(qualend,  ret_len);
      if prevqual <> nil then Inc(prevqual, ret_len);
      if basename <> nil then Inc(basename, ret_len);
      if base_end <> nil then Inc(base_end, ret_len);
    end;
end;

{$HINTS OFF}
procedure copy_type(start: PChar; arglvl: Boolean);
label
  HANDLE_TYPE;
var
 p,name,tname: PChar;
 is_const,is_volatile,is_signed,is_unsigned,maxloop: Integer;
 i,len: Integer;
 c,savechar: char;
 dims: array[0..90-1] of Char;
 callconv,regconv: PChar;
 hasret: Integer;
 save_adjqual: Boolean;
begin
 tname       := nil;
 c           := input;
 is_const    := 0;
 is_volatile := 0;
 is_signed   := 0;
 is_unsigned := 0;
 maxloop     := 100;

 while True do    (* emit type qualifiers *)
   begin
    assert(--maxloop > 0);

    case c of
      'u': is_unsigned := 1;
      'z': is_signed   := 1;
      'x': is_const    := 1;
      'w': is_volatile := 1;

      'y': (* 'y' for closure is followed by 'f' or 'n' *)
          begin
            c := advance;
            assert((c = 'f') or (c = 'n'));
            copy_string('__closure', 9);
          end;
      else
          goto HANDLE_TYPE;
    end;

    c := advance();
   end;