Rem
Rem $Header: wpiutl.sql 12-apr-98.20:55:26 nle Exp $
Rem
Rem dbmspbx.sql
Rem
Rem  Copyright (c) Oracle Corporation 1998. All Rights Reserved.
Rem
Rem    NAME
Rem     wpiutl.sql - PL/SQL describe API for webdb
Rem
Rem    NOTES
Rem	A portion of this file is copied from diutil.sql.  Because this
Rem	package is specificly for webdb, we didn't want to add its
Rem     functionality into package diutil.sql.  If we ever make these more
Rem     generic, we should merge these code into diutil.sql
Rem
Rem    MODIFIED   (MM/DD/YY)
Rem    nle         11/30/99 - handle subtype
Rem    nle         10/20/99 - handle overloading for array and char types
Rem    nle         10/13/99 - fix desctype signature
Rem    nle         09/28/99 - new spec for flex parameter passing
Rem    nle         08/20/99 - error message
Rem    nle         08/19/99 - add hack to describe non-executable types
Rem    nle         08/18/99 - Fix bug for synonym
Rem    nle         08/16/99 - Misuse typname and name
Rem    nle         08/12/99 - Created
Rem
create or replace package sys.wpiutl as
  TYPE tvarchar IS table of varchar2(512) index by binary_integer;
  TYPE tchar3 IS table of CHAR(3) index by binary_integer;
  TYPE tvchar3 IS table of VARCHAR2(3) index by binary_integer;
  SUBTYPE ptnod IS pidl.ptnod;

  -- Constant for errors
  s_ok CONSTANT NUMBER := 0;            -- successful
  s_subpnotfound CONSTANT NUMBER := 1;  -- subprogram NOT found
  s_notinpackage CONSTANT NUMBER := 2;  -- PACKAGE found, proc NOT found
  s_notasub CONSTANT NUMBER := 3;       -- found, but not a subprog
  s_notunique CONSTANT NUMBER := 4;     -- too many matches (overloading error)
  s_nomatch CONSTANT NUMBER := 5;       -- found, but param names not matched
  s_typenotmatch CONSTANT NUMBER := 6;  -- name match, type doesn't match

  -- The following t_ constants can NOT exceed 999
  t_scalar  CONSTANT CHAR(3) := '000';
  t_v7array CONSTANT CHAR(3) := '001';

  -- subpparam: 
  --   IN:  name        name of the subprogram, package, or owner
  --        subname     name of subprogram if not null
  --        prename     name of owner if not null
  --        pnames      names of formal parameter
  --   OUT: ptnames     names of formal parameter types
  --        ptypes      characteristic of the types: scalar, V7_array, ...
  --        status      error code = s_ok           : subprogram found
  --                                 s_subpnotfound : not found in schema
  --                                 s_notinpackage : not found in package
  --                                 s_notasub      : found, but not a subprog
  --                                 s_notunique    : too many matches.
  --                                 s_nomatch      : found, but no match
  --
  -- This function analyzes the following types of names:
  --    <NAME>
  --    <NAME>.<SUBNAME>
  --    <PRENAME>.<NAME>.<SUBNAME>
  -- It resolves overloading subprograms by parameter names (i.e. PNAMES),
  -- and returns types of the parameters that are listed in pnames
  -- <NAME> may not be NULL while prename and subname may.
  -- 
  -- pnames, ptnames, and ptypes are optional.
  --
  PROCEDURE subpparam(objnum NUMBER, name VARCHAR2, subname VARCHAR2,
                      prename VARCHAR2, status OUT NUMBER, misdef OUT VARCHAR2,
                      nename OUT VARCHAR2);
  PROCEDURE subpparam(objnum NUMBER, name VARCHAR2, subname VARCHAR2,
                      prename VARCHAR2, pnames IN OUT tvarchar,
                      ptnames IN OUT tvarchar, ptypes IN OUT tvchar3,
                      status OUT NUMBER, misdef OUT VARCHAR2,
                      nename OUT VARCHAR2);

  -- This is similar to subpparam but used for flexible parameter
  -- Note: different from subpparam, pnames and ptypes are INput only
  PROCEDURE subpfparam(objnum NUMBER, name VARCHAR2, subname VARCHAR2,
                       prename VARCHAR2, pnames IN tvarchar,
                       ptnames IN OUT tvarchar, ptypes IN tvchar3,
                       status OUT NUMBER, misdef OUT VARCHAR2,
                       nename OUT VARCHAR2);
end;
/
create or replace package body sys.wpiutl as
  TYPE tptnod is table of ptnod index by binary_integer;
  TYPE tbool is table of boolean index by binary_integer;
  TYPE tnumber is table of number index by binary_integer;
  owner_prefix VARCHAR2(31);
  package_prefix VARCHAR2(31);

  -- These two variables are used when users pass an array of values
  -- to a scalar parameter
  MatchTypes tvchar3;
  MatchList tptnod;
  MLcnt NUMBER;
  OLnums tnumber;
  CharList tbool;

  -- Error message variables
  missing_defaults VARCHAR2(4096);
  non_exist_names VARCHAR2(4096);
  posterr BOOLEAN;
  posnotunique BOOLEAN; -- flag for posibility of not unique

  --------------------------------
  -- List of private subprograms
  --------------------------------
  -- Driving the whole process
  PROCEDURE driver(objnum NUMBER, ownerName VARCHAR2, objname VARCHAR2,
                   subname VARCHAR2, pnames IN OUT tvarchar,
                   ptnames IN OUT tvarchar, ptypes IN OUT tvchar3,
                   status OUT NUMBER);

  -- Setting error messages
  PROCEDURE setErrMsg(misdef OUT VARCHAR2, nename OUT VARCHAR2);

  -- Find subprograms and describe the parameters
  PROCEDURE describe(objn NUMBER, name VARCHAR2, subname VARCHAR2,
                     usr VARCHAR2, pnames IN OUT tvarchar,
                     ptnames IN OUT tvarchar, ptypes IN OUT tvchar3,
                     status OUT NUMBER);

  -- name of an identifier
  FUNCTION idname(n ptnod) RETURN VARCHAR2;

  -- name of a subprogram
  FUNCTION procname(k ptnod) RETURN VARCHAR2;

  -- name of a type
  FUNCTION typename(k ptnod) RETURN VARCHAR2;

  -- check if a type is a character type
  FUNCTION isCharType(tname VARCHAR2) RETURN BOOLEAN;

  -- read type nodes from a subprog for parameters listed in pnames.
  PROCEDURE getTypeNodes(subnod ptnod, pnames tvarchar,
                         pnodes OUT tptnod);

  -- check if a package subprog has parameter names matching with given names
  FUNCTION ismatched(subnod ptnod, pnames IN OUT tvarchar,
                     pnodes OUT tptnod) RETURN BOOLEAN;

  -- Get types and type names of given parameters (in pnodes)
  PROCEDURE gettypes(pnodes tptnod, ptypes IN OUT tvchar3, objn NUMBER,
                     subname VARCHAR2, olnum NUMBER, pnames tvarchar);
  PROCEDURE gettnames(pnodes tptnod, ptnames IN OUT tvarchar,
                      parent_list pidl.ptseqnd);

  -- Get type and type name of one parameter
  FUNCTION gettname(parnod ptnod, parent_list pidl.ptseqnd) RETURN VARCHAR2;
  FUNCTION gettype(parnod ptnod, objn NUMBER, subname VARCHAR2, olnum NUMBER,
                   pname VARCHAR2) RETURN VARCHAR2;
  FUNCTION descType(objn NUMBER, subname VARCHAR2, olnum number,
                    pname varchar2) RETURN VARCHAR2;

  -- Get text version of all diana nodes
  PROCEDURE exprtext(x ptnod, rv IN OUT VARCHAR2);

  -- Normalize names
  FUNCTION normalname(name VARCHAR2) RETURN VARCHAR2;

  -- enquote special name
  FUNCTION coatname(name VARCHAR2) RETURN VARCHAR2;

  -- Concatenate names into one
  FUNCTION concatNames(prename VARCHAR2, name VARCHAR2, subname VARCHAR2)
    RETURN VARCHAR2;

  ------------------------------------------------------------------------
  --            Public suprogram implementation                         --
  ------------------------------------------------------------------------
  PROCEDURE subpparam(objnum NUMBER, name VARCHAR2, subname VARCHAR2,
                      prename VARCHAR2, status OUT NUMBER, misdef OUT VARCHAR2,
                      nename OUT VARCHAR2) IS
    pnames tvarchar;
    ptnames tvarchar;
    ptypes tvchar3;
  BEGIN
    driver(objnum,prename,name,subname,pnames,ptnames,ptypes,status);
    setErrMsg(misdef, nename);
  END;

  PROCEDURE subpparam(objnum NUMBER, name VARCHAR2, subname VARCHAR2,
                      prename VARCHAR2, pnames IN OUT tvarchar,
                      ptnames IN OUT tvarchar, ptypes IN OUT tvchar3,
                      status OUT NUMBER, misdef OUT VARCHAR2,
                      nename OUT VARCHAR2) IS
  BEGIN
    driver(objnum,prename,name,subname,pnames,ptnames,ptypes,status);
    setErrMsg(misdef, nename);
  END;

  PROCEDURE subpfparam(objnum NUMBER, name VARCHAR2, subname VARCHAR2,
                       prename VARCHAR2, pnames IN tvarchar,
                       ptnames IN OUT tvarchar, ptypes IN tvchar3,
                       status OUT NUMBER, misdef OUT VARCHAR2,
                       nename OUT VARCHAR2) IS
    vpnames tvarchar;
    vptypes tvchar3;
  BEGIN
    vpnames(1) := pnames(2);
    vpnames(2) := pnames(3);
    vptypes(1) := ptypes(2);
    vptypes(2) := ptypes(3);
    
    driver(objnum,prename,name,subname,vpnames,ptnames,vptypes,status);
    setErrMsg(misdef, nename);

    IF (status != s_ok) THEN
      vpnames := pnames;
      vptypes := ptypes;
      driver(objnum,prename,name,subname,vpnames,ptnames,vptypes,status);
      IF (status = s_ok) THEN
        misdef := NULL;
        nename := NULL;
      END IF;
    END IF;
  END;

  ------------------------------------------------------------------------
  --                                                                    --
  --      Private subprogram implementation                             --
  --                                                                    --
  ------------------------------------------------------------------------
  PROCEDURE driver(objnum NUMBER, ownerName VARCHAR2, objname VARCHAR2,
                   subname VARCHAR2, pnames IN OUT tvarchar,
                   ptnames IN OUT tvarchar, ptypes IN OUT tvchar3,
                   status OUT NUMBER) IS
    PROCEDURE setPrefix(prefix VARCHAR2) is
    BEGIN
      IF (prefix = user) THEN
        -- no need to prefix owner name to types
        owner_prefix := NULL;
      ELSE
        owner_prefix := prefix;
      END IF;
    END setPrefix;

  BEGIN
    setPrefix(ownerName);
    missing_defaults := NULL;
    non_exist_names := NULL;
    posterr := TRUE;
    describe(objnum, objname, subname, ownerName, pnames,
             ptnames, ptypes, status);
  END driver;

  PROCEDURE setErrMsg(misdef OUT VARCHAR2, nename OUT VARCHAR2) IS
  BEGIN
    IF (posterr) THEN
      misdef := missing_defaults;
      nename := non_exist_names;
    ELSE
      misdef := NULL;
      nename := NULL;
    END IF;
  END;

  PROCEDURE describe(objn NUMBER, name VARCHAR2, subname VARCHAR2,
                     usr VARCHAR2, pnames IN OUT tvarchar,
                     ptnames IN OUT tvarchar, ptypes IN OUT tvchar3,
                     status OUT NUMBER) is
    oroot ptnod;                -- object root
    subnod ptnod;               -- subprogram tree node
    pnodes tptnod;              -- array of tree nodes for given pnames
    dummy  tptnod;              -- array of tree nodes for given pnames
    fmcnt NUMBER;
    readTypes tvchar3;
    seq pidl.ptseqnd := 0;
    len INTEGER;
    olnum NUMBER;               -- overload number
    found_name boolean;

    di_status diutil.ub4;

    PROCEDURE filterByArrayStatus(nodlis tptnod) IS
      keepbest BOOLEAN := TRUE;
      keepnew  BOOLEAN := TRUE;
      ptype CHAR(3);
      rtype CHAR(3);
      mtype CHAR(3);
    BEGIN
      gettypes(nodlis, readTypes, objn, subname, olnum, pnames);

      -- If this is the first call, assign value and return.
      IF (MatchTypes.count = 0) THEN
        MLcnt := 1;
        MatchList(MLcnt) := subnod;
        OLnums(MLcnt) := olnum;
        FOR i IN 1..ptypes.count LOOP
          IF (ptypes(i) = readTypes(i)) THEN
            MatchTypes(i) := ptypes(i);
          ELSE
            MatchTypes(i) := NULL;
          END IF;
        END LOOP;
        RETURN;
      END IF;

      -- Find the bestmatches sofar
      FOR i IN 1..ptypes.count LOOP
        ptype := ptypes(i);
        mtype := MatchTypes(i);
        rtype := readTypes(i);
        IF (ptype = rtype AND (mtype is NULL OR ptype != mtype)) THEN
          MatchTypes(i) := ptype;
          keepbest := FALSE;
        ELSIF (ptype = mtype AND ptype != rtype) THEN
          keepnew := FALSE;
        END IF;
      END LOOP;

      IF (keepnew != keepbest) THEN
        -- Keep only one of them
        IF (keepnew) THEN
          -- Keep only new one and destroy the current matchlist.
          MLcnt := 1;
          MatchList(MLcnt) := subnod;
          OLnums(MLcnt) := olnum;
        END IF;
      ELSE
        -- Either keep both or destroy both.
        IF (keepnew) THEN
          MLcnt := MLcnt+1;
          MatchList(MLcnt) := subnod;
          OLnums(MLcnt) := olnum;
        ELSE
          MLcnt := 0;
        END IF;
      END IF;
    END;

    PROCEDURE findMatch(nodlis OUT tptnod) IS
    BEGIN
      IF (ismatched(subnod, pnames, nodlis)) THEN
        fmcnt := fmcnt+1;
        filterByArrayStatus(nodlis);
      END IF;
    END;

    PROCEDURE filterByCharType(matchnod OUT ptnod, oln OUT NUMBER) IS
      anod ptnod;
      mb   BOOLEAN;
      nb   BOOLEAN;
      elimbest BOOLEAN;
      elimnew  BOOLEAN;
    BEGIN
      FOR i in 1..MLcnt LOOP
        anod := MatchList(i);
        getTypeNodes(anod, pnames, dummy);

        IF (i = 1) THEN
          gettypes(dummy, MatchTypes, objn, subname, olnum, pnames);
          FOR j IN 1..dummy.count LOOP
            CharList(j) := (MatchTypes(j) = t_scalar) AND
                           (isCharType(gettname(dummy(j),seq)));
          END LOOP;
          matchnod := anod;
          oln := OLnums(i);
        ELSE
          elimbest := FALSE;
          elimnew  := FALSE;
          FOR j IN 1..dummy.count LOOP
            IF (MatchTypes(j) = t_scalar) THEN
              mb := CharList(j);
              nb := isCharType(gettname(dummy(j),seq));
              IF (mb != nb) THEN
                IF (nb) THEN
                  CharList(j) := nb;
                  elimbest := TRUE;
                ELSE
                  elimnew := TRUE;
                END IF;
              END IF;
            END IF;
          END LOOP;

          IF (elimbest != elimnew) THEN
            IF (elimbest) THEN
              matchnod := anod;
              oln := OLnums(i);
            END IF;
          ELSE
            -- since we can only keep one, get rid of both of them
            matchnod := NULL;
          END IF;
        END IF;
      END LOOP;
    END;

  BEGIN
    status := s_ok;

    -- Looking for the object in the schema
    diutil.get_diana(name, usr, NULL, NULL, di_status, oroot,
                     diutil.libunit_type_spec, diutil.load_source_yes);
    IF (oroot is NULL OR oroot = 0) THEN
      status := s_subpnotfound;
      RETURN;
    END IF;

    -- Object is found
    -- Check if it's a subprog and return the type names
    subnod := diana.a_unit_b(oroot);

    -- Normalize name before comparison
    FOR i IN 1..pnames.count LOOP
      pnames(i) := normalname(pnames(i));
    END LOOP;

    IF (subname IS NULL OR subname = '') THEN
      IF (pidl.ptkin(subnod) = diana.d_p_decl OR
          pidl.ptkin(subnod) = diana.d_library) THEN
        status := s_notasub;
      ELSIF (ismatched(subnod, pnames, pnodes)) THEN
        -- No overloading
        gettypes(pnodes, ptypes, objn, NULL, NULL, pnames);
        gettnames(pnodes,ptnames,seq);
      ELSE
        status := s_nomatch;
      END IF;
      RETURN;
    END IF;

    -- search FOR subname among ALL func/proc IN the PACKAGE
    IF (pidl.ptkin(subnod) != diana.d_p_decl) THEN
      status := s_notasub;
      RETURN;
    END IF;

    posnotunique := FALSE;
    package_prefix := name;
    subnod := diana.a_packag(subnod);
    seq := diana.as_list(diana.as_decl1(subnod));
    len := pidl.ptslen(seq) - 1;
    found_name := FALSE;
    olnum := 0;
    MLcnt := 0;
    fmcnt := 0;
    FOR i IN 0..len LOOP
      subnod := pidl.ptgend(seq, i);
      IF (procname(subnod) = subname) THEN
        olnum := olnum+1;
        found_name := TRUE;
        -- If there's already a match, we pass a dummy,
        -- so we won't overwrite pnodes -> optimize the non-overload case
        IF (fmcnt = 0) THEN
          findmatch(pnodes);
        ELSE
          findmatch(dummy);
        END IF;
      END IF;
    END LOOP;

    IF (fmcnt = 0) THEN
      IF (found_name) THEN
        status := s_nomatch;
      ELSE
        status := s_notinpackage;
      END IF;
      RETURN;
    END IF;

    -- No overloading
    IF (fmcnt = 1) THEN
      ptypes := readtypes;
      gettnames(pnodes,ptnames,seq);
      RETURN;
    END IF;

    -- No match for array types
    IF (MLcnt = 0) THEN
      status := s_typenotmatch;
      RETURN;
    END IF;

    IF (MLcnt = 1) THEN
      subnod := MatchList(1);
      olnum := OLnums(1);
    ELSE
      filterByCharType(subnod, olnum);
      IF (subnod is NULL) THEN
        status := s_notunique;
        RETURN;
      END IF;
    END IF;

    getTypeNodes(subnod, pnames, pnodes);
    gettypes(pnodes, ptypes, objn, subname, olnum, pnames);
    gettnames(pnodes,ptnames,seq);
  END describe;

  -----------------------
  -- idname
  -----------------------
  FUNCTION idname(n ptnod) RETURN VARCHAR2 IS
    seq pidl.ptseqnd;
    len BINARY_INTEGER;
  BEGIN
    seq := diana.as_list(n);
    len := pidl.ptslen(seq);
    RETURN coatname(diana.l_symrep(pidl.ptgend(seq, len-1)));
  END idname;

  -----------------------
  -- procname
  -----------------------
  FUNCTION procname(k ptnod) RETURN VARCHAR2 IS
    x ptnod;
    xkind pidl.ptnty;
  BEGIN
    IF (k IS NULL OR k = 0) THEN RETURN NULL; END IF;
    IF (pidl.ptkin(k) != diana.d_s_decl) THEN RETURN NULL; END IF;
    x := diana.a_d_(k);
    xkind := pidl.ptkin(x);
    IF (    xkind != diana.di_funct
        AND xkind != diana.di_proc
        AND xkind != diana.d_def_op) THEN
      RETURN NULL;
    END IF;
    RETURN diana.l_symrep(x);
  END;

  -----------------------
  -- typename
  -----------------------
  FUNCTION typename(k ptnod) RETURN VARCHAR2 IS
    ktype pidl.ptnty;
  BEGIN
    IF (k IS NOT NULL AND k != 0) THEN
      ktype := pidl.ptkin(k);
      IF (ktype = diana.d_type OR ktype = diana.d_subtyp) THEN
        RETURN diana.l_symrep(diana.a_id(k));
      END IF;
    END IF;

    RETURN NULL;
  END;

  -----------------------
  -- ischartype
  -----------------------
  FUNCTION isCharType(tname VARCHAR2) RETURN BOOLEAN IS
  BEGIN
    return (tname LIKE '%CHAR%') OR
           (tname = 'STRING') OR
           (tname = 'LONG') OR
           (tname LIKE '%RAW%') OR
           (tname LIKE '%ROWID');
  END;

  -----------------------
  -- getTypeNodes
  -----------------------
  PROCEDURE getTypeNodes(subnod ptnod, pnames tvarchar,
                         pnodes OUT tptnod) IS
    parseq pidl.ptseqnd;
    parnum NATURAL;
    parnod ptnod;
    parname VARCHAR2(128);
    actnum NATURAL;
  BEGIN
    parseq := diana.as_list(diana.as_p_(diana.a_header(subnod)));
    parnum := pidl.ptslen(parseq);
    actnum := pnames.count;

    FOR j IN 1..actnum LOOP
      FOR i IN 1..parnum LOOP
        parnod := pidl.ptgend(parseq, i-1);
        parname := idname(diana.as_id(parnod));
        IF (parname = pnames(j)) THEN
          pnodes(j) := parnod;
          GOTO found_matched;
        END IF;
      END LOOP;
    <<found_matched>> null;
    END LOOP;
  END;

  -----------------------
  -- ismatched
  -----------------------
  FUNCTION ismatched(subnod ptnod, pnames IN OUT tvarchar,
                     pnodes OUT tptnod) RETURN BOOLEAN IS
    parseq pidl.ptseqnd;
    parnum NATURAL;
    parnod ptnod;
    parname VARCHAR2(128);
    defval ptnod;
    retval boolean := TRUE;
    actnum NATURAL;
  BEGIN
    parseq := diana.as_list(diana.as_p_(diana.a_header(subnod)));
    parnum := pidl.ptslen(parseq);
    actnum := pnames.count;

    IF (missing_defaults IS NOT NULL OR non_exist_names IS NOT NULL) THEN
      posterr := FALSE;
    END IF;

    IF (parnum = 0 AND actnum = 0) THEN
      RETURN TRUE;
    END IF;

    FOR i IN 1..actnum LOOP
      pnodes(i) := 0;
    END LOOP;

    -- First, make sure each formal parameter has an actual value
    FOR i IN 1..parnum LOOP
      parnod := pidl.ptgend(parseq, i-1);
      parname := idname(diana.as_id(parnod));

      FOR j IN 1..actnum LOOP
        IF (parname = pnames(j)) THEN
          pnodes(j) := parnod;
          GOTO found_matched;
        END IF;
      END LOOP;

      defval := diana.a_exp_vo(parnod);
      IF (defval IS NULL OR defval = 0) THEN
        IF (posterr) THEN
          IF (missing_defaults IS NULL) THEN
            missing_defaults := parname;
          ELSE
            missing_defaults := missing_defaults || ',' || parname;
          END IF;
        END IF;
        retval := FALSE;
      END IF;

      <<found_matched>> null;
    END LOOP;

    -- Second, make sure all actual values have associated formal parameters
    FOR i IN 1..actnum LOOP
      IF (pnodes(i) = 0) THEN
        IF (posterr) THEN
          IF (non_exist_names IS NULL) THEN
            non_exist_names := pnames(i);
          ELSE
            non_exist_names := non_exist_names || ',' || pnames(i);
          END IF;
        END IF;
        retval := FALSE;
      END IF;
    END LOOP;

    RETURN retval;
  END;

  -------------------------------
  -- gettypes
  -------------------------------
  PROCEDURE gettypes(pnodes tptnod, ptypes IN OUT tvchar3, objn NUMBER,
                     subname VARCHAR2, olnum NUMBER, pnames tvarchar) IS
    parnum NATURAL;
  BEGIN
    parnum := pnodes.count;
    FOR i IN 1..parnum LOOP
      ptypes(i) := gettype(pnodes(i), objn, subname, olnum, pnames(i));
    END LOOP;
  END;

  -------------------------------
  -- gettnames
  -------------------------------
  PROCEDURE gettnames(pnodes tptnod, ptnames IN OUT tvarchar,
                      parent_list pidl.ptseqnd) IS
    parnum NATURAL;
  BEGIN
    parnum := pnodes.count;
    FOR i IN 1..parnum LOOP
      ptnames(i) := gettname(pnodes(i), parent_list);
    END LOOP;
  END;

  -------------------------------------------------------------------
  -- gettname
  -- This function does name-resolution for two cases:
  --   * var A_TYPE
  --   * var A_OWNER.A_PACK.A_TYPE
  --   For these two case it will look for the package or owner of
  --   the type and prefix the type name with that.
  -- No name-resolution for others. We'll print the type name as is
  -------------------------------------------------------------------
  FUNCTION gettname(parnod ptnod, parent_list pidl.ptseqnd) RETURN VARCHAR2 IS
    tnod ptnod;
    prenod1 ptnod;
    prenod2 ptnod;
    tkind pidl.ptnty;

    name VARCHAR2(512) := NULL;
    typname VARCHAR2(512) := NULL;

    -- Check if a type is defined in the package
    FUNCTION isInPackage(oname VARCHAR2) RETURN BOOLEAN IS
      len NATURAL;
      typnod ptnod;
    BEGIN
      len := pidl.ptslen(parent_list)-1;
      FOR i IN 0..len LOOP
        typnod := pidl.ptgend(parent_list, i);
        IF (typename(typnod) = oname) THEN
          RETURN TRUE;
        END IF;
      END LOOP;
      RETURN FALSE;
    END;

    -- Check if a type is defined in the owner's schema
    FUNCTION isInSchema(oname VARCHAR2) RETURN BOOLEAN IS
      cnt NUMBER;
    BEGIN
      SELECT count(*) INTO cnt FROM all_objects
        WHERE owner=owner_prefix AND object_name=oname;
      IF (cnt = 0) THEN
        RETURN FALSE;
      END IF;
      RETURN TRUE;
    END;

  BEGIN
    tnod := diana.a_name(parnod);

    <<try_again>>
    tkind := pidl.ptkin(tnod);
    -- CASE: (var A_TYPE) 
    IF (tkind = diana.di_u_nam) THEN
      typname := diana.l_symrep(tnod);
      IF (parent_list != 0 AND isInPackage(typname)) THEN
        typname := package_prefix || '.' || typname;
      ELSIF (NOT isInSchema(typname)) THEN
        RETURN typname;
      END IF;
      IF (owner_prefix IS NOT NULL) THEN
        typname := owner_prefix || '.' || typname;
      END IF;

    -- CASE: (var A_PACK.A_TYPE) or (var A_OWNER.A_PACK.A_TYPE) 
    ELSIF (tkind = diana.d_s_ed) THEN
      typname := diana.l_symrep(diana.a_d_char(tnod));
      prenod2 := diana.a_name(tnod);
      tkind := pidl.ptkin(prenod2);

      IF (tkind = diana.di_u_nam) THEN
        name := diana.l_symrep(prenod2);
        typname := name || '.' || typname;
        IF (owner_prefix IS NOT NULL AND isInSchema(name)) THEN
          typname := owner_prefix || '.' || typname;
        END IF;

      ELSIF (tkind = diana.d_s_ed) THEN
        prenod1 := diana.a_name(prenod2);
        IF (pidl.ptkin(prenod1) = diana.di_u_nam) THEN
          typname := diana.l_symrep(prenod1) || '.' ||
                     diana.l_symrep(diana.a_d_char(prenod2)) || '.' ||
                     typname;
        END IF;
      END IF;
    END IF;

    -- OTHER CASES: unknown shape of types; no name resolution
    IF (typname IS NULL) THEN
       exprtext(tnod, typname);
    END IF;

    RETURN typname;
  END;

  ---------------------------------
  -- Get characteristic of the type
  ---------------------------------
  FUNCTION gettype(parnod ptnod, objn NUMBER, subname VARCHAR2, olnum NUMBER,
                   pname VARCHAR2) RETURN VARCHAR2 IS
    tnod ptnod;
    tkind pidl.ptnty;
  BEGIN
    tnod := diana.a_name(parnod);
    tkind := pidl.ptkin(tnod);

    IF (tkind = diana.d_s_ed) THEN
      tnod := diana.a_d_char(tnod);
      tkind := pidl.ptkin(tnod);
    END IF;

    IF (tkind = diana.di_u_nam) THEN
      tnod := diana.s_defn_private(tnod);

      -- First check for DI_TYPE
      IF (pidl.ptkin(tnod) = diana.di_type AND
          pidl.ptkin(diana.s_t_spec(tnod)) = diana.d_array) THEN
        RETURN t_v7array;
      END IF;

      -- Second check for DI_SUBTY
      IF (pidl.ptkin(tnod) = diana.di_subty) THEN
        tnod := diana.s_t_spec(tnod);
        IF (pidl.ptkin(tnod) = diana.d_constr) THEN
          tnod := diana.s_base_t(tnod);
          IF (pidl.ptkin(tnod) = diana.d_array) THEN
            RETURN t_v7array;
          END IF;
        END IF;
      END IF;

      -- Couldn't find the type in diana, look for it in the database
      IF (tnod = 0) THEN
        RETURN desctype(objn, subname, olnum, pname);
      END IF;
    END IF;

    RETURN t_scalar;
  END;

  -------------------------------------------------------
  -- describe kind of types when it's not granted to user
  -------------------------------------------------------
  FUNCTION descType(objn NUMBER, subname VARCHAR2, olnum number,
                    pname varchar2) RETURN VARCHAR2 IS
    tkind VARCHAR2(4) := t_scalar;
    typnum NUMBER;
  BEGIN
    IF (subname IS NULL) THEN
      SELECT type# INTO typnum FROM argument$
        WHERE obj#=objn AND argument=pname;
    ELSE
      BEGIN
        SELECT type# INTO typnum FROM argument$
          WHERE obj#=objn AND procedure$=subname AND argument=pname;
      EXCEPTION
        WHEN too_many_rows THEN
          SELECT type# INTO typnum FROM argument$
            WHERE obj#=objn AND procedure$=subname AND overload#=olnum
                  AND argument=pname;
      END;
    END IF;

    IF (typnum = 251) THEN
      tkind := t_v7array;
    END IF;

    return tkind;
  END;

  -------------------------------
  -- exprtext:
  --  general unparsing FUNCTION
  -------------------------------
  PROCEDURE exprtext(x ptnod, rv IN OUT VARCHAR2) IS

    --------------------
    -- etext:
    --------------------
    PROCEDURE etext(n ptnod) IS
      nkind pidl.ptnty;
    BEGIN
      IF (n IS NOT NULL) THEN
        nkind := pidl.ptkin(n);
        -- simple expr
        IF (nkind = diana.di_u_nam OR nkind = diana.d_used_b
        OR nkind = diana.di_u_blt OR nkind = diana.di_funct
        OR nkind = diana.di_proc OR nkind = diana.di_packa
        OR nkind = diana.di_var OR nkind = diana.di_type
        OR nkind = diana.di_subty OR nkind = diana.di_in
        OR nkind = diana.di_out OR nkind = diana.di_in_ou) THEN
          rv := rv ||  coatname(diana.l_symrep(n));

        ELSIF (nkind = diana.d_s_ed) THEN
          -- x.y
          etext(diana.a_name(n));
          rv := rv || '.';
          etext(diana.a_d_char(n));

        ELSIF (nkind = diana.d_string OR nkind = diana.d_used_c 
               OR nkind = diana.d_def_op) THEN
          rv := rv || '''' || diana.l_symrep(n) || '''';

        ELSIF (nkind = diana.d_attrib) THEN
          etext(diana.a_name(n));
          rv := rv || '%';
          etext(diana.a_id(n));

        ELSIF (nkind = diana.d_numeri) THEN
          rv := rv ||  diana.l_numrep(n);

        ELSIF (nkind = diana.d_constr) THEN  -- constraint
          etext(diana.a_name(n));

        ELSIF (nkind = diana.d_t_ref) THEN
          rv := 'REF ';
          etext(diana.a_type_s(n));

        ELSE
          rv := '';
        END IF;

      END IF;
    END etext;

  BEGIN -- exprText
    etext(x);
  END exprtext;

  -----------------------
  -- normalname: RETURN a normalized name.
  -----------------------
  FUNCTION normalname(name VARCHAR2) RETURN VARCHAR2 IS
    firstchar VARCHAR2(4);
    len NUMBER;
  BEGIN
    IF (name IS NULL OR name = '') THEN RETURN name; END IF;
    firstchar := substr(name, 1, 1);
    IF (firstchar = '"') THEN
      len := length(name);
      IF (len > 1 AND substr(name, len, 1) = '"') THEN
        IF (len > 33) THEN
          len := 31;
        ELSE
          len := len-2;
        END IF;
        RETURN substr(name, 2, len);
      END IF;
    END IF;
    RETURN upper(name);
  END normalname;

  -----------------------
  -- coatname: enquote name IF necessary
  -----------------------
  FUNCTION coatname(name VARCHAR2) RETURN VARCHAR2 IS
  BEGIN
    IF (name != upper(name)) THEN
      RETURN '"' || name || '"';
    ELSE
      RETURN name;
    END IF;
  END coatname;

  FUNCTION concatNames(prename VARCHAR2, name VARCHAR2, subname VARCHAR2)
  RETURN VARCHAR2 AS
    fullname VARCHAR2(128) := NULL;
  BEGIN
    IF (subname IS NOT NULL) THEN
      fullname := subname;
    END IF;
    IF (name IS NOT NULL) THEN
      IF (fullname IS NOT NULL) THEN
        fullname := name || '.' || fullname;
      ELSE
        fullname := name;
      END IF;
    END IF;
    IF (prename IS NOT NULL) THEN
      IF (fullname IS NOT NULL) THEN
        fullname := prename || '.' || fullname;
      ELSE
        fullname := prename;
      END IF;
    END IF;
    RETURN fullname;
  END;

END;
/
show errors;
grant execute on sys.wpiutl to public
/
