152 lines
4.1 KiB
Plaintext
Executable File
152 lines
4.1 KiB
Plaintext
Executable File
subroutine U01AD( proc, ibn, pib, sib, ip, obn, pob, sob )
|
|
*******************************************************************************
|
|
*
|
|
* Perform a file translation from a ProVerb
|
|
*
|
|
* Module %M% Version %I% Date %H%
|
|
*
|
|
* (c) Copyright 1998 Ardent Software Inc. - All Rights Reserved
|
|
* This is unpublished proprietary source code of Ardent Software Inc.
|
|
* The copyright notice above does not evidence any actual or intended
|
|
* publication of such source code.
|
|
*
|
|
*******************************************************************************
|
|
*
|
|
* Maintenence log - insert most recent change descriptions at top
|
|
*
|
|
* Date.... GTAR# WHO Description.........................................
|
|
* 10/14/98 23801 SAP Change copyrights.
|
|
* 11/02/95 17595 SHJ Don't convert blanks when printing to terminal
|
|
* 04/15/92 9342 JWT Fix case for pib len = 0
|
|
* 01/03/92 8557 GMH Corrected placement in pib
|
|
* 07/25/88 - - Maintenence log purged at 5.2.1, see release 5.1.10.
|
|
*
|
|
*******************************************************************************
|
|
*
|
|
* This "user-exit", called from a ProVerb, takes the filename,
|
|
* item-ID, and translation attribute number specified and returns
|
|
* the looked-up value to the named target.
|
|
*
|
|
* Usage:
|
|
* U01AD
|
|
* file.ref item.ref amc.ref target
|
|
* error return
|
|
* success return
|
|
*
|
|
* Where target can be:
|
|
* T - terminal
|
|
* S - Current output buffer
|
|
* A - Alternate output buffer
|
|
* P - Primary input buffer
|
|
* V - Verify existence (produces no output)
|
|
* VA - Verify nonnull attribute
|
|
*
|
|
* All references can be indirect through the proc buffers.
|
|
* Work files are not supported.
|
|
*
|
|
* Arguments to this subroutine are:
|
|
* proc - the text of the proc itself
|
|
* ibn - the current input buffer number (0 = primary;
|
|
* 1 = secondary)
|
|
* pib - the primary input buffer
|
|
* sib - the secondary input buffer
|
|
* ip - the input buffer pointer (character count)
|
|
* obn - the current output buffer number (0 = primary;
|
|
* 1 = secondary)
|
|
* pob - the primary output buffer
|
|
* sob - the secondary output buffer
|
|
*
|
|
*******************************************************************************
|
|
*
|
|
|
|
*
|
|
*
|
|
DIM words( 10 )
|
|
REMOVE line FROM proc SETTING x
|
|
line = TRIM( line )
|
|
MATPARSE words FROM line," "
|
|
CALL $INDIRECT( fileref, pib, sib, pob, sob, obn, words( 1 ))
|
|
IF fileref[ 1,1 ] = "*" THEN
|
|
Dstr = "DICT"
|
|
fileref = fileref[ 2, 999 ]
|
|
END ELSE
|
|
Dstr = ""
|
|
END
|
|
CALL $INDIRECT( itemref, pib, sib, pob, sob, obn, words( 2 ))
|
|
CALL $INDIRECT( amcref, pib, sib, pob, sob, obn, words( 3 ))
|
|
CALL $INDIRECT( target, pib, sib, pob, sob, obn, words( 4 ))
|
|
found = 1
|
|
OPEN Dstr, fileref TO fvu01ad ELSE
|
|
RETURN
|
|
END
|
|
READV item FROM fvu01ad, itemref, amcref ELSE
|
|
found = 0
|
|
END
|
|
IF found THEN
|
|
*
|
|
* If the target designation is prefaced with a "B", then we're
|
|
* to replace all embedded blanks with backslashes.
|
|
*
|
|
IF target[ 1, 1 ] = "B" THEN
|
|
CONVERT " " TO "\" IN item
|
|
target = target[ 2, LEN( target )]
|
|
END ELSE
|
|
IF target[ 1, 1 ] # "T" THEN CONVERT " " TO @AM IN item
|
|
END
|
|
|
|
BEGIN CASE
|
|
CASE target = "T"
|
|
print item
|
|
|
|
CASE target = "T+"
|
|
print item:
|
|
|
|
CASE target = "S"
|
|
IF( obn ) THEN
|
|
sob := item
|
|
END ELSE
|
|
pob := item
|
|
END
|
|
|
|
CASE target = "A"
|
|
IF ( obn ) THEN
|
|
pob = item
|
|
END ELSE
|
|
sob = item
|
|
END
|
|
|
|
CASE target = "P"
|
|
pib.len = len(pib)
|
|
IF ip = pib.len THEN
|
|
IF pib[ip,1] # @AM AND pib.len THEN pib := @AM
|
|
pib := item
|
|
END ELSE
|
|
IF pib[ ip, 1 ] = @AM THEN ip += 1
|
|
first.part = pib[ 1, ip - 1 ] : item : @AM
|
|
last.part = pib[ ip + 1, len( pib )]
|
|
IF pib[ ip, 1 ] # @AM THEN DEL last.part< 1 >
|
|
pib = first.part : last.part
|
|
END
|
|
|
|
CASE target = "V"
|
|
NULL
|
|
|
|
CASE target = "VA"
|
|
IF item = "" THEN
|
|
found = 0
|
|
END
|
|
END CASE
|
|
END
|
|
|
|
*
|
|
* If we found an item, we must remove the error return line
|
|
* from the proc.
|
|
*
|
|
IF found THEN
|
|
REMOVE line FROM proc SETTING x
|
|
END
|
|
|
|
RETURN
|
|
|
|
END
|