/* REXX */
/* CLS2REXXed by FSOX001 on 5 Jul 2016 at 10:41:04  */
/*Trace ?r*/
Signal On NoValue
Call On Error
Signal On Failure
Signal On Syntax
Parse source opsys . exec_name .
Address ISREDIT
 
"MACRO"             /* CACM0007 EDIT MACRO .PDI(?????) */
/*********************************************************************/
/* 09/27/2024 CL Fenton Created to evaluate existance of programs    */
/*            for IFTP0040 for STIG IDs ACF2-US-000170,              */
/*            RACF-FT-000090, and TSS0-FT-000060.                    */
/*            Script to be executed in CACJ0005 in CACC0010 for      */
/*            FTP, SCTASKU0221468.                                   */
/*                                                                   */
/*                                                                   */
/*                                                                   */
/*********************************************************************/
pgmname = "CACC0007 09/27/24"
sysprompt = "OFF"                 /* CONTROL NOPROMPT                */
sysflush = "OFF"                  /* CONTROL NOFLUSH                 */
sysasis = "ON"                    /* CONTROL ASIS - caps off         */
Address ISPEXEC "CONTROL NONDISPL ENTER"
Address ISPEXEC "CONTROL ERRORS RETURN"
maxcc = 0
 
return_code = 0
Address ISPEXEC "VGET (CONSLIST COMLIST SYMLIST TERMMSGS) ASIS"
cm07vget = return_code
If return_code <> 0 then do
  Say pgmname "VGET RC =" return_code zerrsm
  Say pgmname "CONSLIST/"conslist "COMLIST/"comlist "SYMLIST/"symlist
    "TERMMSGS/"termmsgs
  SIGNAL ERR_EXIT
  End
 
If CONSLIST = "ON" | COMLIST = "ON" | SYMLIST = "ON" ,
  then Trace r
 
maxcc = 0
return_code = 0
"DELETE ALL NX"
return_code = 0
/*******************************************/
/* TURN ON MESSAGES                        */
/*******************************************/
syssymlist = symlist          /* CONTROL SYMLIST/NOSYMLIST */
sysconlist = conslist         /* CONTROL CONLIST/NOCONLIST */
syslist = comlist             /* CONTROL LIST/NOLIST       */
sysmsg = termmsgs             /* CONTROL MSG/NOMSG         */
/*******************************************/
/* MAIN PROCESS                            */
/*******************************************/
zispfrc = 0
Address ISPEXEC "VPUT (ZISPFRC) SHARED"
otermmsgs = TERMMSGS
ocomlist  = COMLIST
oconslist = CONSLIST
osymlist  = SYMLIST
TERMMSGS = "OFF"
COMLIST  = "OFF"
CONSLIST = "OFF"
SYMLIST  = "OFF"
Address ISPEXEC "VPUT (CONSLIST COMLIST SYMLIST TERMMSGS)"
a = outtrap("data.")
a = CACC1000('DD JESPROC FTPD')
TERMMSGS = otermmsgs
COMLIST  = ocomlist
CONSLIST = oconslist
SYMLIST  = osymlist
Address ISPEXEC "VPUT (CONSLIST COMLIST SYMLIST TERMMSGS)"
a = outtrap("OFF")
Address ISPEXEC "vget (STCPROC PROC dddsns) asis"
 
Numeric digits 20
Call COMMON            /* control blocks needed by multiple routines */
Call LPA                                    /* LPA List information  */
Call LNKLST                                 /* LNKLST information    */
Call APF                                    /* APF List information  */
/*********************************************************************/
/* Done looking at all control blocks                                */
/*********************************************************************/
programs = "FTCHKCMD" "FTCHKIP" "FTCHKJES" "FTCHKPWD",
  "FTPSMFEX" "FTPOSTPR"
 
err = outtrap("var.")
datasets. =
x = 1
if pos("//STEPLIB",dddsns) > 0 then do
  parse var dddsns . "//STEPLIB" dsnmbr "//"
  datasets.x = dsnmbr
  x = x + 1
  end
Address TSO "MAKEBUF"
do x = x to queued()
  parse pull ac
  parse var ac type dsn .
  datasets.x = dsn
  datasets.0 = x
/*say pgmname "Type:" type "DSN:" dsn
  say pgmname right(x,4,"0") ac*/
  do cnt = 1 to words(programs)
    if sysdsn("'"dsn"("word(programs,cnt)")'") = "OK" then,
      queue left(word(programs,cnt)"        ",10) dsn
    end
  end
 
if queued() = 0 then do
  say pgmname "   1 records written for IFTP0040."
  "LINE_AFTER .ZLAST = DATALINE 'Not a Finding'"
  "LINE_AFTER .ZLAST = DATALINE ' '"
  end
else do
  x = queued() + 2
  say pgmname right(x,4) "records written for IFTP0040."
  ac = "The following IBM z/OS user exits for the FTP server are in use."
  "LINE_AFTER .ZLAST = (AC)"
  "LINE_AFTER .ZLAST = DATALINE ' '"
  do x = 1 to queued()
    parse pull ac
    ac = "     "ac
    "LINE_AFTER .ZLAST = (AC)"
    end
  "LINE_AFTER .ZLAST = DATALINE ' '"
  end
 
return_code = 0
/*******************************************/
/* ERROR EXIT                              */
/*******************************************/
ERR_EXIT:
If maxcc >= 16 | return_code > 0 then do
  Address ISPEXEC "VGET (ZISPFRC) SHARED"
  If maxcc > zispfrc then,
    zispfrc = maxcc
  Else
    zispfrc = return_code
  Address ISPEXEC "VPUT (ZISPFRC) SHARED"
  Say pgmname "ZISPFRC =" zispfrc
  end
 
"END"
Exit 0                                       /* End IPLINFO - RC 0   */
/*********************************************************************/
/*  End of main IPLINFO code                                         */
/*********************************************************************/
 
COMMON:              /* Control blocks needed by multiple routines   */
CVT      = C2d(Storage(10,4))                /* point to CVT         */
CVTFLAG2 = Storage(D2x(CVT+377),1)           /* CVT flag byte 2      */
CVTEXT2  = C2d(Storage(D2x(CVT + 328),4))    /* point to CVTEXT2     */
PRODNAME = Storage(D2x(CVT - 40),7)          /* point to mvs version */
If Substr(PRODNAME,3,1) >= 3 then do         /* HBB3310 ESA V3 & >   */
  CVTOSLV0   = Storage(D2x(CVT + 1264),1)    /* Byte 0 of CVTOSLVL   */
  CVTOSLV1   = Storage(D2x(CVT + 1265),1)    /* Byte 1 of CVTOSLVL   */
  CVTOSLV2   = Storage(D2x(CVT + 1266),1)    /* Byte 2 of CVTOSLVL   */
  CVTOSLV3   = Storage(D2x(CVT + 1267),1)    /* Byte 3 of CVTOSLVL   */
  CVTOSLV4   = Storage(D2x(CVT + 1268),1)    /* Byte 4 of CVTOSLVL   */
  CVTOSLV5   = Storage(D2x(CVT + 1269),1)    /* Byte 5 of CVTOSLVL   */
  CVTOSLV6   = Storage(D2x(CVT + 1270),1)    /* Byte 6 of CVTOSLVL   */
  CVTOSLV7   = Storage(D2x(CVT + 1271),1)    /* Byte 7 of CVTOSLVL   */
  CVTOSLV8   = Storage(D2x(CVT + 1272),1)    /* Byte 8 of CVTOSLVL   */
  CVTOSLV9   = Storage(D2x(CVT + 1273),1)    /* Byte 9 of CVTOSLVL   */
End
If Bitand(CVTOSLV0,'08'x) = '08'x then ,     /* HBB4410 ESA V4 & >   */
  ECVT     = C2d(Storage(D2x(CVT + 140),4))  /* point to CVTECVT     */
FMIDNUM  = Storage(D2x(CVT - 32),7)          /* point to fmid        */
JESCT    = C2d(Storage(D2x(CVT + 296),4))    /* point to JESCT       */
JESCTEXT = C2d(Storage(D2x(JESCT +100),4))   /* point to JESPEXT     */
JESPJESN = Storage(D2x(JESCT + 28),4)        /* name of primary JES  */
CVTSNAME = Storage(D2x(CVT + 340),8)         /* point to system name */
GRSNAME  = Strip(CVTSNAME,'T')               /* del trailing blanks  */
CSD      = C2d(Storage(D2x(CVT + 660),4))    /* point to CSD         */
SMCA     = Storage(D2x(CVT + 196),4)         /* point to SMCA        */
SMCA     = Bitand(SMCA,'7FFFFFFF'x)          /* zero high order bit  */
SMCA     = C2d(SMCA)                         /* convert to decimal   */
ASMVT    = C2d(Storage(D2x(CVT + 704),4))    /* point to ASMVT       */
CVTSCPIN = D2x(CVT+832)                      /* point to SCPINFO     */
If Bitand(CVTOSLV5,'08'x) = '08'x then do    /* z/OS 1.10 and above  */
  ECVTSCPIN = D2x(ECVT+876)                  /* point to cur SCPINFO */
  SCCB      = C2d(Storage(ECVTSCPIN,4))      /* Service Call Cntl Blk*/
End
Else SCCB   = C2d(Storage(CVTSCPIN,4))       /* Service Call Cntl Blk*/
RCE      = C2d(Storage(D2x(CVT + 1168),4))   /* point to RCE         */
MODEL    = C2d(Storage(D2x(CVT - 6),2))      /* point to cpu model   */
/*********************************************************************/
/*  The CPU model is stored in packed decimal format with no sign,   */
/*  so to make the model printable, it needs to be converted back    */
/*  to hex.                                                          */
/*********************************************************************/
MODEL    = D2x(MODEL)                        /* convert back to hex  */
PCCAVT    = C2d(Storage(D2x(CVT + 764),4))   /* point to PCCA vect tb*/
If Bitand(CVTOSLV1,'01'x) = '01'x then do    /* OS/390 R2 and above  */
  ECVTIPA  = C2d(Storage(D2x(ECVT + 392),4)) /* point to IPA         */
  IPASCAT  = Storage(D2x(ECVTIPA + 224),63)  /* SYSCAT  card image   */
End
zARCH = 1                                    /* default ARCHLVL      */
If Bitand(CVTOSLV2,'01'x) = '01'x then do    /* OS/390 R10 and above */
  FLCARCH  = Storage('A3',1)                 /* FLCARCH in PSA       */
  If C2d(FLCARCH) <> 0 then zARCH=2          /* non-zero is z/Arch.  */
End
Return
 
 
LPA:                 /* LPA List sub-routine                         */
CVTSMEXT = C2d(Storage(D2x(CVT + 1196),4))   /* point to stg map ext.*/
CVTEPLPS = C2d(Storage(D2x(CVTSMEXT+56),4))  /* start vaddr of ELPA  */
NUMLPA   = C2d(Storage(D2x(CVTEPLPS+4),4))   /* # LPA libs in table  */
LPAOFF   = 8                                 /* first ent in LPA tbl */
/*Queue '     '
  Queue 'LPA Library List  ('NUMLPA' libraries):'
  Queue '  POSITION    DSNAME'*/
Do I = 1 to NUMLPA
  LEN   = C2d(Storage(D2x(CVTEPLPS+LPAOFF),1)) /* length of entry    */
  LPDSN = Storage(D2x(CVTEPLPS+LPAOFF+1),LEN)  /* DSN of LPA library */
  LPAOFF = LPAOFF + 44 + 1                     /* next entry in table*/
  LPAPOS = Right(I,3)                        /* position in LPA list */
  RELLPPOS = Right('(+'I-1')',6)        /* relative position in list */
/*Queue LPAPOS  RELLPPOS '  ' LPDSN*/
  Queue 'LPA' LPDSN
End
Return
 
 
LNKLST:              /* LNKLST sub-routine                           */
If Bitand(CVTOSLV1,'01'x) <> '01'x then do    /* below OS/390 R2     */
  CVTLLTA  = C2d(Storage(D2x(CVT + 1244),4))  /* point to lnklst tbl */
  NUMLNK   = C2d(Storage(D2x(CVTLLTA+4),4))   /* # LNK libs in table */
  LLTAPFTB = CVTLLTA + 8 + (NUMLNK*45)        /* start of LLTAPFTB   */
  LNKOFF   = 8                                /*first ent in LBK tbl */
  LKAPFOFF = 0                                /*first ent in LLTAPFTB*/
/*Queue '     '
  Queue 'LNKLST Library List  ('NUMLNK' Libraries):'
  Queue '  POSITION    APF    DSNAME'*/
  Do I = 1 to NUMLNK
    LEN = C2d(Storage(D2x(CVTLLTA+LNKOFF),1))     /* length of entry */
    LKDSN = Storage(D2x(CVTLLTA+LNKOFF+1),LEN)    /* DSN of LNK lib  */
    CHKAPF = Storage(D2x(LLTAPFTB+LKAPFOFF),1)    /* APF flag        */
    If  bitand(CHKAPF,'80'x) = '80'x then LKAPF = 'Y'  /* flag on    */
      else LKAPF = ' '                            /* APF flag off    */
    LNKOFF = LNKOFF + 44 + 1                      /*next entry in tbl*/
    LKAPFOFF = LKAPFOFF + 1               /* next entry in LLTAPFTB  */
    LNKPOS = Right(I,3)                           /*position in list */
    RELLKPOS = Right('(+'I-1')',6)      /* relative position in list */
/*  Queue LNKPOS  RELLKPOS '   ' LKAPF '   ' LKDSN*/
    Queue 'LNKLST' LKDSN
  End
End
Else do  /* OS/390 1.2 and above - PROGxx capable LNKLST             */
  ASCB     = C2d(Storage(224,4))               /* point to ASCB      */
  ASSB     = C2d(Storage(D2x(ASCB+336),4))     /* point to ASSB      */
  DLCB     = C2d(Storage(D2x(ASSB+236),4))     /* point to CSVDLCB   */
  DLCBFLGS = Storage(d2x(DLCB + 32),1)         /* DLCB flag bits     */
  SETNAME  = Storage(D2x(DLCB + 36),16)        /* LNKLST set name    */
  SETNAME  = Strip(SETNAME,'T')                /* del trailing blanks*/
  CVTLLTA  = C2d(Storage(D2x(DLCB + 16),4))    /* point to lnklst tbl*/
  LLTX     = C2d(Storage(D2x(DLCB + 20),4))    /* point to LLTX      */
  NUMLNK   = C2d(Storage(D2x(CVTLLTA+4),4))    /* # LNK libs in table*/
  LLTAPFTB = CVTLLTA + 8 + (NUMLNK*45)         /* start of LLTAPFTB  */
  LNKOFF   = 8                                 /*first ent in LLT tbl*/
  VOLOFF   = 8                                 /*first ent in LLTX   */
  LKAPFOFF = 0                                /*first ent in LLTAPFTB*/
/*If Bitand(DLCBFLGS,'10'x) = '10'x then ,     /* bit for LNKAUTH    */
       LAUTH = 'LNKLST'                        /* LNKAUTH=LNKLST     */
  Else LAUTH = 'APFTAB'                        /* LNKAUTH=APFTAB     */
  Queue '     '
  Queue 'LNKLST Library List - Set:' SETNAME ,
        ' LNKAUTH='LAUTH '('NUMLNK' Libraries):'
  If LAUTH = 'LNKLST' then ,
    Queue '     (All LNKLST data sets marked APF=Y due to' ,
          'LNKAUTH=LNKLST)'
  Queue '  POSITION    APF   VOLUME    DSNAME'*/
  Do I = 1 to NUMLNK
    LEN = C2d(Storage(D2x(CVTLLTA+LNKOFF),1))     /* length of entry */
    LKDSN = Storage(D2x(CVTLLTA+LNKOFF+1),LEN)    /* DSN of LNK lib  */
    LNKVOL = Storage(D2x(LLTX+VOLOFF),6)          /* VOL of LNK lib  */
    CHKAPF = Storage(D2x(LLTAPFTB+LKAPFOFF),1)    /* APF flag        */
    If  bitand(CHKAPF,'80'x) = '80'x then LKAPF = 'Y'    /* flag on  */
      else LKAPF = ' '                            /* APF flag off    */
    LNKOFF   = LNKOFF + 44 + 1                    /*next entry in LLT*/
    VOLOFF   = VOLOFF + 8                         /*next vol in LLTX */
    LKAPFOFF = LKAPFOFF + 1               /* next entry in LLTAPFTB  */
    LNKPOS   = Right(I,3)                         /*position in list */
    RELLKPOS = Right('(+'I-1')',6)      /* relative position in list */
/*  Queue LNKPOS  RELLKPOS '   ' LKAPF '  ' LNKVOL '  ' LKDSN*/
    Queue 'LNKLST' LKDSN
  End
End
Return
 
 
APF:                 /* APF List sub-routine                         */
CVTAUTHL = C2d(Storage(D2x(CVT + 484),4))    /* point to auth lib tbl*/
If CVTAUTHL <> C2d('7FFFF001'x) then do      /* dynamic list ?       */
  NUMAPF   = C2d(Storage(D2x(CVTAUTHL),2))   /* # APF libs in table  */
  APFOFF   = 2                               /* first ent in APF tbl */
/*Queue '     '
  Queue 'APF Library List  ('NUMAPF' libraries):'
  Queue '  ENTRY   VOLUME    DSNAME'*/
  Do I = 1 to NUMAPF
    LEN = C2d(Storage(D2x(CVTAUTHL+APFOFF),1)) /* length of entry    */
    VOL = Storage(D2x(CVTAUTHL+APFOFF+1),6)    /* VOLSER of APF LIB  */
    DSN = Storage(D2x(CVTAUTHL+APFOFF+1+6),LEN-6)  /* DSN of apflib  */
    APFOFF = APFOFF + LEN +1
    APFPOS   = Right(I,4)                      /*position in APF list*/
/*  Queue '  'APFPOS '  ' VOL '  ' DSN*/
    Queue 'APF' DSN
  End
End
Else Do
  ECVT     = C2d(Storage(D2x(CVT + 140),4))    /* point to CVTECVT   */
  ECVTCSVT = C2d(Storage(D2x(ECVT + 228),4))   /* point to CSV table */
  APFA = C2d(Storage(D2x(ECVTCSVT + 12),4))    /* APFA               */
  AFIRST = C2d(Storage(D2x(APFA + 8),4))       /* First entry        */
  ALAST  = C2d(Storage(D2x(APFA + 12),4))      /* Last  entry        */
  LASTONE = 0   /* flag for end of list     */
  NUMAPF = 1    /* tot # of entries in list */
  Do forever
    DSN.NUMAPF = Storage(D2x(AFIRST+24),44)    /* DSN of APF library */
    DSN.NUMAPF = Strip(DSN.NUMAPF,'T')         /* remove blanks      */
    CKSMS = Storage(D2x(AFIRST+4),1)           /* DSN of APF library */
    if  bitand(CKSMS,'80'x)  = '80'x           /*  SMS data set?     */
      then VOL.NUMAPF = '*SMS* '               /* SMS control dsn    */
    else VOL.NUMAPF = Storage(D2x(AFIRST+68),6)    /* VOL of APF lib */
    If Substr(DSN.NUMAPF,1,1) <> X2c('00')     /* check for deleted  */
      then NUMAPF = NUMAPF + 1                 /*   APF entry        */
    AFIRST = C2d(Storage(D2x(AFIRST + 8),4))   /* next  entry        */
    if LASTONE = 1 then leave
    If  AFIRST = ALAST then LASTONE = 1
  End
/*Queue '     '
  Queue 'APF Library List  - Dynamic ('NUMAPF - 1' libraries):'
  Queue '  ENTRY   VOLUME    DSNAME'*/
  Do I = 1 to NUMAPF-1
    APFPOS   = Right(I,4)                      /*position in APF list*/
/*  Queue '  'APFPOS '  ' VOL.I '  ' DSN.I*/
    Queue 'APF' DSN.I
  End
End
Return
 
 
/* End of iplinfo */
 
 
/*******************************************/
/*  SYSCALL SUBROUTINES                    */
/*******************************************/
 
 
NoValue:
Failure:
Syntax:
say pgmname 'REXX error' rc 'in line' sigl':' strip(ERRORTEXT(rc))
say SOURCELINE(sigl)
SIGNAL ERR_EXIT
 
 
Error:
return_code = RC
if RC > 4 & RC <> 8 then do
  say pgmname "LASTCC =" RC strip(zerrlm)
  say pgmname 'REXX error' rc 'in line' sigl':' ERRORTEXT(rc)
  say SOURCELINE(sigl)
  end
if return_code > maxcc then,
  maxcc = return_code
return
 
 
