354 lines
12 KiB
Plaintext
354 lines
12 KiB
Plaintext
|
********************************************************************************
|
||
|
|
*
|
||
|
|
* Support of PR1ME INFORMATION subroutine '!BINARY.CONVERT'
|
||
|
|
*
|
||
|
|
* 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.
|
||
|
|
* 09/07/93 12299 LA Initial implementation.
|
||
|
|
*
|
||
|
|
*******************************************************************************
|
||
|
|
* START-DESCRIPTION:
|
||
|
|
*
|
||
|
|
* Converts a string to or from INFO/BASIC format from or to binary format
|
||
|
|
* according to a picture or format given.
|
||
|
|
*
|
||
|
|
*
|
||
|
|
* END-DESCRIPTION
|
||
|
|
*
|
||
|
|
* START-DESIGN:
|
||
|
|
*
|
||
|
|
* The routine is split into two parts according to direction. Each part
|
||
|
|
* loops on each field of the format string converting the corresponding
|
||
|
|
* parts of the input buffer to the output buffer. If a field in the format
|
||
|
|
* consists of a number of values starting with an integer, the following values
|
||
|
|
* are used as format codes for multi-valued fields.
|
||
|
|
*
|
||
|
|
* END-DESIGN
|
||
|
|
*
|
||
|
|
|
||
|
|
$OPTIONS DEFAULT
|
||
|
|
|
||
|
|
subroutine PR1ME(INBUF, BUFFMT, DIRECTION, OUTBUF, STATUS)
|
||
|
|
|
||
|
|
EQUATE IB.TO.INT TO 0,
|
||
|
|
INT.TO.IB TO 1,
|
||
|
|
OTHERWISE LIT 'CASE 1',
|
||
|
|
NULL TO ''
|
||
|
|
*
|
||
|
|
* ==================================================================
|
||
|
|
*
|
||
|
|
* Initialize variables
|
||
|
|
OUTPUT = NULL
|
||
|
|
STATUS = ''
|
||
|
|
BFCOUNT = 1
|
||
|
|
FFCOUNT = 1
|
||
|
|
INDEX = 1
|
||
|
|
*
|
||
|
|
* Loop on each field of format
|
||
|
|
LOOP
|
||
|
|
FMT = BUFFMT<FFCOUNT>
|
||
|
|
WHILE FMT
|
||
|
|
*
|
||
|
|
* Check for simple or multi-value format
|
||
|
|
NV = FMT<1, 1>
|
||
|
|
IF NUM(NV) THEN
|
||
|
|
*
|
||
|
|
* Multi-value format, set up number of fields
|
||
|
|
NF = COUNT(FMT, @VM) + 1
|
||
|
|
*
|
||
|
|
* Adjust buffer field counter for loops
|
||
|
|
BFC = BFCOUNT - 2
|
||
|
|
*
|
||
|
|
* Loop for each value
|
||
|
|
FOR J = 1 TO NV
|
||
|
|
*
|
||
|
|
* Loop for each field
|
||
|
|
FOR I = 2 TO NF
|
||
|
|
*
|
||
|
|
* Get format code for this multi-valued field
|
||
|
|
FMT.CODE = FMT<1, I>
|
||
|
|
*
|
||
|
|
* Calculate field number for this value
|
||
|
|
BFP = BFC + I
|
||
|
|
IF DIRECTION = IB.TO.INT THEN
|
||
|
|
*
|
||
|
|
* INFO/BASIC to internal format, convert value and append
|
||
|
|
FIELD = INBUF<BFP, J>
|
||
|
|
*
|
||
|
|
* to buffer string
|
||
|
|
GOSUB IB.TO.INT.CONV
|
||
|
|
END ELSE
|
||
|
|
*
|
||
|
|
* Internal to INFO/BASIC format, convert value and place
|
||
|
|
GOSUB INT.TO.IB.CONV
|
||
|
|
*
|
||
|
|
* in output string
|
||
|
|
OUTPUT<BFP, J> = FIELD
|
||
|
|
END
|
||
|
|
NEXT I
|
||
|
|
NEXT J
|
||
|
|
*
|
||
|
|
* Increment buffer field count by number of fields added
|
||
|
|
BFCOUNT += NF - 1
|
||
|
|
END ELSE
|
||
|
|
*
|
||
|
|
* Simple format, set up format code and buffer field number
|
||
|
|
FMT.CODE = FMT
|
||
|
|
BFP = BFCOUNT
|
||
|
|
IF DIRECTION = IB.TO.INT THEN
|
||
|
|
*
|
||
|
|
* INFO/BASIC to internal format, get field, convert and append
|
||
|
|
FIELD = INBUF<BFP>
|
||
|
|
*
|
||
|
|
* to buffer string
|
||
|
|
GOSUB IB.TO.INT.CONV
|
||
|
|
END ELSE
|
||
|
|
*
|
||
|
|
* Internal to INFO/BASIC format, convert and place field into
|
||
|
|
GOSUB INT.TO.IB.CONV
|
||
|
|
*
|
||
|
|
* output string
|
||
|
|
OUTPUT<BFP> = FIELD
|
||
|
|
END
|
||
|
|
*
|
||
|
|
* Increment buffer field count (by one)
|
||
|
|
BFCOUNT += 1
|
||
|
|
END
|
||
|
|
*
|
||
|
|
* Increment format field count (by one)
|
||
|
|
FFCOUNT += 1
|
||
|
|
REPEAT
|
||
|
|
*
|
||
|
|
* If converting from internal format check that whole buffer is consumed
|
||
|
|
IF DIRECTION = INT.TO.IB THEN
|
||
|
|
IF LEN(INBUF) <> INDEX - 1 THEN GOSUB ILLEGAL ;*001
|
||
|
|
END
|
||
|
|
*
|
||
|
|
* Copy output to result argument (this is done in case actual input and
|
||
|
|
* output arguments supplied by caller are the same variable)
|
||
|
|
OUTBUF = OUTPUT
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
*
|
||
|
|
* INFO/BASIC to internal conversion subroutine
|
||
|
|
IB.TO.INT.CONV:
|
||
|
|
*
|
||
|
|
* Set up parts for format code for case statements
|
||
|
|
F1 = FMT.CODE[1,1]
|
||
|
|
F12 = FMT.CODE[1,2]
|
||
|
|
N = FMT.CODE[3,99]
|
||
|
|
*
|
||
|
|
* Split on format code
|
||
|
|
BEGIN CASE
|
||
|
|
CASE F12 = 'AS'
|
||
|
|
*
|
||
|
|
* ASCII conversion
|
||
|
|
IF NUM(N) THEN
|
||
|
|
* N += MOD(N, 2) ;*004
|
||
|
|
OUTPUT := ICONV(FIELD[1, N]:STR(' ', N - LEN(FIELD)),'ECS')
|
||
|
|
END ELSE
|
||
|
|
GOSUB ILLEGAL
|
||
|
|
END
|
||
|
|
CASE F1 = 'B'
|
||
|
|
*
|
||
|
|
* Binary conversions
|
||
|
|
IF NUM(N) THEN
|
||
|
|
IF N < 1 OR N > 256 THEN
|
||
|
|
GOSUB ILLEGAL
|
||
|
|
END ELSE
|
||
|
|
* Compress spaces
|
||
|
|
CONVERT ' ' TO '' IN FIELD
|
||
|
|
* Convert number of bits to number of bytes
|
||
|
|
N = INT((N + 7) / 8) ;*004
|
||
|
|
F2 = FMT.CODE[2, 1]
|
||
|
|
BEGIN CASE
|
||
|
|
CASE F2 = 'B'
|
||
|
|
* Binary string (zeros and ones)
|
||
|
|
N = N * 8 ;*004
|
||
|
|
FIELD = FIELD[1, N]:STR('0', N - LEN(FIELD))
|
||
|
|
IF N > 188 THEN
|
||
|
|
* Have to take into account limit of 188 chars
|
||
|
|
FIELD1 = FIELD[1, 128]
|
||
|
|
FIELD2 = FIELD[129, 128]
|
||
|
|
FIELD1 = ICONV(FIELD1, 'MB0C')
|
||
|
|
IF STATUS() = 0 THEN FIELD2 = ICONV(FIELD2, 'MB0C')
|
||
|
|
OUTPUT := FIELD1:FIELD2
|
||
|
|
END ELSE
|
||
|
|
OUTPUT := ICONV(FIELD, 'MB0C')
|
||
|
|
END
|
||
|
|
GOSUB STATUS
|
||
|
|
CASE F2 = 'O'
|
||
|
|
* Octal string (Zeros to sevens)
|
||
|
|
L = LEN(FIELD) / 3
|
||
|
|
* Three digits per byte
|
||
|
|
IF INT(L) = L THEN
|
||
|
|
FIELD = ICONV(FIELD, 'MO0C')
|
||
|
|
* N = N * 2 ;*004
|
||
|
|
OUTPUT := FIELD[1, N]:STR(CHAR(128), N - LEN(FIELD))
|
||
|
|
GOSUB STATUS
|
||
|
|
END ELSE
|
||
|
|
GOSUB FAILED
|
||
|
|
END
|
||
|
|
CASE F2 = 'H'
|
||
|
|
* Hexadecimal string (Zeros to Fs)
|
||
|
|
N = N * 2 ;*004
|
||
|
|
FIELD = FIELD[1, N]:STR('0', N - LEN(FIELD))
|
||
|
|
OUTPUT := ICONV(FIELD, 'MX0C')
|
||
|
|
GOSUB STATUS
|
||
|
|
OTHERWISE
|
||
|
|
GOSUB ILLEGAL
|
||
|
|
END CASE
|
||
|
|
END
|
||
|
|
END ELSE
|
||
|
|
GOSUB ILLEGAL
|
||
|
|
END
|
||
|
|
CASE F1 = 'I' OR F12 = 'FS' OR F12 = 'FD' OR F12 = 'PD'
|
||
|
|
*
|
||
|
|
* Number and packed decimal conversions
|
||
|
|
OUTPUT := ICONV(FIELD, FMT.CODE)
|
||
|
|
GOSUB STATUS
|
||
|
|
CASE F12 = 'SK' ;*002
|
||
|
|
* ;*002
|
||
|
|
* Create N bytes to skip in Midasplus record ;*002
|
||
|
|
IF NUM(N) THEN ;*002
|
||
|
|
* N += MOD(N, 2) ;*004
|
||
|
|
OUTPUT := STR( CHAR( 128), N) ;*002
|
||
|
|
END ELSE ;*002
|
||
|
|
GOSUB ILLEGAL ;*002
|
||
|
|
END ;*002
|
||
|
|
OTHERWISE
|
||
|
|
*
|
||
|
|
* Illegal conversion code
|
||
|
|
GOSUB ILLEGAL
|
||
|
|
END CASE
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
*
|
||
|
|
* Internal to INFO/BASIC conversion subroutine
|
||
|
|
INT.TO.IB.CONV:
|
||
|
|
*
|
||
|
|
* Set up parts for format code for case statements
|
||
|
|
F1 = FMT.CODE[1,1]
|
||
|
|
F12 = FMT.CODE[1,2]
|
||
|
|
N = FMT.CODE[3,99]
|
||
|
|
BEGIN CASE
|
||
|
|
CASE F12 = 'AS'
|
||
|
|
*
|
||
|
|
* ASCII conversion
|
||
|
|
IF NUM(N) THEN
|
||
|
|
FIELD = OCONV(INBUF[INDEX, N], 'ECS')
|
||
|
|
IF LEN(FIELD) <> N THEN GOSUB FAILED
|
||
|
|
END ELSE
|
||
|
|
GOSUB ILLEGAL
|
||
|
|
END
|
||
|
|
CASE F1 = 'B'
|
||
|
|
*
|
||
|
|
* Binary conversions
|
||
|
|
IF NUM(N) THEN
|
||
|
|
IF N < 1 OR N > 256 THEN
|
||
|
|
GOSUB ILLEGAL
|
||
|
|
END ELSE
|
||
|
|
L = N
|
||
|
|
* Convert number of bits to number of bytes
|
||
|
|
N = INT((N + 7) / 8) ;*004
|
||
|
|
F2 = FMT.CODE[2,1]
|
||
|
|
IF F2 = 'H' THEN F2 = 'X'
|
||
|
|
FIELD = OCONV(INBUF[INDEX, N], 'M':F2:'0C')
|
||
|
|
GOSUB STATUS
|
||
|
|
BEGIN CASE
|
||
|
|
CASE F2 = 'B'
|
||
|
|
* Binary string
|
||
|
|
FIELD = FIELD[1, L]
|
||
|
|
CASE F2 = 'O'
|
||
|
|
* Octal string, three digits to a byte
|
||
|
|
L = N * 3 ;*004
|
||
|
|
TEMP = FIELD[1, L]
|
||
|
|
* Separate each three digits by spaces
|
||
|
|
FIELD = NULL
|
||
|
|
FOR I = 1 TO L STEP 3
|
||
|
|
FIELD<-1> = TEMP[I, 3]
|
||
|
|
NEXT I
|
||
|
|
CONVERT @FM TO ' ' IN FIELD
|
||
|
|
CASE F2 = 'X'
|
||
|
|
* Hexadecimal string
|
||
|
|
FIELD = FIELD[1, INT((L + 3) / 4)]
|
||
|
|
END CASE
|
||
|
|
END
|
||
|
|
END ELSE
|
||
|
|
GOSUB ILLEGAL
|
||
|
|
END
|
||
|
|
CASE F1 = 'I' OR F1 = 'F'
|
||
|
|
*
|
||
|
|
* Number conversions
|
||
|
|
N = IF F12 = 'IS' THEN 2 ELSE IF F12 = 'FD' THEN 8 ELSE 4
|
||
|
|
FIELD = OCONV(INBUF[INDEX, N], F12)
|
||
|
|
GOSUB STATUS
|
||
|
|
CASE F12 = 'PD'
|
||
|
|
*
|
||
|
|
* Packed decimal conversion
|
||
|
|
* ;*005
|
||
|
|
* Get the length of the PD string... ;*005
|
||
|
|
N = FIELD(N, '.', 1, 1)
|
||
|
|
IF NUM(N) THEN
|
||
|
|
* Packed decimal strings are this long ;*005
|
||
|
|
N = INT(N / 2) + 1 ;*005
|
||
|
|
FIELD = OCONV( INBUF[ INDEX, N], FMT.CODE)
|
||
|
|
GOSUB STATUS
|
||
|
|
END ELSE
|
||
|
|
GOSUB ILLEGAL
|
||
|
|
END
|
||
|
|
CASE F12 = 'SK' ;*002
|
||
|
|
* ;*002
|
||
|
|
* Skip N bytes in Midasplus record ;*002
|
||
|
|
IF NUM(N) THEN ;*002
|
||
|
|
FIELD = NULL ;*002
|
||
|
|
END ELSE ;*002
|
||
|
|
GOSUB ILLEGAL ;*002
|
||
|
|
END ;*002
|
||
|
|
OTHERWISE
|
||
|
|
*
|
||
|
|
* Illegal conversion code
|
||
|
|
GOSUB ILLEGAL
|
||
|
|
FIELD = NULL
|
||
|
|
END CASE
|
||
|
|
*
|
||
|
|
* Increment index to next byte
|
||
|
|
IF NUM(N) THEN
|
||
|
|
INDEX += N ;*004
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
*
|
||
|
|
ILLEGAL:
|
||
|
|
STATUS<-1> = FFCOUNT:@VM:'I'
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
*
|
||
|
|
FAILED:
|
||
|
|
STATUS<-1> = BFP:@VM:'F'
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
*
|
||
|
|
STATUS:
|
||
|
|
IF STATUS() = 1 THEN GOSUB FAILED ELSE
|
||
|
|
IF STATUS() = 2 THEN GOSUB ILLEGAL ELSE
|
||
|
|
IF STATUS() = -1 THEN STATUS<-1> = BFP:@VM:'P'
|
||
|
|
END
|
||
|
|
END
|
||
|
|
RETURN
|
||
|
|
*
|
||
|
|
*
|
||
|
|
|
||
|
|
END
|