******************************************************************************** * * 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 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 * * 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 = 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 * * 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 = 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