midrange.com code scratchpad
Name:
Show Call Stack - ILE RPG to put call stack into a variable
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
07/30/2012 08:14:41 pm
IP:
Logged
Description:
Shows the call stack, working toward the top until the final (first) entry is found.

Output is like
QCMD/x0496::mylib/6400::QUOCPP/x0776::QUOMAIN/x110A::QUOCMD/x0399::WRKSPLADV/72700::QUIDSPPx00D0::QUIMGFLW/x04C8::QUICMD/x048B::CALLSTK2/1000::LUVSRV_01(showCallStack)/86700
Code:
  1.                                                              
  2.                                                              
  3.                                                              
  4. P showCallStack   B                   Export                 
  5. D showCallStack   PI         65535    Varying                
  6. D  parmSkipTop                  10I 0 Value Options(*NoPass) 
  7. D  parmSkipBotm                 10I 0 Value Options(*NoPass) 
  8. D  parmOrder                      N   Value Options(*NoPass) 
  9.                                                              
  10.                                                              
  11. D RtvCallStack    PR                  ExtPgm('QWVRCSTK')     
  12. D  receiver                           Const like(myReceiver) 
  13. D  rcvrSize                     10I 0 Const                  
  14. D  rcvFormat                     8    Const                  
  15. D  jobIDinfo                          Const likeDS(rqsJob)   
  16. D  jobInfoFmt                    8    Const                  
  17. D  myUSEC                             Like(errorStruct)      
  18.                                                              
  19.                                                              
  20.                                                              
  21. D convertHexChar  PR                  ExtProc('cvthc')       
  22. D  ptrCharReturn                  *   Value                  
  23. D  ptrHexSrc                      *   Value                  
  24. D  hexLength                    10I 0 Value                  
  25.                                                                 
  26.                                                                 
  27. D/Include QSYSINC/QRPGLESRC,QWVRCSTK                            
  28.                                                                 
  29.                                                                 
  30. D errorStruct     DS                  Inz Qualified             
  31. D  QUSBPRV                      10I 0 Inz(%Size(errorStruct))   
  32. D  QUSBAVL                      10I 0                           
  33. D  QUSEI                         7                              
  34. D                                1                              
  35. D  QUSED01                    4096                              
  36. D  bytesProvided                      Overlay(QUSBPRV)          
  37. D                                     Like(errorStruct.QUSBPRV) 
  38. D  bytesAvailable...                                            
  39. D                                     Overlay(QUSBAVL)          
  40. D                                     Like(errorStruct.QUSBAVL) 
  41. D  messageID                          Overlay(QUSEI)            
  42. D                                     Like(errorStruct.QUSEI)   
  43. D  messageData                        Overlay(QUSED01)          
  44. D                                     Like(errorStruct.QUSED01) 
  45.                                                                 
  46.                                                                 
  47. D entryList       S          65535    Varying                   
  48.                                                                        
  49. D topToSkip       S             10I 0 Inz(0)                           
  50. D bottomToSkip    S             10I 0 Inz(0)                           
  51. D bottomToTop     S               N   Inz(*Off)                        
  52.                                                                        
  53. D entryString     S           4096    Varying Dim(256)                 
  54. D procName        S           4096    Varying                          
  55. D stmtIDs         S             10    Dim(8) Based(pStmtIDs)           
  56. D procNameArea    S           4096    Based(pProcNameArea)             
  57. D I               S             10U 0                                  
  58. D J               S             10U 0                                  
  59. D stmtID          S             10    Varying                          
  60. D hexInt          S              8                                     
  61. D incr            S             10I 0                                  
  62. D start           S             10I 0                                  
  63. D stop            S             10I 0                                  
  64.                                                                        
  65. D pReceiver       S               *   Inz(%Addr(myReceiver))           
  66. D myReceiver      S          65535                                     
  67. D hdr             DS                  LikeDS(QWVK0100) Based(pReceiver)
  68. D pEntry          S               *                                    
  69. D entry           DS                  LikeDS(QWVCSTKE) Based(pEntry)   
  70.                                                                        
  71.                                                               
  72. D rqsJob          DS                  Qualified Inz           
  73. D  jobname                      10    Inz('*')                
  74. D  jobuser                      10    Inz(*Blanks)            
  75. D  jobNumber                     6    Inz(*Blanks)            
  76. D  intJobID                     16    Inz(*Blanks)            
  77. D                                2    Inz(X'0000')            
  78. D  threadIndic                  10I 0 Inz(2)                  
  79. D  threadID                      8    Inz(X'0000000000000000')
  80.                                                               
  81.  /Free                                                        
  82.                                                               
  83.   Reset errorStruct ;                                         
  84.   errorStruct.bytesProvided = %Size(errorStruct) ;            
  85.   If %Parms >= 1 ;                                            
  86.      topToSkip = parmSkipTop ;                                
  87.      If %Parms >= 2 ;                                         
  88.         bottomToSkip = parmSkipBotm ;                         
  89.         If %Parms >= 3 ;                                      
  90.            bottomToTop = parmOrder ;                          
  91.         EndIF ;                                               
  92.      EndIF ;                                                  
  93.   EndIF ;                                                     
  94.                                                                      
  95.   Clear entryList ;       // Clear the field to be returned to caller
  96.                                                                      
  97.   // Retrieve the call stack information via IBM API                 
  98.                                                                      
  99.   rtvCalLStack(myReceiver: %Size(myReceiver)                         
  100.              : 'CSTK0100'                                            
  101.              : rqsJob: 'JIDF0100'                                    
  102.              : errorStruct) ;                                        
  103.                                                                      
  104.   // Position our header's pointer to the receiver area.             
  105.                                                                      
  106.   pEntry = pReceiver + hdr.QWVEO ;      // First entry               
  107.   For I = 1 to hdr.QWVERTN ;            // For each call stack entry 
  108.      If entry.QWVPL = *Zero ;           // No procedure name         
  109.         %Len(procName) = *Zero ;        // Clear our copy            
  110.      Else ;                                                          
  111.         pProcNameArea = pEntry + entry.QWVPD ;                       
  112.         procName = %Subst(procNameArea: 1: entry.QWVPL) ;            
  113.      EndIF ;                                                         
  114.      pStmtIDs = pEntry + entry.QWVSD ;  // Point to the Stmt IDs     
  115.      entryString(I) = %Trim(entry.QWVPGMN) ;                         
  116.      If %Len(procName) > *Zero and procName <> entry.QWVPGMN ;       
  117.         entryString(I) += '(' + %Trim(procName) + ')' ;            
  118.      EndIF ;                                                       
  119.      If entry.QWVSRTN > *Zero ;            // If stmt IDs present  
  120.         For J = 1 to entry.QWVSRTN ;       // For each stmt ID     
  121.            stmtID = %Trim(stmtIDs(J)) ;                            
  122.            DoW %Subst(stmtID: 1: 1) = '0' and %Len(stmtID) > 1 ;   
  123.               stmtID = %Subst(stmtID: 2) ;                         
  124.            EndDO ;                                                 
  125.            entryString(I) += '/' + %Trim(stmtID) ;                 
  126.         EndFOR ;                                                   
  127.      ElseIF entry.QWVCTION > *Zero ;       // MI instruction #     
  128.         convertHexChar(%Addr(hexInt): %Addr(entry.QWVCTION)        
  129.                      : %Size(hexInt)) ;                            
  130.         If %Subst(hexInt: 1: 4) = '0000' ;                         
  131.             entryString(I) += '/x' + %Subst(hexInt: 5) ;           
  132.         Else ;                                                     
  133.             entryString(I) += '/x' + hexInt ;                      
  134.         EndIF ;                                                    
  135.      EndIF ;                                                       
  136.      If %Len(entryList) > *Zero ;                                  
  137.         entryList += '::' ;                                        
  138.      EndIF ;                                                       
  139.      // Finished with this entry.  Since we have the length of this
  140.      // entry in entry.QWVEL, we will add this value to current        
  141.      // pEntry to get next pEntry.                                     
  142.      pEntry += entry.QWVEL ;            // Length this entry; -> Next  
  143.   EndFOR ;                                                             
  144.                                                                        
  145.   // Well, that was fun.  Now let's order our output as requested,     
  146.   // and return all except any entries that the caller wanted skipped. 
  147.                                                                        
  148.   Clear entryList ;                                                    
  149.   If bottomToTop ;                     // Same sequence as IBM API     
  150.      incr = 1 ;                        // We'll INCREMENT our array idx
  151.      start = bottomToSkip + 1 ;        // Starting at ...              
  152.      stop = hdr.QWVERTN - topToSkip ;  // Last entry to use            
  153.   Else ;                               // Oldest first                 
  154.      incr = -1 ;                       // We'll DECREMENT our index    
  155.      start = hdr.QWVERTN - topToSkip ; // Starting at...               
  156.      stop = bottomToSkip + 1 ;         // Last entry to use            
  157.   EndIF ;                                                              
  158.   I = start ;                          // Ready ... go!                
  159.   For J = 1 to %Abs(stop - start) + 1 ;                                
  160.      If        %Scan('_QRNP_PEP_': entryString(I)) = 0                 
  161.            and %Scan('_CL_PEP': entryString(I)) = 0 ;                  
  162.         If %Len(entryList) > *Zero and %Len(entryString(I)) > 0 ;      
  163.            entryList += '::' ;                                          
  164.         EndIF ;                                                         
  165.         entryList += entryString(I) ;                                   
  166.      EndIF ;                                                            
  167.      I += incr ;                                                        
  168.   EndFOR ;                                                              
  169.                                                                         
  170.   Return entryList ;                                                    
  171.                                                                         
  172.   *INLR = *On ;                                                         
  173.   Return ;                                                              
  174.                                                                         
  175.  /End-free                                                              
  176.                                                                         
  177. P showCallStack   E                                                     
© 2004-2019 by midrange.com generated in 0.008s valid xhtml & css