 | |||
|
|
||
| |||
| |||
| |
|
Home > AS/400 News > Allow users to see why they are locked -- Code |
| |
|
|
|
|
| AS/400 News: |
|
||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|
|||||||||||||||||||||||||
*--------------------------------------------------------------(BEGIN)----P_S_DSPLOC
*------------------------------------------------------------------------*
* Prototype For Procedure Dsp_Lock : display detailled Locking Info *
*------------------------------------------------------------------------*
D Dsp_lock PR 1 Return Result
* 0 - OK
* 1 - Locking Not Found
* 9 - Process Failure
d 10 CONST File name (I)
d 10i 0 CONST RRN Number (I)
d 58 CONST Message (I)
*------------------------------------------------------------------------*
* Used Variables *
*------------------------------------------------------------------------*
* IOFBDS
d feebk_Lock ds
d rrn_lock 397 400b 0
*Parms
d File_lck s 10
d Rrn_lck s 10i 0
d Msg_lck s 58 INZ('RECORD IS ALREADY LOCKED BY')
* Return Value
d Ret_Dsp_Lock s 1 Returned Value
*--------------------------------------------------------------(END)------P_S_DSPLOC
*--------------------------------------------------------------(BEGIN)----DSPLOCFM
A*%%TS SD 19931026 105559 TS_EDP_93 REL-V2R2M0 5738-PW1
A*%%EC
A DSPSIZ(24 80 *DS3)
A CHGINPDFT
A MSGLOC(24)
A PRINT
A INDARA
A CA03(03 'DETAIL')
A R DSPLOC01
A*%%TS SD 19931026 105559 TS_EDP_93 REL-V2R2M0 5738-PW1
A ASSUME
A OVERLAY
A PROTECT
A PUTOVR
A OVRDTA
A 5 12'._________________________________-
A ___________________________.'
A COLOR(BLU)
A 6 12']'
A COLOR(BLU)
A 6 73']'
A COLOR(BLU)
A 18 12']'
A COLOR(BLU)
A 18 73']'
A COLOR(BLU)
A 19 12']__Enter__________________________-
A ___________F3/Detail_______]'
A COLOR(BLU)
A 18 14' -
A '
A 7 12']'
A COLOR(BLU)
A 9 12']'
A COLOR(BLU)
A 6 14'DSPLOC'
A DSPATR(HI)
A 6 55DATE
A EDTCDE(Y)
A 6 64TIME
A 7 73']'
A COLOR(BLU)
A 9 73']'
A COLOR(BLU)
A E1MSG 58 O 9 14DSPATR(RI)
A 8 12'+----------------------------------
A ---------------------------+'
A COLOR(BLU)
A 10 12'+----------------------------------
A ---------------------------+'
A COLOR(BLU)
A 6 21' '
A 11 12']'
A COLOR(BLU)
A 12 12']'
A COLOR(BLU)
A 13 12']'
A COLOR(BLU)
A 14 12']'
A COLOR(BLU)
A 11 73']'
A COLOR(BLU)
A 11 14'JOB.....:'
A DSPATR(HI)
A 12 14'USER....:'
A DSPATR(HI)
A 15 12']'
A COLOR(BLU)
A 16 12']'
A COLOR(BLU)
A 13 14'Number..:'
A N20 DSPATR(ND)
A 14 14'Status..:'
A N20 DSPATR(ND)
A 15 14'Lock....:'
A N20 DSPATR(ND)
A 17 12']'
A COLOR(BLU)
A 17 14'RRN.....:'
A N20 DSPATR(ND)
A 12 73']'
A COLOR(BLU)
A 13 73']'
A COLOR(BLU)
A 14 73']'
A COLOR(BLU)
A 15 73']'
A COLOR(BLU)
A 16 73']'
A COLOR(BLU)
A 17 73']'
A COLOR(BLU)
A E1JOB 10A O 11 24DSPATR(HI)
A E1USER 10A O 12 24DSPATR(HI)
A E1NUMB 9A O 13 24
A N20 DSPATR(ND)
A E1STAT 10A O 14 24
A N20 DSPATR(ND)
A E1LOCK 10A O 15 24
A N20 DSPATR(ND)
A E1RRN 11A O 17 24
A N20 DSPATR(ND)
A 16 14'File....:'
A N20 DSPATR(ND)
A E1FILE 10A O 16 24
A N20 DSPATR(ND)
A E1LJOB 37A O 11 35
A E1LUSE 37A O 12 35
A 13 34' -
A '
A 14 35' -
A '
A 15 35' -
A '
A 16 35' -
A '
A 17 36' -
A '
A 7 14' * JOB RECORD LOCK INF-
A ORMATION * '
A DSPATR(HI)
*--------------------------------------------------------------(END)------DSPLOCFM
*--------------------------------------------------------------(BEGIN)----S_DSPLOC
hnomain
*****************************************************************
* SRVPGM : yes *
* Module : yes *
* Module : ASRGEN/S_DSPLOC (RPGLE) *
* *
* LOCKING MANAGEMENT SERVICE PROGRAM *
* *
* *
* Use SRVPGM : None *
* Binding Directory : None *
* *
*****************************************************************
* V 04/2002 : Accept Logical Filename as Input parm *
*****************************************************************
FS_DSPLOCFMCF E WORKSTN USROPN /Screen, manualy open
D/COPY P_S_DSPLOC Proto fo S_DSPLOC
d*--------------------------------------
d* Global variables
d*--------------------------------------
d rrn11x ds
d rrn11 11s 0
D errcod ds
D bytpro 10i 0 INZ(256) Bytes provided for Error
D bytava 10i 0 Bytes available (0=no error)
D msgid 7 Exception id
D rsrv1 1 Reserved
D msgdta 240 Exception data
* User spaces created in qtemp
D usrspc DS
D usr1 10 INZ('S_DSPLOC ')
D usr2 10 INZ('QTEMP ')
D format s 8
D p_Usrspc s *
D spc_attr s 10
D spc_size s 10i 0
D spc_init s 1 inz(x'00')
D spc_aut s 10 inz('*ALL')
D spc_text s 50 inz('Used by S_DSPLOC')
D spc_replace s 10 inz('*YES')
D Filename DS Qualified File Name
D File_ 10 File name (from parm)
D Library_ 10 INZ('*LIBL ') Library Name
D Member_ s 10 INZ('*FIRST ') Member Name
d dsin_size s 10i 0 Length receiver
d DEVD0100_Size s 10i 0 Length receiver
d USRI0300_Size s 10i 0 Length receiver
d MBRD0300_Size s 10i 0 Length receiver
d RRCD0100 ds based(p_Dsin) Receiver for QDBRRCDL
D AVAJOB 10i 0 Jobs Available
D RETJOB 10i 0 Jobs Returned
D OFFJOB 10i 0 Offset to Job Information
D SIZJOB 10i 0 Size of Info for each job
d DEVD0100 ds Receiver for QDCRDEVD
d RETBYT_D 10i 0 Returned Bytes
d AVABYT_D 10i 0 Available Bytes
d DATRTV_D 7 Retrieve Date
d TIMRTV_D 6 Retrieve Time
d Dev_Name 10 Device Name
d Dev_Category 10 Device category
d Dev_Onl_Ipl 10 Device OnLine At Ipl
d Dev_Descr 50 Device Description
d Dev_Rsrv 3 Reserved
d USRI0300 ds Receiver For QSYRUSRI
d RETBYT_U 10i 0 Returned Bytes
d AVABYT_U 10i 0 Available Bytes
d Usprf 10 User Profile Name
d Usr_Descr 199 248 User Description
d MBRD0300 ds based(p_Mbrd) Receiver For QUSRMBRD
d RETBYT_Mbr 10i 0 Returned Bytes
d AVABYT_Mbr 10i 0 Available Bytes
d Mbr_file_name 10 Database File name
d Mbr_libr_name 10 Database File Library Name
d Mbr_member 10 Member Name
d Mbr_lf_pf 137 137 Logical(1)/Physical(0) file
d Mbr_Nbr_bo_PF 157 160i 0 Nbr Based on PF members
d Mbr_bo_FLE ds 112 based(p_bofle) Based on File List 1St Entry
d Mbr_bo_pf 10 overlay(Mbr_bo_Fle) Based-on PF name
d Mbr_bo_lib 10 overlay(Mbr_bo_fle:*next) Based-on PF library name
d Mbr_bo_mbr 10 overlay(Mbr_bo_fle:*next) Based-on PF member name
D dsdata ds based(p_Data)
D pjob 10 Job Name
D pusr 10 Job User Name
D pnbr 6 Job Number
D plock_stat 1 Lock Status(0/Held 1/wait)
D plock_type 1 Lock Type (0/read 1/update)
D prrn 10i 0 RRn Locked
D HELD c const('0')
D update c const('1')
D Physical c const('0')
D Logical c const('1')
D Override s 1 inz('1')
D Find_mbr s 1 inz('0')
D rrn_ s 10i 0
***************************************************************************
** Dsp_lock : Display Detailled Locking Info *
***************************************************************************
p Dsp_lock B EXPORT
d Dsp_lock PI 1 Return Result
* 0 - Ok
* 1 - Locking Not Found
* 9 - Process Failure
d File_in 10 CONST Filename (PF or LF)
d Rrn_in 10i 0 CONST Rrn Locked
d msg_in 58 CONST Message for the user
d Return_code s 1 inz('1') No lock found
***********************************************************************************************
*
* Receive parms
*
c eval rrn_ = rrn_in
c eval file_ = file_in
c eval msg_user = Msg_in
*
* Retrieve File Type (PF,LF) and Based-On File 1st list entry
*
*
* Set receiver Length to 496 (MBRD0300 is MBRD0200 + 1st Based-on file list entry)
*
c eval MBRD0300_Size = 384 + 112 MBRD0200 + 1st BOFLE
c alloc MBRD0300_Size p_Mbrd
*
* Retrieve Member Description
*
c call (e) 'QUSRMBRD' Retrive Member Description
c parm MBRD0300 Receiver variable (I)
c parm MBRD0300_size Receiver size (I)
c parm 'MBRD0300' format Format Name (I)
c parm Filename Qualified Filename (I)
c parm '*FIRST' Member_ Member Name (I)
c parm Override Override Proces(1=yes) (I)
c parm ERRCOD Error code (I/O)
c parm Find_mbr Find Mbr Proces(0=Dft) (I)
c if bytava <> 0 or %error (B10) Error ....
c eval return_code = '9'
c goto exit
c endif (E10)
*
* If File Type is Physical, that's ok
* If File Type is Logical, Replace Filename by physical filename of 1st BOFLE
*
c if Mbr_lf_pf = logical (B10)
c eval p_bofle = p_mbrd + 384 Addr 1st Based-on Pf mbr
c eval file_ = Mbr_bo_pf Pf name
c eval Library_ = Mbr_bo_lib Pf Library Name
c eval member_ = Mbr_bo_mbr Pf member name
c endif (E10)
c
c dealloc p_mbrd
*
* Set receiver Length to 16 (Information Returned DS)
*
c eval dsin_size = %size(RRCD0100)
c alloc dsin_size p_Dsin
*
* Retrieve Bytes Required fo API QDBRRCDL (for this run)
*
c call (e) 'QDBRRCDL' Retrieve Record Locks
c parm RRCD0100
c parm Dsin_size
c parm 'RRCD0100' format
c parm Filename
c parm Member_
c parm rrn_
c parm ERRCOD
c if bytava <> 0 or %error (B10) Error ....
c eval return_code = '9'
c goto exit
c endif (E10)
*
* Compute Spaces required ((Available Job * Size 1 job) + offset to Job Info)
*
c eval dsin_size = (avajob * sizjob) + offjob
c eval Spc_size = Dsin_size + 124 124 bytes for USRSPC INFO
c dealloc p_Dsin
*
* Create User Space to get Results from QDBRRCDL
*
C CALL (e) 'QUSCRTUS' Create USer Space S_DSPLOC
c parm Usrspc
C parm spc_ATTR
C parm SPC_SIZE !!!!!
C parm SPC_INIT
C parm SPC_AUT
C parm SPC_TEXT
C parm SPC_REPLACE
C parm ERRCOD
c if bytava <> 0 or %error (B10) Error ....
c eval return_code = '9'
c goto exit
c endif (E10)
*
* Retrieve User Space Address (p_Usrspc)
*
C CALL (e) 'QUSPTRUS'
C parm usrspc
C parm p_Usrspc
C parm ERRCOD
c if bytava <> 0 or %error (B10) Error ....
c eval return_code = '9'
c goto exit
c endif (E10)
*
* Initialize Address of receiver variable for QDBRRCDL ( RRCD0100)
*
C eval p_Dsin = p_Usrspc
*
* Retrieve Record Locks
*
c call (e) 'QDBRRCDL' Retrieve Record Locks
c parm RRCD0100 Receiver variable (I)
c parm dsin_size Receiver Size (I)
c parm 'RRCD0100' format Format Name (I)
c parm Filename Qualified Filename (I)
c parm Member_ Member Name (I)
c parm rrn_ Relative record Number(I)
c parm ERRCOD Error Code (I/O)
c
c if bytava <> 0 or %error (B10) Error ....
c eval return_code = '9'
c goto exit
c endif (E10)
*
* Data Address p_Data is Receiver Address + Offset Job
*
C eval p_Data = p_Dsin + OFFJOB
* Scan Locked Info
*
C
C do retjob (b10)
*
* Until The job Holding the record for Update is found
*
C if plock_stat <> HELD or Plock_type <> update (b20)
C EVAL p_Data = p_Data + SIZjob
C iter
C else (x20)
*
* Open Display File
*
c open S_DSPLOCFM
c eval *in20 = *off No Detail
*
* Retrieve the device name
*
c eval DEVD0100_Size = %size(DEVD0100)
c call (e) 'QDCRDEVD' Retrieve Device Description
c parm DEVD0100
c parm DEVD0100_Size
c parm 'DEVD0100' format
c parm Pjob
c parm ERRCOD
c if bytava <> 0 or %error (B30) Error ....
c eval return_code = '9'
c goto exit
c endif (E30)
c if retbyt_D > 0 (b30)
c movel Dev_Descr Ljob
c else (X30)
c eval Ljob = *BLANK
c endif (E30)
*
* Retrieve the User name
*
c eval USRI0300_Size = %size(USRI0300)
c call (e) 'QSYRUSRI' Retrieve User Description
c parm USRI0300
c parm USRI0300_Size
c parm 'USRI0300' format
c parm Pusr
c parm ERRCOD
c if bytava <> 0 or %error (B30) Error ....
c eval return_code = '9'
c goto exit
c endif (E30)
c if retbyt_U > 0 (b30)
c movel Usr_Descr Lusr
c else (X30)
c eval Lusr = *BLANK
c endif (E30)
*
* Setup additional Info
*
c eval Lstat = 'HELD '
c eval Llock = 'UPDATE '
c eval RRN11 = RRN_
c eval return_code = '0'
*
* Display results
*
C scr1 tag
C EXFMT DSPLOC01
*
* F3/Exit
*
C if *in03 (b30)
C goto exit
C endif (e30)
*
* F10/Toggle Display Detailled Info or not
*
C IF *in10 (b30)
C eval *in20 = not *in20
C endif (e30)
c goto scr1
C endif (e20)
C ENDDO (e10)
c exit tag
*
* Close Opened File
*
c if %open(S_DSPLOCFM)
c Close S_DSPLOCFM
c endif
c return (Return_code)
P E
*--------------------------------------------------------------(END)------S_DSPLOC
|
|
|
|
|||||||||||||||||||||||
| ||||||||||||||||||||||||||
|
|
 |  |  | |  | |  | |  | |  | |  | |  | |  | |  | |
|
|
About Us | Contact Us | For Advertisers | For Business Partners | Site Index | RSS |
|
|
||
|
|||||||
