PC World Komputer 1996 February

home *** CD-ROM | disk | FTP | other *** search

/ PC World Komputer 1996 February / PCWK0296.iso / po7_win / db / rdbms71 / diutil.sql < prev next >

Wrap

Text File | 1994-08-04 | 42.5 KB | 1,342 lines

Rem Rem $Header: diutil.sql 7010400.1 94/06/03 15:17:43 cli Generic<base> $ Rem Rem Copyright (c) 1992 by Oracle Corporation Rem NAME Rem diutil.pls - package DIUTIL Rem DESCRIPTION Rem Diana application routines Rem Rem RETURNS Rem Rem NOTES Rem <other useful comments, qualifications, etc.> Rem MODIFIED (MM/DD/YY) Rem usundara 05/26/94 - bug 196374 again - minor fix Rem usundara 05/16/94 - bug 196374 Rem usundara 01/22/94 - fix traversals (161306,147036) add libunit_type Rem usundara 01/06/94 - fix #190597; deal with %type; reindent. Rem smuench 05/26/93 - fix problems w/ boolean support Rem pshaw 10/21/92 - modify script for bug 131187 Rem gclossma 09/28/92 - sanitize Rem gclossma 09/07/92 - logic error (as if there's some other kind?) Rem gclossma 09/04/92 - no more to-varchar2 Rem gclossma 08/05/92 - source-control Steve M's changes for booleans Rem smuench 07/17/92 - add boolean param supt, int_to_bool/bool_to_int Rem gclossma 07/14/92 - pstubT: add constraints to CHARs; bigger pkgs Rem gclossma 05/08/92 - simplify; check buffer lengths Rem gclossma 04/10/92 - gen CHAR stead of VARCHAR2 for sqlforms3 for v6 Rem ahong 03/25/92 - fix synonym expansion for pstub Rem ahong 03/20/92 - add s_notInPackage Rem ahong 03/12/92 - synonym Rem ahong 03/10/92 - no s_noPriv Rem ahong 03/03/92 - return empty instead of null Rem ahong 02/21/92 - upper names Rem ahong 02/11/92 - Creation Rem NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE Rem NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE Rem NOTE: you must be connected "internal" (i.e. as user SYS) to run this Rem script. Rem NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE Rem NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE NOTICE drop table sys.pstubtbl; create table sys.pstubtbl ( username varchar2(30), dbname varchar2(128), lun varchar2(30), lutype varchar2(3), lineno number, line varchar2(1800) ); grant select,delete on sys.pstubtbl to public; drop package body sys.diutil; drop package sys.diutil; create or replace package sys.diutil is e_subpNotFound exception; e_notInPackage exception; e_noPriv exception; e_stubTooLong exception; e_notv6compat exception; e_other exception; subtype ptnod is pidl.ptnod; subtype ub4 is pidl.ub4; -- Return code from diutil functions -- s_ok constant number := 0; -- successful s_notInPackage constant number := 6; -- package found, proc not found s_subpNotFound constant number := 1; -- subprogram not found s_stubTooLong constant number := 3; -- text to be returned is too long s_logic constant number := 4; -- logic error s_other constant number := 5; -- other error s_defaultVal constant number := 8; -- true iff parameters have default -- values. Applicable to pstub s_notv6compat constant number := 7; -- found non v6 type or construct char_for_varchar2 boolean; -- set from flags for v6 compatibility libunit_type_spec constant number := 1; libunit_type_body constant number := 2; -- get_d: returns the root of the diana of a libunit, given name and usr. -- name will be first folded to upper case if not in quotes, else stripped -- of quotes. -- In: name = subprogram name -- usr = user name -- dbname = database name, null for current -- dbowner = null for current -- libunit_type = libunit_type_spec for spec, -- = libunit_type_body for body -- Out: status = s_ok(0): diana root returned in nod -- s_subpNotFound: nod null -- s_other: other error, nod null -- procedure get_d(name varchar2, usr varchar2, dbname varchar2, dbowner varchar2, status in out ub4, nod OUT ptnod, libunit_type number := libunit_type_spec); -- get_diana: returns the root of the diana of a libunit, given name and usr. -- name will be first folded to upper case if not in quotes, else stripped -- of quotes. Will trace synonym links. -- In: name = subprogram name -- usr = user name -- dbname = database name, null for current -- dbowner = null for current -- libunit_type = libunit_type_spec for spec, -- = libunit_type_body for body -- Out: status = s_ok(0): diana root returned in nod -- s_subpNotFound: nod null -- s_other: other error, nod null -- procedure get_diana(name varchar2, usr varchar2, dbname varchar2, dbowner varchar2, status in out ub4, nod in out ptnod, libunit_type number := libunit_type_spec); -- subptxt: returns the text of a subprogram source (DESCRIBE). -- In: name - package or toplevel proc/func name; -- subname - non-null to specify proc/func in package <name>. -- dbname - database name -- dbowner - dbase owner -- Out: status = s_ok (0): text returned in txt -- s_subpNotFound: txt empty -- s_notInPackagte: txt empty -- s_stubTooLong: txt len too small; txt empty -- s_logic: logic error; txt empty -- s_other: other failure; txt empty -- procedure subptxt(name varchar2, subname varchar2, usr varchar2, dbname varchar2, dbowner varchar2, txt in out varchar2, status in out ub4); -- pstub: procedure returning stub text of a subprogram -- In: pname - subprogram name -- subname - NULL or member name (if pname is a package -- spec) -- uname - user name, NULL or '' to mean current user -- dbname - database name -- dbowner - dbase owner -- Out: status - s_ok (0): stub text in return val -- s_subpNotFound: stubSpec, stubText empty -- s_stubTooLong: stub text too long; stubSpec, -- stubText empty -- s_logic: logic error; stubSpec, stubText empty -- s_other failure; stubSpec, stubText empty -- s_defaultVal: proc/func default parm values; -- stubSpec, stubText partial -- stubSpec - empty if subprogram is a top level proc/func -- or if subname is specified for package pname, -- else contain package spec -- stubText - contains stub body -- procedure pstub(pname varchar2, subname varchar2, uname varchar2, dabaname varchar2, dbowner varchar2, status in out ub4, flags varchar2, stubtype in out varchar2); -- bool_to_int: Translates 3-valued boolean to NUMBER for use -- in sending boolean parameter / return values -- between PLS v1 (client) and PLS v2. Since SQLNET -- has no boolean bind variable type, we encode -- booleans as FALSE = 0, TRUE = 1, NULL = NULL for -- network transfer as NUMBER -- function bool_to_int( b BOOLEAN) return number; -- int_to_bool: Translates 3-valued NUMBER encoding to BOOLEAN for use -- in sending boolean parameter / return values -- between PLS v1 (client) and PLS v2. Since SQLNET -- has no boolean bind variable type, we encode -- booleans as FALSE = 0, TRUE = 1, NULL = NULL for -- network transfer as NUMBER -- function int_to_bool( n NUMBER) return boolean; end diutil; / Rem Rem Package body DIUTIL: Rem Rem create or replace package body sys.diutil is ----------------------- -- Private members ----------------------- procedure diugdn(name varchar2, usr varchar2, dbname varchar2, dbowner varchar2, status out ub4, nod OUT ptnod, libunit_type binary_integer := libunit_type_spec); pragma interface(c,diugdn); procedure diustx(n ptnod, txt out varchar2, status out ub4); pragma interface(c,diustx); assertVal constant boolean := TRUE; ----------------------- -- assert ----------------------- procedure assert(v boolean, str varchar2) is x integer; begin if (assertVal and not v) then raise program_error; end if; end assert; ----------------------- -- assert ----------------------- procedure assert(v boolean) is begin assert(v, ''); end; ----------------------- -- last_elt ----------------------- function last_elt (seq pidl.ptseqnd) return pidl.ptnod is len binary_integer; begin len := pidl.ptslen(seq); assert(len > 0); return pidl.ptgend(seq, len - 1); end last_elt; ----------------------- -- normalName: return a normalized name. Fold up if not in quotes, -- else strip quotes. ----------------------- function normalName(name varchar2) return varchar2 is firstChar varchar2(1); 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 || '"'; elsif char_for_varchar2 and name = 'VARCHAR2' then return 'CHAR'; else return name; end if; end coatName; ----------------------- -- idName ----------------------- function idName(n ptnod) return varchar2 is -- return the text of an ID node. This function is also -- used to limit the recursion in exprText() below. -- Should have the semantics of listText(diana.as_list(n), ','); seq pidl.ptseqnd; begin assert(pidl.ptkin(n) = diana.DS_ID); seq := diana.as_list(n); return coatName(diana.l_symrep(last_elt(seq))); end idName; ----------------------- -- exprText: General unparsing function ----------------------- procedure exprText(x ptnod, rv in out varchar2); ----------------------- -- genProcSpec -- Append the spec for a top-level node n to sText. -- ignoreDefVal controls whether parm default vals should be ignored. -- hasDefVal returned true iff parm default vals exist. -- Toplevel name returned in pName. -- If function, function string returned in returnVal. ----------------------- procedure genProcSpec(n ptnod, ignoreDefVal boolean, hasDefVal in out boolean, pName in out varchar2, returnVal in out varchar2, flags varchar2, sText in out varchar2); ----------------------- -- 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; ----------------------- -- Private members ----------------------- ----------------------- -- get_d ----------------------- procedure get_d (name varchar2, usr varchar2, dbname varchar2, dbowner varchar2, status in out ub4, nod OUT ptnod, libunit_type number := libunit_type_spec) is nName varchar2(100); nUsr varchar2(100); nDbname varchar2(100); nDbowner varchar2(100); begin -- get_d nod := null; begin nName := normalName(name); nUsr := normalName(usr); nDbname := normalName(dbname); nDbowner := normalName(dbowner); if (nName is null or nName = '') then raise e_subpNotFound; end if; diugdn(nName, nUsr, nDbname, nDbowner, status, nod, libunit_type); if (status = 1) then diugdn(nName, 'PUBLIC', nDbname, nDbowner, status, nod, libunit_type); end if; if (status = 1) then raise e_subpNotFound; elsif (status = 2) then raise e_noPriv; elsif (status <> 0) then raise e_other; end if; status := s_ok; exception when e_subpNotFound then status := s_subpNotFound; when e_noPriv then status := s_subpNotFound; when others then status := s_other; end; end get_d; ----------------------- -- get_diana ----------------------- procedure get_diana (name varchar2, usr varchar2, dbname varchar2, dbowner varchar2, status in out ub4, nod in out ptnod, libunit_type number := libunit_type_spec) is t ptnod; begin -- get_diana nod := null; begin get_d(name, usr, dbname, dbowner, status, nod, libunit_type); if (status = s_ok) then t := diana.a_unit_b(nod); assert(pidl.ptkin(t) <> diana.Q_CREATE); end if; exception when program_error then status := s_other; when others then status := s_other; end; end get_diana; ----------------------- -- subptxt ----------------------- procedure subptxt(name varchar2, subname varchar2, usr varchar2, dbname varchar2, dbowner varchar2, txt in out varchar2, status in out ub4) is e_defaultVal boolean := FALSE; ----------------------- -- describeProc ----------------------- procedure describeProc(n ptnod, s in out varchar2) is tmpVal varchar2(100); rVal varchar2(500); begin -- describeProc -- We call genProcSpec here because it is not -- possible to get the text reliably for arbitrary node -- through diustx -- tmpVal := null; genProcSpec(n, FALSE, e_defaultVal, tmpVal, rVal, '', s); s := s || '; '; end describeProc; begin -- subptxt txt := ''; declare troot ptnod; n ptnod; nSubName varchar2(100); begin get_diana(name, usr, dbname, dbowner, status, troot); if (troot is null or troot = 0) then return; end if; nSubname := normalName(subname); n := diana.a_unit_b(troot); if (nSubname is null or nSubname = '') then if (pidl.ptkin(n) = diana.D_P_DECL) then diustx(troot, txt, status); else describeProc(n, txt); end if; else -- search for subname among all func/proc in the package if (pidl.ptkin(n) <> diana.D_P_DECL) then status := s_subpNotFound; return; end if; n := diana.a_packag(n); declare seq pidl.ptseqnd := diana.as_list(diana.as_decl1(n)); len integer := pidl.ptslen(seq) - 1; tmp integer; begin for i in 0..len loop --for each member of the package n := pidl.ptgend(seq, i); if (procName(n) = nSubname) then describeProc(n, txt); end if; end loop; end; if (txt is null or txt = '') then status := s_notInPackage; end if; end if; exception -- txt reset to null when value_error then status := s_stubTooLong; when program_error then status := s_logic; when e_other then status := s_other; when others then status := s_other; end; end subptxt; -------------------- -- pstub -------------------- procedure pstub(pname varchar2, subname varchar2, uname varchar2, dabaname varchar2, dbowner varchar2, status in out ub4, flags varchar2, stubtype in out varchar2) is ignoreParmVal constant boolean := TRUE; subtype ptnod is pidl.ptnod; lubptr ptnod; e_defaultVal boolean := FALSE; tsubName varchar2(100); stubSpec varchar2(32700); stubText varchar2(32700); specLine binary_integer := 1; textLine binary_integer := 1; -------------------- -- flushStubs -------------------- procedure flushStubs (partial_lines_ok boolean) is len binary_integer; pos binary_integer; luty varchar2(3); rowbuf varchar2(1820); begin pos := 1; len := length(stubSpec); if len > 0 then -- we have a package spec assert(stubtype = 'PKG'); luty := 'PKS'; end if; while (len - pos > 1800 or (partial_lines_ok and pos <= len)) loop rowbuf := substr(stubSpec, pos, 1800); insert into sys.pstubtbl (username, dbname, lun, lutype, lineno, line) values (uname, dabaname, pname, luty, specLine, rowbuf); pos := pos + 1800; specLine := specLine + 1; end loop; if pos > 1 then stubSpec := substr(stubSpec, pos); end if; pos := 1; len := length(stubText); if len > 0 then -- a subprogram or package body if stubtype = 'PKG' then luty := 'PKB'; else luty := 'SUB'; end if; end if; while (len - pos > 1800 or (partial_lines_ok and pos <= len)) loop rowbuf := substr(stubText, pos, 1800); insert into sys.pstubtbl (username, dbname, lun, lutype, lineno, line) values (uname, dabaname, pname, luty, textLine, rowbuf); pos := pos + 1800; textLine := textLine + 1; end loop; if pos > 1 then stubText := substr(stubText, pos); end if; end flushStubs; -------------------- -- genStubBody -------------------- procedure genStubBody(x ptnod, pName varchar2, returnVal varchar2) is ------------------------------------------------------- -- append the text for the stub body to stubText buffer ------------------------------------------------------- MAXVCSLEN varchar2(4) := '2000'; Type bindArr is Table of varchar2(30) index by binary_integer; parmSeq pidl.ptseqnd; parmNum natural; k ptnod; knd pidl.ptnty; uniq_id varchar2(80); parmname varchar2(80); digit integer; BoolPrm Boolean := FALSE; bindVarLst BindArr; bindVarTyp BindArr; lstptr integer := 0; -- push_bindvar -- procedure push_bindvar( v_name varchar2, v_type varchar2 ) is begin lstptr := lstptr + 1; bindVarLst(lstptr) := v_name; bindVarTyp(lstptr) := UPPER(v_type); end push_bindvar; -- get_bindvar -- procedure get_bindvar( i integer, v_name OUT varchar2, v_type OUT varchar2) is begin v_name := bindVarLst(i); v_type := bindVarTyp(i); end get_bindvar; -- is_boolean -- function is_boolean( typenode ptnod ) return boolean is typename varchar2(100); begin typename := ''; exprText(typenode,typename); return( ltrim(rtrim(typename))='BOOLEAN'); end is_boolean; begin -- genStubBody assert(x is not null); k := diana.a_header(x); assert(k is not null); parmSeq := diana.as_list(diana.as_p_(k)); assert(parmSeq is not null); parmNum := pidl.ptslen(parmSeq); uniq_id := ''; digit := 0; if returnVal is not null then -- gen a unique id, dift from any parm id, for the return-value -- variable loop uniq_id := 'X'||to_char(digit); for i in 1 .. parmNum loop k := pidl.ptgend(parmSeq, i-1); parmname := idName(diana.as_id(k)); if parmname = uniq_id then exit; end if; end loop; if parmNum = 0 or parmname <> uniq_id then exit; end if; digit := digit + 1; end loop; end if; stubText := stubText || ' is '; if (returnVal is not null) then stubText := stubText || uniq_id || ' '; if (returnVal = 'CHAR' or returnVal = 'VARCHAR2' or returnVal = 'VARCHAR' or returnVal = 'RAW') then stubText := stubText || returnVal || '('||MAXVCSLEN||'); '; else stubText := stubText || returnVal || '; '; end if; end if; stubText := stubText || 'begin stproc.init('''; If (returnVal = 'BOOLEAN') then stubText := stubText || 'declare '||uniq_id||'rv BOOLEAN; '; BoolPrm := TRUE; End If; -- Local BOOL if (parmNum > 0) then for i in 1..parmNum loop k := pidl.ptgend(parmSeq, i-1); if ( is_boolean(diana.a_name(k)) ) then if (NOT BoolPrm) then stubText := stubText || 'declare '; BoolPrm := TRUE; end if; stubText := stubText||uniq_id|| idName(diana.as_id(k))||' BOOLEAN; '; end if; end loop; end if; stubText := stubText || 'begin '; -- Init all BOOL params if (parmNum > 0) then for i in 1..parmNum loop k := pidl.ptgend(parmSeq, i-1); if ( is_boolean(diana.a_name(k)) ) then stubText := stubText||uniq_id||idName(diana.as_id(k))|| ' := sys.diutil.int_to_bool(:'|| idName(diana.as_id(k))||'); '; end if; end loop; end if; -- Non-BOOL Return Val if (returnVal is not null) then if (returnVal = 'BOOLEAN') then stubText := stubText || uniq_id ||'rv := ' || pName; else stubText := stubText || ':'||uniq_id||' := ' || pName; end if; else stubText := stubText || pName; end if; if (parmNum > 0) then k := pidl.ptgend(parmSeq, 0); -- Pass local BOOL, non-BOOL binds if ( is_boolean(diana.a_name(k)) ) then stubText := stubText || '(' || uniq_id||idName(diana.as_id(k)); else stubText := stubText || '(:' || idName(diana.as_id(k)); end if; for i in 2..parmNum loop k := pidl.ptgend(parmSeq, i-1); if ( is_boolean(diana.a_name(k)) ) then stubText := stubText || ', ' || uniq_id||idName(diana.as_id(k)); else stubText := stubText || ', :' || idName(diana.as_id(k)); end if; end loop; stubText := stubText || ')'; end if; stubText := stubText || '; '; -- Convert OUT booleans (including return value) if (returnVal is not null and returnVal = 'BOOLEAN' ) then stubText := stubText ||':'||uniq_id|| ' := sys.diutil.bool_to_int('||uniq_id||'rv);'; end if; if (parmNum > 0) then for i in 1..parmNum loop k := pidl.ptgend(parmSeq, i-1); if ( is_boolean(diana.a_name(k)) ) then knd := pidl.ptkin(k); if (knd = diana.D_OUT or knd = diana.D_IN_OUT) then stubText := stubText||':'||idName(diana.as_id(k))|| ' := sys.diutil.bool_to_int('|| uniq_id||idName(diana.as_id(k))||');'; end if; end if; end loop; end if; stubText := stubText || ' end;''); '; -- Bind order according to bind var appearance in stub for i in 1..parmNum loop k := pidl.ptgend(parmSeq, i-1); if ( is_boolean(diana.a_name(k))) then knd := pidl.ptkin(k); declare tmp varchar2(100); begin if (knd = diana.D_IN) then tmp := 'bind_i'; push_bindvar(IdName(diana.as_id(k)),'IN'); elsif (knd = diana.D_OUT) then tmp := 'bind_o'; push_bindvar(IdName(diana.as_id(k)),'OUT'); else tmp := 'bind_io'; push_bindvar(IdName(diana.as_id(k)),'IN OUT'); end if; stubText := stubText || 'stproc.' || tmp || '(' || idName(diana.as_id(k)) || '); '; end; end if; end loop; if (returnVal is not null and returnVal <> 'BOOLEAN') then stubText := stubText || 'stproc.bind_o(' || uniq_id || '); '; push_bindvar(uniq_id,'OUT'); end if; for i in 1..parmNum loop k := pidl.ptgend(parmSeq, i-1); if ( NOT is_boolean(diana.a_name(k))) then knd := pidl.ptkin(k); declare tmp varchar2(100); begin if (knd = diana.D_IN) then tmp := 'bind_i'; push_bindvar(IdName(diana.as_id(k)),'IN'); elsif (knd = diana.D_OUT) then tmp := 'bind_o'; push_bindvar(IdName(diana.as_id(k)),'OUT'); else tmp := 'bind_io'; push_bindvar(IdName(diana.as_id(k)),'IN OUT'); end if; stubText := stubText || 'stproc.' || tmp || '(' || idName(diana.as_id(k)) || '); '; end; end if; end loop; if (returnVal is not null and returnVal = 'BOOLEAN') then stubText := stubText || 'stproc.bind_o(' || uniq_id || '); '; push_bindvar(uniq_id,'OUT'); end if; stubText := stubText || 'stproc.execute; '; -- Retrieve all out bind variables declare bvarname varchar2(30); bvartype varchar2(30); begin for i in 1..lstptr loop get_bindvar(i,bvarname,bvartype); if (bvartype in ('OUT','IN OUT')) then stubText := stubText || 'stproc.retrieve(' || to_char(i) || ', ' || bvarname || '); '; end if; end loop; end; if (returnVal is not null) then stubText := stubText || 'return '|| uniq_id || '; '; end if; stubText := stubText || 'end; '; end genStubBody; -------------------- -- genStub -------------------- procedure genStub(x ptnod) is -- generate the stub for a subprogram -- if a Proc/Func, generate the stub into stubText -- if a Package, stuff the spec into stubSpec, -- the body into stubText n ptnod; nKind pidl.ptnty; tKind pidl.ptnty; subpName varchar2(100); returnVal varchar2(500); isPackage boolean; saverow varchar2(1800); begin assert(x is not null); n := diana.a_unit_b(x); assert(n is not null); tKind := pidl.ptkin(n); subpName := pName; -- assume top-level synonym isPackage := false; stubType := 'SUB'; -- assume subprg, not pkg if (tKind = diana.D_P_DECL) then --package -- stubSpec := 'package ' || exprText(diana.a_id(n)) || ' is '; -- stubText := 'package body ' || exprText(diana.a_id(n)) || ' is '; isPackage := true; stubType := 'PKG'; if (tsubName is null or tsubName = '') then stubSpec := 'package ' || pName || ' is '; stubText := 'package body ' || pName || ' is '; end if; n := diana.a_packag(n); declare seq pidl.ptseqnd := diana.as_list(diana.as_decl1(n)); len integer := pidl.ptslen(seq) - 1; tmp integer; begin -- this loop should be factored out with the Describe loop for i in 0..len loop -- for each member of the package saverow := stubSpec; -- save in case of rollback begin n := pidl.ptgend(seq, i); assert(n is not null); nKind := pidl.ptkin(n); if (nKind = diana.D_S_DECL) then --proc/func if (tsubName is null or tsubName = '') then tmp := length(stubText); subpName := null; genProcSpec(n, ignoreParmVal, e_defaultVal, subpName, returnVal, flags, stubText); stubSpec := stubSpec || substr(stubText, tmp+1) || '; '; genStubBody(n, pName || '.' || subpName, returnVal); else if (procName(n) = tsubName) then subpName := null; exit; end if; end if; --else -- if (tsubName is null or tsubName = '') then -- exprText(n, stubSpec); -- stubSpec := stubSpec || '; '; -- end if; end if; n := null; flushstubs(false); exception when e_notv6compat then stubSpec := saverow; -- rollback end; end loop; end; if (tsubName is null or tsubName = '') then stubSpec := stubSpec || ' end;'; stubText := stubText || 'end;'; end if; end if; if (stubSpec is null or stubSpec = '') then if (n is null) then raise e_notInPackage; end if; genProcSpec(n, ignoreParmVal, e_defaultVal, subpName, returnVal, flags, stubText); if (isPackage) then genStubBody(n, pName || '.' || subpName, returnVal); else genStubBody(n, subpName, returnVal); end if; end if; end genstub; begin -- pstub status := s_ok; stubText := ''; stubSpec := ''; char_for_varchar2 := 0 < instr(flags, '6'); begin get_diana(pname, uname, dabaname, dbowner, status, lubptr); if (lubptr is null or lubptr = 0) then return; end if; tSubName := normalName(subname); genStub(lubptr); if (e_defaultVal) then status := s_defaultVal; end if; exception -- stubText, stubSpec reset to null when value_error then status := s_stubTooLong; when e_other then status := s_other; when program_error then status := s_logic; when e_notInPackage then status := s_notInPackage; when e_notv6compat then status := s_notv6Compat; when others then status := s_other; end; flushstubs(true); end pstub; ----------------------------------------------------------------------- -- Private implementations ----------------------------------------------------------------------- -------------------- -- exprText: -- General unparsing function -------------------- procedure exprText(x ptnod, rv IN OUT varchar2) is -------------------- -- eText: -------------------- procedure eText(n ptnod); -------------------- -- listText -------------------- procedure listText(seq pidl.ptseqnd, spc varchar2) is len integer; begin len := pidl.ptslen(seq); if (len >= 1) then eText(pidl.ptgend(seq, 0)); len := len - 1; for i in 1..len loop rv := rv || spc; eText(pidl.ptgend(seq, i)); end loop; end if; end; -------------------- -- 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 -- x.y%type -- simply add the %type text rather than try to resolve -- it to get the name of the type -- eText(diana.a_name(n)); rv := rv || '%'; eText(diana.a_id(n)); /* -- 14jul92 =G=> Many of these remaining cases by An work, -- but aren't needed. elsif (nKind = diana.D_NUMERI) then rv := rv || diana.l_numrep(n); elsif (nKind = diana.D_NULL_A) then rv := rv || 'null'; -- implicit conversion elsif (nKind = diana.D_PARM_C) then declare seq pidl.ptseqnd := diana.as_list(diana.as_p_ass(n)); begin eText(last_elt(seq)); end; -- arglist elsif (nKind = diana.DS_APPLY) then declare aseq ptnod := diana.as_list(n); begin rv := rv || '('; listText(aseq, ','); rv := rv || ')'; end; -- d_f_call elsif (nKind = diana.D_F_CALL) then declare args ptnod := diana.as_p_ass(n); begin if (pidl.ptkin(args) <> diana.DS_PARAM) then -- ordinary function call eText(diana.a_name(n)); eText(args); else -- operator functions, determine if unary or n-ary declare s pidl.ptseqnd := diana.as_list(args); nameNode ptnod := diana.a_name(n); begin if (pidl.ptslen(s) = 1) then -- unary eText(nameNode); rv := rv || ' '; eText(pidl.ptgend(s, 0)); else exprText(nameNode, rv); listText(s, rv); end if; end; end if; end; -- parenthesized expr elsif (nKind = diana.D_PARENT) then rv := rv || '('; eText(diana.a_exp(n)); rv := rv || ')'; -- binary logical operation elsif (nKind = diana.D_BINARY) then eText(diana.a_exp1(n)); rv := rv || ' '; eText(diana.a_binary(n)); rv := rv || ' '; eText(diana.a_exp2(n)); elsif (nKind = diana.D_AND_TH) then rv := rv || 'and'; elsif (nKind = diana.D_OR_ELS) then rv := rv || 'or'; elsif (nKind = diana.DS_ID) then -- idList -- listText(diana.as_list(n), ','); causes PL/SQL Check #21037. declare seq pidl.ptseqnd := diana.as_list(n); begin rv := rv || coatName(diana.l_symrep(last_elt(seq))); end; elsif (nKind = diana.DS_D_RAN) then declare seq pidl.ptseqnd := diana.as_list(n); x ptnod; begin x := last_elt(seq); eText(diana.a_name(x)); end; -- declarations elsif (nKind = diana.D_VAR or nKind = diana.D_CONSTA) then -- var and const eText(diana.as_id(n)); rv := rv || ' '; if (nKind = diana.D_CONSTA) then rv := rv || 'constant '; end if; eText(diana.a_type_s(n)); if (diana.a_object(n) is not null and diana.a_object(n) <> 0) then rv := rv || ' := '; eText(diana.a_object(n)); else assert(nKind <> diana.D_CONSTA); end if; elsif (nKind = diana.D_CONSTR) then -- constraint eText(diana.a_name(n)); if (diana.a_constt(n) is not null and diana.a_constt(n) <> 0) then rv := rv || ' '; eText(diana.a_constt(n)); end if; elsif (nKind = diana.D_INTEGE) then eText(diana.a_range(n)); elsif (nKind = diana.D_RANGE) then if (diana.a_exp1(n) is not null and diana.a_exp1(n) <> 0) then -- in case of array single index; rv := rv || 'range '; eText(diana.a_exp1(n)); rv := rv || '..'; end if; eText(diana.a_exp2(n)); elsif (nKind = diana.D_TYPE) then -- type declaration rv := rv || 'type '; eText(diana.a_id(n)); if (diana.a_type_s(n) is not null and diana.a_type_s(n) <> 0) then rv := rv || ' is '; eText(diana.a_type_s(n)); end if; elsif (nKind = diana.D_SUBTYP) then -- subtype declaration rv := rv || 'subtype '; eText(diana.a_id(n)); rv := rv || ' is '; eText(diana.a_constd(n)); elsif (nKind = diana.D_R_) then -- record type rv := rv || 'record ('; -- listText(diana.as_list(n), ','); causes PL/SQL Check #21037. declare seq pidl.ptseqnd := diana.as_list(n); begin listText(seq, ', '); end; rv := rv || ')'; elsif (nKind = diana.D_ARRAY) then rv := rv || 'table of '; eText(diana.a_name(diana.a_constd(n))); rv := rv || '('; eText(diana.a_constt(diana.a_constd(n))); rv := rv || ') indexed by '; eText(diana.as_dscrt(n)); elsif (nKind = diana.D_EXCEPT) then eText(diana.as_id(n)); rv := rv || ' exception'; */ else raise e_notv6compat; end if; end if; end eText; begin -- exprText eText(x); end exprText; -------------------- -- is_v6_type -- -- check whether given D_NAME node (from an a_NAME(parm)) names a -- v6-compatible type, e.g., DATE, NUMBER, or CHAR -------------------- function is_v6_type (typenode ptnod) return boolean is typename varchar2(100); begin typename := ''; exprText(typenode, typename); typename := ltrim(rtrim(typename)); if (typename = '' or typename is null) or not ( typename = 'DATE' or typename = 'NUMBER' or typename = 'BINARY_INTEGER' or typename = 'PLS_INTEGER' or typename = 'CHAR' or typename = 'VARCHAR2' or typename = 'VARCHAR' or typename = 'INTEGER' or typename = 'BOOLEAN' or substr(typename, -5, 5) = '%TYPE' -- or typename = 'RAW' -- or typename = 'CHARN' -- or typename = 'STRING' -- or typename = 'STRINGN' -- or typename = 'DATEN' -- or typename = 'NUMBERN' -- or typename = 'PLS_INTEGERN' -- or typename = 'NATURAL' -- or typename = 'NATURALN' -- or typename = 'POSITIVE' -- or typename = 'POSITIVEN' -- or typename = 'SIGNTYPE' -- or typename = 'BOOLEANN' -- or typename = 'REAL' -- or typename = 'DECIMAL' -- or typename = 'FLOAT' ) then return false; else return true; end if; end is_v6_type; -------------------- -- genProcSpec: -- Append the spec for a top-level node n to sText. -- ignoreDefVal controls whether parm default vals should be ignored. -- hasDefVal returned true iff parm default vals exist. -- Toplevel name returned in pName. If function, function -- string returned in returnVal. -------------------- procedure genProcSpec(n ptnod, ignoreDefVal boolean, hasDefVal in out boolean, pName in out varchar2, returnVal in out varchar2, flags varchar2, sText in out varchar2) is nodeKind pidl.ptnty; leftChild ptnod; rightChild ptnod; returnTypeNode ptnod; -------------------- -- genParmText -------------------- procedure genParmText(parmSeq pidl.ptseqnd) is -- append text for param list sText parmNum natural; k ptnod; knd pidl.ptnty; begin parmNum := pidl.ptslen(parmSeq); if (parmNum > 0) then sText := sText || ' ('; for i in 1 .. parmNum loop k := pidl.ptgend(parmSeq, i-1); assert(k is not null); sText := sText || idName(diana.as_id(k)) || ' '; knd := pidl.ptkin(k); if (knd = diana.D_OUT) then sText := sText || 'out '; elsif (knd = diana.D_IN_OUT) then sText := sText || 'in out '; else assert(knd = diana.D_IN); end if; exprText(diana.a_name(k), sText); if 0 < instr(flags, '6') and not is_v6_type(diana.a_name(k)) then raise e_notv6compat; end if; k := diana.a_exp_vo(k); if (k is not null and k <> 0) then hasDefVal := TRUE; if (not ignoreDefVal) then sText := sText || ' := '; exprText(k, sText); end if; end if; if (i < parmNum) then sText := sText || ', '; end if; end loop; sText := sText || ')'; end if; end genParmText; begin -- genProcSpec -- generate a procedure declaration into sText spec returnVal := ''; assert(n is not null); leftChild := diana.a_d_(n); assert(leftChild is not null); nodeKind := pidl.ptkin(leftChild); rightChild := diana.a_header(n); if (nodeKind = diana.DI_FUNCT or nodeKind = diana.D_DEF_OP) then sText := sText || 'function '; returnTypeNode := diana.a_name_v(rightChild); exprText(returnTypeNode, returnVal); -- ?? returnVal := substr(exprText(diana.a_name_v(rightChild)), 1, 511); else sText := sText || 'procedure '; returnVal := null; assert(nodeKind = diana.DI_PROC); end if; if (pName is null) then exprText(leftChild, pName); end if; sText := sText || pName; rightChild := diana.as_p_(rightChild); assert(rightChild is not null); genParmText(diana.as_list(rightChild)); if (returnVal is not null) then if 0 < instr(flags, '6') and not is_v6_type(returnTypeNode) then raise e_notv6compat; end if; sText := sText || ' return ' || returnVal; end if; end genProcSpec; -------------------- -- bool_to_int -------------------- function bool_to_int(b BOOLEAN) return number is begin if b then return 1; elsif not b then return 0; else return NULL; end if; end bool_to_int; -------------------- -- int_to_bool -------------------- function int_to_bool(n NUMBER) return boolean is begin if n is null then return NULL; elsif n = 1 then return TRUE; elsif n = 0 then return FALSE; else raise VALUE_ERROR; end if; end int_to_bool; end diutil; / grant execute on diutil to public;