**********************************************************************************************
* 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
Copyright © 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