星期一, 11月 27, 2023

AS/400 Journal ODBC Exit Program

Following code from AS/400 Journal ODBC Security

Attach this program to QIBM_QZDA_INIT exit point.?This program handles the ODBC security by rejecting request to users who are not authorized to the ODBC *AUTL.?Make sure you create the ODBC authorization list first.



/*------------------------------------------------------------------*/
/*                                                                  */
/*  System name  . . . :‚  Technical Support                       €*/
/*  Module/Program . . :‚  EXTDBSE                                 €*/
/*  Text . . . . . . . :‚  Exit program for Database Server entry  €*/
/*                                                                  */
/*  Author . . . . . . :‚  Alex Nubla                              €*/
/*  Creation date. . . :‚  10/13/98                                €*/
/*  Description  . . . :   This is the exit point program for       */
/*                         QIBM_QZDA_INIT.                          */
/*                         This program handles the ODBC security   */
/*                         by rejecting requests from users who     */
/*                         are not authorized in ODBC authorization */
/*                         list                                     */
/*                                                                  */
/*------------------------------------------------------------------*/
             pgm        (&Okay         /* 1=Allow; 0=Reject     */   +
                         &Request  )   /* Parameter Structure   */

/*--------------------------------------------------------*/
/*  declaration                                           */
/*--------------------------------------------------------*/
             dcl        &Okay      *char    1
             dcl        &Request   *char   34

             dcl        &User      *char   10
             dcl        &SvrId     *char   10
             dcl        &Format    *char    8
             dcl        &Func      *char    4

/*--------------------------------------------------------*/
/*  error message variables                               */
/*--------------------------------------------------------*/
             dcl        &error     *lgl                   /* std err */
             dcl        &msgid     *char    7             /* std err */
             dcl        &msgkey    *char    4             /* std err */
             dcl        &msgdta    *char  100             /* std err */
             dcl        &msgf      *char   10             /* std err */
             dcl        &msgflib   *char   10             /* std err */
             dcl        &msgtyp    *char   10  '*DIAG'    /* std err */
             dcl        &msgtypctr *char    4 X'00000001' /* std err */
             dcl        &pgmmsgq   *char   10  '*'        /* std err */
             dcl        &stkctr    *char    4 X'00000001' /* std err */
             dcl        &errbytes  *char    4 X'00000000' /* std err */

             monmsg     msgid(cpf0000) exec(goto error)

             chgvar     &User      %sst(&Request    1   10)
             chgvar     &SvrId     %sst(&Request   11   10)
             chgvar     &Format    %sst(&Request   21    8)
             chgvar     &Func      %sst(&Request   28    4)

/*--------------------------------------------------------*/
/*  Check if user has *USE authority to ODBC              */
/*--------------------------------------------------------*/
             chgvar     &Okay      '1'

             addlible   techlib    *last
             monmsg     cpf0000

             chkaut     user(&User)         +
                         obj(ODBC)          +
                         objtype(*AUTL)     +
                         aut(*USE)
             monmsg     cpf9802             exec(do)
               chgvar     &Okay      '0'
             enddo

             Goto       End

/*--------------------------------------------------------*/
/*  error routine:                                        */
/*--------------------------------------------------------*/
 error:
             if         &error     (goto errordone)
               else      chgvar       &error  '1'
          /*----------------------------------------------*/
          /*  move all *DIAG message to *PRV program queue*/
          /*----------------------------------------------*/
             call       QMHMOVPM   (&msgkey      +
                                    &msgtyp      +
                                    &msgtypctr   +
                                    &pgmmsgq     +
                                    &stkctr      +
                                    &errbytes)
          /*----------------------------------------------*/
          /*  resend the last *ESCAPE message             */
          /*----------------------------------------------*/
 errordone:
             call       QMHRSNEM   (&msgkey      +
                                    &errbytes)
             monmsg     cpf0000    exec(do)
               sndpgmmsg  msgid(cpf3cf2) msgf(QCFPMSG) +
                            msgdta('QMHRSNEM') msgtype(*escape)
               monmsg     cpf0000
             enddo
 end:        endpgm




AS/400 Journal - FTP Exit Program

Following code from AS/400 Journal https://www.oocities.org/siliconvalley/Pines/5581/ftpsec.htm

File Transfer Protocol (FTP)

File Transfer Protocol (FTP) requires the user to provide a user ID and password (in a secured environment). FTP also verifies that a user profile has authority to any file that is to be transferred. You access this function using the STRTCPFTP or FTP command, or by connecting to the AS/400 FTP Server using another system’s FTP client.

Controlling FTP Access

  • Be aware that there are security issues that comes with FTP clients who accesses the system. Our object security scheme might not provide detailed enough protection when we allow FTP to our system. For example, when a user has the authority to view a file (*USE authority), the user can also download a copy of the file to a PC or another system. I have added FTP exit programs to restrict the FTP operations that users can perform.
    Note: FTP exits are available since V3R2.
  • FTP provides a remote-command capability. The FTP subcommand is equivalent to having a command line on the system. The FTP Request Validation Exit Program for the server rejects remote-command unless properly authorized.
  • Another security glitch in FTP is that passwords are not encrypted when they are sent between the client system and the server system. Passwords may be vulnerable through line sniffing.
  • User can access objects in the IFS (integrated file system) with FTP. We must ensure that our authority scheme for the IFS is adequate.
  • The system value QMAXSIGN does not apply to FTP. Within FTP, the connections ends after 5 unsuccessful attemps, but the user can just QUIT and re-attempt to sign back on. FTP users have unlimited attempts to break in the system.

FTP Server Logon Exit Program -- FTPLOGON

The purpose of the server logon exit program is to allow or deny the users to log on based on 
the User Id, Password or Client IP Address. The FTPLOGON program validates the user id who logs 
on the server. The user must be authorized to the authorization list FTPLOGON, and have at least 
*USE authority. We are also tracking "anonymous" user id, logging their E-mail address for their 
password. The FTPLOGON program sends a message to QSYSOPR & QHST with the user id and E-mail address.

The program continues but since "ANONYMOUS" is not a valid user id, the FTP fails. We may substitute 
another user id to replace the ANONYMOUS user id.

The program also validates the Client IP address against all valid IP address found in the Host Table. 
You may access the Host table entries from the CFGTCP menu. Option 10, Work with TCP/IP host table 
entries, enables us to add host IP address and their associated host names to the host table. The host 
table is stored in member HOST of the file QATOCHOST in library QUSRSYS. The Host table must be identical 
throughout the network. The FTPLOGON program denies any client IP address not found in the host table.

The FTPLOGON program accepts 7 input parameters and returns 4 output parameters. Based on the input 
parameters, FTPLOGON determines what parameters to validate. FTPLOGON program enables the initial 
current library to be set by allowing the current library listed in the input parameter to be overriden. 
FTPLOGON sets the return code output parameter to indicate whether or not to allow the server is to 
continue logon operation. Different return codes are available to enable alternative ways of processing 
the logon and initializing the current library.

NOTE: The FTPLOGON program allows the FTP to continue from either an invalid IP address, 
or users not authorized to FTPLOGON authorization list. 
Change the program to reject (remove the *@@@@@ comment line) the logon to stop the FTP log on. 
A special user id ZFTP is used to bypass FTP security.

      /TITLE FTPLOGON  Firewall Program for FTP Server Logon
      *--------------------------------------------------------------*
      *  Programmers Group & Management Resources   Copyright  1999  *
      *                                                              *
      *                           \\\\\\\                            *
      *                          ( o   o )                           *
      *---------------------oOOO----(_)----OOOo----------------------*
      *                                                              *
      *  System name. . :  Security                                  *
      *  Module/Program :  FTPLOGON                                  *
      *  Text . . . . . :  Firewall for FTP Server Logon             *
      *                                                              *
      *  Author . . . . :  Alex Nubla                                *
      *  Description. . :  This program must be added to the exit    *
      *                    point QIBM_QTMF_SVR_LOGON for format      *
      *                    TCPL0100.                                 *
      *                                                              *
      *                   OOOOO              OOOOO                   *
      *                   (    )             (    )                  *
      *--------------------(   )-------------(   )-------------------*
      *                     (_)               (_)                    *
      *                                                              *
      * Modification Log :                                           *
      *                                                              *
      *           Task  Programmer/                                  *
      *   Date     No.  Description                                  *
      * -------- ------ -------------------------------------------- *
      * 10/15/98        Alex Nubla                                   *
      *                 Creation Date                                *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      * Modules:                                                     *
      *                                                              *
      * 1. FTPLOGON   RPGLE    FTP Server Logon Exit Program         *
      *                                                              *
      * Service Programs:                                            *
      *                                                              *
      * 1. *NONE                                                     *
      *                                                              *
      * Programs:                                                    *
      *                                                              *
      * 1. *NONE                                                     *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *  APIs Used:                                                  *
      *                                                              *
      *  QSYRUSRA      Retrieve user authority to object             *
      *                                                              *
      *--------------------------------------------------------------*
     H COPYRIGHT('(C) Alex Nubla of PGMR, Inc.  1999')
      ****************************************************************
      *  F I L E   D E S C R I P T I O N   S P E C I F I C A T I O N *
      ****************************************************************
     FQATOCHOST IF   E           K DISK
      *
      *  Host Table by IP address
      *
      *--------------------------------------------------------------*
     D/EJECT
      ****************************************************************
      *       D E F I N I T I O N     S P E C I F I C A T I O N      *
      ****************************************************************

      *--------------------------------------------------------------*
      *
      *  Retrieve user authority to Object (QSYRUSRA) API
      *
     D@RtnObjAut       DS            93
     D  @UA2byte                      9B 0 Inz
     D  @UA2avail                     9B 0 Inz
     D  @UA2ObjAut                   10    Inz
      *
     D @UA2Len         S              9B 0 Inz(93)
     D @UA2Format      S              8    Inz('USRA0100')
     D @UA2User        S             10    Inz
     D @UA2Object      S             20    Inz('FTPLOGON  QSYS      ')
     D @UA2OType       S             10    Inz('*AUTL')

      *--------------------------------------------------------------*
      *
      *  TCP/IP Application Server Logon Exit Point Interface
      *
      * *------------------------------------------------------------*
      * |  1 | Application identifier      | Input  | Binary(4)      |
      * |    |                             |        |                |
      * |    |  1 = FTP server program     |        |                |
      * |    |  2 = REXEC server program   |        |                |
      * |    |                             |        |                |
      * |----+------------+----------------+--------+----------------|
      * |  2 | User identifier             | Input  | Char(*)        |
      * |----+------------+----------------+--------+----------------|
      * |  3 | Length of user identifier   | Input  | Binary(4)      |
      * |----+------------+----------------+--------+----------------|
      * |  4 | Authentication string       | Input  | Char(*)        |
      * |----+------------+----------------+--------+----------------|
      * |  5 | Length of authentication    | Input  | Binary(4)      |
      * |    | string                      |        |                |
      * |----+------------+----------------+--------+----------------|
      * |  6 | Client IP address           | Input  | Char(*)        |
      * |----+------------+----------------+--------+----------------|
      * |  7 | Length of client IP address | Input  | Binary(4)      |
      * |----+------------+----------------+--------+----------------|
      * |  8 | Return code                 | Output | Binary(4)      |
      * |    |                             |        |                |
      * |    |  0 = Reject Logon           |        |                |
      * |    |  1 = Continue Logon         |        |                |
      * |    |  2 = Continue Logon,        |        |                |
      * |    |      override current       |        |                |
      * |    |      library                |        |                |
      * |    |  3 = Continue Logon,        |        |                |
      * |    |      override user prf,     |        |                |
      * |    |      password               |        |                |
      * |    |  4 = Continue Logon,        |        |                |
      * |    |      override user prf,     |        |                |
      * |    |      password, current      |        |                |
      * |    |      library                |        |                |
      * |    |  5 = Accept logon with      |        |                |
      * |    |      user prf returned      |        |                |
      * |    |  6 = Accept logon with      |        |                |
      * |    |      user prf returned,     |        |                |
      * |    |      override current       |        |                |
      * |    |      library                |        |                |
      * |    |                             |        |                |
      * |----+------------+----------------+--------+----------------|
      * |  9 | User profile                | Output | Char(10)       |
      * |----+------------+----------------+--------+----------------|
      * | 10 | Password                    | Output | Char(10)       |
      * |----+------------+----------------+--------+----------------|
      * | 11 | Initial current library     | Output | Char(10)       |
      * *------------------------------------------------------------*
      *
      *     Exit Point:  QIBM_QTMF_SVR_LOGON
      *                  QIBM_QTMX_SVR_LOGON
      *
     D AppId           S              9B 0
     D UserId          S            999
     D UserIdLen       S              9B 0
     D Authen          S            999
     D AuthenLen       S              9B 0
     D IpAddr          S             15
     D IpAddrLen       S              9B 0
     D RtnCode         S              9B 0
     D User            S             10
     D Password        S             10
     D CurrLib         S             10

     D Email           S             30
     D FTPUser         S             10
     D Message         S             52
     D FullJob         S             28

      *--------------------------------------------------------------*
      *
      *  Record structure for error code parameter
      *
     D@ErrData         DS
     D  @BytesProv                    9B 0 Inz(200)
     D  @BytesAval                    9B 0
     D  @ExcpId                       7
     D  @Reserved1                    1
     D  @ExcpData                   184

      *--------------------------------------------------------------*
      *
      *  Constants
      *
     D Special         C                   'ZFTP'
     D Anonymous       C                   'ANONYMOUS '
     D LogMsg1         C                   'ANONYMOUS ('
     D LogMsg2         C                   ') try to logon FTP'
     D LogMsg3         C                   ' logon to FTP'
     D @Sign           C                   '@'
     D Warn1           C                   ' SECURITY VIOLATION:               '
     D Warn2           C                   ' =================================-
     D                                     =================='
     D Warn3           C                   ' Invalid IP Address of FTP Logon. -
     D                                     Check the ff:'
     D Warn4           C                   ' Not authorized to FTPLOGON *AUTL.-
     D                                      Check the ff:'
     D Reject          C                   0
     D Continue        C                   1
     D Accept          C                   5
      *
     C/EJECT
      ****************************************************************
      *     C A L C U L A T I O N     S P E C I F I C A T I O N      *
      ****************************************************************
      *
     C     *Entry        Plist
      *
      * Input parameters
     C                   Parm                    AppId
     C                   Parm                    UserId
     C                   Parm                    UserIdLen
     C                   Parm                    Authen
     C                   Parm                    AuthenLen
     C                   Parm                    IpAddr
     C                   Parm                    IpAddrLen
      *
      * Return parameters
     C                   Parm                    RtnCode
     C                   Parm                    User
     C                   Parm                    Password
     C                   Parm                    CurrLib
      *
      *----------------------------------------------------*
      *  Check user id requesting the FTP                  *
      *----------------------------------------------------*
     C                   If        UserIdLen   > *Zeros
     C                   Eval      FtpUser     = %Subst(UserId: 1: UserIdLen)
     C                   EndIf
      *
     C                   Select
      *----------------------------------------------------*
      *  ANONYMOUS user log on                             *
      *----------------------------------------------------*
     C                   When      FtpUser     = Anonymous
     C                   Exsr      $Anonym
     C                   Other
      *----------------------------------------------------*
      *  Is user authorized to FTPLOGON *AUTL              *
      *----------------------------------------------------*
     C                   Exsr      $Autl
     C                   EndSl
      *
     C                   Eval      *InLR       = *On
     C                   Return
      /EJECT
      ****************************************************************
      *                    S U B R O U T I N E S                     *
      ****************************************************************
      /SPACE
      *==============================================================*
      *                                                              *
      *  Anonymous user log on                                       *
      *                                                              *
     C     $Anonym       Begsr
      *==============================================================*
      *----------------------------------------------------*
      *  We may want ANONYMOUS user id in the fututre -    *
      *  if so, create the user id use by "PUBLIC" user.   *
      *  For now, it will abend because ANONYMOUS is not a *
      *  valid AS/400 id. Read I.7 Anonymous FTP of        *
      *  OS/400 TCP/IP Configuration & Reference Manual.   *
      *----------------------------------------------------*

      *         *------------------------------------------*
      *         *  email address follows ANONYMOUS         *
      *         *------------------------------------------*
     C     @Sign         Scan      Authen:2                               88
     C                   If        *In88
      *
      *          if we allow "PUBLIC" FTP, change this code
      *            to use the "PUBLIC" user id.
      *
     C                   Eval      User        = FtpUser
     C                   Eval      RtnCode     = Accept
     C                   Eval      Email       = %Subst(Authen: 1: AuthenLen)
     C                   Eval      Message     = LogMsg1          +
     C                                           %Trimr(Email)    +
     C                                           LogMsg2
     C     Message       Dsply     'QSYSOPR'
     C                   Else
     C                   Eval      RtnCode     = Reject
     C                   EndIf
      *
      *
     C     #Anonym       Endsr
      /SPACE
      *==============================================================*
      *                                                              *
      *  Authorized to FTPLOGON *AUTL?                               *
      *                                                              *
     C     $Autl         Begsr
      *==============================================================*
      *----------------------------------------------------*
      *  User must be authorized to FTPLOGON *AUTL.        *
      *----------------------------------------------------*
     C                   Reset                   @RtnObjAut
     C                   Reset                   @UA2Len
     C                   Reset                   @UA2Format
     C                   Eval      @UA2User    = FtpUser
     C                   Call      'QSYRUSRA'
     C                   Parm                    @RtnObjAut
     C                   Parm                    @UA2Len
     C                   Parm                    @UA2Format
     C                   Parm                    @UA2User
     C                   Parm                    @UA2Object
     C                   Parm                    @UA2OType
     C                   Parm                    @ErrData
      *         *------------------------------------------*
      *         *  Not authorized to FTPLOGON *AUTL.       *
      *         *  If we want to prevent the FTP for the   *
      *         *  user, use the Reject statement instead. *
      *         *------------------------------------------*
     C                   If        @UA2ObjAut  = '*EXCLUDE'
     C                   Eval      RtnCode     = Continue
      *@@@@@@@@          Eval      RtnCode     = Reject
     C     Warn2         Dsply     'QSYSOPR'
     C                   Eval      Message     = %Trimr(Warn1)     +
     C                                           ' USER ID INVALID'
     C     Message       Dsply     'QSYSOPR'
     C     Warn4         Dsply     'QSYSOPR'
     C                   Eval      Message     = '   User Id   : ' +  FtpUser
     C     Message       Dsply     'QSYSOPR'
     C                   Eval      Internet    = %Subst(IpAddr: 1: IpAddrLen)
     C                   Eval      Message     = '   IP Address: ' +  Internet
     C     Message       Dsply     'QSYSOPR'
     C     Warn2         Dsply     'QSYSOPR'
      *
     C                   Else
      *         *------------------------------------------*
      *         *  if authorized, validate IP              *
      *         *------------------------------------------*
     C                   Exsr      $ValidIp
     C                   EndIf
      *
     C     #Autl         Endsr
      /SPACE
      *==============================================================*
      *                                                              *
      *  Validate the FTP Client IP Address                          *
      *                                                              *
     C     $ValidIp      Begsr
      *==============================================================*
      *----------------------------------------------------*
      *  Validate the IP address the FTP request is coming *
      *  in from. The IP must be registered as one of the  *
      *  host tables.  GO CFGTCP and take option 10 to     *
      *  enter new host in the table.                      *
      *----------------------------------------------------*
      *
     C                   Eval      Internet    = %Subst(IpAddr: 1: IpAddrLen)
     C     Internet      Chain     QATOCHOST                          40
     C                   If        Not *In40
     C                   Eval      RtnCode     = Continue
     C                   If        FtpUser    <> Special
     C                   Eval      Message     = %Trimr(FtpUser)   +  LogMsg3
     C     Message       Dsply     'QSYSOPR'
     C                   EndIf
      *
     C                   Else
      *         *------------------------------------------*
      *         *  Invalid Client IP Address.              *
      *         *  If we want to prevent the FTP for the   *
      *         *  user, use the Reject statement instead. *
      *         *------------------------------------------*
     C                   Eval      RtnCode     = Continue
      *@@@@@@@@          Eval      RtnCode     = Reject
     C     Warn2         Dsply     'QSYSOPR'
     C                   Eval      Message     = %Trimr(Warn1)     +
     C                                           ' CLIENT IP ADDRESS INVALID'
     C     Message       Dsply     'QSYSOPR'
     C     Warn3         Dsply     'QSYSOPR'
     C                   Eval      Message     = '   IP Address: ' +  Internet
     C     Message       Dsply     'QSYSOPR'
     C                   Eval      Message     = '   User Id   : ' +  FtpUser
     C     Message       Dsply     'QSYSOPR'
     C     Warn2         Dsply     'QSYSOPR'
     C                   EndIf
      *
     C     #ValidIp      Endsr


FTP Request Validation Exit Program

The FTP request validation exit program determines whether to allow or deny permission of FTP 
operation based either on user id, client IP address, operation being requested, or 
directory/file/library affected. The FTPRQSVLD program is used for this exit program for both 
client and server request.

Requested operations are permitted or denied based on the returned "Allow operation" output 
parameter. For example, the FTP application calls FTPRQSVLD with a request to PUT (write/update) 
to this file? FTPRQSVLD determines whether the request is accepted and returns the "Allow operation" 
return code to the FTP application. If it is denied, the FTP application issues a message that state 
that the operation is rejected.

The exit program may also indicate that the FTP request will always be allowed or always denied 
for a particular user. When always allowed or always denied is returned, the FTP application will 
not call the exit program again for the same request during the user session.

The FTPRQSVLD program accepts 7 input parameters and returns 1 output parameter. Based on the
input parameter, FTPRQSVLD can determine what type of FTP operation is being requested, For 
operation containing name of library or file name, FTPRQSVLD allows the operation if the 
library requested is a "Test" type library. For "Production" type library, the FTP request is 
rejected. FTP request requiring execution of CL commands are all rejected.

      /TITLE FTPRQSVLD  Firewall Program for FTP Request Validation
      *--------------------------------------------------------------*
      *  Programmers Group & Management Resources   Copyright  1999  *
      *                                                              *
      *                           \\\\\\\                            *
      *                          ( o   o )                           *
      *---------------------oOOO----(_)----OOOo----------------------*
      *                                                              *
      *  System name. . :  Security                                  *
      *  System name. . :  Technical Support                         *
      *  Module/Program :  FTPRQSVLD                                 *
      *  Text . . . . . :  Firewall for FTP Request Validation       *
      *                                                              *
      *  Author . . . . :  Alex Nubla                                *
      *  Description. . :  This program must be added to the exit    *
      *                    point QIBM_QTMF_CLIENT_REQ and            *
      *                    QIBM_QTMF_SERVER_REQ.                     *
      *                                                              *
      *                   OOOOO              OOOOO                   *
      *                   (    )             (    )                  *
      *--------------------(   )-------------(   )-------------------*
      *                     (_)               (_)                    *
      *                                                              *
      * Modification Log :                                           *
      *                                                              *
      *           Task  Programmer/                                  *
      *   Date     No.  Description                                  *
      * -------- ------ -------------------------------------------- *
      * 10/19/98        Alex Nubla                                   *
      *                 Creation Date                                *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      * Modules:                                                     *
      *                                                              *
      * 1. FTPRQSVLD  RPGLE    FTP Request Validation Exit Program   *
      *                                                              *
      * Service Programs:                                            *
      *                                                              *
      * 1. *NONE                                                     *
      *                                                              *
      * Programs:                                                    *
      *                                                              *
      * 1. *NONE                                                     *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *  APIs Used:                                                  *
      *                                                              *
      *  QSYRUSRA      Retrieve user authority to object             *
      *                                                              *
      *--------------------------------------------------------------*
     H COPYRIGHT('(C) Alex Nubla of PGMR, Inc.  1998')
     D/EJECT
      ****************************************************************
      *       D E F I N I T I O N     S P E C I F I C A T I O N      *
      ****************************************************************

      *--------------------------------------------------------------*
      *
      *  Retrieve user authority to Object (QSYRUSRA) API
      *
     D@RtnObjAut       DS            93
     D  @UA2byte                      9B 0 Inz
     D  @UA2avail                     9B 0 Inz
     D  @UA2ObjAut                   10    Inz
      *
     D @UA2Len         S              9B 0 Inz(93)
     D @UA2Format      S              8    Inz('USRA0100')
     D @UA2User        S             10    Inz
     D @UA2Object      S             20    Inz('FTPLOGON  QSYS      ')
     D @UA2OType       S             10    Inz('*AUTL')

      *--------------------------------------------------------------*
      *
      *  Retrieve library description (QLIRLIBD) API
      *
     D@RtnLibDsc       DS            33
     D  @LDByte                       9B 0 Inz
     D  @LDAvail                      9B 0 Inz
     D  @LDLenRtn                     9B 0 Inz
     D  @LDLenAvail                   9B 0 Inz
     D  @LDRecord                    17    Inz
     D   @LDRLen                      9B 0 overlay(@LDRecord:  1)
     D   @LDRKey                      9B 0 overlay(@LDRecord:  5)
     D   @LDRSize                     9B 0 overlay(@LDRecord:  9)
     D   @LDRType                     1    overlay(@LDRecord: 13)
      *
     D@RtvAttr         DS
     D  @AttrElm                      9B 0 Inz(1)
     D  @ReqKey                       9B 0 Inz(1)
      *
     D @LDLen          S              9B 0 Inz(33)
     D FtpLib          S             10    Inz
     D FtpPath         S            256    Inz
     D Str             S              5S 0 Inz
     D Pos             S              5S 0 Inz
     D Len             S              5S 0 Inz
      *
     D Production      C                   '0'
     D Test            C                   '1'

      *--------------------------------------------------------------*
      *
      *  Record structure for error code parameter
      *
     D@ErrData         DS
     D  @BytesProv                    9B 0 Inz(200)
     D  @BytesAval                    9B 0
     D  @ExcpId                       7
     D  @Reserved1                    1
     D  @ExcpData                   184

      *--------------------------------------------------------------*
      *
      *  TCP/IP Application Request Validation Exit Point Interface
      *
      * *------------------------------------------------------------*
      * |  1 | Application identifier      | Input  | Binary(4)      |
      * |    |                             |        |                |
      * |    |  0 = FTP client program     |        |                |
      * |    |  1 = FTP server program     |        |                |
      * |    |                             |        |                |
      * |----+------------+----------------+--------+----------------|
      * |  2 | Operations identified       | Input  | Binary(4)      |
      * |    |                             |        |                |
      * |    |  0 = Session initialization |        |                |
      * |    |  1 = Directory/library      |        |                |
      * |    |      creation               |        |                |
      * |    |  2 = Directory/library      |        |                |
      * |    |      deletion               |        |                |
      * |    |  3 = Set current directory  |        |                |
      * |    |  4 = List files             |        |                |
      * |    |  5 = File deletion          |        |                |
      * |    |  6 = Sending file           |        |                |
      * |    |  7 = Receiving file         |        |                |
      * |    |  8 = Renaming file          |        |                |
      * |    |  9 = Execute CL command     |        |                |
      * |    |                             |        |                |
      * |----+------------+----------------+--------+----------------|
      * |  3 | User profile                | Input  | Char(10)       |
      * |----+------------+----------------+--------+----------------|
      * |  4 | Remote IP address           | Input  | Char(*)        |
      * |----+------------+----------------+--------+----------------|
      * |  5 | Length of remote IP address | Input  | Binary(4)      |
      * |----+------------+----------------+--------+----------------|
      * |  6 | Operation-specific          | Input  | Char(*)        |
      * |    | information                 |        |                |
      * |----+------------+----------------+--------+----------------|
      * |  7 | Length of                   | Input  | Binary(4)      |
      * |    | operation-specific          |        |                |
      * |    | information                 |        |                |
      * |----+------------+----------------+--------+----------------|
      * |  8 | Allow operation             | Output | Binary(4)      |
      * |    |                             |        |                |
      * |    | -1 = Never allow the        |        |                |
      * |    |      operation identifier   |        |                |
      * |    |  0 = Reject the operation   |        |                |
      * |    |  1 = Allow the operation    |        |                |
      * |    |  2 = Always allow this      |        |                |
      * |    |      operation identifier   |        |                |
      * |    |                             |        |                |
      * *------------------------------------------------------------*
      *
      *     Exit Point:  QIBM_QTMF_CLIENT_REQ
      *                  QIBM_QTMF_SERVER_REQ
      *                  QIBM_QTMX_SERVER_REQ
      *                  QIBM_QTOD_SERVER_REQ
      *
     D AppId           S              9B 0
     D OperRqs         S              9B 0
     D User            S             10
     D IpAddr          S             15
     D IpAddrLen       S              9B 0
     D OperInf         S            999
     D OperInfLen      S              9B 0
     D AllowOper       S              9B 0
     D FullJob         S             26

     D SessionInz      C                   0
     D MakeDir         C                   1
     D DelDir          C                   2
     D ChgDir          C                   3
     D ListFile        C                   4
     D DelFile         C                   5
     D PutFile         C                   6
     D GetFile         C                   7
     D RnmFile         C                   8
     D SysCmd          C                   9
     D NeverAllow      C                   -1
     D Reject          C                   0
     D Allow           C                   1
     D AlwaysAllw      C                   2

      *--------------------------------------------------------------*
      *
      *  Standalone fields
      *
     D Message         S             52
     D Internet        S             15

      *--------------------------------------------------------------*
      *
      *  Constants
      *
     D @LO             C                   'abcdefghijklmnopqrstuvwxyz'
     D @UP             C                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
      *
     D Client          C                   0
     D Server          C                   1
      *
     D Warn1           C                   ' FTP REQUEST:                      '
     D Warn2           C                   ' =================================-
     D                                     =================='
     D Warn3           C                   ' The following info was logged fro-
     D                                     m the Server:'
      *
     D Anonymous       C                   'ANONYMOUS '
     D Special         C                   'ZFTP'
     D Qtcp            C                   'QTCP'
     D QsysLib         C                   '/QSYS.LIB/'
     D DotLib          C                   '.LIB'
     C/EJECT
      ****************************************************************
      *     C A L C U L A T I O N     S P E C I F I C A T I O N      *
      ****************************************************************
      *
     C     *Entry        Plist
      *
      * Input parameters
     C                   Parm                    AppId
     C                   Parm                    OperRqs
     C                   Parm                    User
     C                   Parm                    IpAddr
     C                   Parm                    IpAddrLen
     C                   Parm                    OperInf
     C                   Parm                    OperInfLen
      *
      * Return parameters
     C                   Parm                    AllowOper
      *
     C                   Eval      AllowOper   = Allow
     C                   If        User       <> Special   and
     C                             User       <> Qtcp
      *----------------------------------------------------*
      *  Determine client or server request                *
      *----------------------------------------------------*
B01  C                   Select
      *         *------------------------------------------*
      *         *  Client FTP request                      *
      *         *------------------------------------------*
     C                   When      AppId       = Client
     C                   Exsr      $ClientRq
      *         *------------------------------------------*
      *         *  Server FTP request                      *
      *         *------------------------------------------*
     C                   When      AppId       = Server
     C                   Exsr      $ServerRq
E01  C                   EndSl
      *
E01  C                   EndIf
      *
     C                   Eval      *InLR       = *On
     C                   Return
      /EJECT
      ****************************************************************
      *                    S U B R O U T I N E S                     *
      ****************************************************************
      /SPACE
      *==============================================================*
      *                                                              *
      *  Validate FTP Client Request                                 *
      *                                                              *
     C     $ClientRq     BegSr
      *==============================================================*
      *----------------------------------------------------*
      *  Validate client request (job on this server)      *
      *----------------------------------------------------*
     C                   Select
      *         *------------------------------------------*
      *         *  Rejected requests                       *
      *         *------------------------------------------*
     C                   When      OperRqs     = MakeDir   or
     C                             OperRqs     = DelDir    or
     C                             OperRqs     = DelFile   or
     C                             OperRqs     = RnmFile   or
     C                             OperRqs     = SysCmd
     C                   Eval      AllowOper   = NeverAllow
      *
      *         *------------------------------------------*
      *         *  Accepted requests - have the server     *
      *         *  system validate our request.            *
      *         *------------------------------------------*
     C                   When      OperRqs     = ChgDir    or
     C                             OperRqs     = ListFile  or
     C                             OperRqs     = PutFile   or
     C                             OperRqs     = GetFile
     C                   Eval      AllowOper   = Allow
E02  C                   EndSl
      *
     C     #ClientRq     EndSr
     C/EJECT
      *==============================================================*
      *                                                              *
      *  Validate FTP Server Request                                 *
      *                                                              *
     C     $ServerRq     BegSr
      *==============================================================*
      *----------------------------------------------------*
      *  User id accepted at this point                    *
      *----------------------------------------------------*
      *
B02  C                   Select
      *         *------------------------------------------*
      *         *  Rejected requests                       *
      *         *------------------------------------------*
     C                   When      OperRqs     = MakeDir   or
     C                             OperRqs     = DelDir    or
     C                             OperRqs     = DelFile   or
     C                             OperRqs     = RnmFile   or
     C                             OperRqs     = SysCmd
     C                   Eval      AllowOper   = NeverAllow
      *
      *         *------------------------------------------*
      *         *  Accepted requests - only for TEST type  *
      *         *  library.                                *
      *         *------------------------------------------*
     C                   When      OperRqs     = ChgDir    or
     C                             OperRqs     = ListFile  or
     C                             OperRqs     = PutFile   or
     C                             OperRqs     = GetFile
     C                   Eval      AllowOper   = Allow
      *
     C                   Reset                   FtpLib
     C                   Eval      FtpPath     = %Subst(OperInf: 1: OperInfLen)
     C     @Lo:@Up       Xlate     FtpPath       FtpPath
     C     QSysLib       Scan      FtpPath       Pos                      90
      *
     C                   If        *In90
     C                   Eval      Str         = Pos + 10
     C     DotLib        Scan      FtpPath:Str   Pos                      89
     C                   If        *In89
     C                   Eval      Len         = Pos - Str
     C                   Eval      FtpLib      = %Subst(FtpPath: Str: Len)
     C                   Else
     C                   Eval      FtpLib      = 'QSYS'
     C                   EndIf
      *
     C                   Call      'QLIRLIBD'
     C                   Parm                    @RtnLibDsc
     C                   Parm                    @LDLen
     C                   Parm                    FtpLib
     C                   Parm                    @RtvAttr
     C                   Parm                    @ErrData
      *
     C                   If        @LDRType    = Production
     C                   Eval      AllowOper   = Reject
     C                   Else
      *         *------------------------------------------*
      *         *  Log the request to QSYSOPR              *
      *         *------------------------------------------*
     C     Warn2         Dsply     'QSYSOPR'
     C                   Select
     C                   When      OperRqs     = ChgDir
     C                   Eval      Message     = %Trimr(Warn1)     +
     C                                           ' CHANGE DIRECTORY'
     C                   When      OperRqs     = ListFile
     C                   Eval      Message     = %Trimr(Warn1)     +
     C                                           ' LIST THE NAMES'
     C                   When      OperRqs     = PutFile
     C                   Eval      Message     = %Trimr(Warn1)     +
     C                                           ' COPY OUR PATH TO REMOTE IP'
     C                   When      OperRqs     = GetFile
     C                   Eval      Message     = %Trimr(Warn1)     +
     C                                           ' COPY FROM IP INTO OUR PATH'
     C                   EndSl
     C     Message       Dsply     'QSYSOPR'
     C     Warn3         Dsply     'QSYSOPR'
     C                   Eval      Message     = '   User Id   : ' +  User
     C     Message       Dsply     'QSYSOPR'
     C                   Eval      Internet    = %Subst(IpAddr: 1: IpAddrLen)
     C                   Eval      Message     = '   IP Address: ' +  Internet
     C     Message       Dsply     'QSYSOPR'
     C                   Eval      Message     = '   Path Rqs  : '
     C     Message       Dsply     'QSYSOPR'
     C                   Eval      Message     = '   ' + FtpPath
     C     Message       Dsply     'QSYSOPR'
     C     Warn2         Dsply     'QSYSOPR'
     C                   EndIf
     C                   EndIf
      *
     C                   Other
      *         *------------------------------------------*
      *         *  If this is a secured system, use the    *
      *         *  Reject statement instead.               *
      *         *------------------------------------------*
     C                   Eval      AllowOper   = Allow
      *@@@@@@@@          Eval      AllowOper   = Reject
E02  C                   EndSl
      *
     C     #ServerRq     EndSr



星期一, 11月 13, 2023

IBM i Services很棒,但並不神奇

IBM i Services are Great, but they're NOT Magic


IBM i Services:概觀



2023-11-13 Retrieve Current job last spooled file ID with API QSPRILSP


Retrieve Last Spooled file ID with API QSPRILSP
擷取 Job 最後產生的報表資訊 API QSPRILSP

pgm 
                                                  
   dcl   &SplfNbr1    *int    4
   dcl   &SplfNbr2    *int    4                   
                                                  
   dcl   &RcvVar        *char  70                   
   dcl     &BytesAvail  *int    4  stg(*defined) defvar(&RcvVar  1) 
   dcl     &BytesRtn    *int    4  stg(*defined) defvar(&RcvVar  5) 
   dcl     &SplfName    *char  10  stg(*defined) defvar(&RcvVar  9) 
   dcl     &JobName     *char  10  stg(*defined) defvar(&RcvVar 19) 
   dcl     &UserName    *char  10  stg(*defined) defvar(&RcvVar 29) 
   dcl     &JobNbr      *char   6  stg(*defined) defvar(&RcvVar 39) 
   dcl     &SplfNbr     *int    4  stg(*defined) defvar(&RcvVar 45) 
   dcl     &SysName     *char   8  stg(*defined) defvar(&RcvVar 49) 
   dcl     &SplfCrtDat  *char   7  stg(*defined) defvar(&RcvVar 57) 
   dcl     &SplfCrtTim  *char   6  stg(*defined) defvar(&RcvVar 65) 

   dcl   &RcvVarLen   *int    4    value(70)               
   dcl   &FmtName     *char  10                   
   dcl   &ErrorCode   *char   8                   
                                                  
   dcl   &Stat        *lgl                        
   dcl   &SplfExists  *lgl                        
                                                  

   callsubr subr(RtvSplfNbr) rtnval(&SplfNbr1)                   
   call     pgm1                                               
   callsubr subr(RtvSplfNbr) rtnval(&SplfNbr2)                   

/* If pgm1 created a report, continue with other tasks. */
   if (&SplfNbr2 *ne &SplfNbr1) do  
      call pgm2                             
      call pgm3                             
      call pgm4                             
   enddo                                     
   return                                    
       
subr subr(RtvSplfNbr) 
        
   chgvar   &BytesAvail         70 
   chgvar   &FmtName            'SPRL0100' 
   chgvar   &ErrorCode          x'0000000000000000' 
                                         
   chgvar   &SplfExists  '1'         
   call     QSPRILSP     (&RcvVar &RcvVarLen &FmtName &ErrorCode)  
   monmsg   cpf333a      exec(chgvar &SplfExists '0') 
   if (&SplfExists) then
   else do        
      chgvar   &SplfNbr        0    
   enddo                                
                                        
endsubr rtnval(&SplfNbr) 
                           
endpgm



Copy from https://www.itjungle.com/2006/02/08/fhg020806-story01/

星期五, 11月 10, 2023

Auditting IPs accessing IBMi via port 446

    Port 446 is the DRDA port, QRWTLSTN is the job that is listening on that port, so a couple of ways I can think of:

  • 1) exit program

  • 2) look thru history log :  DSPLOG msgid(CPI3E34) job(QRWT*)

    CPI3E34    DDM job xxxx servicing user yyy on mm/dd/yy at hh:mm:ss (This can be suppressed with QRWOPTIONS)

    Distributed relational database messages

    QRWOPTIONS data area

  • 3) History of connections to IBM i
    https://www.ibm.com/support/pages/node/6212238

  • https://community.ibm.com/community/user/power/discussion/auditting-ips-accessing-ibmi-via-port-446
  •   -- category:Robert Berendt 
      select * 
      FROM TABLE (QSYS2.HISTORY_LOG_INFO(START_TIME => CURRENT DATE - 2 days
            )) AS X
      Where message_id='CPI3E34'
       and from_job_name like 'QRWT%'
      ORDER BY ORDINAL_POSITION desc;
      
    
      -- category: bryandietz
      --  find DRDA and ODBC like connections
      -- description: history log-find user from QZDASOINIT-QRWTSRVR
      SELECT Message_Timestamp
             ,From_User
             ,From_Job
             ,Message_Id
             ,MESSAGE_TEXT
          FROM TABLE(Qsys2.History_Log_Info(
          Start_Time => current_timestamp - 1 day,   -- pick your time frame
          End_Time =>  current_timestamp
          )) i
          WHERE  Message_Id in ('CPIAD09','CPI3E34')
           --  AND        MESSAGE_TEXT LIKE '%YOUR_USER%'  -- if needing to "audit" for a single user
      ;
    
    
    
      -- find ip from message_tokens
      -- category: Robert Berendt
      select trim(substring(message_tokens, 75, 15)) as IP_address, x.* 
      FROM TABLE (QSYS2.HISTORY_LOG_INFO(START_TIME => CURRENT DATE - 2 days
                    )) AS X
      Where message_id='CPI3E34'
        and from_job_name like 'QRWT%'
      ORDER BY ORDINAL_POSITION desc;
    
    
      -- find IP
      -- category: bryandietz
      --  find DRDA and ODBC like connections
      -- description: history log-find user from QZDASOINIT-QRWTSRVR
      SELECT Message_Timestamp
             ,From_User
             ,From_Job
             ,Message_Id
             ,MESSAGE_TEXT
             ,TRIM(SUBSTR(Message_Text,(LOCATE_IN_STRING(Message_Text, 'client', 1)+7),   -- start of IP
                                (LOCATE_IN_STRING(Message_Text, ' connected', 1) -
                                (LOCATE_IN_STRING(Message_Text, 'client ', 1)+7)           -- end of IP address
                                ))) AS IP_addr
          FROM TABLE(Qsys2.History_Log_Info(
          Start_Time => current_timestamp - 1 day,   -- pick your time frame
          End_Time =>  current_timestamp
          )) i
          WHERE  Message_Id in ('CPIAD09','CPI3E34')
           --  AND        MESSAGE_TEXT LIKE '%YOUR_USER%'  -- if needing to "audit" for a single user
      ;
      
    
      
      
      

2023-11-10 如何於 CL 中產生 UUID ?(Command GENUUID with MI GENUUID)


如何於 CL 中產生 UUID ?(Command GENUUID with MI GENUUID)
How to Generate UUID in CL ? (Command GENUUID with MI GENUUID)

File  : QCLSRC
Member: GENUUIDC
Type  : CLLE

 /*                                                                */
 /*                             \\\\\\\                            */
 /*                            ( o   o )                           */
 /*------------------------oOO----(_)----OOo-----------------------*/
 /*                                                                */
 /*   Program :      GENUUIDC                                      */
 /*   System  :      IBM i V7R2                                    */
 /*   Author  :      Vengoal Chang                                 */
 /*   Date    :      2023/11/10                                    */
 /*   Description :  Generate Universal Unique Identifier (GENUUID)*/
 /*                  GENUUID command CPP                           */
 /*                                                                */
 /*                     ooooO              Ooooo                   */
 /*                     (    )             (    )                  */
 /*----------------------(   )-------------(   )-------------------*/
 /*                       (_)               (_)                    */
 /*                                                                */
 /*                                                                */
 /*   To compile :                                                 */
 /*         The source type must be "CLLE"   (and not CLP).        */
 /*         Compile with STRPDM option 14  or use the              */
 /*         CRTBNDCL command.                                      */
 /*                                                                */
 /*----------------------------------------------------------------*/
             Pgm       Parm(&UUIDP  &UUIDHEX)

             Dcl        &UUIDP          *Char  16
             Dcl        &UUIDHEX        *Char  32

             Dcl        &TMPL           *Char  32
             Dcl        &LEN            *Uint   4  VALUE(32)
             Dcl        &BytPrv         *Uint  Stg(*DEFINED) +
                          Len(4)  DefVar(&TMPL)
             Dcl        &BytAvl         *Uint  Stg(*DEFINED) +
                          Len(4)  DefVar(&TMPL)
             Dcl        &Reserved       *Char  Stg(*DEFINED) +
                          Len(8)  DefVar(&TMPL 10)
             Dcl        &UUID           *Char  Stg(*DEFINED) +
                          Len(16) DefVar(&TMPL 17)
             Dcl        &RcvHexLen      *Int    4  32

             CallPrc    Prc('_PROPB') Parm((&TMPL *ByRef)  +
                                           (X'00' *ByVal)  +
                                           (&LEN  *ByVal))

             ChgVar     &BytPrv      32
             CallPrc    Prc('_GENUUID') Parm((&TMPL *ByRef))

             ChgVar     &UUIDP          &UUID
             CallPrc    PRC('cvthc')             +
                        PARM((&UUIDHEX  *ByRef)  +
                             (&UUID     *ByRef)  +
                             (&RcvHexLen *ByVal))

          /* DmpClPgm    */

 End:        EndPgm


File  : QCMDSRC
Member: GENUUID
Type  : CMD

/*****************************************************************/
/*                                                               */
/* Command name: GenUUID                                         */
/*                                                               */
/* Author      : Vengoal Chang                                   */
/*                                                               */
/* Date written: 2023/11/10                                      */
/*                                                               */
/* Description : Generate Universal Unique Identifier (GENUUID)  */
/*                                                               */
/* To compile:                                                   */
/*     CRTCMD CMD( GenUUID )                                     */
/*            PGM( GenUUIDC )                                    */
/*            SRCMBR( GenUUID )                                  */
/*            ALLOW( *Ipgm *Bpgm )                               */
/*                                                               */
/*****************************************************************/

             Cmd        Prompt('Generate Universal Unique ID')

             Parm       Kwd( UUID )                             +
                          Type(*CHAR)                           +
                          Len(16)                               +
                          RtnVal(*YES)                          +
                          Prompt('CL var for UUID         (16)')

             Parm       Kwd( UUIDHEX )                          +
                          Type(*CHAR)                           +
                          Len(32)                               +
                          RtnVal(*YES)                          +
                          Prompt('CL var for UUID HEX STR (32)')





星期四, 11月 09, 2023

2018-12-03 Check Daily Batch Jobs started or not


Check Daily Batch Jobs started or not

CHKBCHJOB CLP read file CHKBCHJOBP and check current time >=  start time and current time < end time and chkflg ='Y',
then call API get the job active information, If job does not active, then send the job not acticve message to sysopr.
If job active, but status is MSGW, also send message to sysopr.


File  : QDDSSRC
Member: CHKBCHJOBP
Type  : PF
Usage : CrtPF File(CHKBCHJOBP)        
        




     A*****************************************************************
     A*   FUNCTION    : CHKBCHJOB monitor batch job file
     A*   FILE        : CHKBCHJOBP
     A*   AUTHOR      : Vengoal Chang
     A*   DATE        : 2018/12/03
     A*****************************************************************
     A                                      UNIQUE
     A          R BCHJOBR                   TEXT('Batch job record')
     A            JOBNAME       10A         COLHDG(' JOB NAME')
     A            JOBUSER       10A         COLHDG(' USER')
     A            STRTIME        6S 0       COLHDG('start time')
     A            ENDTIME        6S 0       COLHDG('end time')
     A            CHKFLAG        1A         COLHDG('check Y/N')
     A            NOTE          32O         COLHDG('note')
     A            UPDDATE        8S 0       COLHDG('update date')
     A            UPDTIME        6S 0       COLHDG('update time')
     A*----------------------------------------------------------------
     A          K JOBNAME





File  : QCLSRC
Member: CHKBCHJOBC
Type  : CLP
OS400 : V5R4 above
Usage : CrtClPgm Pgm(ChkBCHJOBC)
        
        




/*  ===============================================================  */
/*  = Program ChkBchJobC                                          =  */
/*  =   ChkBchJob  CLP                                            =  */
/*  =   Paramater notes:                                          =  */
/*  =     Read CHKBCHJOBP file to check daily job active or not   =  */
/*  ===============================================================  */
/*  = Date  : 2018/12/03                                          =  */
/*  = Author: Vengoal Chang                                       =  */
/*  ===============================================================  */

PGM

     DCL         &CURTIMEC    *CHAR  6
     DCL         &STRTIMEC    *CHAR  6
     DCL         &ENDTIMEC    *CHAR  6
     DCL         &CURTIME     *DEC  (6 0)
     DCL         &MSGTEXT     *CHAR 256

     DCL         &USP_NAME    *CHAR  10
     DCL         &USP_LIB     *CHAR  10
     DCL         &USP_QUAL    *CHAR  20
     DCL         &USP_TYPE    *CHAR  10
     DCL         &USP_SIZE    *CHAR  4
     DCL         &USP_FILL    *CHAR  1
     DCL         &USP_AUT     *CHAR  10
     DCL         &USP_TEXT    *CHAR  50

     DCL         &API_USQUAL  *CHAR  20
     DCL         &API_JBQUAL  *CHAR  26
     DCL         &API_JBNAM   *CHAR  10
     DCL         &API_USER    *CHAR  10
     DCL         &API_JOBNR   *CHAR  6
     DCL         &API_STATUS  *CHAR  10

     DCL         &STARTPOS    *CHAR  4
     DCL         &DATALEN     *CHAR  4
     DCL         &HEADER      *CHAR  150
     DCL         &LST_OFFSET  *DEC  (10 0)
     DCL         &LST_SIZE    *DEC  (10 0)
     DCL         &LST_DATA    *CHAR  4096
     DCL         &LST_NBR     *DEC  (5 0)
     DCL         &LST_LEN     *DEC  (5 0)
     DCL         &LST_LENBIN  *CHAR  4
     DCL         &LST_POSBIN  *CHAR  4
     DCL         &LST_COUNT   *DEC  (5 0) VALUE(0)
     DCL         &EXC_COUNT   *DEC  (5 0) VALUE(0)
     DCL         &TYPE        *CHAR  1    VALUE('*')
     DCL         &NBRTORTN    *CHAR  4
     DCL         &KEYSTORTN   *CHAR  16
     DCL         &KEY1        *CHAR  4
     DCL         &KEY2        *CHAR  4
     DCL         &KEY3        *CHAR  4
     DCL         &KEY4        *CHAR  4
     DCL         &SBSSYS      *CHAR  20
     DCL         &WRKSTS      *CHAR  4
     DCL         &MSGRPLY     *CHAR  1
     DCL         &USER        *CHAR  10
     DCL         &CURUSR      *CHAR  10
     DCL         &JOBNBR      *CHAR  6
     DCL         &STATUS      *CHAR  10
     DCL         &JOBTYPE     *CHAR  1
     DCL         &SUBTYPE     *CHAR  1

     DCLF        CHKBCHJOBP

     MONMSG      (CPF0000 MCH0000) *NONE   GOTO ERROR

 READF:
     RCVF
     MONMSG      CPF0864 *N GOTO ENDF

     RTVSYSVAL   SYSVAL(QTIME) RTNVAR(&CURTIMEC)
     CHGVAR      &CURTIME      &CURTIMEC
     IF         (&CURTIME >= &STRTIME *AND                      +
                 &CURTIME <  &ENDTIME *AND                      +
                 &CHKFLAG =  'Y')     Do

       CallSubR   SubR(ListJob)
       If         (&LST_NBR *EQ 0)    Do
       CHGVAR     &STRTIMEC     &STRTIME
       CHGVAR     &ENDTIMEC     &ENDTIME
       CHGVAR     &MSGTEXT      +
                 ('* Bctch Job=' *CAT                        +
                  &JOBNAME  *CAT  'run time : '  *CAT          +
                  &STRTIMEC *BCAT '~' *BCAT &ENDTIMEC *CAT      +
                  ', program not started !')
       SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG)                  +
                  MSGDTA(&MSGTEXT) TOMSGQ(*SYSOPR)
       EndDo

     EndDo

     Goto        READF

 ENDF:
     Return

 Error:
     Call        QMHMOVPM    ( '    '                           +
                               '*DIAG'                          +
                               x'00000001'                      +
                               '*PGMBDY'                        +
                               x'00000001'                      +
                               x'0000000800000000'              +
                             )

     Call        QMHRSNEM    ( '    '                           +
                               x'0000000800000000'              +
                             )

    /****************************************************************/
    /* Sub routine ListJob                                          */
    /****************************************************************/
     SUBR        SUBR(ListJob)
             CHGVAR     VAR(%BIN(&NBRTORTN)) VALUE(4)
     /* 0101 -- Ststus as WRKACTJOB */
             CHGVAR     VAR(%BIN(&KEY1     )) VALUE(0101)
     /* 1906 -- Subsystem */
             CHGVAR     VAR(%BIN(&KEY2     )) VALUE(1906)
     /* 1307 -- Message Reply */
             CHGVAR     VAR(%BIN(&KEY3     )) VALUE(1307)
     /* 0305 -- Current user profile */
             CHGVAR     VAR(%BIN(&KEY4     )) VALUE(0305)
             CHGVAR     VAR(&KEYSTORTN) VALUE(&KEY1 *CAT &KEY2 *CAT +
                                              &KEY3 *CAT &KEY4)

             CHGVAR     VAR(&USP_NAME) VALUE('CHKJOBNAME')
             CHGVAR     VAR(&USP_LIB)  VALUE('QTEMP')
             CHGVAR     VAR(&USP_QUAL) VALUE(&USP_NAME *CAT +
                          &USP_LIB)
             CHGVAR     VAR(&USP_TYPE) VALUE('MYTYPE')
             CHGVAR     VAR(%BIN(&USP_SIZE)) VALUE(128000)
             CHGVAR     VAR(&USP_FILL) VALUE(' ')
             CHGVAR     VAR(&USP_AUT)  VALUE('*USE')
             CHGVAR     VAR(&USP_TEXT) VALUE('my user space')

             DLTUSRSPC  USRSPC(&USP_LIB/&USP_NAME)
             MONMSG CPF0000

             CALL       PGM(QUSCRTUS) PARM(&USP_QUAL &USP_TYPE +
                          &USP_SIZE &USP_FILL &USP_AUT &USP_TEXT)

             CHGVAR     VAR(&API_USQUAL) VALUE(&USP_QUAL)
             CHGVAR     VAR(&API_JBNAM)  VALUE(&JOBNAME)
             CHGVAR     VAR(&API_USER)   VALUE('*ALL')
     /*      CHGVAR     VAR(&API_USER)   VALUE(&JOBUSER)      */
             CHGVAR     VAR(&API_JOBNR)  VALUE('*ALL')
             CHGVAR     VAR(&API_STATUS) VALUE('*ACTIVE')
             CHGVAR     VAR(&API_JBQUAL) VALUE(&API_JBNAM *CAT +
                          &API_USER *CAT &API_JOBNR)

             CALL       PGM(QUSLJOB) PARM(&API_USQUAL 'JOBL0200' +
                          &API_JBQUAL &API_STATUS X'00000000' +
                          &TYPE &NBRTORTN &KEYSTORTN)

             CHGVAR     VAR(%BIN(&STARTPOS)) VALUE(1)
             CHGVAR     VAR(%BIN(&DATALEN))  VALUE(140)

             CALL       PGM(QUSRTVUS) PARM(&API_USQUAL &STARTPOS +
                          &DATALEN &HEADER)

             CHGVAR     VAR(&LST_OFFSET) VALUE(%BIN(&HEADER 125 4))
             CHGVAR     VAR(&LST_SIZE)   VALUE(%BIN(&HEADER 129 4))
             CHGVAR     VAR(&LST_NBR)    VALUE(%BIN(&HEADER 133 4))
             CHGVAR     VAR(&LST_LEN)    VALUE(%BIN(&HEADER 137 4))

             CHGVAR     VAR(%BIN(&LST_POSBIN)) VALUE(&LST_OFFSET + 1)
             CHGVAR     VAR(&LST_LENBIN) VALUE(%SST(&HEADER 137 4))

             CHGVAR     VAR(&LST_COUNT) VALUE(0)

             IF (&LST_NBR *EQ 0) DO
             /* Job not found   */
             Goto       Lst_End
             ENDDO

 LST_LOOP:   IF         COND(&LST_COUNT *EQ &LST_NBR) THEN(GOTO +
                          CMDLBL(LST_END))

             CALL       PGM(QUSRTVUS) PARM(&API_USQUAL &LST_POSBIN +
                          &LST_LENBIN &LST_DATA)

             CHGVAR     VAR(&JOBNAME) VALUE(%SST(&LST_DATA 1 10))
             CHGVAR     VAR(&USER)    VALUE(%SST(&LST_DATA 11 10))
             CHGVAR     VAR(&JOBNBR)  VALUE(%SST(&LST_DATA 21 6))
             CHGVAR     VAR(&STATUS)  VALUE(%SST(&LST_DATA 43 10))
             CHGVAR     VAR(&JOBTYPE) VALUE(%SST(&LST_DATA 53 1))
             CHGVAR     VAR(&SUBTYPE) VALUE(%SST(&LST_DATA 54 1))
      /* for status */
             CHGVAR     VAR(&WRKSTS ) VALUE(%SST(&LST_DATA 81 4))
      /* for subsystem */
             CHGVAR     VAR(&SBSSYS ) VALUE(%SST(&LST_DATA 101 20))
      /* for msgrply   */
             CHGVAR     VAR(&MSGRPLY) VALUE(%SST(&LST_DATA 137  1))
      /* for current user */
             CHGVAR     VAR(&CURUSR ) VALUE(%SST(&LST_DATA 157  10))

             IF   (&WRKSTS *EQ 'MSGW' *AND &MSGRPLY *EQ '1')  DO
               CHGVAR &MSGTEXT ('* Job' *BCAT +
                                &JOBNBR *TCAT '/' *CAT +
                                &USER   *TCAT '/' *CAT +
                                &JOBNAME *BCAT 'status is' *BCAT +
                                &WRKSTS *TCAT '.')
               SNDPGMMSG        MSGID(CPF9898) MSGF(QCPFMSG)       +
                                MSGDTA(&MSGTEXT) TOMSGQ(*SYSOPR)
             EndDo

             CHGVAR     VAR(&LST_COUNT) VALUE(&LST_COUNT + 1)
             CHGVAR     VAR(%BIN(&LST_POSBIN)) +
                          VALUE(%BIN(&LST_POSBIN) + &LST_LEN)
             GOTO       CMDLBL(LST_LOOP)

 LST_END:
             DLTUSRSPC  USRSPC(&USP_LIB/&USP_NAME)
     ENDSUBR

 EndPgm:
     EndPgm





						
File  : QCLSRC
Member: CHKBCHJOB
Type  : CLP 
Usage : CRTCLPGM CHKBCHJOB
        Insert your batch job which need to be monitored to CHKBCHJOBP 
        SBMJOB CMD(CALL CHKBCHJOB) JOB(CHKBCHJOB)

PGM


/*-- Global error monitoring:  --------------------------------------*/
     MonMsg     CPF0000      *N        GoTo Error

 Loop:                    
     Call       ChkBchJobC
     DlyJob     300       
     Goto       Loop      

 Return:
     
     Return

/*-- Error handling:  -----------------------------------------------*/
 Error:

     Call      QMHMOVPM    ( '    '                                  +
                             '*DIAG'                                 +
                             x'00000001'                             +
                             '*PGMBDY'                               +
                             x'00000001'                             +
                             x'0000000800000000'                     +
                           )

     Call      QMHRSNEM    ( '    '                                  +
                             x'0000000800000000'                     +
                           )

 EndPgm:
     EndPgm







2017-11-21 Check Message Queue Manager started or not


Check Message Queue Manager started or not

File  : QCLSRC
Member: CHKMQM
Type  : CLLE
Usage : CrtCLMod   Module( ChkMqm )
        CrtPgm Pgm( ChkMqm ) BndSrvPgm((QMQM/LIBMQM))
        




/*-------------------------------------------------------------------*/
/*                                                                   */
/*  Program . . : CHKMQM                                             */
/*  Description : Check MQM Status                                   */
/*  Author  . . : Vengoal Chang                                      */
/*  Published . : AS400ePaper                                        */
/*  Date  . . . : November 21, 2017                                  */
/*                                                                   */
/*  Program function:  CHKMQM   command processing program           */
/*                                                                   */
/*                                                                   */
/*  Programmer's notes:                                              */
/*                                                                   */
/*  Compile options:                                                 */
/*    CrtCLMod   Module( ChkMqm )                                    */
/*    CrtPgm Pgm( ChkMqm )                                           */
/*           BndSrvPgm((QMQM/LIBMQM))                                */
/*-------------------------------------------------------------------*/
/*                                                                   */
/*  Exceptions monitored :                                           */
/*       MQCONN         MQRC_Q_MGR_STOPPING                          */
/*                      MQRC_Q_MGR_QUIESCING                         */
/*                      MQRC_Q_MGR_NOT_AVAILABLE                     */
/*                      MQRC_STORAGE_NOT_AVAILABLE                   */
/*                                                                   */
/*-------------------------------------------------------------------*/
     Pgm      ( &MQMName &RCChar)

     Dcl        &MQMName      *CHAR    48
     Dcl        &RCChar      *Char    10

     /* Define local variables                      */
     Dcl        &HCONN       *CHAR     4   X'00000000'
     Dcl        &CCODE       *CHAR     4   X'00000000'
     Dcl        &REASON      *CHAR     4   X'00000000'
     Dcl        &NOTAVAIL    *CHAR     4   X'0000080B'
     Dcl        &STOPPING    *CHAR     4   X'00000872'
     Dcl        &QUIESCING   *CHAR     4   X'00000871'
     Dcl        &NOSTORAGE   *CHAR     4   X'00000817'
     Dcl        &UNKNOWN     *CHAR     4   X'0000080A'

     Dcl        &MsgDta      *Char   256
     Dcl        &Rc          *Dec   (10 0)


/*-- Global error monitoring:  --------------------------------------*/
     MonMsg    (CPF0000 MCH3601)     *N        GoTo Error

     AddLibLe  QMQM
     MonMsg    CPF0000

     /******************************************************/
     /* Connect to queue manager                           */
     /******************************************************/
     CallPrc 'MQCONN' (&MQMName &Hconn &Ccode &Reason)
     If     (%bin(&Ccode) *ne 0) Do
          /*************************************************/
          /* MQCONN failed                                 */
          /*************************************************/
          ChgVar   &Rc     %Bin(&Reason)
          ChgVar   &RcChar &Rc
          Select
          When (&Reason = &STOPPING)  Do
            ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
                            'stopping, RC =' *bcat &RcChar)
          EndDo

          When (&Reason = &NOTAVAIL)  Do
            ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
                            'not available, RC =' *bcat &RcChar)
          EndDo
          When (&Reason = &QUIESCING) Do
            ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
                            'quiescing, RC =' *bcat &RcChar)
          EndDo
          When (&Reason = &NOSTORAGE) Do
            ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
                            'nostorage, RC =' *bcat &RcChar)
          EndDo
          When (&Reason = &UNKNOWN)   Do
            ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
                            'unknown, RC =' *bcat &RcChar)
          EndDo
          Otherwise  Do
            ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
                            'conn error, RC =' *bcat &RcChar)
          EndDo
          EndSelect

          SndPgmMsg  MsgId(CPF9898) MsgF(QCPFMSG) +
                     MsgDta(&MsgDta) ToPgmQ(*Ext) MsgType(*Info)
          Goto         Return
     ENDDO

     ChgVar &MsgDta ('Qmgr' *bcat &MQMName *Bcat +
                     'started')
     SndPgmMsg  MsgId(CPF9898) MsgF(QCPFMSG) +
                MsgDta(&MsgDta) ToPgmQ(*EXT) MsgType(*INFO)

     /******************************************************/
     /* MQCONN worked so disonnect                         */
     /******************************************************/
     CallPrc 'MQDISC' (&Hconn &Ccode &Reason)

 Return:
     Return

/*-- Error handling:  -----------------------------------------------*/
 Error:
     Call      QMHMOVPM    ( '    '                                  +
                             '*DIAG'                                 +
                             x'00000001'                             +
                             '*PGMBDY'                               +
                             x'00000001'                             +
                             x'0000000800000000'                     +
                           )

     Call      QMHRSNEM    ( '    '                                  +
                             x'0000000800000000'                     +
                           )

 EndPgm:
     EndPgm



File  : QCMDSRC
Member: CHKMQM
Type  : CMD
Usage : CrtCmd      Cmd( CHKMQM  )	
                    Pgm( CHKMQM   )
                    SrcFile( QCMDSRC )	
                    Allow( *IPGM *BPGM )					

       


/*-------------------------------------------------------------------*/
/*                                                                   */
/*  Compile options:                                                 */
/*                                                                   */
/*    CrtCmd Cmd( CHKMQM )                                           */
/*           Pgm( CHKMQM )                                           */
/*           SrcMbr( CHKMQM )                                        */
/*           Allow( *IPGM *BPGM )                                    */
/*                                                                   */
/*-------------------------------------------------------------------*/
          Cmd      Prompt( 'Check MQ Queue Manager')

          Parm     Kwd(MQMNAME) Type(*CHAR) Len(48) Min(1) +
                   Prompt('Message Queue Manager name')

          Parm     Kwd(RC) Type(*CHAR) Len(10)  +
                   RtnVal(*Yes)                 +
                   Prompt('Return code')


						
File  : QCLSRC
Member: CHKMQMTSTC
Type  : CLP 
Usage : CRTCLPGM CHKMQMTSTC

PGM
     DCL &MQMNAME        *CHAR     48
     DCL &RC             *CHAR     10


/*-- Global error monitoring:  --------------------------------------*/
     MonMsg     CPF0000      *N        GoTo Error

     CHGVAR     &MQMNAME              'TEST'
     CHKMQM     MQMNAME(&MQMNAME) RC(&RC)
     If        (&RC *NE ' ') Do
               DmpClPgm
       /* MQM got Exception */
       /* do exception process */
     EndDo

     CHGVAR     &MQMNAME              'TEST1'
     CHKMQM     MQMNAME(&MQMNAME) RC(&RC)
     If        (&RC *NE ' ') Do
               DmpClPgm
       /* MQM got Exception */
       /* do exception process */
     EndDo

 Return:
     RCLACTGRP  ACTGRP(*ELIGIBLE)
     Return

/*-- Error handling:  -----------------------------------------------*/
 Error:
     RCLACTGRP  ACTGRP(*ELIGIBLE)

     Call      QMHMOVPM    ( '    '                                  +
                             '*DIAG'                                 +
                             x'00000001'                             +
                             '*PGMBDY'                               +
                             x'00000001'                             +
                             x'0000000800000000'                     +
                           )

     Call      QMHRSNEM    ( '    '                                  +
                             x'0000000800000000'                     +
                           )

 EndPgm:
     EndPgm



2016-12-26 Log message to IFS file with command LOGTOIFS


Log message to IFS file with command LOGTOIFS



File  : QRPGLESRC
Member: LOGTOIFS
Type  : RPGLE
Usage : CRTBNDRPG PGM(LOGTOIFS) SRCFILE(LIBxx/QRPGLESRC) SRCMBR(LOGTOIFS)		
        




      **===============================================================
      **  Command....... LogToIfs                                     =
      **  CPP........... LogToIfs RPGLE                               =
      **  Description... Log Message to IFS File                      =
      **===============================================================
      **  Date  : 2016/12/26                                          =
      **  Author: Vengoal Chang                                       =
      **===============================================================
      **                                                              =
      **  To compile:                                                 =
      **     CRTBNDRPG LOGTOIFS SRCFILE(lib/QRPGLESRC) DBGVIEW(*LIST) =
      **                                                              =
      **===============================================================

     H DftActGrp(*NO)
     H Debug  Option(*SrcStmt:*NoDebugIo)

      * PGM SDS
     D                SDS
     D psdsPgmName       *Proc
     D psdsPgmLib             81     90                                         * Program library
     D JobNam                244    253
     D JobUsr                254    263
     D JobNbr                264    269
     D CurUsr                358    367

      ** API call to open a stream file
      **
     D open            PR            10I 0 ExtProc('open')
     D  path                           *   value options(*string)
     D  openflags                    10I 0 value
     D  mode                         10U 0 value options(*nopass)
     D  ccsid                        10U 0 value options(*nopass)
     D  txtcreatid                   10U 0 value options(*nopass)

     D**********************************************************************
     D*  Flags for use in open()
     D*
     D* More than one can be used -- add them together.
     D**********************************************************************
     D*                                            Writing Only
     D O_WRONLY        C                   2
     D*                                            Create File if not exist
     D O_CREAT         C                   8
     D*                                            Truncate File to 0 bytes
     D O_TRUNC         C                   64
      *                                            Append to file
     D O_APPEND        C                   256
     D*                                            Convert text by code-page
     D O_CODEPAGE      C                   8388608
     D*                                            Convert text by ccsid
     D O_CCSID         C                        32
     D*                                            Open in text-mode
     D O_TEXTDATA      C                   16777216
      * Note: O_TEXT_CREAT requires all of the following flags to work:
      *           O_CREAT+O_TEXTDATA+(O_CODEPAGE or O_CCSID)
     D O_TEXT_CREAT    C                   33554432
     D*                                         owner authority
     D**********************************************************************
     D*      Mode Flags.
     D*         basically, the mode parm of open(), creat(), chmod(),etc
     D*         uses 9 least significant bits to determine the
     D*         file's mode. (peoples access rights to the file)
     D*
     D*           user:       owner    group    other
     D*           access:     R W X    R W X    R W X
     D*           bit:        8 7 6    5 4 3    2 1 0
     D*
     D* (This is accomplished by adding the flags below to get the mode)
     D**********************************************************************
     D S_IRUSR         C                   256
     D S_IWUSR         C                   128
     D S_IXUSR         C                   64
     D S_IRWXU         C                   448
     D*                                         group authority
     D S_IRGRP         C                   32
     D S_IWGRP         C                   16
     D S_IXGRP         C                   8
     D S_IRWXG         C                   56
     D*                                         other people
     D S_IROTH         C                   4
     D S_IWOTH         C                   2
     D S_IXOTH         C                   1
     D S_IRWXO         C                   7


      ** API call to write data to a stream file
      **
     D write           PR            10I 0 extproc('write')
     D   fildes                      10I 0 value
     D   buf                           *   value
     D   nbyte                       10U 0 value

      ** API call to close a stream file
      **
     D close           PR            10I 0 extproc('close')
     D   fildes                      10I 0 value

     D @__ERRNO        PR              *   EXTPROC('__errno')

     D STRERROR        PR              *   EXTPROC('strerror')
     D    ERRNUM                     10I 0 VALUE

     D ERRNO           PR            10I 0

     D DIE             PR
     D   PEMSG                      256A   CONST

     D GetCaller       PR
     D  CallingPgmNam                10
     D  CallingPgmLib                10

     D fd              S             10I 0
     D data            S           4096A
     D IfsPath         S            256A
     D Curtime         S               Z

     D PgmNam          S             10
     D PgmLib          S             10
     D Proc            S             32

      * Program parameters - title and page length in lines
     D paIfsFile       S             64
     D paPath          S            256
     D paMessage       S           2048
     D paIncludeJob    S              4

      * Program parameters

     C     *Entry        Plist
     C                   Parm                    paIfsFile
     C                   Parm                    paPath
     C                   Parm                    paMessage
     C                   Parm                    paIncludeJob

     c                   eval      *inlr = *on

     C                   eval      IfsPath = %trim(paPath) + '/' +
     C                                        %trim(paIfsFile)

     C* Create an empty file
     c                   eval      fd = open(%trim(IfsPath)
     c                                  : O_CREAT + O_APPEND +  O_WRONLY
     c                                            + O_CCSID + O_TEXT_CREAT
     c                                            + O_TEXTDATA
     c                                  : S_IWUSR+S_IRUSR+S_IRGRP+S_IROTH
     c                                  : 0
     c                                  : 0 )

     c                   if        fd < 0
     c                   callp     die('open(): ' + %Char(ERRNO) + ' ' +
     c                                 %trim(IfsPath) + ' ' +
     c                                              %STR(STRERROR(ERRNO)))
     c                   return
     c                   endif

     C                   Time                    Curtime
     C                   If        paIncludeJob = '*YES'
     C                   callp     GetCaller (  PgmNam
     C                                        : PgmLib
     C                                       )
     C                   eval      data = %SubSt(%Char(Curtime):1:23)+ ' ' +
     C                                    JobNam + ' ' +
     C                                    JobUsr + ' ' +
     C                                    JobNbr + ' ' +
     C                                    PgmLib + ' ' +
     C                                    PgmNam + ' ' +
     C                                    %trimR(paMessage) + x'0D25'
     C                   Else
     C                   eval      data = %SubSt(%Char(Curtime):1:23)+ ' ' +
     C                                    %trimR(paMessage) + x'0D25'
     C                   EndIf
     C
     c                   callp     write(fd: %addr(data): %len(%trim(data)))

     C* Close the file:
     c                   callp     close(fd)

      **********************************************************************
      *  Get Caller with Retrieve Call Stack API
      **********************************************************************

     P GetCaller       B

     D GetCaller       PI
     D  CallingPgmNam                10
     D  CallingPgmLib                10

     D RtvCallStack    PR                  Extpgm('QWVRCSTK')
     D                             2000
     D                               10I 0
     D                                8    CONST
     D                               56
     D                                8    CONST
     D                               15

     D Var             DS          2000
     D  BytAvl                       10I 0
     D  BytRtn                       10I 0
     D  Entries                      10I 0
     D  Offset                       10I 0
     D  EntryCount                   10I 0
     D VarLen          S             10I 0 Inz(%size(Var))
     D ApiErr          S             15

     D JobIdInf        DS
     D  JIDQName                     26    Inz('*')
     D  JIDIntID                     16
     D  JIDRes3                       2    Inz(*loval)
     D  JIDThreadInd                 10I 0 Inz(1)
     D  JIDThread                     8    Inz(*loval)

     D Entry           DS           256
     D  EntryLen                     10I 0
     D  PgmNam                       10    Overlay(Entry:25)
     D  PgmLib                       10    Overlay(Entry:35)

     c                   eval      CallingPgmNam = *blanks
     c                   eval      CallingPgmLib = *blanks
     c                   callp     RtvCallStack (  Var
     c                                           : VarLen
     c                                           : 'CSTK0100'
     c                                           : JobIdInf
     c                                           : 'JIDF0100'
     c                                           : ApiErr
     c                                          )
     C                   Do        EntryCount
     C                   Eval      Entry = %subst(Var:Offset + 1)
     c                   if        CallingPgmNam = *blanks and
     c                             CallingPgmLib = *blanks
     c                   if        PgmNam = psdsPgmName and
     c                             PgmLib = psdsPgmLib
     C                   Else
     c                   eval      CallingPgmNam = Pgmnam
     c                   eval      CallingPgmLib = Pgmlib
     C                   Endif
     C                   Endif
     C                   Eval      Offset = Offset + EntryLen
     C                   Enddo
     C
     C                   Return
     P GetCaller       E

      **********************************************************************
      *  This ends this program abnormally, and sends back an escape.
      *   message explaining the failure.
      **********************************************************************

     P DIE             B

     D DIE             PI
     D   PeMsg                      256A   CONST

     D SndPgmMsg       PR                  ExtPgm('QMHSNDPM')
     D   MessageId                    7A   Const
     D   QualMsgF                    20A   Const
     D   MsgData                    256A   Const
     D   MsgDtaLen                   10I 0 Const
     D   MsgType                     10A   Const
     D   CallStkEnt                  10A   Const
     D   CallStkCct                  10I 0 Const
     D   MessageKey                   4A
     D   ErrorCode                32766A   Options(*VarSize)

     D Dsec            DS
     D  DsecBytesP             1      4I 0 Inz(256)
     D  DsecBytesA             5      8I 0 Inz(0)
     D  DsecMsgId              9     15
     D  DsecReserv            16     16
     D  DsecMsgDta            17    256

     D WWMsgLen        S             10I 0
     D WWTheKey        S              4A

     C                   EVAL      WWMsgLen = %Len(%TrimR(PeMsg))
     C                   IF        WWMsgLen<1
     C                   RETURN
     C                   ENDIF

     C                   Callp     SndPgmMsg('CPF9897': 'QCPFMSG   *LIBL':
     C                               PeMsg: WWMsgLen: '*ESCAPE':
     C                               '*PGMBDY': 1: WWTheKey: Dsec)

     C                   RETURN

     P DIE             E

      **********************************************************************
      *  This procedure return call socket C API errno
      **********************************************************************

     P ErrNo           B

     D ErrNo           PI            10I 0
     D P_EeeNo         S               *
     D WWReturn        S             10I 0 Based(P_Errno)
     C                   EVAL      P_Errno = @__Errno
     C                   RETURN    WWReturn

     P Errno           E




File  : QCMDSRC
Member: LOGTOIFS
Type  : CMD
Usage : CrtCmd      Cmd( LogToIfs  )	
                    Pgm( LogToIfs   )
                    SrcFile( QCMDSRC )					

       


/*  ===============================================================  */
/*  = Command....... LogToIfs                                     =  */
/*  = CPP........... LogToIfs RPGLE                               =  */
/*  = Description... Log Message to IFS File                      =  */
/*  =                                                             =  */
/*  = CrtCmd      Cmd( LogToIfs  )                                =  */
/*  =             Pgm( LogToIfs   )                               =  */
/*  =             SrcFile( QCMDSRC )                              =  */
/*  ===============================================================  */
/*  = Date  : 2016/12/26                                          =  */
/*  = Author: Vengoal Chang                                       =  */
/*  ===============================================================  */

             Cmd        Prompt('Log Message To IFS File')

             Parm       Kwd(ToStmf)                  +
                        Type(*Name) Len(64) Min(1)   +
                        Prompt('To stream file name')

             Parm       Kwd(ToDir)                   +
                        Type(*Pname) LEN(256) MIN(1) +
                        Prompt('To directory')

             Parm       Kwd(LogMsg)                  +
                        Type(*Char) Len(2048) Min(1) +
                        Prompt('Log message')

             Parm       Kwd(InCldJob)                +
                        Type(*Char) Len(4)           +
                        Rstd(*Yes)                   +
                        Dft(*No )                    +
                        Values(*YES *NO)             +
                        Prompt('Log include job info')

						
Usage example:

                       Log Message To IFS File (LOGTOIFS)                       
                                                                                
 Type choices, press Enter.                                                     
                                                                                
 To stream file name  . . . . . .                                               
                                                                                
 To directory . . . . . . . . . .                                               
                                                                                
 Log message  . . . . . . . . . .                                               
                                                                                
                                                                                
                                                                                
                                                                                
                                                                                
                                                                     ...        
 Log include job info . . . . . .   *NO           *YES, *NO                     
                                                                                

LOGTOIFS TOSTMF(AP1LOG.TXT) TODIR('/tmp') LOGMSG('test 2') INCLDJOB(*YES)
LOGTOIFS TOSTMF(AP1LOG.TXT) TODIR('/tmp') LOGMSG('test 3') INCLDJOB(*YES)
LOGTOIFS TOSTMF(AP1LOG.TXT) TODIR('/tmp') LOGMSG('test 3')
LOGTOIFS TOSTMF(AP1LOG.TXT) TODIR('/tmp') LOGMSG('test 4')

DSPF STMF('/tmp/AP1LOG.TXT')

 Browse : /tmp/AP1LOG.TXT                                                      
 Record :       1   of       4 by  14            Column :    1     59 by  79   
 Control :                                                                     
                                                                               
....+....1....+....2....+....3....+....4....+....5....+....6....+....7....+....
 ************Beginning of data**************                                   
2016-12-26-15.25.45.104 QPADEV0047 USRTEST    317148 QSYS       QUOCMD     test 2                    
2016-12-26-15.25.50.561 QPADEV0047 USRTEST    317148 QSYS       QUOCMD     test 3                    
2016-12-26-15.25.57.791 test 3                                                 
2016-12-26-15.26.02.863 test 4                                                 
 ************End of Data********************