RpgleDBG212R4 < DBG400

<verbatim>

      **********************************************************************************************
      * 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
      **********************************************************************************************
</verbatim>
This topic: DBG400 > SourceCodeList > RpgleSource > RpgleDBG212R4
Topic revision: r1 - 26 Jan 2011 - 16:05:07 - 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