Add APIs
This commit is contained in:
SJLennon
@@ -0,0 +1,405 @@
|
||||
*******************************************************************
|
||||
* From "Sort Those API Lists," NEWS/400, May 1996.
|
||||
* Author: Greg LaForge
|
||||
* COPYRIGHT (c) 1996 Duke Communications International,
|
||||
* ALL RIGHTS RESERVED.
|
||||
*
|
||||
*
|
||||
* Program: SRTUSRSPC
|
||||
* Description: This program sorts in a user space lists
|
||||
* created by system API commands.
|
||||
*
|
||||
**************************************************************************
|
||||
* Indicators used.
|
||||
*
|
||||
* 01 - Error on CALLs. Triggers abnormal termination of program and
|
||||
* sets return parameter EXITER to *ON.
|
||||
*
|
||||
**************************************************************************
|
||||
* Arrays.
|
||||
*
|
||||
* AD - Array of ascending/descending sequences (passed in).
|
||||
* DT - Array of key fields' data types.
|
||||
* KY - Array to pass info to the sort routine.
|
||||
* LN - Array of key lengths (passed in).
|
||||
* ST - Array of key starting positions (passed in).
|
||||
*
|
||||
D ad s 1 dim(10) ascend/descend
|
||||
D dt s 1 dim(10) data type
|
||||
D ln s 5 0 dim(10) lengths
|
||||
D st s 5 0 dim(10) start positions
|
||||
* ************************************************************************
|
||||
* Data structures.
|
||||
*
|
||||
* BINALP - Converts binary to alpha field.
|
||||
* ERROR - Formats error fields for sort APIs.
|
||||
* INDTA - Creates a 9,000-byte field.
|
||||
* MISC - Defines some binary fields.
|
||||
* OUTDTA - Creates a 9,000-byte field.
|
||||
* RCVVAR - Defines some binary fields for user space lists.
|
||||
* SORT - Formats sort control block for QLGSORT API.
|
||||
* SORTIN - Formats input fields for QLGSRTIO API.
|
||||
* SORTOU - Formats output fields for QLGSRTIO API.
|
||||
*
|
||||
*-----------------------------------------------------------------------
|
||||
* Converts binary to alpha field.
|
||||
*
|
||||
D binalp ds
|
||||
D alpha 4
|
||||
D binary 9b 0 overlay(alpha)
|
||||
*-----------------------------------------------------------------------
|
||||
* Formats error fields for sort APIs.
|
||||
*
|
||||
D error ds
|
||||
D errlen 9b 0
|
||||
D erravl 9b 0
|
||||
D errid 7
|
||||
D errdta 17 272
|
||||
*-----------------------------------------------------------------------
|
||||
* Creates a 9,000-byte field.
|
||||
*
|
||||
D indta ds 9000
|
||||
D hold 9000 9000
|
||||
*-----------------------------------------------------------------------
|
||||
* Defines some binary fields.
|
||||
*
|
||||
D misc ds
|
||||
D lendta 9b 0
|
||||
D strpos 9b 0
|
||||
D lenspc 9b 0
|
||||
D lenvar 9b 0
|
||||
D parm3 9b 0
|
||||
D parm4 9b 0
|
||||
D outlen 9b 0
|
||||
*-----------------------------------------------------------------------
|
||||
* Creates a 9,000-byte field.
|
||||
*
|
||||
D outdta ds 9000
|
||||
D holda 9000 9000
|
||||
*-----------------------------------------------------------------------
|
||||
* Defines some binary fields for user space lists.
|
||||
*
|
||||
D rcvvar ds
|
||||
D offset 9b 0
|
||||
D nbrent 9 12b 0
|
||||
D sizent 9b 0
|
||||
*-----------------------------------------------------------------------
|
||||
* Formats sort control block for QLGSORT API.
|
||||
*
|
||||
D sort ds
|
||||
D blklen 1 4b 0
|
||||
D reqtyp 5 8b 0
|
||||
D fill01 9 12b 0
|
||||
D option 13 16b 0
|
||||
D rcdlen 17 20b 0
|
||||
D rcdcnt 21 24b 0
|
||||
D keyoff 25 28b 0
|
||||
D keys 29 32b 0
|
||||
D lanoff 33 36b 0
|
||||
D inoff 37 40b 0
|
||||
D #infil 41 44b 0
|
||||
D outoff 45 48b 0
|
||||
D #outfi 49 52b 0
|
||||
D fill02 53 56b 0
|
||||
D ky 57 216
|
||||
D dim(40) key fields
|
||||
*-----------------------------------------------------------------------
|
||||
* Formats input fields for QLGSRTIO API.
|
||||
*
|
||||
D sortin ds
|
||||
D intype 9b 0
|
||||
D infil1 9b 0
|
||||
D inlen 9b 0
|
||||
D inrecs 9b 0
|
||||
*-----------------------------------------------------------------------
|
||||
* Formats output fields for QLGSRTIO API.
|
||||
*
|
||||
D sortou ds
|
||||
D ourprc 9b 0
|
||||
D ouravl 9b 0
|
||||
D oufil1 9b 0
|
||||
D oufil2 9b 0
|
||||
*---------------------------------------------------------------------
|
||||
* BEGIN of work fields added by CONNECTIONS 2000's CVTILERPG utility
|
||||
*---------------------------------------------------------------------
|
||||
D #keys s like(dec003 )
|
||||
D #recs s like(int )
|
||||
D byte s 1
|
||||
D chr032 s 32
|
||||
D dec003 s 3 0
|
||||
D exiter s like(byte )
|
||||
D force s like(byte )
|
||||
D i s like(int )
|
||||
D inbuff s like(chr032 )
|
||||
D int s 9 0
|
||||
D i1 s like(int )
|
||||
D i2 s like(int )
|
||||
D i3 s like(int )
|
||||
D i4 s like(int )
|
||||
D lib s like(name )
|
||||
D name s 10
|
||||
D oubuff s like(chr032 )
|
||||
D qname s 20
|
||||
D spacer s like(qname )
|
||||
D tmp50 s like(int )
|
||||
D totrec s like(int )
|
||||
D usrspc s like(name )
|
||||
*---------------------------------------------------------------------
|
||||
* END of work fields added by CONNECTIONS 2000's CVTILERPG utility
|
||||
*---------------------------------------------------------------------
|
||||
**************************************************************************
|
||||
*
|
||||
* Mainline.
|
||||
*
|
||||
C exsr inzpgm
|
||||
C exsr prcpgm
|
||||
C exsr trmpgm
|
||||
*
|
||||
C return
|
||||
*-----------------------------------------------------------------------
|
||||
* CHK4ER: Look to see whether error has occurred; if so, exit.
|
||||
*
|
||||
C chk4er begsr
|
||||
*
|
||||
B001 C if *in01 = *on error in call
|
||||
001 C or errid <> *blanks returned error
|
||||
001 C exsr *pssr
|
||||
E001 C endif
|
||||
*
|
||||
C endsr
|
||||
*-----------------------------------------------------------------------
|
||||
* DCLVAR: Declare program variables.
|
||||
* This subroutine is never executed.
|
||||
*
|
||||
C dclvar begsr
|
||||
* Declare data types.
|
||||
C eval byte = *blank
|
||||
C eval chr032 = *blank
|
||||
C eval dec003 = 0
|
||||
C eval int = 0
|
||||
C eval name = *blank
|
||||
C eval qname = *blank
|
||||
*
|
||||
* Declare variables based on data types.
|
||||
*
|
||||
C endsr
|
||||
*-----------------------------------------------------------------------
|
||||
* INZPGM: Initialize program.
|
||||
*
|
||||
C inzpgm begsr
|
||||
*
|
||||
C *entry plist
|
||||
C parm usrspc user space
|
||||
C parm lib user space lib
|
||||
C parm #keys nbr of keys
|
||||
C parm st start positions
|
||||
C parm ln lengths
|
||||
C parm ad ascend/descend
|
||||
C parm dt data types
|
||||
C parm exiter *ON=error
|
||||
*
|
||||
* Clear error flag.
|
||||
C move *off exiter
|
||||
*
|
||||
* Get some info in the user space header.
|
||||
C movel usrspc spacer
|
||||
C move lib spacer
|
||||
*
|
||||
C call 'QUSRTVUS' 01
|
||||
C parm spacer
|
||||
C parm 125 strpos
|
||||
C parm 16 lendta
|
||||
C parm rcvvar
|
||||
*
|
||||
C exsr chk4er
|
||||
*
|
||||
* Determine starting position of list in the user space.
|
||||
C eval strpos = offset
|
||||
C eval strpos = strpos + 1
|
||||
*
|
||||
* Initialize the sort function.
|
||||
C eval blklen = #keys length of
|
||||
C eval blklen = blklen * 16 sort control
|
||||
C eval blklen = blklen + 56 block
|
||||
C eval reqtyp = 8 sort type
|
||||
C eval fill01 = 0 filler
|
||||
C eval option = 0 no options
|
||||
C eval rcdlen = sizent rec size
|
||||
C eval rcdcnt = 0 no rec count
|
||||
C eval keyoff = 56 offset to keys
|
||||
C eval keys = #keys # of keys
|
||||
C eval lanoff = 0 language offset
|
||||
C eval inoff = 0 no input files
|
||||
C eval #infil = 0 no input files
|
||||
C eval outoff = 0 no out files
|
||||
C eval #outfi = 0 no out files
|
||||
C eval fill02 = 0
|
||||
*
|
||||
* Fill the key field area.
|
||||
B001 C 1 do #keys i
|
||||
001 C eval i1 = i - 1
|
||||
001 C eval i1 = i1 * 4
|
||||
001 C eval i1 = i1 + 1
|
||||
001 C eval i2 = i1 + 1
|
||||
001 C eval i3 = i2 + 1
|
||||
001 C eval i4 = i3 + 1
|
||||
001 *
|
||||
001 * Convert start position to binary and place into array.
|
||||
001 C eval binary = st(i)
|
||||
001 C movel alpha ky(i1)
|
||||
001 *
|
||||
001 * Convert key length to binary and place into array.
|
||||
001 C eval binary = ln(i)
|
||||
001 C movel alpha ky(i2)
|
||||
001 *
|
||||
001 * Convert data type to binary and place into array.
|
||||
B002 C select
|
||||
002 C when dt(i) = 'Z' zoned decimal
|
||||
002 C eval binary = 2
|
||||
002 C when dt(i) = 'B' binary
|
||||
002 C eval binary = 0
|
||||
002 C when dt(i) = 'P' packed decimal
|
||||
002 C eval binary = 3
|
||||
002 C other all else
|
||||
002 C eval binary = 6
|
||||
E002 C endsl
|
||||
001 *
|
||||
001 C movel alpha ky(i3)
|
||||
001 *
|
||||
001 * Convert the sort order to binary and place into array.
|
||||
B002 C if ad(i) = 'D' descend
|
||||
002 C eval binary = 2
|
||||
X002 C else
|
||||
002 C eval binary = 1
|
||||
E002 C endif
|
||||
001 *
|
||||
001 C movel alpha ky(i4)
|
||||
E001 C enddo
|
||||
*
|
||||
C endsr
|
||||
*-----------------------------------------------------------------------
|
||||
* PRCPGM: Process program.
|
||||
*
|
||||
C prcpgm begsr
|
||||
*
|
||||
* Now that the sort control block is built, initialize
|
||||
* the sort routine and get it ready to accept records.
|
||||
*
|
||||
C eval errlen = 272 avail space
|
||||
*
|
||||
C call 'QLGSORT' 01
|
||||
C parm sort control block
|
||||
C parm inbuff input buffer
|
||||
C parm oubuff output buffer
|
||||
C parm 0 parm3 not used
|
||||
C parm 0 parm4 not used
|
||||
C parm error error ds
|
||||
*
|
||||
C exsr chk4er
|
||||
*
|
||||
* Pass a block of records to the sort routine. The block
|
||||
* can contain up to 9,000 bytes.
|
||||
*
|
||||
C eval #recs = 9000 / rcdlen number of recs
|
||||
C eval intype = 1 put records
|
||||
C eval infil1 = 0 not used
|
||||
C eval inlen = rcdlen rec len
|
||||
C eval inrecs = #recs
|
||||
C eval totrec = 0
|
||||
* Do for blocks of records:
|
||||
B001 C dow totrec < nbrent
|
||||
001 C eval totrec = totrec + #recs
|
||||
B002 C if totrec > nbrent
|
||||
002 C eval tmp50 = totrec - nbrent
|
||||
002 C eval inrecs = inrecs - tmp50
|
||||
E002 C endif
|
||||
001 C eval lendta = rcdlen * inrecs
|
||||
001 * Retrieve a block of records.
|
||||
001 C call 'QUSRTVUS' 01
|
||||
001 C parm spacer
|
||||
001 C parm strpos
|
||||
001 C parm lendta
|
||||
001 C parm indta
|
||||
001 *
|
||||
001 C exsr chk4er
|
||||
001 * Send them to the sort routine.
|
||||
001 C call 'QLGSRTIO' 01
|
||||
001 C parm sortin
|
||||
001 C parm indta
|
||||
001 C parm outdta
|
||||
001 C parm outlen
|
||||
001 C parm sortou
|
||||
001 C parm error
|
||||
001 *
|
||||
001 C exsr chk4er
|
||||
001 *
|
||||
001 C eval strpos = strpos + lendta
|
||||
E001 C enddo
|
||||
*
|
||||
* Tell the sort routine we are all done.
|
||||
C eval intype = 2 end put
|
||||
C call 'QLGSRTIO' 01
|
||||
C parm sortin
|
||||
C parm indta
|
||||
C parm outdta
|
||||
C parm outlen
|
||||
C parm sortou
|
||||
C parm error
|
||||
*
|
||||
C exsr chk4er
|
||||
*
|
||||
* Retrieve records from the sort and place back into user space.
|
||||
C eval intype = 3 get records
|
||||
C eval strpos = offset
|
||||
C eval strpos = strpos + 1
|
||||
C eval inrecs = #recs
|
||||
C eval totrec = 0
|
||||
*
|
||||
* Do for blocks of records:
|
||||
B001 C dow totrec < nbrent
|
||||
001 C eval totrec = totrec + #recs
|
||||
B002 C if totrec > nbrent
|
||||
002 C eval tmp50 = totrec - nbrent
|
||||
002 C eval inrecs = inrecs - tmp50
|
||||
E002 C endif
|
||||
001 C eval lendta = rcdlen * inrecs
|
||||
001 * Retrieve a block of records.
|
||||
001 C call 'QLGSRTIO' 01
|
||||
001 C parm sortin
|
||||
001 C parm indta
|
||||
001 C parm outdta
|
||||
001 C parm outlen
|
||||
001 C parm sortou
|
||||
001 C parm error
|
||||
001 *
|
||||
001 C exsr chk4er
|
||||
001 * Place them back into user space.
|
||||
001 C call 'QUSCHGUS' 01
|
||||
001 C parm spacer
|
||||
001 C parm strpos
|
||||
001 C parm lendta
|
||||
001 C parm outdta
|
||||
001 C parm '2' force
|
||||
001 *
|
||||
001 C exsr chk4er
|
||||
001 *
|
||||
001 C eval strpos = strpos + lendta
|
||||
E001 C enddo
|
||||
*
|
||||
C endsr
|
||||
*-----------------------------------------------------------------------
|
||||
* *PSSR: Error handling subroutine.
|
||||
*
|
||||
C *pssr begsr
|
||||
C move *on exiter
|
||||
C move *on *inlr
|
||||
C return
|
||||
C endsr
|
||||
*-----------------------------------------------------------------------
|
||||
* TRMPGM: Terminate program.
|
||||
*
|
||||
C trmpgm begsr
|
||||
* All done.
|
||||
C move *on *inlr
|
||||
*
|
||||
C endsr
|
||||
Reference in New Issue
Block a user