IVXSNAME TITLE 'Simple IPCS Verb Exit accessing storage'                        
* ===================================================================           
*                                                                               
* Name: IVXSNAME                                                                
*                                                                               
* Author: David Alcock :: http://www.planetmvs.com                              
*                                                                               
* Purpose: Simple VERBEXIT accessing storage                                    
*                                                                               
* Invoked in IPCS option 6: VERBX IVXSNAME                                      
*                                                                               
* Disclaimer: This program is FREEWARE.  Use at your own risk.  It              
*             is provided for your enjoyment and neither David                  
*             Alcock or his employer provides any warranty for it's             
*             use.  I'd like to hear how it works on your system.               
*                                                                               
*             This software is not in the public domain but is                  
*             available free of charge and with source code                     
*             provided.  It is copyright 1997-2009+ by David Alcock             
*             All rights reserved.                                              
* ===================================================================           
                                                                                
*                                                                               
* IBM macros                                                                    
*                                                                               
         YREGS ,                        Equate registers                        
         PRINT GEN                                                              
         BLSABDPL DSECT=YES,            Get IPCS mapping DSECTs        @        
               AMDPACC=YES              ..Storage access                        
#ADPLBUF EQU  133                       Length of our output buffer             
         CVT   DSECT=YES,LIST=NO        Communications Vector Table             
#CVTL    EQU   CVTOSLVF-CVTMAP+L'CVTOSLVF                                       
         PRINT GEN                                                              
*                                                                               
* Enter Housekeeping                                                            
*                                                                               
IVXSNAME CSECT ,                                                                
IVXSNAME AMODE 31                                                               
IVXSNAME RMODE ANY                                                              
         BAKR  R14,0                    Save regs                               
         LAE   R12,0(R15,0)             Get base register                       
         USING IVXSNAME,R12             Get addressibility                      
         STORAGE OBTAIN,LENGTH=DSAL,LOC=BELOW Obtain storage                    
         LR    R13,R1                   Point to Save Area                      
         USING DSA,R13                  Get addressibility to area              
         MVC   4(4,R13),=C'F1SA'        Indicate stack SA                       
         EREG  R1,R1                    Get R1 at entry off the stack           
         ST    R1,DSAABDPL              Save input ABDPL address                
*                                                                               
* Access the CVT and print the system name found in the CVT                     
*                                                                               
         L     R1,DSAABDPL              Locate ABDPL                            
         L     R1,ADPLCVT-ABDPL(R1)     Address to get (CVT)                    
         LA    R0,#CVTL                 Length to get                           
         bas   r14,Access_Storage                                               
         ltr   r15,r15                  Did we get it?                          
         bnz   Error                                                            
         lr    r2,r1                    Get CVT address                         
         bas   r14,Initialize_Line                                              
         mvc   0(18,r15),=c'The system name is'                                 
         la    r15,19(r15)                                                      
         mvc   0(l'CVTSNAME,r15),CVTSNAME-CVT(R2)                               
         bas   r14,Print_Line                                                   
         b     Exit                                                             
Error    ds    0h                                                               
         bas   r14,Initialize_Line                                              
         mvc   0(23,r15),=c'Error accessing the CVT'                            
         bas   r14,Print_Line                                                   
*                                                                               
* Exit Housekeeping                                                             
*                                                                               
Exit     DS    0H                                                               
         LR    R2,R13                   Get storage address                     
         STORAGE RELEASE,LENGTH=DSAL,ADDR=(R2) Release storage                  
         SLR   R15,R15                  Set return code                         
         PR    ,                        Return to caller                        
*                                                                               
* Access Storage in IPCS dump                                                   
*                                                                               
* Input: R1 has the address, R0 has the length                                  
*                                                                               
* Output: R15 has RC from Storage access call, R1 has address of                
*         storage if RC =0                                                      
*                                                                               
Access_Storage DS 0H                                                            
         BAKR  R14,0                                                            
         L     R2,DSAABDPL               Locate ABDPL                           
         MVI   ADPLPRDP-ABDPL(R2),ADPLVIRT Set to virtual storage               
         STH   R0,ADPLDLEN-ABDPL(R2)    Save length to get                      
*                                                                               
         XC    DSAPACC(ADPLLACC),DSAPACC Clear PACC to zeros                    
iPACC    USING ADPLPACC,DSAPACC                                                 
         ST    R1,iPACC.ADPLPAAD        Set address to get                      
*                                                                               
         L     R15,ADPLSERV-ABDPL(R2)   Locate IPCS service routine             
         CALL  (15),                    Call IPCS service routine      @        
               ((2),                    ..ABDPL                        @        
               =A(ADPLSACC),            ..Type of call: Access Stor    @        
               DSAPACC),                ..Access Storage parm list     @        
               MF=(E,DSAParm)                                                   
*-Here you could "ltr 15,15; print error message if non-zero", etc              
         L     R1,iPACC.ADPLPART          Get returned storage in R1            
         PR    ,                          RC from SACC in R15                   
         DROP  iPACC                                                            
         EJECT                                                                  
*                                                                               
* Initialize line output line in IPCS buffer                                    
*                                                                               
* Output: R15 has start of line                                                 
*                                                                               
Initialize_Line DS 0H                                                           
         L     R1,DSAABDPL                                                      
         L     R15,ADPLBUF-ABDPL(R1)    Locate Print Message                    
         MVI   0(R15),C' '              Get blank                               
         MVC   1(#ADPLBUF-1,R15),0(R15) ..Propagate it                          
         BSM   0,R14                                                            
*                                                                               
* Print Line to IPCS output                                                     
*                                                                               
Print_Line DS 0H                                                                
         BAKR  R14,0                                                            
         L     R2,DSAABDPL              Locate ABDPL                            
         L     R15,ADPLSERV-ABDPL(R2)   Locate IPCS service routine             
         CALL  (15),                    Call IPCS service routine      @        
               ((2),                    ..ABDPL                        @        
               =A(ADPLSPRT)),           ..Service: Print line          @        
               MF=(E,DSAParm)                                                   
         PR    ,                                                                
*                                                                               
* Constants                                                                     
*                                                                               
         LTORG ,                                                                
         DROP  R12,R13                                                          
*                                                                               
* Dynamic Save area                                                             
*                                                                               
DSA      DSECT ,                                                                
         DS    18F                      Register Save Area                      
DSAABDPL DS    A                        Address of the IPCS ABDPL               
DSAPACC  DS    XL(ADPLLACC)             IPCS Storage Access Parm list           
DSAParm  DS    8F                       Parameter list for calls                
         DS    0D                                                               
DSAL     EQU   *-DSA                                                            
         END   ,