{-----------------------------------------------------------------------------
 Unit Name: UOraTnsNameParser
 Author:    LHQ
 Date:      2010-02-25
 Purpose:  parser tnsnames.ora file
 History:
 Example:
 //Connect Oracle Database
   RegOracleKeyFileString;
  MakeOracleLocalName('network\ADMIN\tnsnames.ora','JST','192.168.1.224','ORAC');
  dm.DBName:='JST';
  dm.ConnectDB;
-----------------------------------------------------------------------------}

unit OraTnsNamesParser;

interface

uses
  SysUtils, classes, windows, Common, RegExpr, Registry;

type
  TOraItem = class(TCollectionItem)
  private
  public
    LocalName: string;
    Desc: string;
    Protocol: string;
    Host: string;
    Port: integer;
    ServiceName: string;
    procedure Assign(Source: TPersistent); override;
  end;
  TOraItems = class(TCollection)
  private
    expr: TRegExpr;
    tnsNamesList: TStringList;
    procedure ParserInfo;
    function GetItem(Index: Integer): TOraItem;
    procedure SetItem(Index: Integer; const Value: TOraItem);
  public
    constructor Create;
    destructor Destroy; override;
    procedure LoadData(tnsNamesFile: string);
    procedure SaveData(tnsNamesFile: string);
    function Add: TOraItem;
    //get oralce connection infomation from local name from tns file.
    function GetOraItemFromLocalName(LocalName: string): TOraItem;
    //local name exists
    function LocalNameExists(LocalName: string): Boolean;
    //hostname,servicename,Port if exists result LocalName else Result ''
    function ConInfoExists(HostName, ServiceName: string; Port: Integer): string;
    property Items[Index: Integer]: TOraItem read GetItem write SetItem;
  end;

function RegOracleKeyFileString(OraDriverDir: string = ''): string;
function MakeOracleLocalName(tnsFile, aLocalName, aHost, aServiceName: string; aPort: Integer = 1521): Boolean;
implementation

function TOraItems.Add: TOraItem;
begin
  Result := TOraItem(inherited Add);
end;

function TOraItems.ConInfoExists(HostName, ServiceName: string;
  Port: Integer): string;
var
  i: Integer;
begin
  Result := '';
  for i := 0 to Count - 1 do
  begin
    if (Items[i].Host = HostName) and (Items[i].ServiceName = ServiceName) and
      (Items[i].Port = Port) then
    begin
      Result := Items[i].LocalName;
      Exit;
    end;
  end;
end;

constructor TOraItems.Create;
begin
  inherited Create(TOraItem);
  tnsNamesList := TStringList.Create;
  expr := TRegExpr.Create;
end;

destructor TOraItems.Destroy;
begin
  expr.free;
  tnsNamesList.Free;
  inherited;
end;

function TOraItems.GetItem(Index: Integer): TOraItem;
begin
  Result := TOraItem(inherited Items[Index]);
end;

function TOraItems.GetOraItemFromLocalName(LocalName: string): TOraItem;
var
  i: Integer;
begin
  Result := nil;
  for i := 0 to Count - 1 do
  begin
    if UpperCase(Items[i].LocalName) = UpperCase(LocalName) then
    begin
      Result := Items[i];
      Exit;
    end;
  end;
end;

procedure TOraItems.LoadData(tnsNamesFile: string);
begin
  if FileExists(tnsNamesFile) then
    tnsNamesList.LoadFromFile(tnsNamesFile);
  ParserInfo;
end;

function TOraItems.LocalNameExists(LocalName: string): Boolean;
var
  i: Integer;
begin
  Result := False;
  for i := 0 to Count - 1 do
  begin
    if UpperCase(LocalName) = UpperCase(Items[i].LocalName) then
    begin
      Result := True;
      Exit;
    end;
  end;
end;

procedure TOraItems.ParserInfo;
var
  i: Integer;
  s: string;
begin
  for i := 0 to tnsNamesList.Count - 1 do
  begin
    s := Trim(tnsNamesList.Strings[i]);
    if (Length(s) > 0) and (s[1] = '#') then //strip comment line
      Continue;
      //found local alias
    if (Length(s) > 0) and (s[1] in ['a'..'z', 'A'..'Z', '0'..'9']) and instr('=', s) then
    begin
      Add.LocalName := Trim(Copy(s, 1, Pos('=', s) - 1));
    end;
    if InStr('ADDRESS', s) and InStr('PROTOCOL', s) and InStr('HOST', s) and InStr('PORT', s) then
    begin
      expr.Expression := 'PROTOCOL\s*=\s*(.*?)\)\s*\(\s*HOST\s*=\s*(.*?)\)\(\s*PORT\s*=\s*(.*?)\)';
      expr.InputString := s;
      expr.ModifierI := True;
      expr.Exec;
      if expr.SubExprMatchCount = 3 then
      begin
        Items[Count - 1].Protocol := Trim(expr.Match[1]);
        Items[Count - 1].Host := Trim(expr.Match[2]);
        Items[Count - 1].Port := StrToInt(Trim(expr.Match[3]));
      end;
    end;
    //found service_name
    if instr('SERVICE_NAME', s) then
    begin
      expr.Expression := 'SERVICE_NAME\s*=\s*(.*?)\s*\)';
      expr.Exec(s);
      if expr.SubExprMatchCount = 1 then
        Items[Count - 1].ServiceName := Trim(expr.Match[1]);
    end;
  end;
end;

procedure TOraItems.SaveData(tnsNamesFile: string);
const
  tnsInfo = '%s =' + #13#10 +
    '  (DESCRIPTION =' + #13#10 +
    '    (ADDRESS_LIST =' + #13#10 +
    '      (ADDRESS = (PROTOCOL = %s)(HOST = %s)(PORT = %d))' + #13#10 +
    '    )' + #13#10 +
    '    (CONNECT_DATA =' + #13#10 +
    '      (SERVICE_NAME = %s)' + #13#10 +
    '    )' + #13#10 +
    '  )' + #13#10;
var
  i: Integer;
begin
  tnsNamesList.Clear;
  for i := 0 to Count - 1 do
  begin
    tnsNamesList.Add(Format(tnsInfo, [Items[i].LocalName, Items[i].Protocol,
      Items[i].Host, Items[i].Port, Items[i].ServiceName]));
  end;
  tnsNamesList.SaveToFile(tnsNamesFile);
end;

procedure TOraItems.SetItem(Index: Integer; const Value: TOraItem);
begin
  inherited Items[Index] := Value;
end;

procedure TOraItem.Assign(Source: TPersistent);
begin
  if Source is TOraItem then
  begin
    Desc := TOraItem(Source).Desc;
    Protocol := TOraItem(Source).Protocol;
    HOst := TOraItem(Source).HOst;
    Port := TOraItem(Source).Port;
    ServiceName := TOraItem(Source).ServiceName;
  end else
    inherited;
end;

function RegOracleKeyFileString(OraDriverDir: string = ''): string;
var
  reg: TRegistry;
  sKey: string;
  sl: TStringList;
begin
  Result := '';
  if OraDriverDir = '' then
    OraDriverDir := ExtractFileDir(ParamStr(0));
  if not FileExists(OraDriverDir + '\oracle.key') then
  begin
    Exit;
  end;
  sKey := '';
  sl := TStringList.Create;
  try
    sl.LoadFromFile(OraDriverDir + '\oracle.key');
    sKey := Trim(sl.Text);
  finally
    sl.Free;
  end;
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_LOCAL_MACHINE;
    if not reg.OpenKey(sKey, True) then
    begin
      Exit;
    end;
    //create key info
    reg.WriteString('NLS_LANG', 'SIMPLIFIED CHINESE_CHINA.ZHS16GBK');
    reg.WriteString('ORACLE_HOME', OraDriverDir);
    reg.CloseKey;
  finally
    reg.Free;
  end;
end;

function MakeOracleLocalName(tnsFile, aLocalName, aHost, aServiceName: string; aPort: Integer = 1521): Boolean;
var
  i: Integer;
  OraItems: TOraItems;
  aItem: TOraItem;
  s: string;
begin
  Result := False;
  OraItems := TOraItems.Create;
  try
    s := '';
    if FileExists(tnsFile) then
      OraItems.LoadData(tnsFile);
    s := OraItems.ConInfoExists(aHost, aServiceName, aPort);
    if s = aLocalName then
    begin
      Result := True;
      Exit;
    end;
    if (s <> aLocalName) and (s <> '') then
    begin
      aItem := OraItems.GetOraItemFromLocalName(aLocalName);
      if aItem <> nil then
      begin
        aItem.LocalName := aLocalName;
        aItem.Host := aHost;
        aItem.ServiceName := aServiceName;
        aItem.Port := aPort;
        aItem.Protocol := 'TCP';
      end else
        with OraItems.Add do
        begin
          LocalName := aLocalName;
          Host := aHost;
          ServiceName := aServiceName;
          Port := aPort;
          Protocol := 'TCP';
        end;
    end else
    begin
      with OraItems.Add do
      begin
        LocalName := aLocalName;
        Host := aHost;
        ServiceName := aServiceName;
        Port := aPort;
        Protocol := 'TCP';
      end;
    end;
    OraItems.SaveData(tnsFile);
  finally
    OraItems.Free;
  end;
end;

end.