|
With a quick look around in my account.... I found a
MACRO program that might give you a start....
If you need more help... Let me know, and I'll try to
work on a real routine specific to you needs...
-----------------------------------------------------------------------
.title d_date
fab1: $fab ctx=1,fop=<cbt,tef>,-
rat=cr,xab=xab1
rab1: $rab ctx=1,fab=fab1,rop=<asy>
xab1: $xabdat
;
; CALL D_DATE(filename,qdate)
; where filename is the filename in either CHARACTER form or
; null terminated BYTE string,
; and qdate is the address of a quadword to be set to
; the revision/creation date of the file.
;
d_date:: .word ^m<r2,r3>
cmpw 0(ap),#2 ;are there 2 args ?
beql name ;YES. Good, that's only legal choice
jmp badarg ;error
name:
movl 4(ap),r0 ; get addr of descriptor
movl r0,r3
cmpb 2(r0),#14 ;is it a character string ?
beql char ;yes. Descriptors always have 14 in high word
movl r0,r1 ;not CHAR, must be BYTE w/ null at end
cloop:
tstb (r1)+ ;look for terminating null
bneq cloop ;not yet found
decl r1 ;found null. point to last good char
subl r0,r1 ;get string length
$fab_store fab=fab1,fns=r1,fna=(r3)
brb done
char:
movzbl (r3),r1 ;get string length
movl 4(r3),r0 ;get string address
decl r0 ;r1 is 1 too big
chloop: ;get rid of trailing blanks
addl2 r1,r0 ;get last char of string
cmpb (r0),#^a/ / ;is it a blank ?
bneq cdon ;no. stop looking for more blanks
subl2 r1,r0 ;fix up address for next time
sobgtr r1,chloop ;decrement length
cdon:
$fab_store fab=fab1,fns=r1,fna=@4(r3)
done:
read: ; open an existing file to read date
clrq xab$q_rdt + xab1
clrq xab$q_cdt + xab1
movq #0,@8(ap) ;pre-clear result to zero
; $fab_store fab=fab1,fac=<get>
.list meb
$fab_store fab=fab1,shr=<upi>
.list
$open fab=fab1,err=error
blbs fab$l_sts + fab1,goon
ret
goon:
; pushal fab1
; calls #1,error
movq xab$q_rdt + xab1,@8(ap)
bneq close
norev: movq xab$q_cdt + xab1,@8(ap)
close:
$close fab=fab1,err=error
ret
;
;
error:
.word 0
moval @4(ap),r0 ;happily error is called by an AST
pushal rab$l_sts(r0) ;with the control block as parameter.
; cmpl #rms$_eof,@(sp) ;assume that rab$l_sts and fab$l_sts
; beql okay ;will always coincide.
cmpl #rms$_fnf,@(sp)
beql okay
do_mes: calls #1,errmes ;dump error message.
okay: ret
;
badarg:
pushal invarg
calls #1,errmes
ret
invarg: .long mth$_wronumarg
;
.end
|
| Hi Dan,
Here's a sample using COBOL. I wouldn't say it sucks although
the lack of an unsigned byte variable forces you the resort to a
silly workaround moving a value in a word first and then in a byte.
Anyways, it works. The example consist of a main program and an
include file, seperated by a formfeed.
Hope this helps,
Hein.
IDENTIFICATION DIVISION.
PROGRAM-ID. HEIN.
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 A.
COPY RMS.
01 stat PIC S9(9) COMP.
01 FAB$M_GET PIC S9(4) COMP VALUE 1.
01 RMS$_NORMAL PIC S9(9) COMP VALUE EXTERNAL RMS$_NORMAL.
01 word-value PIC S9(9) COMP.
01 filler redefines word-value.
03 byte-value PIC X.
PROCEDURE DIVISION GIVING stat.
BEGIN-HERE.
MOVE FAB$M_GET TO word_value.
MOVE byte_value TO FAC.
MOVE 0 TO word_value.
MOVE byte_value to RAC, TMO, KSZ, KRF, MBF.
MOVE byte_value to FAC, SHR, RTV, ORG, RAT, RFM, DNS.
DISPLAY "File name:" WITH NO ADVANCING.
ACCEPT file-name-buffer.
INSPECT file-name-buffer TALLYING word_value
FOR CHARACTERS BEFORE INITIAL SPACE.
MOVE byte_value TO FNS.
CALL "sys$open" USING BY REFERENCE fab GIVING stat.
IF stat IS FAILURE THEN EXIT PROGRAM.
CALL "sys$close" USING BY REFERENCE fab GIVING stat.
CALL "sys$asctim" USING
OMITTED,
BY DESCRIPTOR record-buffer,
BY REFERENCE CDT OF XABDAT,
GIVING stat.
IF stat IS FAILURE THEN EXIT PROGRAM.
DISPLAY record-buffer.
EXIT PROGRAM.
03 RAB.
05 RAB_ID PIC S9(9) COMP VALUE IS 17409.
05 ROP PIC S9(9) COMP.
05 STS PIC S9(9) COMP.
05 STV PIC S9(9) COMP.
05 RFA_VBN PIC S9(9) COMP.
05 RFA_ID PIC S9(4) COMP.
05 FILLER PIC S9(4) COMP.
05 CTX PIC S9(9) COMP.
05 FILLER PIC S9(4) COMP.
05 RAC PIC X.
05 TMO PIC X.
05 USZ PIC S9(4) COMP VALUE IS 80.
05 RSZ PIC S9(4) COMP.
05 UBF USAGE IS POINTER VALUE IS REFERENCE record-buffer.
05 RBF USAGE IS POINTER.
05 RHB USAGE IS POINTER.
05 KBF USAGE IS POINTER.
05 KSZ PIC X.
05 KRF PIC X.
05 MBF PIC X.
05 MBC PIC X.
05 BKT PIC S9(9) COMP.
05 FAB-ADD USAGE IS POINTER VALUE IS REFERENCE fab.
05 XAB-ADD USAGE IS POINTER.
03 FAB.
05 FAB_ID PIC S9(9) COMP VALUE 20483.
05 FOP PIC S9(9) COMP.
05 STS PIC S9(9) COMP.
05 STV PIC S9(9) COMP.
05 ALQ PIC S9(9) COMP.
05 DEQ PIC S9(4) COMP.
05 FAC PIC X.
05 SHR PIC X.
05 CTX PIC S9(9) COMP.
05 RTV PIC X.
05 ORG PIC X.
05 RAT PIC X.
05 RFM PIC X.
05 JNL PIC S9(9) COMP.
05 XAB-ADD USAGE IS POINTER VALUE IS REFERENCE xabdat.
05 NAM-ADD USAGE IS POINTER.
05 FNA USAGE IS POINTER VALUE IS REFERENCE file-name-buffer.
05 DNA USAGE IS POINTER VALUE IS REFERENCE default-name-buffer.
05 FNS PIC X.
05 DNS PIC X.
05 MRS PIC S9(4) COMP.
05 MRN PIC S9(9) COMP.
05 BLS PIC S9(4) COMP.
05 FILLER PIC X(18).
03 XABDAT.
05 XABDAT_ID PIC S9(9) COMP VALUE 11282.
05 NXT PIC S9(9) COMP.
05 FILLER PIC S9(9) COMP.
05 FILLER PIC S9(9) COMP.
05 FILLER PIC S9(9) COMP.
05 CDT PIC S9(10) COMP.
05 EDT PIC S9(10) COMP.
05 BDT PIC S9(10) COMP.
03 record-buffer PIC X(80).
03 file-name-buffer PIC X(80).
03 default-name-buffer PIC X(80).
|
| IMPLICIT NONE
CHARACTER*80 FILE_NAME
INTEGER*2 FILE_NAME_SIZE
INTEGER*4 UFO_OPEN, LUN
EXTERNAL UFO_OPEN
CALL LIB$GET_INPUT (FILE_NAME, 'File name? ', FILE_NAME_SIZE)
OPEN (UNIT=LUN, FILE=FILE_NAME(1:FILE_NAME_SIZE),
1 STATUS='OLD', USEROPEN = UFO_OPEN)
END
C-----------------------------------------------------------------------
INTEGER FUNCTION UFO_OPEN(FAB,RAB,LUN)
IMPLICIT NONE
INTEGER NXT, LAST_XAB, LUN, STATUS
INTEGER*2 BUFLEN
INTEGER SYS$OPEN, SYS$CONNECT
CHARACTER*200 ACLBUF,OUTBUF
BYTE COD, BLN
INCLUDE '($FABDEF)'
INCLUDE '($RABDEF)'
INCLUDE '($XABDATDEF)'
INCLUDE '($XABPRODEF)'
RECORD /FABDEF/FAB, /RABDEF/RAB, /XABPRODEF1/PRO, /XABDATDEF/DAT
C Make this PRO a real XABPRO by Filling in the code fields.
C This XAB will be the last in the chain (NXT=0)
CALL SET_XAB(DAT,XAB$C_DAT,XAB$C_DATLEN,%LOC(PRO))
CALL SET_XAB(PRO,XAB$C_PRO,XAB$C_PROLEN,0) !Init COD and BLN
PRO.XAB$L_ACLBUF = %LOC(ACLBUF) !Init ACL buffer pointer
PRO.XAB$W_ACLSIZ = 200 !Init ACL buffer size
NXT = FAB.FAB$L_XAB !At least 1 XAB (XABFHC)
DO WHILE (NXT.NE.0) !Walk the chain
LAST_XAB = NXT !Pointer to last XAB
CALL GET_XAB(%VAL(LAST_XAB),COD,BLN,NXT) !Should check COD..
END DO !..no duplicates allowed
CALL SET_XAB(%VAL(LAST_XAB),COD,BLN,%LOC(DAT)) !Hook'm up.
STATUS = SYS$OPEN(FAB)
IF (STATUS) STATUS = SYS$CONNECT(RAB)
UFO_OPEN = STATUS
CALL SYS$ASCTIM (BUFLEN,OUTBUF,DAT.XAB$Q_CDT)
TYPE *,' Created: ',OUTBUF(0:BUFLEN)
CALL SYS$FORMAT_ACL (ACLBUF(0:PRO.XAB$W_ACLLEN), BUFLEN, OUTBUF,
1 50, '**', 3)
WRITE (5,1) PRO.XAB$W_GRP, PRO.XAB$W_MBM, PRO.XAB$W_PRO,
1 PRO.XAB$W_ACLLEN, PRO.XAB$L_ACLSTS, BUFLEN
1 FORMAT (' Owner=[',O3,',',O3,'], Protection mask=',O6,
1 ' BUFLEN=',I3,', ACLSTS=',Z8,' OUT=',I3)
TYPE *,OUTBUF(0:BUFLEN)
END
C-----------------------------------------------------------------------
SUBROUTINE SET_XAB(XAB,COD,BLN,NXT)
IMPLICIT NONE
INCLUDE '($XABDEF)'
RECORD /XABDEF/ XAB
BYTE COD, BLN
INTEGER NXT
XAB.XAB$B_COD=COD
XAB.XAB$B_BLN=BLN
XAB.XAB$L_NXT=NXT
END
C-----------------------------------------------------------------------
SUBROUTINE GET_XAB(XAB,COD,BLN,NXT)
IMPLICIT NONE
INCLUDE '($XABDEF)'
RECORD /XABDEF/ XAB
BYTE COD, BLN
INTEGER NXT
COD=XAB.XAB$B_COD
BLN=XAB.XAB$B_BLN
NXT=XAB.XAB$L_NXT
END
|