**********************************************************************************************
      * DBG188R4: Retrieve spoolfile info by User Profile or #OUTQ
      * Copyright (C) 2000  Martin Rowe   <martin@dbg400.net>
      *
      * This program is free software; you can redistribute it and/or modify
      * it under the terms of the GNU General Public License as published by
      * the Free Software Foundation; either version 2 of the License, or
      * (at your option) any later version.
      *
      * This program is distributed in the hope that it will be useful,
      * but WITHOUT ANY WARRANTY; without even the implied warranty of
      * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      * GNU General Public License for more details.
      *
      * You should have received a copy of the GNU General Public License
      * along with this program; if not, write to the Free Software
      * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
      *
      * Note: Some of the API usage was derived from examples in the IBM API reference. I don't
      * think I've infringed any copyrights but if you know different let me know.
      **********************************************************************************************
     H DATEDIT(*YMD) DEBUG(*YES) OPTION(*NODEBUGIO : *SRCSTMT)
      **********************************************************************************************
      *  APIs Used:    QUSLSPL  - List Spooled Files
      *                QUSCRTUS - Create User Space
      *                QUSPTRUS - Retrieve Pointer to User Space
      **********************************************************************************************
      * FILES:
      **********************************************************************************************
     FDBG1860W  O    E             DISK    USROPN
      **********************************************************************************************
      * ARRAYS:
      **********************************************************************************************
     D ARR             S              1    BASED(Lstptr) DIM(32767)
     D KEYS            S              9B 0 DIM(20)
      **********************************************************************************************
      * DATA STRUCTURES:
      **********************************************************************************************
      * Error Code parameter include
      * This code is the same as /COPY QSYSINC/QRPGLESRC,QUSEC - but not everyone has it installed.
     DQUSEC            DS
     D QUSBPRV                 1      4B 0
     D QUSBAVL                 5      8B 0
     D QUSEI                   9     15
     D QUSERVED               16     16
      *
     D                 DS
     D SpoolNbr#                      9B 0
     D  SpoolNbrChr                   4    OVERLAY(SpoolNbr#)
      *
     D                 DS
     D Totpages#                      9B 0
     D  TotpagesChr                   4    OVERLAY(Totpages#)
      *
     D                 DS
     D Curpage#                       9B 0
     D  CurpageChr                    4    OVERLAY(Curpage#)
      *
     D                 DS
     D Copiesleft#                    9B 0
     D  CopiesleftChr                 4    OVERLAY(Copiesleft#)
      *
      *****************************************************************
      *
      * The following QUSGEN include from QSYSINC is copied into
      * this program so that it can be declared as BASED on SPCPTR
      *
      *****************************************************************
     DQUSH0100         DS                  BASED(Spcptr)
      *                                             Qus Generic Header 0100
     D Qusua                         64
      *                                             User Area
     D Qussgh                         9B 0
      *                                             Size Generic Header
     D Qussrl                         4
      *                                             Structure Release Level
     D Qusfn                          8
      *                                             Format Name
     D Qusau                         10
      *                                             API Used
     D Qusdtc                        13
      *                                             Date Time Created
     D Qusis                          1
      *                                             Information Status
     D Qussus                         9B 0
      *                                             Size User Space
     D Qusoip                         9B 0
      *                                             Offset Input Parameter
     D Qussip                         9B 0
      *                                             Size Input Parameter
     D Qusohs                         9B 0
      *                                             Offset Header Section
     D Qusshs                         9B 0
      *                                             Size Header Section
     D Qusold                         9B 0
      *                                             Offset List Data
     D Qussld                         9B 0
      *                                             Size List Data
     D Qusnbrle                       9B 0
      *                                             Number List Entries
     D Qussee                         9B 0
      *                                             Size Each Entry
     D Qussidle                       9B 0
      *                                             CCSID List Ent
     D Quscid                         2
      *                                             Country ID
     D Quslid                         3
      *                                             Language ID
     D Qussli                         1
      *                                             Subset List Indicator
     D Quserved00                    42
      * Type definition for the SPLF0200 format.
     DQUSSPLKI         DS           100    BASED(Lstptr2)
      *                                             Qus LSPL Key Info
     D Quslfir02                      9B 0
      *                                             Len Field Info Retd
     D Quskfffr00                     9B 0
      *                                             Key Field for Field Retd
     D Qustod02                       1
      *                                             Type of Data
     D Qusr300                        3
      *                                             Reserv3
     D Qusdl02                        9B 0
      *                                             Data Length
      *                             Varying length
     DQUSF0200         DS                  BASED(Lstptr)
      *                                             Qus SPLF0200
     D Qusnbrfr00                     9B 0
      *                                             Num Fields Retd
     D CLRPFM          DS
     D                               80    INZ('CLRPFM FILE(QTEMP/DBG1860W)')
      **********************************************************************************************
      * WORK FIELDS:
      **********************************************************************************************
     D CmdLength       S             15  5
     D CmdString       S            256
     D Ext_Attr        S             10
     D Format          S              8
     D FormType        S             10
     D Index           S              3  0
     D JobName         S             26
     D Key#            S              9B 0 INZ(20)
     D Lstptr          S               *
     D Lstptr2         S               *
     D OnePercent      S             11  2
     D Outqueue        S             20
     D P_Marker        S              1    INZ(X'33')
     D P_Percent       S              3  0
     D P_Text          S             20
     D P#MbrOpt        S              8
     D P#OutQ          S             20
     D P#User          S             10
     D RcdsRead        S              9  0
     D Remainder       S              9  0
     D Spc_Aut         S             10
     D Spc_Domain      S             10
     D Spc_Init        S              1    INZ(X'00')
     D Spc_Name        S             20    INZ('USERSPLF  QTEMP     ')
     D Spc_Replac      S             10
     D Spc_Size        S              9B 0 INZ(2000)
     D Spc_Text        S             50
     D Spcptr          S               *
     D SplDateChr      S              7
     D SplTimeChr      S              6
     D User            S             10
     D UserData        S             10
     D X               S              9  0
      **********************************************************************************************
      * ENTRY PARAMETERS:
      **********************************************************************************************
     C     *ENTRY        PLIST
     C                   PARM                    P#User
     C                   PARM                    P#OutQ
     C                   PARM                    P#MbrOpt
      **********************************************************************************************
      * MAINLINE:
      **********************************************************************************************
     C                   EXSR      #INITS
      * Set Error Code structure to use exceptions
     C                   EVAL      QUSBPRV = 0
      * Load the Keys array - might as well get the whole lot.
B001 C                   DO        20            Index
     C                   EVAL      KEYS(Index) = 200 + Index
E001 C                   ENDDO
      * Create a User Space for the List generated by QUSLSPL
     C                   CALL      'QUSCRTUS'
     C                   PARM                    Spc_Name
     C                   PARM      'quslspl   '  Ext_Attr
     C                   PARM                    Spc_Size
     C                   PARM                    Spc_Init
     C                   PARM      '*ALL'        Spc_Aut
     C                   PARM      'WRKUSROUTQ'  Spc_Text
     C                   PARM      '*YES'        Spc_Replac
     C                   PARM                    QUSEC
     C                   PARM      '*USER'       Spc_Domain
      * Call QUSLSPL to get all spooled files for input parms
     C                   CALL (E)  'QUSLSPL'
     C                   PARM                    Spc_Name
     C                   PARM      'SPLF0200'    Format
     C                   PARM      P#User        User
     C                   PARM      P#OutQ        Outqueue
     C                   PARM      '*ALL'        FormType
     C                   PARM      '*ALL'        UserData
     C                   PARM                    QUSEC
     C                   PARM                    JobName
     C                   PARM                    KEYS
     C                   PARM                    Key#
      *
B001 C                   IF        NOT %ERROR
      * Get a resolved pointer to the User Space for performance
     C                   CALL      'QUSPTRUS'
     C                   PARM                    Spc_Name
     C                   PARM                    Spcptr
     C                   PARM                    QUSEC
      * If valid information was returned
B002 C                   IF        Qussrl = '0100'
B003 C                   IF        Qusis = 'C'
     C                             OR Qusis = 'P'
      * and list entries were found
B004 C                   IF        Qusnbrle > 0
      * Account for low record numbers
     C                   EVAL      OnePercent = Qusnbrle / 100
B005 C                   IF        Qusnbrle < 10
     C                   EVAL      OnePercent = 0.1
     C                   EVAL      RcdsRead = 10 - Qusnbrle
E005 C                   ENDIF
      * Set progress meter message
B005 C                   IF        P#User = '*ALL'
     C                   EVAL      P_Text = 'Loading ' + %SUBST(P#OutQ : 1 : 10)
X005 C                   ELSE
     C                   EVAL      P_Text = 'Loading ' + P#User
E005 C                   ENDIF
      * set LSTPTR to the first byte of the User Space
     C                   EVAL      Lstptr = Spcptr
      * increment LSTPTR to the first List entry
     C                   EVAL      Lstptr = %ADDR(ARR(Qusold + 1))
      * and process all of the entries
B005 C                   DO        Qusnbrle
      * Keep track of how far through the user space we have got
     C                   EVAL      RcdsRead = RcdsRead + 1
     C     RcdsRead      DIV       OnePercent    P_Percent
     C                   MVR                     Remainder
      * If we've completed another one percent of the file, report it
B006 C                   IF        Remainder = 0
     C                   CALL      'DBG202R4'
     C                   PARM                    P_Percent
     C                   PARM                    P_Text
     C                   PARM                    P_Marker
E006 C                   ENDIF
      * set LSTPTR2 to the first variable length record for this entry
     C                   EVAL      X = 5
     C                   EVAL      Lstptr2 = %ADDR(ARR(X))
B006 C                   DO        Qusnbrfr00
      * process the data based on key type
B007 C                   SELECT
S007 C                   WHEN      Quskfffr00 = 201
     C                   EVAL      SPLNAME = %SUBST(QUSSPLKI:17:Qusdl02)
S007 C                   WHEN      Quskfffr00 = 202
     C                   EVAL      SPLJOBNAME = %SUBST(QUSSPLKI:17:Qusdl02)
S007 C                   WHEN      Quskfffr00 = 203
     C                   EVAL      SPLUSERPRF = %SUBST(QUSSPLKI:17:Qusdl02)
S007 C                   WHEN      Quskfffr00 = 204
     C                   EVAL      SPLJOBNBR = %SUBST(QUSSPLKI:17:Qusdl02)
S007 C                   WHEN      Quskfffr00 = 205
     C                   EVAL      SpoolNbrChr = %SUBST(QUSSPLKI:17:Qusdl02)
     C                   EVAL      SPLNBR = SpoolNbr#
S007 C                   WHEN      Quskfffr00 = 206
     C                   EVAL      SPLOUTQ = %SUBST(QUSSPLKI:17:Qusdl02)
S007 C                   WHEN      Quskfffr00 = 207
     C                   EVAL      SPLOUTQLIB = %SUBST(QUSSPLKI:17:Qusdl02)
S007 C                   WHEN      Quskfffr00 = 208
     C                   EVAL      SPLDEVICE = %SUBST(QUSSPLKI:17:Qusdl02)
S007 C                   WHEN      Quskfffr00 = 209
     C                   EVAL      SPLUSRDTA = %SUBST(QUSSPLKI:17:Qusdl02)
S007 C                   WHEN      Quskfffr00 = 210
     C                   EVAL      SPLSTATUS = %SUBST(QUSSPLKI:17:Qusdl02)
S007 C                   WHEN      Quskfffr00 = 211
     C                   EVAL      TotpagesChr = %SUBST(QUSSPLKI:17:Qusdl02)
     C                   EVAL      SPLTOTPAGE = Totpages#
S007 C                   WHEN      Quskfffr00 = 212
     C                   EVAL      CurpageChr = %SUBST(QUSSPLKI:17:Qusdl02)
     C                   EVAL      SPLCURPAGE = Curpage#
S007 C                   WHEN      Quskfffr00 = 213
     C                   EVAL      CopiesleftChr = %SUBST(QUSSPLKI:17:Qusdl02)
     C                   EVAL      SPLCPYLEFT = Copiesleft#
S007 C                   WHEN      Quskfffr00 = 214
     C                   EVAL      SPLFORMTYP = %SUBST(QUSSPLKI:17:Qusdl02)
S007 C                   WHEN      Quskfffr00 = 215
     C                   EVAL      SPLPRIORTY = %SUBST(QUSSPLKI:17:Qusdl02)
S007 C                   WHEN      Quskfffr00 = 216
     C                   EVAL      SplDateChr = %SUBST(QUSSPLKI:17:Qusdl02)
     C                   MOVE      SplDateChr    SPLDATE
S007 C                   WHEN      Quskfffr00 = 217
     C                   EVAL      SplTimeChr = %SUBST(QUSSPLKI:17:Qusdl02)
     C                   MOVE      SplTimeChr    SPLTIME
S007 C                   WHEN      Quskfffr00 = 218
     C                   EVAL      SPLINJOBID = %SUBST(QUSSPLKI:17:Qusdl02)
S007 C                   WHEN      Quskfffr00 = 219
     C                   EVAL      SPLINSPLID = %SUBST(QUSSPLKI:17:Qusdl02)
S007 C                   WHEN      Quskfffr00 = 220
     C                   EVAL      SPLDEVTYPE = %SUBST(QUSSPLKI:17:Qusdl02)
B008 C                   IF        SPLDEVTYPE = 'PRINTER'
     C                   EVAL      SPLDEVICE = SPLOUTQ
E008 C                   ENDIF
S007 C                   OTHER
     C                   EXSR      ERROR
E007 C                   ENDSL
      * increment LSTPTR2 to next variable length record
     C                   EVAL      X = X + Quslfir02
     C                   EVAL      Lstptr2 = %ADDR(ARR(X))
E006 C                   ENDDO
     C                   WRITE     DBG186W
      * after each entry, increment LSTPTR to the next entry
     C                   EVAL      Lstptr = %ADDR(ARR(Qussee + 1))
E005 C                   ENDDO
E004 C                   ENDIF
E003 C                   ENDIF
E002 C                   ENDIF
E001 C                   ENDIF
      * Exit the program
     C                   EVAL      *INLR = *ON
     C                   RETURN
      **********************************************************************************************
      * #INITS:
      **********************************************************************************************
     C     #INITS        BEGSR
      *
B001 C                   IF        P#MbrOpt = '*REPLACE'
     C                   CALL      'QCMDEXC'                            90
     C                   PARM      CLRPFM        CmdString
     C                   PARM      80            CmdLength
E001 C                   ENDIF
     C                   OPEN      DBG1860W
      *
     C                   ENDSR
      **********************************************************************************************
      **********************************************************************************************
      * SUBRTN:
      **********************************************************************************************
     C     ERROR         BEGSR
      *
     C     Quskfffr00    DSPLY
     C                   EVAL      *INLR = *ON
     C                   RETURN
      *
     C                   ENDSR
      **********************************************************************************************


This topic: DBG400 > SourceCodeList > RpgleSource > RpgleDBG188R4
Topic revision: r1 - 26 May 2005 - 19:41:28 - MartinRowe
 
This site is powered by FoswikiCopyright © by the contributing authors. All material on this collaboration platform is the property of the contributing authors.
Ideas, requests, problems regarding DBG/400? Send feedback