}

Delphi.int.ru — Портал программистов

Вход Регистрация | Забыли пароль?

Просмотр кода

Идентификатор: c152eaca Описание: EClasses.pas Код загружен: 3 июля 2011, 17:21 (mirt.steelwater)

  1. unit EClasses;
  2. {******************************************************************************}
  3. {* Unit to work with Exceptions in the Classes *}
  4. {* Class declaration, the owner of an exception *}
  5. {* must be declared with the directive $M+ *}
  6. {* Revolutionary Confederation of Anarcho Syndicalists *}
  7. {* Written by: black.rabbit 2010 *}
  8. {******************************************************************************}
  9. interface
  10.  
  11. {$I 'std.inc'}
  12.  
  13. uses
  14. Windows, SysUtils, TypInfo,
  15. VarRecs;
  16.  
  17. type
  18. {$M+}
  19. EClass = class (Exception)
  20. private
  21. f_EGUID: String; { уникальный идентификатор исключения }
  22.   protected
  23.  
  24. protected
  25. procedure SetEGUID (const aValue: String);
  26. public
  27. constructor Create (anArgs: array of const;
  28. const anEGUID: String = ''); overload;
  29. constructor Create (anArgs: array of const;
  30. anEGUID: array of const); overload;
  31. property EGUID: String read f_EGUID write SetEGUID;
  32. end;
  33. {tionMessage (const aValue: TVarRec) : String;
  34.  
  35. function RaiseErrorInClass (doRaise: Boolean;
  36.   anArgs: array of const;
  37.   const anEGUID: String = '') : String;
  38.  
  39. implementation
  40.  
  41. function toExceptionMessage (const aValue: TVarRec) : String;
  42. begin
  43.   Result := '';
  44.   with aValue do
  45.   try
  46.   case VType of
  47.   vtObject: if VObject.InheritsFrom (Exception) then
  48.   Result := Exception (VObject).Message
  49.   else
  50.   Result := VObject.ClassName;
  51.   else Result := toString (aValue);
  52.   end;
  53.   except
  54.   Result := 'Unknown Error';
  55.   end;
  56. end;
  57.  
  58. function RaiseErrorInClass (doRaise: Boolean;
  59.   anArgs: array of const;
  60.   const anEGUID: String = '') : String;
  61. var
  62.   I : Integer;
  63.  
  64.   { функция определения исполняемого модуля приложения }
  65.   function GetClassPackageName (aClass: TClass) : St
  66. function GetClassPackageName (aClass: TClass) : String;
  67. var
  68. M : TMemoryBasicInformation;
  69. begin
  70. {M, SizeOf (M) );
  71.   SetLength (Result,MAX_PATH+1);
  72.   { если это не главная программа }
  73.   if ( hModule (M.AllocationBase) <> hInstance ) then
  74.   begin
  75.   GetModuleFil
  76. if ( hModule (M.AllocationBase) <> hInstance ) then
  77. begin
  78. GetModuleFileName ( hModule (M.AllocationBase), PChar (Result), MAX_PATH );
  79. SetLength ( Result, StrLen ( PChar (Result) ) );
  80. Result := ExtractFileName (Result);
  81. end
  82. else
  83. Result := ExtractFileName ( ParamStr (0) );
  84. end;
  85.  
  86. {r;
  87.   begin
  88.   Result := 'Unknown';
  89.   C := aClass.ClassInfo;
  90.   if Assigned (C) then
  91.   Result := GetTypeData (C).UnitName;
  92.   end;
  93.  
  94. begin
  95.   Result := '';
  96.   for I := Low (anArgs) to High (anArgs) do
  97.   with anArgs [I] do
  98.   begin
  99.   { первый параметр - класс, в котором возникло исключение }
  100.   if ( I = 0 ) then
  101.   begin
  102.   case VType of
  103.   vtClass: Result := Format( '%s::%s::%s',[ GetClassPackageName (VClass),
  104.  
  105. if ( I = 0 ) then
  106. begin
  107. case VType of
  108. vtClass: Result := Format( '%s::%s::%s',[ GetClassPackageName (VClass),
  109. GetClassUnitName (VClass),
  110. VClass.ClassName ] );
  111. vtObject: if VObject.InheritsFrom (Exception) then
  112. Result := Exception (VObject).Message
  113. else
  114. Result := Format( '%s::%s::%s',[ GetClassPackageName (VObject.ClassType),
  115. GetClassUnitName (VObject.ClassType),
  116. VObject.ClassName ] );
  117. else Result := toExceptionMessage (anArgs [I]);
  118. end;
  119. end
  120. {Char]);
  121.   vtString: Result := Format ('%s.%s',[Result,VString^]);
  122.   vtPChar: Result := Format ( '%s.%s',[ Result, StrPas (VPChar) ] );
  123.   vtAnsiString: Result := Format ( '%s.%s',[ Result, String (VAnsiString) ] );
  124.   vtWideChar: Result := Format ( '%s.%s',[ Result, Char (VWideChar) ] );
  125.   vtPWideChar: Result := Format ( '%s.%s',[ Result, WideCharToString (VPWideChar) ] );
  126.   vtWideString: Result := Format ( '%s.%s',[ Result, WideCharToString (VWideString) ] );
  127.   vtVariant: Result := Format ('%s.%s',[Result,VVariant^]);
  128.   else Result := Format ( '%s : '#13#10'%s',[ Result, toExceptionMessage (anArgs [I]) ] );
  129.   end;
  130.   end
  131.   { остальные параметры - текстовые сообщения или экземпляры класса исключения }
  132.   else
  133.   Result := Format ( '%s : '#13#10'%s',[ Result, toExceptionMessage (anArgs [I]) ] );
  134.   end;
  135.   { уникальный идентификатор исключения }
  136.   if ( anEGUID <> '' ) then
  137.   Result := Format ('%s'#13#10'%s',[anEGUID,Result]);
  138.   if doRaise then
  139.  
  140. else
  141. Result := Format ( '%s : '#13#10'%s',[ Result, toExceptionMessage (anArgs [I]) ] );
  142. end;
  143. {_CASE}
  144.   f_EGUID := UpperCase (aValue);
  145.   {$ELSE}
  146.   f_EGUID := LowerCase (aValue);
  147.   {$ENDIF HEX_UPPER_CASE}
  148. end;
  149.  
  150. constructor EClass.Create (anArgs: array of const;
  151.   const anEGUID: String = '');
  152. begin
  153.   EGUID := anEGUID;
  154.   inherited Create
  155. f_EGUID := UpperCase (aValue);
  156. {) );
  157. end;
  158.  
  159. constructor EClass.Create (anArgs: array of const;
  160.   anEGUID: array of const);
  161. var
  162.   I : Integer;
  163. begin
  164.   EGUID := '';
  165.   for I := Low (anEGUID) to High (anEGUID) do
  166.   EGUID := Format ('%s%s',[ EGUID, toString (anEGUID [I]) ]);
  167.   inherited Create ( RaiseErrorInClass (FALSE,anArgs,EGUID) );
  168. end;
  169.  
  170. end.</code>

Ссылка на данный код:

На главную страницу сервиса обмена кодом »