In trying to save the last few OpenVMS systems my company has, I have created a couple of virtualized instances of OpenVMS 9 x86. During my port of a large ALPHA FORTRAN based application, I discovered a utility executable that several DCL command procedures are using in various capacities. This program was created by Frank Nagy in 1985. Sorry to say Frank passed away around 2017.
In my attempt to create a new FORTRAN program to perform the same functions, I am having a few issues I need some help with. If I can get this utility completed, I intend on posting it, along with an associated CLD and HLP file to share with others. A reduced section of my code is listed below with comments.
Code: Select all
!+
! Currently getting a buffer overflow when making the $GETUAI system service call.
! The UAI flags are NOT returning correctly.
! I think the uai_return_flags (a longword bit vector) definition is the issue as I have never created one before.
!
! Additionally the ASTM limit is also NOT returning correctly.
!
! The UAI account "owner" IS returning correctly.
!
! Still trying to blow the rust off of my FORTRAN skills... Any help would be very much appreciated!
!-
PROGRAM LWBV
IMPLICIT NONE
! INCLUDE '($SYSSRVNAM)' ! Let's reduce bloating and define our single system srv call below
INCLUDE '($UAIDEF)'
CHARACTER*32 OWNER /''/
CHARACTER*12 USERNAME /'DEFAULT'/
INTEGER*2 ASTLM /0/
INTEGER*2 ASTLM_LEN /0/
INTEGER CONTEXT /-1/
INTEGER OWNER_LEN /0/
INTEGER USERNAME_LEN /0/
INTEGER STATUS /0/
INTEGER SYS$GETUAI
INTEGER*4 UAI_RET_FLAGS /0/
BYTE A /0/ ! Testing...
BYTE B /0/ ! Testing...
BYTE C /0/ ! Testing...
INTEGER :: I ! Array pointer
INTEGER*4 :: ARRAY1(1) ! 1D INTEGER ARRAY OF 1 ELEMENT
! Testing - Longword bit array testing. Lets practice how we create arrays
! INTEGER*4 :: ARRAY1 ! 1D INTEGER DYNAMIC ARRAY
! INTEGER :: ARRAY1(10) ! 1D INTEGER ARRAY OF 10 ELEMENT
! INTEGER :: ARRAY2(10, 10) ! 2D INTEGER ARRAY OF 100 ELEMENTS
! INTEGER :: ARRAY3(10, 10, 10) ! 3D INTEGER ARRAY OF 1000 ELEMENTS
STRUCTURE /ITEM_LIST/
INTEGER*2 BUFLEN, ITMCOD
INTEGER*4 BUFADR, RETADR
END STRUCTURE
RECORD /ITEM_LIST/ ITEMLIST(4)
!+
! Testing...
! array1 = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] ! Array constructor
! array1 = [(i, i = 1, 32)] ! Implied do loop constructor
array1(:) = 0 ! Set all elements to zero
! array1(1:5) = 1 ! Set first five elements to one
! array1(6:) = 1 ! Set all elements after five to one
TYPE *,'Displaying the array before the call.'
print *, array1(1:29) ! Print out elements
! print *, array1(1:10:2) ! Print out elements at odd indices
! print *, array2(:,1) ! Print out the first column in a 2D array
! print *, array1(29:1:-1) ! Print an array in reverse
!-
! Stuff the structure then make the call to $GETUAI
ItemList(1).ITMCOD = UAI$_ASTLM ! This item is NOT comming back correctly.
! ItemList(1).BUFLEN = LEN(ASTLM)
ItemList(1).BUFADR = %LOC(ASTLM)
ItemList(1).RETADR = %LOC(ASTLM_LEN)
ItemList(2).ITMCOD = UAI$_OWNER !This item is coming back correctly,
ItemList(2).BUFLEN = LEN(OWNER)
ItemList(2).BUFADR = %LOC(OWNER)
ItemList(2).RETADR = %LOC(OWNER_LEN)
!+ Testing in progress
! When you specify UAI$_FLAGS, $GETUAI returns, as a longword bit vector, the various login flags set
! for the user. Each flag is represented by a bit. The $UAIDEF macro defines the following symbolic names for these
! flags.
!-
ItemList(3).ITMCOD = UAI$_FLAGS
! ItemList(3).BUFLEN = LEN(UAI_RET_FLAGS)
ItemList(3).BUFADR = %LOC(ARRAY1(:))
! ItemList(3).RETADR = %LOC(UAI_RET_FAGS_LEN)
ItemList(4).ITMCOD = 0 !List Terminator
ItemList(4).BUFLEN = 0 !Optional terminator
ItemList(4).BUFADR = 0 !Optional terminator
ItemList(4).RETADR = 0 !Optional terminator
! %REF / %VAL / %DESCR / %LOC
! Status = SYS$GETUAI (,%REF(CONTEXT),%DESCR(USERNAME),ITEMLIST,,,) ! Errors out on context?
Status = SYS$GETUAI (,,%DESCR(USERNAME),%REF(ITEMLIST),,,)
! IF (.NOT. STATUS) CALL LIB$Signal (%VAL (STATUS))
CALL LIB$Signal (%VAL (STATUS)) ! For testing display STATUS always
TYPE *,'Displaying the array elements after the call.' ! For testing
PRINT *, ARRAY1(1:29) ! Referencing the array elements
TYPE *,'Displaying the array after the call.' ! For testing
PRINT *, ARRAY1(:) ! Referencing the array
TYPE *,'Username : ',USERNAME
TYPE *,'Owner : ',OWNER(1:OWNER_LEN)
TYPE *,'ASTLM is : ',ASTLM
TYPE *,'UAI$M_DISACNT : ',UAI$M_DISACNT !to diagnose the issue
TYPE *,'UAI$S_DISACNT : ',UAI$S_DISACNT !to diagnose the issue
TYPE *,'UAI$V_DISACNT : ',UAI$V_DISACNT !to diagnose the issue
TYPE *,'ARRAY1(UAI$V_DISACNT) is: ',Array1(UAI$V_DISACNT) !to diagnose the issue
! More testing....The FIELD account flags are currently set to both captive and disusered.
! (Still not working correctly)
A = IBITS(UAI_RET_FLAGS,UAI$V_DISACNT,1)
B = IBITS(UAI_RET_FLAGS,UAI$V_DISACNT-1,1)
C = IBITS(UAI_RET_FLAGS,UAI$V_DISACNT+1,1)
TYPE *, '********************: 12345678'
TYPE *, 'Byte VALUE DISACNT : ',A
TYPE *, 'Byte VALUE DISACNT-1 : ',B
TYPE *, 'Byte VALUE DISACNT+1 : ',C
IF (UAI$M_DISACNT == 1) THEN
TYPE *,'Account is disusered.'
ELSE
TYPE *,'Account is NOT disusered.'
END IF
IF (UAI$M_CAPTIVE == 1) THEN
TYPE *,'Account is captive.'
ELSE
TYPE *,'Account is NOT captive.'
END IF
999 END PROGRAM LWBV
