# Access.pm: Class Used for Objects to Manage Access Credentials

package RDA::Object::Access;

# $Id: Access.pm,v 1.21 2015/07/09 08:04:18 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/Access.pm,v 1.21 2015/07/09 08:04:18 RDA Exp $
#
# Change History
# 20150709  MSC  Improve support of TNS names for JDBC.

=head1 NAME

RDA::Object::Access - Class Used for Objects to Manage Access Credentials

=head1 SYNOPSIS

 require RDA::Object::Access;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Access> class are used to manage the access
credentials. It is a subclass of L<RDA::Object|RDA::Object>.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Alarm qw(clear_alarm set_alarm);
  use RDA::Object qw(encode);
  use RDA::Object qw(encode);
  use RDA::Object::Rda;
}

# Define the global public variables
use vars qw($STRINGS $VERSION @DUMP @EXPORT_OK @ISA %SDCL
            $RE_EXT $RE_EZC $RE_EZD $RE_SID $RE_SVC);
$VERSION   = sprintf('%d.%02d', q$Revision: 1.21 $ =~ /(\d+)\.(\d+)/);
@DUMP      = (
  str => { map {$_ => 1} qw(con dos pwd) },
  );
@EXPORT_OK = qw($RE_EXT $RE_EZC $RE_EZD $RE_SID $RE_SVC
                ask_password check_dsn check_sid norm_credential);
@ISA       = qw(RDA::Object Exporter);
%SDCL      = (
  als => {
    ## no critic (Interpolation)
    'askPassword'    => ['${CUR.O_ACCESS}', 'ask_password'],
    'derivePassword' => ['${CUR.O_ACCESS}', 'derive_password'],
    'getLogins'      => ['${CUR.O_ACCESS}', 'get_logins'],
    'hasPassword'    => ['${CUR.O_ACCESS}', 'has_password'],
    'samePassword'   => ['${CUR.O_ACCESS}', 'same_password'],
    'setPassword'    => ['${CUR.O_ACCESS}', 'set_password'],
    'sharePassword'  => ['${CUR.O_ACCESS}', 'share_password'],
    },
  inc => [qw(RDA::Object)],
  met => {
    'ask_password'    => {ret => 0},
    'derive_password' => {ret => 0},
    'get_logins'      => {ret => 1},
    'has_password'    => {ret => 0},
    'same_password'   => {ret => 0},
    'set_password'    => {ret => 0},
    'share_password'  => {ret => 0},
    },
  );

$RE_EXT = qr{^([^:]+:\d+:([^:]*:)?|//[^:/]+(:\d+)?/)[^:]+$};
$RE_EZC = qr{^(//)?([^:/]+):(\d+)/([^:]+)$};
$RE_EZD = qr{^(//)?([^:/]+)/([^:]+)$};
$RE_SID = qr/^([^:]+):(\d+):([^:]+)$/;
$RE_SVC = qr/^([^:]+):(\d+):([^:]*):([^:]+)$/;

# Define the global private constants
my $EMP = q{};

# Define the global private variables
my %tb_log = (
  q{}    => \&_get_any_logins,
  oracle => \&_get_oracle_logins,
  );

# Report the package version
sub Version
{ return $VERSION;
}

=head2 S<$h = RDA::Object::Access-E<gt>new($collector)>

The object constructor. This method enables you to specify the collector object
reference as an argument.

C<RDA::Object::Access> is represented by a blessed hash reference. The
following special keys are used:

=over 16

=item S<    B<'cfg' > > Reference to the RDA software configuration

=item S<    B<'col' > > Reference to the collector object

=item S<    B<'dft' > > Default password

=item S<    B<'oid' > > Object identifier

=item S<    B<'_pwd'> > Password container

=back

Internal keys are prefixed by an underscore.

=cut

sub new
{ my ($cls, $col) = @_;
  my ($pwd, $slf);

  # Create the setup object
  $slf = bless {
    cfg  => $col->get_config,
    col  => $col,
    dft  => $col->get_first('DEFAULT.B_LOGIN') ? undef : q{?},
    oid  => 'access',
    _pwd => {},
    }, ref($cls) || $cls;

  # Load the credentials
  $slf->load_credentials($pwd) if ($pwd = $col->find('ACCESS'));

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>ask_password($text[,$default])>

This method asks for a password. When supported by the installed Perl version,
it suppresses the character echo for password entry. When the character echo is
suppressed, the method requests the password twice. If both strings do not
match after three attempts, the request is canceled. It returns the password,
or, in case of failure, it returns an undefined value.

=head2 S<RDA::Object::Access::ask_password($agent,$text[,$default])>

This method asks for a password without requiring an access control object.

=head2 S<RDA::Object::Access::ask_password($collector,$text[,$default])>

This method asks for a password without requiring an access control object.

=cut

sub ask_password  ## no critic (Complex)
{ my ($slf, $txt, $pwd) = @_;
  ## no critic (Numbered)
  my ($clf, $cnt, $err, $fdi, $ofh, $str1, $str2, $tio);

  # Return the default password  when the dialogues are suppressed
  return defined($pwd) ? $pwd : $slf->get_default if $slf->is_isolated;

  # Assume a default input prompt
  $txt = get_string('Enter') unless defined($txt);
  $txt =~ s/[\s\r\n]+$/ /;

  # Try to get the password without character echo
  $ofh = $slf->get_screen;
  eval {
    die "Not a tty\n" unless -t STDIN;
    if (RDA::Object::Rda->is_windows)
    { # Get the input device
      die "Bad DOS windows\n"
        unless ref($tio = $slf->get_info('cfg')->get_input);

      # Request the password
      for ($cnt = 3 ;;)  ## no critic (Loop)
      { $str1 = _get_dos_password($ofh, $tio, $txt);
        $str2 = _get_dos_password($ofh, $tio, qq{\n}.get_string('ReEnter'));
        _display($ofh, qq{\n});

        if ($str1 ne $str2)
        { $err = get_string('NoMatch');
        }
        else
        { $str1 =~ s/[\r\n]+$//;
          if ($str1 ne $EMP)
          { $pwd = $str1;
            last;
          }
          $err = get_string('Empty');
        }
        if (--$cnt < 1)
        { _display($ofh, get_string('MaxTries').qq{\n});
          last;
        }
        _display($ofh, "$err. ".get_string('TryAgain').qq{\n});
      }
    }
    else
    { # Get initial standard input setting
      ## no critic (Bit,Call)
      require POSIX;
      $tio = POSIX::Termios->new;       ## no critic (Explicit)
      $tio->getattr($fdi = fileno(STDIN));
      $clf = $tio->getlflag;

      # Trap Interrupt signal to restore echo
      sub trap_int  ## no critic (Nested)
      { my $tio = POSIX::Termios->new;  ## no critic (Explicit)
        $tio->getattr(fileno(STDIN));
        $tio->setlflag($tio->getlflag | POSIX::ECHO());
        $tio->setattr(fileno(STDIN), POSIX::TCSANOW());
        exit(1);
      }
      local $SIG{'INT'} = \&trap_int;

      # Suppress character echo
      $tio->setlflag($clf & ~POSIX::ECHO());
      $tio->setattr($fdi, POSIX::TCSANOW());

      # Ask for the password and verify string match
      for ($cnt = 3 ;;)  ## no critic (Loop)
      { _display($ofh, $txt);
        unless (defined($str1 = <STDIN>))  ## no critic (Stdin)
        { _display($ofh, qq{\n}.get_string('ErrInput').qq{\n});
          last;
        }
        _display($ofh, qq{\n}.get_string('ReEnter'));
        unless (defined($str2 = <STDIN>))  ## no critic (Stdin)
        { _display($ofh, qq{\n}.get_string('ErrConfirm').qq{\n});
          last;
        }
        _display($ofh, qq{\n});

        if ($str1 ne $str2)
        { $err = get_string('NoMatch');
        }
        else
        { $str1 =~ s/[\r\n]+$//;
          if ($str1 ne $EMP)
          { $pwd = $str1;
            last;
          }
          $err = get_string('Empty');
        }
        if (--$cnt < 1)
        { _display($ofh, get_string('MaxTries').qq{\n});
          last;
        }
        _display($ofh, $err.'. '.get_string('TryAgain').qq{\n});
      }

      # Restore initial standard input setting
      $tio->setlflag($clf);
      $tio->setattr($fdi, &POSIX::TCSANOW());
    }
  };

  # If that is not possible, try it without suppressing character echo
  if ($@)
  { for ($cnt = 3 ;;)  ## no critic (Loop)
    { _display($ofh, $txt);
      unless (defined($pwd = <STDIN>))  ## no critic (Stdin)
      { _display($ofh, qq{\n}.get_string('ErrInput').qq{\n});
        last;
      }
      $pwd =~ s/[\r\n]+$//;
      last if $pwd;
      if (--$cnt < 1)
      { _display($ofh, get_string('MaxInput').qq{\n});
        last;
      }
      _display($ofh, get_string('Empty').'. '.get_string('TryAgain').qq{\n});
    }
    _display($ofh, qq{\n}) unless -t STDIN;
  }

  # Return the password
  return defined($pwd) ? $pwd : $slf->get_default;
}

sub _display
{ my ($ofh, $txt) = @_;

  return syswrite($ofh, $txt, length($txt));
}

sub _get_dos_password
{ my ($ofh, $dev, $txt) = @_;
  my ($chr, $pwd, @inp);

  _display($ofh, $txt);
  $pwd = $EMP;
  for (;;)  ## no critic (Loop)
  { @inp = $dev->Input();
    next unless $inp[0] == 1 && $inp[1] == 1  ## no critic (Unless)
             && $inp[5] != 0;
    $chr = chr(($inp[5] > 0) ? $inp[5] : 256 + $inp[5]);
    last if $chr eq "\r";
    $pwd .= $chr;
  }
  return $pwd;
}


=head2 S<$h-E<gt>derive_password($type,$sid,$user,$pseudo)>

This method derives a missing password for the specified login from the pseudo
user credentials. It indicates whether a password is still missing.

=cut

sub derive_password
{ my ($slf, $typ, $sid, $usr, $ref) = @_;
  my ($pwd);

  return 1 unless defined($typ) && defined($sid) && defined($usr);
  ($typ, $sid, $usr) = norm_credential($typ, $sid, $usr);
  return 0 if _has_password($slf, $typ, $sid, $usr);
  return 1 unless defined($ref)
    && defined($pwd = _return_password($slf, 'pseudo', $EMP, $ref));
  _set_password($slf, $typ, $sid, $usr, $pwd);
  return 0;
}

=head2 S<$h-E<gt>get_default>

This method returns the default password.

=cut

sub get_default
{ return shift->{'dft'};
}

=head2 S<$h-E<gt>get_input($login...)>

This method gets input directives for the specified logins. It supports logins
in both C<user@type@sid> and C<user@sid> formats.

=cut

sub get_input
{ my ($slf, @log) = @_;
  my ($cnt, $ref, @inp);

  foreach my $log (@log)
  { $ref = ref($log);
    if ($ref eq 'ARRAY')
    { push(@inp, map {_get_input($slf, ++$cnt, $_)} @{$log});
    }
    elsif ($ref eq 'HASH')
    { push(@inp, map {_get_input($slf, ++$cnt, $_)} keys(%{$log}));
    }
    else
    { push(@inp, _get_input($slf, ++$cnt, $log));
    }
  }
  return (@inp, q{#EOF});
}

sub _get_input
{ my ($slf, $uid, $log) = @_;
  my ($pwd, $sid, $typ, $usr);

  if (!ref($log) && defined($log) && $log =~ m/^([^\@]*)(\@([^\@]*))?\@(.*)$/)
  { ($typ, $sid, $usr) = norm_credential($2 ? $3 : 'oracle', $4, $1);
    if (_has_password($slf, $typ, $sid, $usr))
    { $pwd = pack('u', $slf->{'_pwd'}->{$typ}->{$sid}->{$usr});
      chomp($pwd);
      return (qq{COL/ACCESS.$typ.T_CRD_ACC_$uid=}.encode($pwd),
              qq{COL/ACCESS.$typ.T_SID_ACC_$uid=}.encode($sid),
              qq{COL/ACCESS.$typ.T_USR_ACC_$uid=}.encode($usr));
    }
  }
  return ();
}

=head2 S<$h-E<gt>get_logins([$type...])>

This method returns the list of defined logins of the specified types, all
types per default.

=cut

sub get_logins
{ my ($slf, @typ) = @_;
  my ($tbl, @tbl);

  $tbl = $slf->{'_pwd'};
  @typ = keys(%{$tbl}) unless @typ;
  foreach my $typ (sort @typ)
  { push(@tbl,
      &{$tb_log{exists($tb_log{$typ}) ? $typ : q{}}}($tbl->{$typ}, $typ))
      if exists($tbl->{$typ});
  }
  return @tbl;
}

sub _get_any_logins
{ my ($tbl, $typ) = @_;
  my (@tbl);

  foreach my $sid (sort keys(%{$tbl}))
  { push(@tbl, map {join(q{@}, $_, $typ, $sid)}
                   sort keys(%{$tbl->{$sid}}));
  }
  return @tbl;
}

sub _get_oracle_logins
{ my ($tbl, $typ) = @_;
  my (@tbl);

  foreach my $sid (sort keys(%{$tbl}))
  { push(@tbl, map {join(q{@}, $_, $typ, $sid)}
                   grep {length($_)}
                   sort keys(%{$tbl->{$sid}}));
  }
  return @tbl;
}

=head2 S<$h-E<gt>get_password($type,$sid,$user[,$text[,$default]])>

This method returns the password for the specified login.

=cut

sub get_password
{ my ($slf, $typ, $sid, $usr, $txt, $dft) = @_;

  return _get_password($slf, norm_credential($typ, $sid, $usr), $txt, $dft);
}

sub _get_password
{ my ($slf, $typ, $sid, $usr, $txt, $dft, $lim) = @_;

  unless (_has_password($slf, $typ, $sid, $usr))
  { clear_alarm() if $lim;
    $slf->{'_pwd'}->{$typ}->{$sid}->{$usr} = $slf->ask_password($txt, $dft);
    set_alarm($lim) if $lim;
  }
  return $slf->{'_pwd'}->{$typ}->{$sid}->{$usr};
}

=head2 S<$h-E<gt>get_screen>

This method returns the display file handle.

=cut

sub get_screen
{ return shift->{'col'}->get_screen;
}

=head2 S<$h-E<gt>has_password($type,$sid,$user)>

This method indicates whether a password hash entry already exists for the
specified login.

=cut

sub has_password
{ my ($slf, $typ, $sid, $usr) = @_;

  return _has_password($slf, norm_credential($typ, $sid, $usr));
}

sub _has_password
{ my ($slf, $typ, $sid, $usr) = @_;

  # Create the system list
  if ($typ eq 'oracle')
  { $slf->{'_pwd'}->{$typ}->{$sid}->{$EMP} = $EMP
      unless exists($slf->{'_pwd'}->{$typ}->{$sid});
  }
  else
  { $slf->{'_pwd'}->{$typ}->{$sid} = {}
      unless exists($slf->{'_pwd'}->{$typ}->{$sid});
  }

  # Check the login record existence
  return exists($slf->{'_pwd'}->{$typ}->{$sid}->{$usr});
}

=head2 S<$h-E<gt>is_isolated>

This method indicates whether customer interactions are disabled.

=cut

sub is_isolated
{ return shift->{'col'}->is_isolated;
}

=head2 S<$h-E<gt>load_credentials($item)>

This method loads the database passwords stored in the specified item. It
does not overwrite existing passwords. It returns the object reference.

=cut

sub load_credentials
{ my ($slf, $itm) = @_;
  my ($def, $dft, $grp, $pwd, $sid, $typ, $usr);

  # Determine the default group
  if ($def = $slf->{'col'}->find('SETUP.DB.DB'))
  { $usr = $def->get_prime('T_USER',       $EMP);
    $sid = $def->get_prime('T_ORACLE_SID', $EMP);
    $grp = ($usr =~ m/\@\S/)            ? $EMP :
           ($sid =~ $RE_EXT)            ? check_sid($sid) :
           $def->get_prime('B_LOCAL',1) ? uc($sid) :
                                          $EMP;
  }
  else
  { $grp = $EMP;
  }

  # Create the default entries
  $slf->{'_pwd'}->{'oracle'}->{$EMP}->{$EMP} = $EMP;

  # Load the passwords
  foreach my $chl ($itm->get_childs)
  { $typ = lc($chl->get_oid);
    $dft = ($typ eq 'oracle') ? $grp : $EMP;
    foreach my $key ($chl->grep('^T_USR_\w+$'))
    { next unless length($usr = $chl->get_first($key, $EMP));
      $key = substr($key, 6);
      $sid = $chl->get_first(["T_SID_$key", 'T_SID'], $dft);
      $pwd = unpack('u', $chl->get_first("T_CRD_$key", $EMP));
      $pwd =~ s/\r\n//g;
      _set_password($slf, norm_credential($typ, $sid, $usr), $pwd);
    }
  }

  # Return the object reference
  return $slf;
}

=head2 S<$h-E<gt>obtain_password($type,$sid,$user,$limit[,$text[,$default]])>

This method returns the password for the specified login. It disables the
alarm while asking for a password.

=cut

sub obtain_password
{ my ($slf, $typ, $sid, $usr, $lim, $txt, $dft) = @_;

  return _get_password($slf, norm_credential($typ, $sid, $usr), $txt, $dft,
    $lim);
}

=head2 S<$h-E<gt>return_password($type,$sid,$user[,$default])>

This method returns an existing password for the specified login.

=cut

sub return_password
{ my ($slf, $typ, $sid, $usr, $dft) = @_;

  return _return_password($slf, norm_credential($typ, $sid, $usr), $dft);
}

sub _return_password
{ my ($slf, $typ, $sid, $usr, $dft) = @_;

  return _has_password($slf, $typ, $sid, $usr)
    ? $slf->{'_pwd'}->{$typ}->{$sid}->{$usr}
    : $dft;
}

=head2 S<$h-E<gt>same_password($user,$type,@sid)>

This method assigns the current password of the specified user to all specified
systems of a same type.

=cut

sub same_password
{ my ($slf, $usr, $typ, @arg) = @_;
  my ($alt, $cnt, $pwd, $sid, $tbl, @tbl);

  $cnt = 0;
  if (defined($usr) && defined($typ) && defined($sid = shift(@arg)))
  { ($typ, $sid, $usr) = norm_credential($typ, $sid, $usr);
    if (exists($slf->{'_pwd'}->{$typ}))
    { $tbl = $slf->{'_pwd'}->{$typ};

      # Normalize the system identifiers
      push(@tbl, [$sid, $usr]);
      foreach my $arg (@arg)
      { if (ref($arg) eq 'ARRAY')
        { ($sid, $alt) = @{$arg};
          next unless defined($sid) && defined($alt);
          ($typ, $sid, $alt) = norm_credential($typ, $sid, $alt);
          push(@tbl, [$sid, $alt]);
        }
        else
        { next unless defined($arg);
          ($typ, $sid) = norm_credential($typ, $arg);
          push(@tbl, [$sid, $usr]);
        }
      }

      # Get the password
      foreach my $rec (@tbl)
      { ($sid, $usr) = @{$rec};
        next unless exists($tbl->{$sid}) && exists($tbl->{$sid}->{$usr});
        $pwd = $tbl->{$sid}->{$usr};
        last;
      }

      # Assign the password
      if (defined($pwd))
      { foreach my $rec (@tbl)
        { _set_password($slf, $typ, @{$rec}, $pwd);
          ++$cnt;
        }
      }
    }
  }
  return $cnt;
}

=head2 S<$h-E<gt>set_password($type,$sid,$user,$pwd)>

This method defines a new password hash entry. It returns the password.

=cut

sub set_password
{ my ($slf, $typ, $sid, $usr, $pwd) = @_;

  return _set_password($slf, norm_credential($typ, $sid, $usr), $pwd);
}

sub _set_password
{ my ($slf, $typ, $sid, $usr, $pwd) = @_;

  $slf->{'_pwd'}->{$typ}->{$sid}->{$EMP} = $EMP
    unless $typ ne 'oracle'  ## no critic (Unless)
        || exists($slf->{'_pwd'}->{$typ}->{$sid});
  return $slf->{'_pwd'}->{$typ}->{$sid}->{$usr} = $pwd;
}

=head2 S<$h-E<gt>share_password($type,$sid,...)>

This method shares the credentials between the specified systems, identified by
type and identifier pairs.

=cut

sub share_password
{ my ($slf, @arg) = @_;
  my ($cnt, $dst, $sid, $src, $typ);

  $cnt = 0;
  $dst = {};
  while (($typ, $sid) = splice(@arg, 0, 2))
  { next unless defined($typ) && defined($sid);

    # Normalize the identifiers
    ($typ, $sid) = norm_credential($typ, $sid);

    # Merge the credentials
    if (ref($src = $slf->{'_pwd'}->{$typ}->{$sid}))
    { foreach my $usr (keys(%{$src}))
      { $dst->{$usr} = $src->{$usr} unless exists($dst->{$usr});
      }
    }
    elsif ($typ eq 'oracle')
    { $dst->{$EMP} = $EMP unless exists($dst->{$EMP});
    }

    # Share the credentials
    $slf->{'_pwd'}->{$typ}->{$sid} = $dst;
    ++$cnt;
  }
  return $cnt;
}

# --- Internal routines -------------------------------------------------------

# Check the DSN
sub check_dsn
{ my ($dsn, $dft) = @_;
  my (%dsn);

  return $dft unless defined($dsn);
  return $dsn unless $dsn =~ m/=/;

  # Sort the extended DSN attributes
  foreach my $att (split(/;/, $dsn))
  { $dsn{$1} = $2 if $att =~ /\s*([^=]+)=(.*)$/;
  }
  return join($EMP, map {$_.q{=}.$dsn{$_}.q{;}} sort keys(%dsn));
}

# Check the SID
sub check_sid
{ my ($sid, $dft, $flg) = @_;

  return $dft unless defined($sid);
  return ($sid =~ $RE_EZC) ? join(q{:}, $2, $3, $EMP, uc($4)) :
         ($sid =~ $RE_EZD) ? join(q{:}, $2, 1521, $EMP, uc($3)) :
         ($sid =~ $RE_SID) ? join(q{:}, $1, $2, $flg ? $3 : uc($3)) :
         ($sid =~ $RE_SVC) ? join(q{:}, $1, $2, $3, uc($4)) :
         $flg              ? $sid :
                             uc($sid);
}

# Normalize the user, the type, and the system identifier
sub norm_credential  ## no critic (Complex)
{ my ($typ, $sid, $usr) = @_;
  my ($hst, $prt, %par);

  $typ = (!defined($typ) || $typ eq q{+}) ? 'oracle' :
         ($typ eq q{-})                   ? 'odbc' :
                                            lc($typ);
  if ($typ eq 'jdbc')
  { $sid =~ s/^[^\|]*\|//;
    $sid =~ s/^jdbc://i;
    if ($sid =~ s/^oracle\:thin\:\@//i)
    { if ($sid =~ m/^(?:\/\/)?([\w\.\-]+)\:(\d+)\/([\w\.\-]+)$/)
      { ($typ, $sid) = ('oracle', join(q{:}, $1, $2, $EMP, $3));
      }
      elsif ($sid =~ m/^([\w\.\-]+)\:(\d+)\:([\w\.\-]+)$/)
      { ($typ, $sid) = ('oracle', join(q{:}, $1, $2, $3));
      }
      elsif ($sid =~ m/^[\w\.\-]+$/)
      { $typ = 'oracle';
      }
      else
      { $sid = 'oracle@'.$sid;
      }
    }
    elsif ($sid =~ s/^db2\://i)
    { if ($sid =~ m/^\/\/([\w\.\-]+)\:(\d+)\/([\w\.\-]+)$/)
      { ($typ, $sid) = ('db2', join(q{:}, $1, $2, $3));
      }
      elsif ($sid =~ m/^\/\/([\w\.\-]+)\/([\w\.\-]+)$/)
      { ($typ, $sid) = ('db2', join(q{:}, $1, $EMP, $2));
      }
      elsif ($sid =~ m/^[\w\.\-]+$/)
      { $typ = 'db2';
      }
      else
      { $sid = 'db2@'.$sid;
      }
    }
    elsif ($sid =~ s/^odbc\:(DSN=)?//i)
    { $typ = 'odbc';
    }
    elsif ($sid =~ s/^sqlserver\://i)
    { $typ = 'sqlserver';
      %par = (databaseName => $EMP,
              portNumber   => $EMP,
              serverName   => $EMP,
             );
      if ($sid =~ m/^\/\/([\w\.\-]+)(\\([\w\.\-]+))?(\:(\d+))?/)
      { $par{'serverName'}   = $1;
        $par{'instanceName'} = $3 if $2;
        $par{'portNumber'}   = $5 if $4;
      }
      foreach my $par (split(/;/, $sid))
      { $par{$1} = $2 if $par =~ m/^(\w+)=(.*)$/;
      }
      $par{'instanceName'} = $1 if $par{'serverName'} =~ s/\\+([\w\.\-]+)$//;
      $par{'serverName'} =~ s/:/_/g;
      $sid = join(q{:}, (exists($par{'instanceName'})
        ? $par{'serverName'}.qq{\\}.$par{'instanceName'}
        : $par{'serverName'}),
        $par{'portNumber'}, $par{'databaseName'});
    }
    elsif ($sid =~ s/^weblogic\:(db2|sqlserver)\:\/\/([\w\.\-]+)\:(\d+)//i)
    { $typ = $1;
      $hst = $2;
      $prt = $3;
      %par = (DATABASENAME => $EMP);
      foreach my $par (split(/;/, $sid))
      { $par{uc($1)} = $2 if $par =~ m/^(\w+)=(.*)$/;
      }
      $sid = join(q{:}, $hst, $prt, $par{'DATABASENAME'});
    }
  }

  if ($typ eq 'oracle')
  { $usr = uc($usr) if defined($usr);
    $sid = check_sid($sid, $EMP);
  }
  elsif ($typ eq 'host')
  { $sid = defined($sid) ? lc($sid) : $EMP;
  }
  elsif ($typ eq 'odbc')
  { $sid = check_dsn($sid, $EMP);
  }
  elsif ($typ eq 'pseudo')
  { $sid = defined($sid) ? lc($sid) : 'other';
    $usr = (!defined($usr)) ? $EMP :
           ($sid eq 'db')   ? uc($usr) :
           ($sid eq 'host') ? lc($usr) :
                              $usr;
    $sid = $EMP;
  }
  elsif ($typ eq 'wls' || $typ eq 'wsp')
  { $usr = defined($usr) ? lc($usr) : $EMP;
    $sid = defined($sid) ? lc($sid) : $EMP;
  }

  return ($typ, $sid, $usr);
}

1;

__END__

=head1 SEE ALSO

L<RDA::Alarm|RDA::Alarm>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Item|RDA::Object::Item>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Text|RDA::Text>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle and Java are registered trademarks of Oracle and/or its
affiliates. Other names may be trademarks of their respective owners.

=cut