**********************************************************************************************
* DBG212R4: Process Object Locks
* Copyright (C) 2007 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
**********************************************************************************************
H DATEDIT(*YMD) DEBUG(*YES) OPTION(*NODEBUGIO : *SRCSTMT)
H DFTACTGRP(*NO)
**********************************************************************************************
* FILES:
**********************************************************************************************
**********************************************************************************************
* PROTOTYPES:
**********************************************************************************************
**********************************************************************************************
* RunCmd: Run a system command
**********************************************************************************************
D RunCmd PR 1N
D Command 999 Options(*VARSIZE) Const
**********************************************************************************************
* DATA STRUCTURES:
**********************************************************************************************
* Program Name
D SDS
D SDS_PGM 10
* ==List API structures==
* Standard error code DS for API error handling
D Error_Code DS
D BytesProvd 1 4B 0 Inz(0)
D BytesAvail 5 8B 0 Inz(0)
D Except_ID 9 15
D Reserved 16 16
D Exception 17 272
* Receiver value DS for user space header info (used in first call to QUSRTVUS)
D GenRcvrDS DS
D UserArea 1 64
D GenHdrSize 65 68B 0
D StrucLevel 69 72
D FormatName 73 80
D APIused 81 90
D CreateStamp 91 103
D InfoStatus 104 104
D SizeUSused 105 108B 0
D InpParmOff 109 112B 0
D InpParmSiz 113 116B 0
D HeadOffset 117 120B 0
D HeaderSize 121 124B 0
D ListOffset 125 128B 0
D ListSize 129 132B 0
D ListNumber 133 136B 0
D EntrySize 137 140B 0
* QWCLOBJL format OBJL0100 structure
D ObjL0100DS DS
D ObjL0100
D L_JobName 10A Overlay( ObjL0100 : 1 )
D L_JobUser 10A Overlay( ObjL0100 : 11 )
D L_JobNumber 6A Overlay( ObjL0100 : 21 )
D L_LockState 10A Overlay( ObjL0100 : 27 )
D L_LockStatus 10I 0 Overlay( ObjL0100 : 37 )
D L_LockType 10I 0 Overlay( ObjL0100 : 41 )
D L_MemberName 10A Overlay( ObjL0100 : 45 )
D L_Share 1A Overlay( ObjL0100 : 55 )
D L_LockScope 1A Overlay( ObjL0100 : 56 )
D L_ThreadID 8A Overlay( ObjL0100 : 57 )
**********************************************************************************************
* WORK FIELDS:
**********************************************************************************************
D CurrentEnt S 5P 0 Inz(1)
D DataLength S 9B 0 Inz(140)
D ExtendAttr S 10 Inz('USRSPC ')
D InitialSiz S 9B 0 Inz(1024)
D InitialVal S 1 Inz(X'00')
D ListFormat S 8
D P_Option S 7
D P_QualObj S 20
D P_Type S 7
D P_Member S 10
D P_Locks S 10 0
D P_Errors S 10 0
D MemberName S 10
D ObjectType S 10
D PublicAut S 10 Inz('*ALL ')
D QualifyObj S 20
D ReplaceSpc S 10 Inz('*YES ')
D StartPos S 10I 0 Inz(1)
D TextDescrp S 50 Inz('QWCLOBJL List API')
D UserSpace S 20 Inz('DBG212US QTEMP ')
**********************************************************************************************
* CONSTANTS:
**********************************************************************************************
**********************************************************************************************
* ENTRY PARAMETERS:
**********************************************************************************************
C *ENTRY PList
C Parm P_QualObj
C Parm P_Type
C Parm P_Member
C Parm P_Option
C Parm P_Locks
C Parm P_Errors
**********************************************************************************************
* KEY LISTS:
**********************************************************************************************
**********************************************************************************************
* MAINLINE:
**********************************************************************************************
C ExSr Inits
* Process returned entries
B001 C If ListNumber > 0
* Set the initial offset for the start of the list entries
C Eval ListOffset = ListOffset + 1
* Loop through the entries held in the list section of the user space
B002 C DoW CurrentEnt <= ListNumber
* Get next entry for this space
C Call 'QUSRTVUS'
C Parm UserSpace
C Parm ListOffset
C Parm EntrySize
C Parm ObjL0100DS
C Parm Error_Code
* Process the object lock as required
B003 C If RunCmd('ENDJOB JOB(' + L_JobNumber +
C '/' + %trim(L_JobUser) + '/' +
C %trim(l_jobname) + ') OPTION(' + P_Option +
C ')')
C Eval P_Errors = P_Errors + 1
E003 C EndIf
* Bump up the counter & offset for the next entry
C Eval ListOffset = ListOffset + EntrySize
C Eval CurrentEnt = CurrentEnt + 1
E002 C EndDo
E001 C EndIf
* Inform caller of how many locks are present
C Eval P_Locks = ListNumber
* EXIT PROGRAM
C Eval *INLR = *On
C Return
**********************************************************************************************
* Inits: Program initialisation
**********************************************************************************************
C Inits BegSr
* Use the QWCLOBJL (List Object Locks) API to get the lock info on the qualified object parm
C Eval QualifyObj = P_QualObj
* Create a user space to hold the format list entries
C Call 'QUSCRTUS'
C Parm UserSpace
C Parm ExtendAttr
C Parm InitialSiz
C Parm InitialVal
C Parm PublicAut
C Parm TextDescrp
C Parm ReplaceSpc
C Parm Error_Code
* List the object locks
C Call 'QWCLOBJL'
C Parm UserSpace
C Parm 'OBJL0100' ListFormat
C Parm QualifyObj
C Parm P_Type ObjectType
C Parm P_Member MemberName
C Parm Error_Code
* Get the header info for this space
C Call 'QUSRTVUS'
C Parm UserSpace
C Parm StartPos
C Parm DataLength
C Parm GenRcvrDS
C Parm Error_Code
*
C EndSr
**********************************************************************************************
* PROCEDURES:
**********************************************************************************************
**********************************************************************************************
* RunCmd: Run a command via QCMDEXC & return the error flag
**********************************************************************************************
P RunCmd B
D RunCmd PI 1N
D Command 999 Options(*VARSIZE) Const
D RunCmdError S 1N
D P_CmdString S 999
D P_CmdLength S 15 5
C Eval P_CmdLength = %Len(%TrimR(Command))
C Call (E) 'QCMDEXC'
C Parm Command P_CmdString
C Parm P_CmdLength
C Eval RunCmdError = %ERROR
C Return RunCmdError
P E
**********************************************************************************************
This topic: DBG400 > SourceCodeList > RpgleSource > RpgleDBG212R4
Topic revision: r2 - 01 Oct 2014 - 19:37:01 - UnknownUser
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