The Road to Delphi

Delphi – Free Pascal – Oxygene


18 Comments

Using the Google Translate API V2 (Labs) from Delphi

UPDATE

The Google Translate API has been officially deprecated  an alternative  is the Microsoft Translator V2, check this article for more details.

 

In this post i will show you how work with the Google Translate API V2 (Labs),  this API lets you automatically translates text from one language to another.

Disclaimer

  • This version of the Google Translate API is in Labs, and its features might change unexpectedly until it graduates.
  • The Google Translate API requires the use of an API key, which you can get from the Google APIs console
  • Before to use this API check the Google Translate API Terms of Use.

To use the Google Translate API you must send a HTTP GET request to its URI.

The URI for a request has the following format:

https://www.googleapis.com/language/translate/v2?parameters

Example to making a request to translate the Hello World text from English (en) to Spanish (es) the URI must be constructed in this way

https://www.googleapis.com/language/translate/v2?key=INSERT-YOUR-KEY&source=en&target=es&q=Hello%20world

The response in JSON format will be

{"data":{"translations":[{"translatedText":"Hola Mundo"}]}}

To activate the auto-detection of the source language you must avoid the use of the source keyword

https://www.googleapis.com/language/translate/v2?key=INSERT-YOUR-KEY&target=es&q=Hello%20world

and the JSON response in this case will be

{"data":{"translations":[{"translatedText":"Hola a todos","detectedSourceLanguage":"en"}]}

if you pass incorrect parameters the response will look like this

{"error":{"errors":[{"domain":"global","reason":"invalid","message":"Invalid Value"}],"code":400,"message":"Invalid Value"}}

some conversions between languages are not allowed by the API, in thi case you will get a response of this type

{"error":{"errors":[{"domain":"global","reason":"badRequest","message":"Bad language pair: en|zh-TW"}],"code":400,"message":"Bad language pair: en|zh-TW"}}

Now I will show 3 ways to process the data

Using the JSON – SuperObject , this library is very well written and is very easy to use, also is compatible with olders versions of Delphi and Freepascal (win32/64 linux32/64).

function Translate_JSONsuperobject(const Text:string;Source,Dest:TGoogleLanguages):string;
var
  XMLHTTPRequest: IXMLHTTPRequest;
  EncodedRequest: string;
  Response      : string;
begin
  Result:='';
  if Source=Autodetect then //build the URI
    EncodedRequest:=Format(GoogleTranslateUrlAuto,[GoogleLanguageApiKey,GoogleLanguagesArr[Dest],HTTPEncode(Text)])
  else
    EncodedRequest:=Format(GoogleTranslateUrl,[GoogleLanguageApiKey,HTTPEncode(Text),GoogleLanguagesArr[Source],GoogleLanguagesArr[Dest]]);

  XMLHTTPRequest := CoXMLHTTP.Create;
  XMLHTTPRequest.open('GET', EncodedRequest, False, EmptyParam, EmptyParam); //Make the request
  XMLHTTPRequest.send('');
  Response:=XMLHTTPRequest.responseText;
  if Response<>'' then
  begin
    if SO(Response)['error']=nil then //all ok
     Result := SO(Response)['data.translations[0].translatedText'].AsString
    else //exist an error response
     Result := Format('Error Code %d message %s',[SO(Response)['error.code'].AsInteger,SO(Response)['error.message'].AsString]);
     Result:=HTMLDecode(Result);
  end;

end;

Using the DBXJSON unit included since Delphi 2010

function Translate_DBXJSON(const Text:string;Source,Dest:TGoogleLanguages):string;
var
  XMLHTTPRequest: IXMLHTTPRequest;
  EncodedRequest: string;
  json          : TJSONObject;
  jPair         : TJSONPair;
  jValue        : TJSONValue;
  Response      : string;
begin
  Result:='';
  if Source=Autodetect then //buil the URI
    EncodedRequest:=Format(GoogleTranslateUrlAuto,[GoogleLanguageApiKey,GoogleLanguagesArr[Dest],HTTPEncode(Text)])
  else
    EncodedRequest:=Format(GoogleTranslateUrl,[GoogleLanguageApiKey,HTTPEncode(Text),GoogleLanguagesArr[Source],GoogleLanguagesArr[Dest]]);

  XMLHTTPRequest := CoXMLHTTP.Create;
  XMLHTTPRequest.open('GET', EncodedRequest, False, EmptyParam, EmptyParam); //make the request
  XMLHTTPRequest.send('');
  Response:=XMLHTTPRequest.responseText;

  if Response<>'' then
  begin
      json    := TJSONObject.ParseJSONValue(TEncoding.ASCII.GetBytes(Response),0) as TJSONObject; //create a TJSONObject instance
    try
      jPair   := json.Get(0);
      if jPair.JsonString.value='error' then //if error in response
        Result := Format('Error Code %s message %s',[TJSONObject(jPair.JsonValue).Get(1).JsonValue.Value,TJSONObject(jPair.JsonValue).Get(2).JsonValue.Value])
      else //all ok, show the response,
      begin
        jValue := TJSONArray(TJSONObject(jPair.JsonValue).Get(0).JsonValue).Get(0);
        Result := TJSONObject(jValue).Get(0).JsonValue.Value;
      end;
    finally
       json.Free;
    end;

      Result:=HTMLDecode(Result);
  end;
end;

and finally without using JSON, a very ugly way, but works.

function Translate_JSONLess(const Text:string;Source,Dest:TGoogleLanguages):string;
const
  TagIOk='{"data":{"translations":[{"translatedText":"';
  TagFOk='"}]}}';
  TagErr='{"error":{"errors":[{';
  TagAut=',"detectedSourceLanguage":"';
var
  XMLHTTPRequest: IXMLHTTPRequest;
  EncodedRequest: string;
  Response      : string;
begin
  Result:='';

  if Source=Autodetect then //build the URI
    EncodedRequest:=Format(GoogleTranslateUrlAuto,[GoogleLanguageApiKey,GoogleLanguagesArr[Dest],HTTPEncode(Text)])
  else
    EncodedRequest:=Format(GoogleTranslateUrl,[GoogleLanguageApiKey,HTTPEncode(Text),GoogleLanguagesArr[Source],GoogleLanguagesArr[Dest]]);

  XMLHTTPRequest := CoXMLHTTP.Create;
  XMLHTTPRequest.open('GET', EncodedRequest, False, EmptyParam, EmptyParam); //make the request
  XMLHTTPRequest.send('');
  Response:=XMLHTTPRequest.responseText;
  if Response<>'' then
  begin
    if StartsStr(TagErr,(Response)) then  //Response  Error
    begin
      Result:='Error'
    end
    else
    begin  //Response Ok
      if Source=Autodetect then
      begin
        Result:=StringReplace(Response,TagIOk,'',[rfReplaceAll]); //remove tags
        Result:=Copy(Result,1,Pos(TagAut,Result)-2);//remove tags
      end
      else
      begin
        Result:=StringReplace(Response,TagIOk,'',[rfReplaceAll]);//remove tags
        Result:=StringReplace(Result,TagFOk,'',[rfReplaceAll]);//remove tags
      end;
    end;

    Result:=HTMLDecode(Result);
  end;
end;

Check the full source showing the 3 ways to access the Google Translate API, listed in this entry.

program GoogleAPITranslate;
//Author  : Rodrigo Ruz V. 2010-12-03  03;30 A.M

{$APPTYPE CONSOLE}
{$DEFINE USE_SUPER_OBJECT}
{$DEFINE USE_DBXJSON}
{$DEFINE USE_JSONLess}

uses
   msxml
  ,Activex
  ,HTTPApp
  ,Variants
  ,SysUtils
  {$IFDEF USE_JSONLess}
  ,StrUtils
  {$ENDIF}
  {$IFDEF USE_SUPER_OBJECT}
  ,superobject
  {$ENDIF}
  {$IFDEF USE_DBXJSON}
  ,DBXJSON
  {$ENDIF}
  ;

  type
  TGoogleLanguages=
  (Autodetect,Afrikaans,Albanian,Arabic,Basque,Belarusian,Bulgarian,Catalan,Chinese,Chinese_Traditional,
  Croatian,Czech,Danish,Dutch,English,Estonian,Filipino,Finnish,French,Galician,German,Greek,
  Haitian_Creole,Hebrew,Hindi,Hungarian,Icelandic,Indonesian,Irish,Italian,Japanese,Latvian,
  Lithuanian,Macedonian,Malay,Maltese,Norwegian,Persian,Polish,Portuguese,Romanian,Russian,
  Serbian,Slovak,Slovenian,Spanish,Swahili,Swedish,Thai,Turkish,Ukrainian,Vietnamese,Welsh,Yiddish);

  const
  GoogleLanguagesArr : array[TGoogleLanguages] of string =
  ( 'Autodetect','af','sq','ar','eu','be','bg','ca','zh-CN','zh-TW','hr','cs','da','nl','en','et','tl','fi','fr','gl',
    'de','el','ht','iw','hi','hu','is','id','ga','it','ja','lv','lt','mk','ms','mt','no','fa','pl','pt',
    'ro','ru','sr','sk','sl','es','sw','sv','th','tr','uk','vi','cy','yi');

  //¡¡¡¡¡¡Please be nice and create your own Google Api Key ¡¡¡¡¡¡¡
  GoogleLanguageApiKey   ='AIzaSyDb18pd1IfkYyupC2XUIANcRoB3f9J2DJg';
  GoogleTranslateUrl     ='https://www.googleapis.com/language/translate/v2?key=%s&q=%s&source=%s&target=%s';
  GoogleTranslateUrlAuto ='https://www.googleapis.com/language/translate/v2?key=%s&target=%s&q=%s';

{$IFDEF USE_DBXJSON}
function Translate_DBXJSON(const Text:string;Source,Dest:TGoogleLanguages):string;
var
  XMLHTTPRequest: IXMLHTTPRequest;
  EncodedRequest: string;
  json          : TJSONObject;
  jPair         : TJSONPair;
  jValue        : TJSONValue;
  Response      : string;
begin
  Result:='';
  if Source=Autodetect then
    EncodedRequest:=Format(GoogleTranslateUrlAuto,[GoogleLanguageApiKey,GoogleLanguagesArr[Dest],HTTPEncode(Text)])
  else
    EncodedRequest:=Format(GoogleTranslateUrl,[GoogleLanguageApiKey,HTTPEncode(Text),GoogleLanguagesArr[Source],GoogleLanguagesArr[Dest]]);

  XMLHTTPRequest := CoXMLHTTP.Create;
  XMLHTTPRequest.open('GET', EncodedRequest, False, EmptyParam, EmptyParam);
  XMLHTTPRequest.send('');
  Response:=XMLHTTPRequest.responseText;

  if Response<>'' then
  begin
      json    := TJSONObject.ParseJSONValue(TEncoding.ASCII.GetBytes(Response),0) as TJSONObject;
    try
      jPair   := json.Get(0);
      if jPair.JsonString.value='error' then
        //{"error":{"errors":[{"domain":"global","reason":"invalid","message":"Invalid Value"}],"code":400,"message":"Invalid Value"}}
        Result := Format('Error Code %s message %s',[TJSONObject(jPair.JsonValue).Get(1).JsonValue.Value,TJSONObject(jPair.JsonValue).Get(2).JsonValue.Value])
      else
      begin
        //{"data":{"translations":[{"translatedText":"Hola a todos","detectedSourceLanguage":"en"}]}}
        jValue := TJSONArray(TJSONObject(jPair.JsonValue).Get(0).JsonValue).Get(0);
        Result := TJSONObject(jValue).Get(0).JsonValue.Value;
      end;
    finally
       json.Free;
    end;

      Result:=HTMLDecode(Result);
  end;
end;
{$ENDIF}

{$IFDEF USE_SUPER_OBJECT}
function Translate_JSONsuperobject(const Text:string;Source,Dest:TGoogleLanguages):string;
var
  XMLHTTPRequest: IXMLHTTPRequest;
  EncodedRequest: string;
  Response      : string;
begin
  Result:='';
  if Source=Autodetect then
    EncodedRequest:=Format(GoogleTranslateUrlAuto,[GoogleLanguageApiKey,GoogleLanguagesArr[Dest],HTTPEncode(Text)])
  else
    EncodedRequest:=Format(GoogleTranslateUrl,[GoogleLanguageApiKey,HTTPEncode(Text),GoogleLanguagesArr[Source],GoogleLanguagesArr[Dest]]);

  XMLHTTPRequest := CoXMLHTTP.Create;
  XMLHTTPRequest.open('GET', EncodedRequest, False, EmptyParam, EmptyParam);
  XMLHTTPRequest.send('');
  Response:=XMLHTTPRequest.responseText;
  if Response<>'' then
  begin
  //{"data":{"translations":[{"translatedText":"Hola a todos","detectedSourceLanguage":"en"}]}}
    if SO(Response)['error']=nil then
     Result := SO(Response)['data.translations[0].translatedText'].AsString
    else
     //{"error":{"errors":[{"domain":"global","reason":"invalid","message":"Invalid Value"}],"code":400,"message":"Invalid Value"}}
     //{"error":{"errors":[{"domain":"global","reason":"badRequest","message":"Bad language pair: en|zh-TW"}],"code":400,"message":"Bad language pair: en|zh-TW"}}
     Result := Format('Error Code %d message %s',[SO(Response)['error.code'].AsInteger,SO(Response)['error.message'].AsString]);
     Result:=HTMLDecode(Result);
  end;

end;
{$ENDIF}

{$IFDEF USE_JSONLess}
function Translate_JSONLess(const Text:string;Source,Dest:TGoogleLanguages):string;
const
  TagIOk='{"data":{"translations":[{"translatedText":"';
  TagFOk='"}]}}';
  TagErr='{"error":{"errors":[{';
  TagAut=',"detectedSourceLanguage":"';
var
  XMLHTTPRequest: IXMLHTTPRequest;
  EncodedRequest: string;
  Response      : string;
begin
  Result:='';

  if Source=Autodetect then
    EncodedRequest:=Format(GoogleTranslateUrlAuto,[GoogleLanguageApiKey,GoogleLanguagesArr[Dest],HTTPEncode(Text)])
  else
    EncodedRequest:=Format(GoogleTranslateUrl,[GoogleLanguageApiKey,HTTPEncode(Text),GoogleLanguagesArr[Source],GoogleLanguagesArr[Dest]]);

  XMLHTTPRequest := CoXMLHTTP.Create;
  XMLHTTPRequest.open('GET', EncodedRequest, False, EmptyParam, EmptyParam);
  XMLHTTPRequest.send('');
  Response:=XMLHTTPRequest.responseText;
  if Response<>'' then
  begin
    if StartsStr(TagErr,(Response)) then  //Response  Error
    begin
      Result:='Error'
    end
    else
    begin  //Response Ok
      if Source=Autodetect then
      begin
        Result:=StringReplace(Response,TagIOk,'',[rfReplaceAll]);
        Result:=Copy(Result,1,Pos(TagAut,Result)-2);
      end
      else
      begin
        Result:=StringReplace(Response,TagIOk,'',[rfReplaceAll]);
        Result:=StringReplace(Result,TagFOk,'',[rfReplaceAll]);
      end;
    end;

    Result:=HTMLDecode(Result);
  end;
end;
{$ENDIF}

Const
 Text ='"Hello  World"';
Var
 TranslatedText : string;
begin
  try
    CoInitialize(nil);
    try
       {$IFDEF USE_JSONLess}
       Writeln('Without JSON (very ugly)');
       Writeln('');
       TranslatedText:=Translate_JSONLess(Text,Autodetect,Spanish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONLess(Text,English,Chinese_Traditional);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONLess(Text,English,German);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONLess(Text,English,Danish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONLess(Text,English,Portuguese);
       Writeln(TranslatedText);
       Writeln('');
       {$ENDIF}

       {$IFDEF USE_SUPER_OBJECT}
       Writeln('Using the superobject library');
       Writeln('');
       TranslatedText:=Translate_JSONsuperobject(Text,Autodetect,Spanish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONsuperobject(Text,English,Chinese_Traditional);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONsuperobject(Text,English,German);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONsuperobject(Text,English,Danish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONsuperobject(Text,English,Portuguese);
       Writeln(TranslatedText);
       Writeln('');
       {$ENDIF}

       {$IFDEF USE_DBXJSON}
       Writeln('Using the DBXJSON unit');
       Writeln('');
       TranslatedText:=Translate_DBXJSON(Text,Autodetect,Spanish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_DBXJSON(Text,English,Chinese_Traditional);
       Writeln(TranslatedText);
       TranslatedText:=Translate_DBXJSON(Text,English,German);
       Writeln(TranslatedText);
       TranslatedText:=Translate_DBXJSON(Text,English,Danish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_DBXJSON(Text,English,Portuguese);
       Writeln(TranslatedText);
       Writeln('');
       {$ENDIF}

    finally
     CoUninitialize;
    end;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.
Check this link  <a href=”http://code.google.com/apis/language/translate/terms.html&#8221; rel=”nofollow”>Google Translate API Terms of Use</a>.


7 Comments

Building a traceroute application with IP geolocation using Delphi

Using the free service of ip geolocation provided by http://ipinfodb.com/ , you can do very cool things.

See this sample wich intregrates a trace route and the ip geolocation, to obtain the location of every server included in the trace of an ip address.

First we define the stucture to contain the geolocation data

type
 TGeoInfo   = record
  Status        : string;
  CountryCode   : string;
  CountryName   : string;
  RegionCode    : string;
  City          : string;
  ZipPostalCode : string;
  Latitude      : double;
  Longitude     : double;
  TimezoneName  : string;
  Gmtoffset     : string;
  Isdst         : string;
  function LatitudeToString:string;
  function LongitudeToString:string;
 end;

function TGeoInfo.LatitudeToString: string; //this helper function retrieve the latitute as a string, forcing the decimal separator to a dot
var
  FormatSettings: TFormatSettings;
begin
  FormatSettings.DecimalSeparator:='.';
  result:=FloatToStr(Latitude,FormatSettings);
end;

function TGeoInfo.LongitudeToString: string;//this helper function retrieve the longitude as a string, forcing the decimal separator to a dot
var
  FormatSettings: TFormatSettings;
begin
  FormatSettings.DecimalSeparator:='.';
  result:=FloatToStr(Longitude,FormatSettings);
end;

Now the function to retrieve the geolocation, the url was updated to use the new api published the 2010-11-15.

const
//the key used in this link if only for demo purposes, create your own free key registering in http://ipinfodb.com/
 UrlGeoLookupInfo  ='http://api.ipinfodb.com/v2/ip_query.php?key=a069ef201ef4c1b61231b3bdaeb797b5488ef879effb23d269bda3a572dc704c&ip=%s&timezone=true';

procedure GetGeoInfo(const IpAddress : string;var GeoInfo :TGeoInfo);
var
  lHTTP         : TIdHTTP;
  lStream       : TStringStream;
  XMLDoc        : OleVariant;
  ANode         : OleVariant;
  FormatSettings: TFormatSettings;
  d             : Double;
  Success       : HResult;
begin
  lHTTP   := TIdHTTP.Create(nil);
  lStream := TStringStream.Create('');
  Success := CoInitializeEx(nil, COINIT_MULTITHREADED);//necesary to support MULTITHREAD
  try
      lHTTP.Get(Format(UrlGeoLookupInfo,[IpAddress]), lStream);
      lStream.Seek(0,soFromBeginning);
      XMLDoc := CreateOleObject('Msxml2.DOMDocument.6.0');
      XMLDoc.async := false;
      XMLDoc.LoadXML(lStream.ReadString(lStream.Size));
      XMLDoc.setProperty('SelectionLanguage','XPath');
      ANode:=XMLDoc.selectSingleNode('/Response/Status');
      if not VarIsNull(ANode) then GeoInfo.Status:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/CountryCode');
      if not VarIsNull(ANode) then GeoInfo.CountryCode:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/CountryName');
      if not VarIsNull(ANode) then GeoInfo.CountryName:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/RegionCode');
      if not VarIsNull(ANode) then GeoInfo.RegionCode:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/City');
      if not VarIsNull(ANode) then GeoInfo.City:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/ZipPostalCode');
      if not VarIsNull(ANode) then GeoInfo.ZipPostalCode:=ANode.Text;

      ANode:=XMLDoc.selectSingleNode('/Response/Latitude');
      if not VarIsNull(ANode) then
      begin
        FormatSettings.DecimalSeparator:='.';
        d:=StrToFloat(ANode.Text,FormatSettings);
        GeoInfo.Latitude:=d;
      end;

      ANode:=XMLDoc.selectSingleNode('/Response/Longitude');
      if not VarIsNull(ANode) then
      begin
        FormatSettings.DecimalSeparator:='.';
        d:=StrToFloat(ANode.Text,FormatSettings);
        GeoInfo.Longitude:=d;
      end;

      ANode:=XMLDoc.selectSingleNode('/Response/TimezoneName');
      if not VarIsNull(ANode) then GeoInfo.TimezoneName:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/Gmtoffset');
      if not VarIsNull(ANode) then GeoInfo.Gmtoffset:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/Isdst');
      if not VarIsNull(ANode) then GeoInfo.Isdst:=ANode.Text;
  finally
    lHTTP.Free;
    lStream.Free;
    case Success of
      S_OK, S_FALSE: CoUninitialize;
    end;
  end;
end;

Now using the IcmpCreateFile,IcmpCloseHandle and IcmpSendEcho functions we can write a trace route function.

function IcmpCreateFile: THandle; stdcall; external 'ICMP.DLL' name 'IcmpCreateFile';
function IcmpCloseHandle(IcmpHandle: THandle): BOOL; stdcall;  external 'ICMP.DLL' name 'IcmpCloseHandle';
function IcmpSendEcho(IcmpHandle : THandle; DestinationAddress: Longint;  RequestData: Pointer; RequestSize: Word; RequestOptions: PIP_option_information; ReplyBuffer: Pointer; ReplySize, Timeout: DWORD): DWORD; stdcall;  external 'ICMP.DLL' name 'IcmpSendEcho';

Check the definition of the TGeoTraceThread TThread

  ProcTraceCallBack    = procedure(const ServerName,ServerIp:string) of object;
  ProcTraceLogCallBack = procedure(const Msg:string) of object;
  TGeoTraceThread = class(TThread)
  private
    DestAddr            : in_addr;
    TraceHandle         : THandle;
    FDestAddress        : string;
    FLogString          : string;
    FIcmpTimeOut        : Word;
    FMaxHops            : Word;
    FResolveHostName    : boolean;
    FServerCallBack     : string;
    FServerIpCallBack   : string;
    FCallBack           : ProcTraceCallBack;
    FLogCallBack        : ProcTraceLogCallBack;
    FIncludeGeoInfo     : boolean;
    FGeoInfo            : TGeoInfo;
    function  Trace(const Ttl: Byte): Longint;
    procedure Log;
    procedure IntCallBack;
  public
    procedure Execute; override;
    property  MaxHops : Word read FMaxHops write FMaxHops default 30;
    property  DestAddress : string read FDestAddress write FDestAddress;
    property  IcmpTimeOut : Word read FIcmpTimeOut write FIcmpTimeOut default 5000;
    property  ResolveHostName : boolean read FResolveHostName write FResolveHostName default True;
    property  IncludeGeoInfo : boolean read FIncludeGeoInfo write FIncludeGeoInfo default True;
    property  CallBack : ProcTraceCallBack read FCallBack write FCallBack;
    property  MsgCallBack : ProcTraceLogCallBack read FLogCallBack write FLogCallBack;
  end;

and now the implementation of the TGeoTraceThread TThread, the code was commented to explain the logic of the trace route.

procedure TGeoTraceThread.Execute;
const
  MaxPings = 3;
var
  HostName   : String;
  HostReply  : Boolean;
  HostIP     : LongInt;
  HostEnt    : PHostEnt;
  WSAData    : TWSAData;
  WsaErr     : DWORD;
  OldTick    : DWORD;
  PingTime   : DWORD;
  TraceResp  : Longint;
  Index      : Word;
  FCurrentTTL: Word;
  sValue     : string;
  FGeoInfoStr: string;
  IpAddress  : in_addr;
begin

  WsaErr := WSAStartup($101, WSAData);
  if WsaErr <> 0 then
  begin
    FLogString := SysErrorMessage(WSAGetLastError);
    if Assigned(FLogCallBack)then Synchronize(Log);
    Exit;
  end;

  try
    HostEnt := gethostbyname(PAnsiChar(AnsiString(FDestAddress))); //get the host to trace
    if not Assigned(HostEnt) then
    begin
      FLogString := SysErrorMessage(WSAGetLastError);
      if Assigned(FLogCallBack) then Synchronize(Log);
      Exit;
    end;

    DestAddr     := PInAddr(in_addr(HostEnt.h_addr_list^))^; //get the address of the host to trace
    TraceHandle := IcmpCreateFile;

    if TraceHandle = INVALID_HANDLE_VALUE then
    begin
      FLogString := SysErrorMessage(GetLastError);
      if Assigned(FLogCallBack) then Synchronize(Log);
      Exit;
    end;

    try

      if Assigned(FLogCallBack)then //check if the callback function to log the data is assigned
      begin
        FLogString := Format('Tracing route to %s [%s]',[FDestAddress,string(inet_ntoa(DestAddr))]);
        Synchronize(Log); //Log the data
        FLogString := Format('over a maximum of %d hops ',[FMaxHops]);
        Synchronize(Log);//log the data
      end;

      TraceResp    := 0;
      FCurrentTTL  := 0;

      while (TraceResp <> DestAddr.S_addr) and (FCurrentTTL < FMaxHops) do //begin the trace
      begin
        Inc(FCurrentTTL);
        HostReply := False;
        sValue:='';
        for Index := 0 to MaxPings-1 do // make 3 pings to the current host
        begin
          OldTick   := GetTickCount; //save the current time
          TraceResp := Trace(FCurrentTTL); //do the trace

          if TraceResp = -1 then //check for the response of the trace, -1 indicate a request time-out
            FLogString := '    *    '
          else
          begin
            PingTime   :=GetTickCount - OldTick; //calculate the elapsed time in ms

            if PingTime>0 then
             FLogString := Format('%6d ms', [PingTime])
            else
             FLogString := Format('    <%d ms', [1]);

            HostReply := True;
            HostIP    := TraceResp;
          end;

          if Index = 0 then
            FLogString := Format('%3d %s', [FCurrentTTL, FLogString]);

          sValue:=sValue+FLogString;
        end;

        FLogString:=sValue+' ';

        if HostReply then
        begin
          IpAddress.s_addr :=HostIP;
          sValue :=string(inet_ntoa(IpAddress)); //get the ip address (x.x.x.x) of the current host

          FGeoInfoStr:='';
          if FIncludeGeoInfo then //makes the magic now
          begin
            GetGeoInfo(sValue,FGeoInfo); //get the geolocation info about the current host
            FGeoInfoStr:=Format('(%s,%s) %s-%s TimeZone %s',[FGeoInfo.LongitudeToString,FGeoInfo.LatitudeToString,FGeoInfo.CountryName,FGeoInfo.City,FGeoInfo.TimezoneName]); //construct the string to log the data
          end;

          FServerCallBack  :='';
          FServerIpCallBack:=sValue;
          if FResolveHostName then //only if the property ResolveHostName is Tru try to resolve the current host name
          begin
            HostName         := GetRemoteHostName(HostIP);
            FServerCallBack  := HostName;
            if HostName <> '' then
              FLogString := FLogString + HostName + ' [' + sValue + '] '+FGeoInfoStr
            else
              FLogString := FLogString + sValue +' '+ FGeoInfoStr;
          end
          else
          FLogString := FLogString + sValue+' '+ FGeoInfoStr;

          if Assigned(FCallBack) then Synchronize(IntCallBack);
        end
        else
          FLogString := FLogString+' Request timed out.';

        FLogString := '  ' + FLogString;
        if Assigned(FLogCallBack) then Synchronize(Log);
      end;

    finally
      IcmpCloseHandle(TraceHandle);
    end;

    if Assigned(FLogCallBack) then
    begin
      FLogString := 'Trace complete'; //we are done
      Synchronize(Log);
    end;

  finally
    WSACleanup;
  end;
end;

function TGeoTraceThread.Trace(const Ttl: Byte): Longint;
var
  IPOptionInfo: TIPOptionInformation;
  IcmpEcho    : PIcmpEchoReply;
  IcpmErr     : Integer;
begin
  GetMem(IcmpEcho, SizeOf(TIcmpEchoReply));
  try
    IPOptionInfo.Ttl         := Ttl;
    IPOptionInfo.Tos         := 0;
    IPOptionInfo.Flags       := 0;
    IPOptionInfo.OptionsSize := 0;
    IPOptionInfo.OptionsData := nil;

    IcpmErr := IcmpSendEcho(TraceHandle,DestAddr.S_addr,nil,0,@IPOptionInfo,IcmpEcho,SizeOf(TIcmpEchoReply),FIcmpTimeOut); //send the echo request and wait for any echo response replies
    if IcpmErr = 0 then //check for the reply
    begin
      Result := -1;
      Exit;
    end;
    Result := IcmpEcho.Address;
  finally
    FreeMem(IcmpEcho); //dispose the memory allocated
  end;
end;

procedure TGeoTraceThread.IntCallBack; //this callback function report the current server name and ip address
begin
  FCallBack(FServerCallBack,FServerIpCallBack);
end;

procedure TGeoTraceThread.Log; //this callback log the data
begin
  FLogCallBack(FLogString);
end;

finally you can call the the TGeoTraceThread class in this way

procedure TFrmMainTrace.TraceAddress;
var
  Trace : TGeoTraceThread;
begin
    if Trim(EditAddress.Text)='' then  Exit;
    Trace:=TGeoTraceThread.Create(True);
    Trace.FreeOnTerminate    :=True;
    Trace.DestAddress        :=EditAddress.Text;
    Trace.MaxHops            :=30; //hops
    Trace.ResolveHostName    :=True;
    Trace.IcmpTimeOut        :=5000; //timeout in ms
    Trace.MsgCallBack        :=TraceLogCallBack; //assign the callback
    Trace.IncludeGeoInfo     :=True; //set this property true option to display the geoloccation info result in the trace
    Trace.Start;
end;

procedure TFrmMainTrace.TraceLogCallBack(const Msg: string);
begin
  MemoTrace.Lines.Add(Msg);
  MemoTrace.Perform(WM_VSCROLL, SB_BOTTOM, 0);
end;

and the output look like this, check which the trace includes the latitude, longitude, timezone, country and city for each host included in the trace.

Tracing route to theroadtodelphi.wordpress.com [76.74.254.123]
over a maximum of 30 hops
    1     16 ms    <1 ms    <1 ms DD-WRT [192.168.1.2] (0,0) Reserved- TimeZone
    2     16 ms    <1 ms    16 ms 10.9.90.1 (0,0) Reserved- TimeZone
    3     <1 ms    16 ms    <1 ms sblx12gw.gtdinternet.com [190.196.63.126] (-70.6667,-33.45) Chile-Santiago TimeZone Chile/Continental
    4     <1 ms    16 ms    <1 ms 190.196.125.185 (-70.6667,-33.45) Chile-Santiago TimeZone Chile/Continental
    5     <1 ms    16 ms    <1 ms ci1.te1-2.v218.cn1.gtdinternet.com [190.196.124.74] (-70.6667,-33.45) Chile-Santiago TimeZone Chile/Continental
    6     <1 ms    16 ms    <1 ms ci2.te1-1.ci1.gtdinternet.com [201.238.238.26] (-70.6667,-33.45) Chile-Santiago TimeZone Chile/Continental
    7     16 ms    <1 ms    15 ms ge13-0-0.santiago2.san.seabone.net [195.22.221.85] (-70.6667,-33.45) Chile-Santiago TimeZone Chile/Continental
    8     *        *        *      Request timed out.
    9    109 ms   125 ms   109 ms pos0-15-1-0.miami13.mia.seabone.net [195.22.221.205] (-70.6667,-33.45) Chile-Santiago TimeZone Chile/Continental
   10    125 ms   109 ms   125 ms te7-2.miami7.mia.seabone.net [195.22.199.111] (-80.2939,25.7615) United States-Miami TimeZone America/New_York
   11    172 ms   187 ms   171 ms te-7-4.car2.Miami1.Level3.net [63.209.150.165] (-97,38) United States- TimeZone
   12    188 ms   187 ms   187 ms ae-31-51.ebr1.Miami1.Level3.net [4.69.138.94] (-97,38) United States- TimeZone
   13    172 ms   187 ms   171 ms ae-2-2.ebr1.Dallas1.Level3.net [4.69.140.133] (-97,38) United States- TimeZone
   14    171 ms   203 ms   187 ms ae-3-80.edge9.Dallas1.Level3.net [4.69.145.144] (-97,38) United States- TimeZone
   15    188 ms   171 ms   187 ms PEER-1-NETW.edge9.Dallas1.Level3.net [4.59.118.6] (-95.7402,29.1793) United States-West Columbia TimeZone America/Chicago
   16     *        *        *      Request timed out.
   17     *        *        *      Request timed out.
   18    187 ms   188 ms   187 ms wordpress.com [76.74.254.123] (-98.5353,29.4713) United States-San Antonio TimeZone America/Chicago
Trace complete

Check the source code on Github

(The demo project was compiled under Delphi XE, but the TGeoTraceThread class can be used with older versions of Delphi)


4 Comments

Delphi : Enumerating Remote Desktop Servers in a network domain

Using the WinApi WTSEnumerateServers function you can get a list of all Remote Desktop Servers in a network domain.

Check this code. Tested on Delphi 2007, Delphi 2010, Delphi XE – (Windows XP/7/2008 Server)

program GetRemoteDesktops;

{$APPTYPE CONSOLE}

type
PWTS_SERVER_INFO = ^WTS_SERVER_INFO;
_WTS_SERVER_INFO = packed record
pServerName:LPTSTR;
end;
WTS_SERVER_INFO = _WTS_SERVER_INFO;
WTS_SERVER_INFO_Array  = Array [0..0] of WTS_SERVER_INFO;
PWTS_SERVER_INFO_Array =^WTS_SERVER_INFO_Array;

{$IFDEF UNICODE}
function WTSEnumerateServers( pDomainName: LPTSTR; Reserved: DWORD; Version: DWORD; ppServerInfo: PWTS_SERVER_INFO; pCount: PDWORD):BOOLEAN; stdcall; external 'wtsapi32.dll'  name 'WTSEnumerateServersW';
{$ELSE}
function WTSEnumerateServers( pDomainName: LPTSTR; Reserved: DWORD; Version: DWORD; ppServerInfo: PWTS_SERVER_INFO; pCount: PDWORD):BOOLEAN; stdcall; external 'wtsapi32.dll'  name 'WTSEnumerateServersA';
{$ENDIF}
procedure WTSFreeMemory(pMemory:Pointer);stdcall; external 'wtsapi32.dll' name 'WTSFreeMemory';

procedure GetRemoteDesktopsList(const Domain:PChar;const Servers:TStrings);
var
ppServerInfo : PWTS_SERVER_INFO_Array;//PWTS_SERVER_INFO;
pCount       : DWORD;
i            : integer;
begin
  Servers.Clear;
  ppServerInfo:=nil;
  try
    if WTSEnumerateServers(Domain,0,1,PWTS_SERVER_INFO(@ppServerInfo),@pCount) then
      for i := 0 to pCount - 1 do
        Servers.Add(ppServerInfo^[i].pServerName)
    else
    Raise Exception.Create(SysErrorMessage(GetLastError));
  finally
    if ppServerInfo<>nil then
    WTSFreeMemory(ppServerInfo);
  end;
end;


4 Comments

Fun with Delphi RTTI – Dump a TRttiType

Here ‘s a sample code of how you can dump the declaration of a TRttiType using the Rtti.

Supports classes, records and interfaces.

Delphi

//Author  Rodrigo Ruz V. 2010-10-10
uses
  Rtti,
  TypInfo,
  Classes,
  Generics.Collections,
  SysUtils;

function  DumpTypeDefinition(ATypeInfo: Pointer;OnlyDeclarated:Boolean=False) : string;

  //add and format a field
  procedure AddField(List:TStrings;lField : TRttiField);
  begin
     if Assigned(lField.FieldType) then
      List.Add((Format('   %-20s:%s;',[lField.Name,lField.FieldType.Name])))
     else
      List.Add((Format('   %-20s:%s;',[lField.Name,'Unknow'])));
  end;

  //add and format a method
  procedure AddMethod(List:TStrings;lMethod : TRttiMethod);
  begin
     List.Add((Format('   %s;',[lMethod.ToString])));
  end;

  //add and format a Property
  procedure AddProperty(List:TStrings;lProperty : TRttiProperty);
  begin
     List.Add((Format('   %s;',[lProperty.ToString])));
  end;

const
 sType          = 'type';
 sIndent        = '  ';
 ArrVisibility  : Array[TMemberVisibility] of string = ('private','protected','public','published');//Helper array for Visibility
var
  ctx       : TRttiContext;
  lType     : TRttiType;
  lMethod   : TRttiMethod;
  lProperty : TRttiProperty;
  lField    : TRttiField;
  Definition: TObjectDictionary<string, TStrings>;
  i         : TMemberVisibility;
begin
   Result:='No Rtti Information';
   ctx       := TRttiContext.Create;
   Definition:= TObjectDictionary<string, TStrings>.Create([doOwnsValues]);
   try

     if not Assigned(ATypeInfo) then exit;
     lType:=ctx.GetType(ATypeInfo);
     if not Assigned(lType) then exit;

     Definition.Add(sType,TStringList.Create);
     Definition.Items[sType].Add('type');

     //Initialize the buffers to hold the data
     for i:=Low(TMemberVisibility) to High(TMemberVisibility) do
     begin
      Definition.Add(ArrVisibility[i]  ,TStringList.Create);
      Definition.Items[ArrVisibility[i]].Add(sIndent+ArrVisibility[i]);
     end;

     case lType.TypeKind of
       tkUnknown    : ;
       tkInteger    : ;
       tkChar       : ;
       tkEnumeration: ;
       tkFloat      : ;
       tkString     : ;
       tkSet        : ;
       tkClass      :
                     begin
                       //get the main definition
                       if Assigned(lType.BaseType) then
                        Definition.Items[sType].Add(Format('%s%s=class(%s)',[sIndent,lType.Name,lType.BaseType.Name]))
                       else
                        Definition.Items[sType].Add(Format('%s%s=class',[sIndent,lType.Name]));
                     end;
       tkMethod     : ;
       tkWChar      : ;
       tkLString    : ;
       tkWString    : ;
       tkVariant    : ;
       tkArray      : ;
       tkRecord     : begin
                       //get the main definition
                        Definition.Items[sType].Add(Format('%s%s=record',[sIndent,lType.Name]));
                      end;

       tkInterface  :
                     begin
                       //get the main definition
                       if Assigned(lType.BaseType) then
                        Definition.Items[sType].Add(Format('%s%s=Interface(%s)',[sIndent,lType.Name,lType.BaseType.Name]))
                       else
                        Definition.Items[sType].Add(Format('%s%s=Interface',[sIndent,lType.Name]));

                     end;
       tkInt64      : ;
       tkDynArray   : ;
       tkUString    : ;
       tkClassRef   : ;
       tkPointer    : ;
       tkProcedure  : ;
     end;

       //add the fields
       if OnlyDeclarated then
         for lField in lType.GetDeclaredFields do
           AddField(Definition.Items[ArrVisibility[lField.Visibility]],lField)
       else
         for lField in lType.GetFields do
           AddField(Definition.Items[ArrVisibility[lField.Visibility]],lField);

       //add the methods
       if OnlyDeclarated then
         for lMethod in lType.GetDeclaredMethods do
           AddMethod(Definition.Items[ArrVisibility[lMethod.Visibility]],lMethod)
       else
         for lMethod in lType.GetMethods do
           AddMethod(Definition.Items[ArrVisibility[lMethod.Visibility]],lMethod);

       //add the Properties
       if OnlyDeclarated then
         for lProperty in lType.GetDeclaredProperties do
           AddProperty(Definition.Items[ArrVisibility[lProperty.Visibility]],lProperty)
       else
         for lProperty in lType.GetProperties do
           AddProperty(Definition.Items[ArrVisibility[lProperty.Visibility]],lProperty);

     for i:=Low(TMemberVisibility) to High(TMemberVisibility) do
      if Definition.Items[ArrVisibility[i]].Count>1 then
       Definition.Items[sType].AddStrings(Definition.Items[ArrVisibility[i]]);

     Definition.Items[sType].Add(sIndent+'end;');
     Result:=Definition.Items[sType].Text;
   finally
    Definition.free;
    ctx.free;
   end;
end;

Use in this way

//to dump a Class
DumpTypeDefinition(TypeInfo(TStringList));
//or
DumpTypeDefinition(TStringList.ClassInfo);

OutPut

the output is this

type
  TStringList=class(TStrings)
  private
   FList               : PStringItemList ;
   FCount              :Integer;
   FCapacity           :Integer;
   FSorted             :Boolean;
   FDuplicates         :TDuplicates;
   FCaseSensitive      :Boolean;
   FOnChange           :TNotifyEvent;
   FOnChanging         :TNotifyEvent;
   FOwnsObject         :Boolean;
   FEncoding           :TEncoding;
   FDefined            :TStringsDefined;
   FDefaultEncoding    :TEncoding;
   FDelimiter          :Char;
   FLineBreak          :string;
   FQuoteChar          :Char;
   FNameValueSeparator :Char;
   FStrictDelimiter    :Boolean;
   FUpdateCount        :Integer;
   FAdapter            :IStringsAdapter;
   FWriteBOM           :Boolean;
  public
   constructor Create;
   constructor Create(OwnsObjects: Boolean);
   class destructor Destroy;
   function Add(const S: string): Integer;
   function AddObject(const S: string; AObject: TObject): Integer;
   procedure Assign(Source: TPersistent);
   procedure Clear;
   procedure Delete(Index: Integer);
   procedure Exchange(Index1: Integer; Index2: Integer);
   function Find(const S: string; var Index: Integer): Boolean;
   function IndexOf(const S: string): Integer;
   procedure Insert(Index: Integer; const S: string);
   procedure InsertObject(Index: Integer; const S: string; AObject: TObject);
   procedure Sort;
   procedure CustomSort(Compare: TStringListSortCompare);
   constructor Create;
   class destructor Destroy;
   function Add(const S: string): Integer;
   function AddObject(const S: string; AObject: TObject): Integer;
   procedure Append(const S: string);
   procedure AddStrings(Strings: TStrings);
   procedure AddStrings(const Strings: TArray);
   procedure AddStrings(const Strings: TArray; const Objects: TAr
ray);
   procedure Assign(Source: TPersistent);
   procedure BeginUpdate;
   procedure Clear;
   procedure Delete(Index: Integer);
   procedure EndUpdate;
   function Equals(Strings: TStrings): Boolean;
   procedure Exchange(Index1: Integer; Index2: Integer);
   function GetEnumerator: TStringsEnumerator;
   function GetText: PWideChar;
   function IndexOf(const S: string): Integer;
   function IndexOfName(const Name: string): Integer;
   function IndexOfObject(AObject: TObject): Integer;
   procedure Insert(Index: Integer; const S: string);
   procedure InsertObject(Index: Integer; const S: string; AObject: TObject);
   procedure LoadFromFile(const FileName: string);
   procedure LoadFromFile(const FileName: string; Encoding: TEncoding);
   procedure LoadFromStream(Stream: TStream);
   procedure LoadFromStream(Stream: TStream; Encoding: TEncoding);
   procedure Move(CurIndex: Integer; NewIndex: Integer);
   procedure SaveToFile(const FileName: string);
   procedure SaveToFile(const FileName: string; Encoding: TEncoding);
   procedure SaveToStream(Stream: TStream);
   procedure SaveToStream(Stream: TStream; Encoding: TEncoding);
   procedure SetText(Text: PWideChar);
   function ToStringArray: TArray;
   function ToObjectArray: TArray;
   class destructor Destroy;
   procedure Assign(Source: TPersistent);
   function GetNamePath: string;
   constructor Create;
   procedure Free;
   class function InitInstance(Instance: Pointer): TObject;
   procedure CleanupInstance;
   function ClassType: TClass;
   class function ClassName: string;
   class function ClassNameIs(const Name: string): Boolean;
   class function ClassParent: TClass;
   class function ClassInfo: Pointer;
   class function InstanceSize: Integer;
   class function InheritsFrom(AClass: TClass): Boolean;
   class function MethodAddress(const Name: ShortString): Pointer;
   class function MethodAddress(const Name: string): Pointer;
   class function MethodName(Address: Pointer): string;
   function FieldAddress(const Name: ShortString): Pointer;
   function FieldAddress(const Name: string): Pointer;
   function GetInterface(const IID: TGUID; out Obj): Boolean;
   class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;
   class function GetInterfaceTable: PInterfaceTable;
   class function UnitName: string;
   function Equals(Obj: TObject): Boolean;
   function GetHashCode: Integer;
   function ToString: string;
   function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HRESU
LT;
   procedure AfterConstruction;
   procedure BeforeDestruction;
   procedure Dispatch(var Message);
   procedure DefaultHandler(var Message);
   class function NewInstance: TObject;
   procedure FreeInstance;
   class destructor Destroy;
   property Duplicates: TDuplicates;
   property Sorted: Boolean;
   property CaseSensitive: Boolean;
   property OnChange: TNotifyEvent;
   property OnChanging: TNotifyEvent;
   property OwnsObjects: Boolean;
   property Capacity: Integer;
   property CommaText: string;
   property Count: Integer;
   property DefaultEncoding: TEncoding;
   property Delimiter: Char;
   property DelimitedText: string;
   property Encoding: TEncoding;
   property LineBreak: string;
   property QuoteChar: Char;
   property NameValueSeparator: Char;
   property StrictDelimiter: Boolean;
   property Text: string;
   property StringsAdapter: IStringsAdapter;
   property WriteBOM: Boolean;
  end;
//to dump a Class with only the declarateds fields, methods and properties
DumpTypeDefinition(TypeInfo(TStringList),True);
//or
DumpTypeDefinition(TStringList.ClassInfo,True);

the output

type
  TStringList=class(TStrings)
  private
   FList               : PStringItemList;
   FCount              :Integer;
   FCapacity           :Integer;
   FSorted             :Boolean;
   FDuplicates         :TDuplicates;
   FCaseSensitive      :Boolean;
   FOnChange           :TNotifyEvent;
   FOnChanging         :TNotifyEvent;
   FOwnsObject         :Boolean;
  public
   constructor Create;
   constructor Create(OwnsObjects: Boolean);
   class destructor Destroy;
   function Add(const S: string): Integer;
   function AddObject(const S: string; AObject: TObject): Integer;
   procedure Assign(Source: TPersistent);
   procedure Clear;
   procedure Delete(Index: Integer);
   procedure Exchange(Index1: Integer; Index2: Integer);
   function Find(const S: string; var Index: Integer): Boolean;
   function IndexOf(const S: string): Integer;
   procedure Insert(Index: Integer; const S: string);
   procedure InsertObject(Index: Integer; const S: string; AObject: TObject);
   procedure Sort;
   procedure CustomSort(Compare: TStringListSortCompare);
   property Duplicates: TDuplicates;
   property Sorted: Boolean;
   property CaseSensitive: Boolean;
   property OnChange: TNotifyEvent;
   property OnChanging: TNotifyEvent;
   property OwnsObjects: Boolean;
  end;
//to dump a record
DumpTypeDefinition(TypeInfo(TSysLocale));

the output look like this

type
  TSysLocale=record
  public
   DefaultLCID         :Integer;
   PriLangID           :Integer;
   SubLangID           :Integer;
   FarEast             :Boolean;
   MiddleEast          :Boolean;
  end;
//finally to dump an interface
DumpTypeDefinition(TypeInfo(IInterfaceList));


Leave a comment

Fun with Delphi RTTI – Building a Unit Dependency Tree

You can build a unit dependency tree, wich shows the direct dependency for each unit in your project using the New Rtti.

Here a short description of the algorithm used in this code.

  • For each Type(TRttiType) in the list do the following
  • check if the basetype exist in the same unit else add the unit to the list.
  • for each public field in the current type check if exist in the same unit else add the unit to the list.
  • for each method in the current type with an valid ReturnType check if exist in the same unit else add the unit to the list.
  • for each property in the current type check if exist in the same unit else add the unit to the list.

Limitations:

  • Only show direct dependency of the units (example if Unit A depends on Unit B and Unit B depends on UnitC, the tree will show wich the Unit A depends on only of Unit B)
  • Only supports Types with Rtti info.
  • Due to Rtti Limitations only supports public fields (TRttiField).
uses
Rtti,
Generics.Collections,
TypInfo;

procedure FillTreeUnits(TreeViewUnits:TTreeView);
var
  ctx      : TRttiContext;
  TypeList : TArray<TRttiType>;
  lType    : TRttiType;
  lMethod  : TRttiMethod;
  lProperty: TRttiProperty;
  lField   : TRttiField;
  Node     : TTreeNode;
  UnitName : string;
  RefUnit  : string;
  UnitsDict: TObjectDictionary<String, TStringList>;
  UnitList : TStringList;

      function GetUnitName(lType: TRttiType): string;
      begin
        {
        if lType.IsInstance then
        Result:=lType.UnitName
        else
        }
        Result := StringReplace(lType.QualifiedName, '.' + lType.Name, '',[rfReplaceAll]);
      end;

      //Check if exist the Unit in the Dictionary and if has a Unit Children in the associated list
      procedure CheckAndAdd(UnitName,RefUnit:string);
      begin
            if UnitName<>RefUnit then
             if not UnitsDict.ContainsKey(UnitName) then
             begin
               UnitList:=TStringList.Create;
               UnitList.Add(RefUnit);
               UnitsDict.Add(UnitName,UnitList);
             end
             else
             begin
               UnitList:=UnitsDict.Items[UnitName];
               if UnitList.IndexOf(RefUnit)<0 then
               UnitList.Add(RefUnit);
             end;
      end;

begin
  ctx       := TRttiContext.Create;
  UnitsDict := TObjectDictionary<String, TStringList>.Create([doOwnsValues]);
  TreeViewUnits.Items.BeginUpdate;
  try
    TreeViewUnits.Items.Clear;
    TypeList:= ctx.GetTypes;

      //Fill a Dictionary with all the units and the dependencies
      for lType in TypeList do
      begin
             //Search references to another units in the BaseType
             UnitName:=GetUnitName(lType);
             if Assigned(lType.BaseType) then
                CheckAndAdd(UnitName,GetUnitName(lType.BaseType));

             //Search references to another units in the public fields (due to RTTI limitations only works with public fields)
             for lField in lType.GetDeclaredFields do
             if Assigned(lField.FieldType) and (lField.FieldType.IsPublicType) then
                CheckAndAdd(UnitName,GetUnitName(lField.FieldType));

             //Search references to another units in the properties
             for lProperty in lType.GetDeclaredProperties do
             if Assigned(lProperty.PropertyType) then
                CheckAndAdd(UnitName,GetUnitName(lProperty.PropertyType));

             //Search references to another units in functions with ExtendedInfo (HasExtendedInfo=True)
             for lMethod in lType.GetDeclaredMethods do
             if (lMethod.HasExtendedInfo) and (lMethod.MethodKind in [mkFunction,mkClassFunction]) then
                CheckAndAdd(UnitName,GetUnitName(lMethod.ReturnType));
        end;

       //finally fill the treeview
       for UnitName in UnitsDict.Keys do
       begin
          UnitList:=UnitsDict.Items[UnitName];
          Node    :=TreeViewUnits.Items.Add(nil,UnitName);
           for RefUnit in UnitList do
             TreeViewUnits.Items.AddChild(Node,RefUnit);
       end;

  finally
    UnitsDict.Destroy;
    ctx.Free;
    TreeViewUnits.Items.EndUpdate;
  end;
end;

Finally the output for the source code


3 Comments

Fun with Delphi RTTI – Building a TreeView with all your classes

Do you remember the great posters  that came with older versions of delphi?

Now you can build your own tree of classes using the new rtti, here I leave the source code

uses
Rtti;

procedure FillTreeClasses(TreeViewClasses:TTreeView);

        //function to get the node wich match with the TRttiType
        function FindTRttiType(lType:TRttiType):TTreeNode;
        var
          i        : integer;
          Node     : TTreeNode;
        begin
           Result:=nil;
             for i:=0 to TreeViewClasses.Items.Count-1 do
             begin
                Node:=TreeViewClasses.Items.Item[i];
                if Assigned(Node.Data) then
                 if lType=TRttiType(Node.Data) then
                 begin
                  Result:=Node;
                  exit;
                 end;
             end;
        end;

        //function to get the node wich not match with the BaseType of the Parent
        function FindFirstTRttiTypeOrphan:TTreeNode;
        var
          i        : integer;
          Node     : TTreeNode;
          lType    : TRttiType;
        begin
           Result:=nil;
             for i:=0 to TreeViewClasses.Items.Count-1 do
             begin
                 Node :=TreeViewClasses.Items[i];
                 lType:=TRttiType(Node.Data);

                if not Assigned(lType.BaseType) then Continue;

                if lType.BaseType<>TRttiType(Node.Parent.Data) then
                begin
                   Result:=Node;
                   break;
                 end;
             end;
        end;

var
  ctx      : TRttiContext;
  TypeList : TArray<TRttiType>;
  lType    : TRttiType;
  PNode    : TTreeNode;
  Node     : TTreeNode;
begin
  ctx := TRttiContext.Create;
  TreeViewClasses.Items.BeginUpdate;
  try
    TreeViewClasses.Items.Clear;

      //Add Root, TObject
      lType:=ctx.GetType(TObject);
      Node:=TreeViewClasses.Items.AddObject(nil,lType.Name,lType);

      //Fill the tree with all the classes
      TypeList:= ctx.GetTypes;
      for lType in TypeList do
        if lType.IsInstance then
        begin
             if Assigned(lType.BaseType) then
             TreeViewClasses.Items.AddChildObject(Node,lType.Name,lType);
        end;

      //Sort the classes
      Repeat
         Node:=FindFirstTRttiTypeOrphan;
         if Node=nil then break;
         //get the location of the node containing the BaseType
         PNode:=FindTRttiType(TRttiType(Node.Data).BaseType);
         //Move the node to the new location
         Node.MoveTo(PNode,naAddChild);
      Until 1<>1;

  finally
    TreeViewClasses.Items.EndUpdate;
    ctx.Free;
  end;
end;

When you run this code the output will look like this


17 Comments

Fun with Delphi RTTI – Rtti Explorer Lite

Just for fun, I wrote an application (unit) to inspect the types (With RTTI info) used on my projects developed using Delphi 2010 and Delphi XE.

This project has these features

  • A hierarchical view of all types   With Rtti info, tha data is showed  following this structure Package->Unit->Type->Fields (Methods, properties, fields)
  • Show rtti information about any Rtti element
  • Search a particular Rtti Element
  • A hierarchical view of all existing classes in your project

Check the Screenshots

This slideshow requires JavaScript.

If you want use this unit in your own projects (Delphi 2010 or Delphi XE), simply add the unit MainRttiExpl to your project and run the procedure ShowRttiLiteExplorer

The source code is available in Github and the demo app is here.

Links updated, now using Dropbox ;).