Program BXACOPY

© Copyright B.V. Bixoft 1999-2003. All rights reserved.

Copy data from any format to any format

This program makes use of various macros from Bixoft's eXtended Assembly language. For your convenience the non-trivial macros are described here. For a complete overview, please refer to the Macro overview page on this site.

Macro Short description
PGM Program entry logic, including DSECT mappings
MAP$COPY Invoked by PGM, maps the private area of BXACOPY
EQUREG Assigns the number of an available register
USE Replaces USING, keeps track of registers in use on behalf of EQUREG, even when they are not used to address data
IF Specifies a condition
CPY Copies a field or register, depending on argument type
MVPL MoVes a Parameter List from constants area to dynamic area
DEC Decrements a register
SET SETs a pointer in a field or register
SETON Turns on a named bit
SETOF Turns off a named bit
EXTRT EXecutes a TRT instruction
EXMVC EXecutes a MVC instruction
EXSR EXecutes a SubRoutine
BEGSR BEGins a SubRoutine
ENDSR ENDs a SubRoutine
GOTO Branches to a label, if the specified condition is met

This software is free; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version.
More information is available from the Free Software Foundation or the Open Source Initiative.

This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.

You should have received a copy of the GNU General Public License along with this software; if not, write to either of the following:

the Free Software Foundation, Inc.
59 Temple Place, Suite 330
Boston, MA 02111-1307
United States of America
B.V. Bixoft
Rogge 9
7261 JA Ruurlo
The Netherlands
  email: bixoft@bixoft.nl
phone: +31-6-22755401

Remark:
This software - and more programs and macros - are available in a format more suitable for uploading to your mainframe. Please e-mail B.V. Bixoft with your request and you will receive a zipped IEBUPDTE job with the program sources.


*                                                                       00000100
* This program is free software; you can redistribute it and/or modify  00000200
* it under the terms of the GNU General Public License as published by  00000300
* the Free Software Foundation; either version 2 of the License         00000400
* or (at your option) any later version.                                00000500
* The license text is available at the following internet addresses:    00000600
* - http://www.bixoft.com/english/gpl.htm                               00000700
* - http://fsf.org                                                      00000800
* - http://opensource.org                                               00000900
*                                                                       00001000
* This program is distributed in the hope that it will be useful,       00001100
* but WITHOUT ANY WARRANTY; without even the implied warranty of        00001200
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                  00001300
* See the GNU General Public License for more details.                  00001400
*                                                                       00001500
* You should have received a copy of the GNU General Public License     00001600
* along with this program; if not, write to either of the following:    00001700
* the Free Software Foundation, Inc.      B.V. Bixoft                   00001800
* 59 Temple Place, Suite 330              Rogge 9                       00001900
* Boston, MA 02111-1307                   7261 JA Ruurlo                00002000
* United States of America                The Netherlands               00002100
*                                                                       00002200
*                                         e-mail: bixoft@bixoft.nl      00002300
*                                         phone : +31-6-22755401        00002400
*                                                                       00002500
*PROCESS FLAG(SUBSTR)                                                   00010000
*PROCESS RENT                                                           00020000
*********************************************************************** 00030000
*                                                                       00040000
* BIXXAMS - Bixoft Cross Access Method Services                         00050000
* Licensed material - Property of B.V. Bixoft                           00060000
*                                                                       00070000
* This program can be licensed or used on an as-is basis.               00080000
* No warranty, neither implicit nor explicit, is given.                 00090000
* It remains your own responsibility to ensure the correct              00100000
* working of this program in your installation.                         00110000
*                                                                       00120000
* Suggestions for improvement are always welcome at                     00130000
* http://www.bixoft.com  or mail to  bixoft@bixoft.nl                   00140000
*                                                                       00150000
* (C) Copyright B.V. Bixoft, 1999-2001                                  00160000
*********************************************************************** 00170000
*                                                                       00180000
* This program will copy a member from a PDS concatenation              00190000
*                     or a physical sequential dataset concatenation    00200000
*                                                                       00210000
*********************************************************************** 00220000
*                                                                       00230000
* Input:  parameter specifying 'MEMBER=memname'                         00240000
*                           or 'DATSET=PS'                              00250000
*         INPUT  dd-statement giving the input dataset(s)               00260000
* OUTPUT: OUTPUT dd-statement specifying the dataset to create          00270000
*                                                                       00280000
* For MEMBER=memname the INPUT concatenation of PDS'es will             00290000
*     be searched for the specified member, which will then             00300000
*     be copied to OUTPUT.                                              00310000
* For DATSET=PS the INPUT concatenation of physical sequential files    00320000
*     will be copied to OUTPUT.                                         00330000
*                                                                       00340000
* IEBCOPY does more, but needs control cards for its input,             00350000
*         which cannot be substituted from JCL variables.               00360000
* IEHLIST will also copy datasets, but it also lists all                00370000
*         records, filling up the spool.                                00380000
*                                                                       00390000
*********************************************************************** 00400000
         PGM   VERSION=V00R00M00,      * Version number                *00410000
               HDRTXT='Bixxams copy utility',                          *00420000
               WORKAREA=COPY,          * Dynamic area                  *00430000
               SAVES=4,                * Internal save-areas           *00440000
               ABND=4090,              * Abend code                    *00450000
               MAPS=($COPY,            * Private mapping macros        *00460000
               DCB,DCBE,DECB,IOB,SDWA)                                  00470000
*                                                                       00480000
* Assign some global registers                                          00490000
R_RCD    EQUREG ,                      * Assign retcode register        00500000
         USE   R_RCD,SCOPE=CALLED      * Set register in use            00510000
R_TMP    EQU   R_RCD                   * retcode reg also temp reg      00520000
R_LEN    EQUREG ,                      * Assign length register         00530000
         USE   R_LEN,SCOPE=CALLED      * Set length reg in use          00540000
R_RSN    EQU   R_LEN                   * length reg also reson reg      00550000
*                                                                       00560000
* Assign registers for input parm parsing                               00570000
R_PTR1   EQUREG ,                      * Ptr to first operand           00580000
         USE   R_PTR1                  * Set register in use            00590000
R_PTR2   EQUREG ,                      * Ptr to second operand          00600000
         USE   R_PTR2                  * Set register in use            00610000
R_LEN1   EQUREG ,                      * Length of first operand        00620000
         USE   R_LEN1                  * Set register in use            00630000
R_LEN2   EQUREG ,                      * Length of second operand       00640000
         USE   R_LEN2                  * Set register in use            00650000
*                                                                       00660000
* Retrieve JCL parameter - if specified - and save in R_PTR1            00670000
         IF    R1,Z                    * Pointer to parmlist valid?     00680000
          ABND ,                       * No: issue error                00690000
         ENDIF ,                       *                                00700000
         L     R_PTR1,0(,R1)           * Retrieve ptr to JCL parm       00710000
         CLEAR (R_PTR1,*ADDR)          * Wipe hi-order bit              00720000
         IF    R_PTR1,Z                * If it is invalid               00730000
          ABND ,                       * issue error                    00740000
         ENDIF ,                       *                                00750000
         LH    R_LEN1,0(R_PTR1)        * First halfword is length       00760000
         INC   R_PTR1,2                * Point start of text of parm    00770000
         IF    R_LEN1,GT,256           * If it is too long              00780000
          ABND ,                       * Issue error                    00790000
         ENDIF ,                       *                                00800000
         IF    R_LEN1,Z                * If no parm was specified       00810000
          ABND ,                       * Issue error                    00820000
         ENDIF ,                       *                                00830000
*                                                                       00840000
* Find equal sign in input string                                       00850000
         L     R_TMP,=A(TRTAB1)        * Point table to be used         00860000
         EXTRT 0(R_LEN1,R_PTR1),0(R_TMP) * Search first equal sign      00870000
         ABND  Z                       * Abend if not found             00880000
*                                                                       00890000
* Determine length of operand 1 and remainder of string                 00900000
         LA    R_PTR2,1(,R1)           * Point after equal sign         00910000
         CPY   R_LEN2,R_LEN1           * Copy string length             00920000
         CPY   R_TMP,R1                * Delimiter location             00930000
         SR    R_TMP,R_PTR1            * Nr of chars in first operand   00940000
         ABND  Z                       * Empty operand is error         00950000
         CPY   R_LEN1,R_TMP            * Set length of operand 1        00960000
         SR    R_LEN2,R_LEN1           * Remaining string length        00970000
         DEC   R_LEN2                  *    after delimiter             00980000
         IF    R_LEN2,LE,0             * Something left?                00990000
          ABND ,                       * No: error                      01000000
         ENDIF ,                       *                                01010000
*                                                                       01020000
* Operand 1 must be a valid keyword                                     01030000
         CASE  R_LEN1,EQ,6             * Length must be 6               01040000
          CASE E,CLC,=CL6'MEMBER',0(R_PTR1),NEST=YES * MEMBER copy?     01050000
           SETON COPYMEM               * Yes: indicate member copy      01060000
          CASE E,CLC,=CL6'DATSET',0(R_PTR1) * Dataset copy?             01070000
           SETON COPYDS                * Yes: indicate dataset copy     01080000
          ELSE ,                       *                                01090000
           ABND ,                      * Invalid keyword                01100000
          ENDCASE ,                    *                                01110000
         ELSE  ,                       * Other keyword lengths          01120000
          ABND ,                       * Invalid keyword length         01130000
         ENDCASE ,                     *                                01140000
*                                                                       01150000
* Test operand 2 for validity                                           01160000
         CASE  COPYMEM                 * Copy member requested?         01170000
          IF   R_LEN2,GT,8             * Length max is 8                01180000
           ABND ,                      * Member name too long           01190000
          ENDIF ,                      *                                01200000
          CLEAR COPYMBNM               * Wipe member name               01210000
          EXMVC COPYMBNM(R_LEN2),0(R_PTR2) * Copy member name           01220000
         CASE  COPYDS                  * Copy dataset requested?        01230000
          IF   R_LEN2,NE,2             * Length must be 2               01240000
           ABND ,                      * Wrong organisation             01250000
          ENDIF ,                      *                                01260000
          IF   E,CLC,=CL2'PS',0(R_PTR2) * Physical Sequential?          01270000
           SETON COPYPS                * Indicate PS copy request       01280000
          ENDIF ,                      *                                01290000
         ENDCASE ,                     *                                01300000
*                                                                       01310000
* Input string processing complete: drop used registers                 01320000
         DROP  R_PTR1                  *                                01330000
         DROP  R_PTR2                  *                                01340000
         DROP  R_LEN1                  *                                01350000
         DROP  R_LEN2                  *                                01360000
*                                                                       01370000
* Set up recovery environment                                           01380000
         MVPL  COPYESTAE,CPY_ESTAE     * Copy ESTAE parmlist            01390000
         ESTAE RECOVER,CT,             * Create new ESTAE-environment  *01400000
               PARAM=(R13),            * Pass COPY as parameter field  *01410000
               MF=(E,COPYESTAE)        *                                01420000
         ABND  TSTRC,RCD=(R_RCD,R_RSN) * Abend on error                 01430000
                                                                        01440000
*                                                                       01450000
* Perform requested function                                            01460000
         CASE  COPYMEM                 * Member copy?                   01470000
          EXSR CPYMEM                  * Ok: copy a member              01480000
         CASE  COPYPS                  * PS copy?                       01490000
          EXSR CPYPS                   * Ok: copy a PS dataset          01500000
         ENDCASE ,                                                      01510000
*                                                                       01520000
* Remove ESTAE environment                                              01530000
         MVPL  COPYESTAE,CPY_ESTAE     * Copy ESTAE parmlist            01540000
         ESTAE 0,                      * Remove our ESTAE-environment  *01550000
               MF=(E,COPYESTAE)        *                                01560000
         ABND  TSTRC,RCD=(R_RCD,R_RSN) * Abend on error                 01570000
*                                                                       01580000
* And exit program                                                      01590000
         RETRN RC=0                    * Quit this program              01600000
*********************************************************************** 01610000
*                                                                       01620000
* Routine to copy a PDS member                                          01630000
*                                                                       01640000
*********************************************************************** 01650000
CPYMEM   BEGSR ,                                                        01660000
*                                                                       01670000
* Allocate input DCB and DCBE in the workarea                           01680000
         MVPL  COPYDCBP,CPY_DCBP       * Copy input DCB                 01690000
         MVPL  COPYDCBE,CPY_DCBE       * Copy DCBE to be used           01700000
IN       USE   DCB,COPYDCBP            * Set DCB fields addressable     01710000
         USE   DCBE,COPYDCBE           * Set DCBE fields addressable    01720000
         SET   IN.DCBDCBE,COPYDCBE     * Point from DCB to DCBE         01730000
         SET   DCBEEODA,EODADRTN       * Point to EODAD routine         01740000
*                                                                       01750000
* Open the input PDS (concatenation)                                    01760000
         MVPL  COPYOPEN,CPY_OPEN       * Copy open parmlist             01770000
         OPEN  (COPYDCBP,INPUT),       * Open the input dataset(s)     *01780000
               MF=(E,COPYOPEN)         *                                01790000
         ABND  TSTRC,RCD=R_RCD         * Abend on failure               01800000
*                                                                       01810000
* Allocate and open the output DCB in the workarea                      01820000
         MVPL  COPYDCBO,CPY_DCBO       * Copy output DCB                01830000
OUT      USE   DCB,COPYDCBO            * Set DCB fields addressable     01840000
CPYMEM_OPEN LABEL ,                    *                                01850000
         MVPL  COPYOPEN,CPY_OPEN       * Copy open parmlist             01860000
         OPEN  (COPYDCBO,OUTPUT),      * Open the output dataset       *01870000
               MF=(E,COPYOPEN)         *                                01880000
         ABND  TSTRC,RCD=R_RCD         * Abend on failure               01890000
*                                                                       01900000
* Locate the required input member                                      01910000
         FIND  COPYDCBP,COPYMBNM,D     * Locate required member         01920000
         ABND  TSTRC,RCD=R_RCD         * Abend on failure               01930000
*                                                                       01940000
* Allocate 1 buffer for the BPAM input dataset                          01950000
R_BUFP   EQUREG ,                      * Assign buffer ptr              01960000
         USE   R_BUFP                  * Set ptr in use                 01970000
         CPY   R_LEN,IN.DCBBLKSI       * Obtain input block size        01980000
         STORAGE OBTAIN,LOC=ANY,       * Get storage above the line    *01990000
               LENGTH=(R_LEN)          *   for a single block           02000000
         CPY   R_BUFP,R1               * Set ptr to buffer              02010000
         CPY   COPYBUFI,R_BUFP         * And save buffer address        02020000
*                                                                       02030000
* Allocate 1 buffer for an output record                                02040000
R_BUFO   EQUREG ,                      * Assign buffer ptr              02050000
         USE   R_BUFO                  * Set ptr in use                 02060000
         CPY   R_LEN,OUT.DCBLRECL      * Obtain (max) output lrecl      02070000
         STORAGE OBTAIN,LOC=ANY,       * Get storage above the line    *02080000
               LENGTH=(R_LEN)          *   for a single block           02090000
         CPY   R_BUFO,R1               * Set ptr to buffer              02100000
         CPY   COPYBUFO,R_BUFO         * And save buffer address        02110000
*                                                                       02120000
* Loop to read all blocks in the member                                 02130000
         DO    UNTIL,COPYEOF           * Until EOF detected             02140000
          MVPL COPYDECB,CPY_DECB       * Set up initial DECB            02150000
          USE  DECB,COPYDECB           * Set DECB fields addressable    02160000
          CPY  R_TMP,R_BUFP            * Set ptr to BPAM buffer         02170000
          READ COPYDECB,SF,            * Read forward                  *02180000
               COPYDCBP,(R_TMP),'S',   *  1 block from input dataset   *02190000
               MF=E                    *                                02200000
          CHECK COPYDECB               * Wait for READ to complete      02210000
          IF   NOT,COPYEOF             * Valid block was read?          02220000
* For Fixed records: use IOB to determine end-of-buffer                 02230000
* For Variable records: use BDW to determine end-of-buffer              02240000
           IF  IN.DCBRECF              * Fixed or FB input records?     02250000
            CPY R_LEN,IN.DCBBLKSI      * Load input block length        02260000
R_IOB       EQUREG ,                   * Assign IOB ptr                 02270000
            USE IOBSTDRD,R_IOB         * Set IOB addressable            02280000
            CPY R_IOB,DECIOBPT         * And point to IOB               02290000
            CPY R_TMP,IOBRESCT         * Load residual count            02300000
            DROP R_IOB                 * IOB no longer needed           02310000
            SR R_LEN,R_TMP             * Nr of bytes in input buffer    02320000
            AR R_LEN,R_BUFP            * Point past end of data         02330000
            ST R_LEN,COPYBUFE          * Save end-of-block ptr          02340000
            ST R_BUFP,COPYREC          * Set ptr to current record      02350000
           ELSE  ,                     * Must be variable or VB records 02360000
R_BDW       EQUREG ,                   * Assign buffer ptr              02370000
            USE BDW,R_BDW              * Address block descriptor word  02380000
            CPY R_BDW,R_BUFP           * Point to filled buffer         02390000
            CPY R_LEN,BDWBLKLN         * Retrieve length of block       02400000
            AR  R_LEN,R_BUFP           * Point past end of data         02410000
            ST  R_LEN,COPYBUFE         * Set ptr to end of buffer       02420000
            LA  R_TMP,BDW_LEN(,R_BUFP) * Point to first RDW in buffer   02430000
            CPY COPYREC,R_TMP          * Set ptr to current record      02440000
            DROP R_BDW                 * Buffer ptr no longer needed    02450000
           ENDIF ,                     *                                02460000
           EXSR CPYBLK                 * Go copy a block to output      02470000
          ENDIF ,                      *                                02480000
         ENDDO ,                       *                                02490000
*                                                                       02500000
* Free the output record buffer                                         02510000
         CPY   R_LEN,OUT.DCBLRECL      * Obtain output record length    02520000
         STORAGE RELEASE,ADDR=(R_BUFO), * Free storage allocated       *02530000
               LENGTH=(R_LEN)          *   for a single record          02540000
         DROP  R_BUFO                  * Buffer ptr no longer valid     02550000
         CLEAR COPYBUFO                * And wipe ptr in storage too    02560000
*                                                                       02570000
* Free the input buffer                                                 02580000
         CPY   R_LEN,IN.DCBBLKSI       * Obtain input block size        02590000
         STORAGE RELEASE,ADDR=(R_BUFP), * Free storage allocated       *02600000
               LENGTH=(R_LEN)          *   for a single block           02610000
         DROP  R_BUFP                  * Buffer ptr no longer valid     02620000
         CLEAR COPYBUFI                * And wipe ptr in storage too    02630000
*                                                                       02640000
* Close the input PDS (concatenation)                                   02650000
         MVPL  COPYCLOS,CPY_CLOS       * Copy close parmlist            02660000
         CLOSE (COPYDCBP),MF=(E,COPYCLOS) * Close the input dataset(s)  02670000
         ABND  TSTRC,RCD=R_RCD         * Abend on failure               02680000
*                                                                       02690000
* Close the output dataset                                              02700000
         MVPL  COPYCLOS,CPY_CLOS       * Copy close parmlist            02710000
         CLOSE (COPYDCBO),MF=(E,COPYCLOS) * Close the input dataset(s)  02720000
         ABND  TSTRC,RCD=R_RCD         * Abend on failure               02730000
*                                                                       02740000
* Release registers                                                     02750000
         DROP  R_RCD                   *                                02760000
         DROP  R_LEN                   *                                02770000
*                                                                       02780000
         ENDSR ,                                                        02790000
*********************************************************************** 02800000
*                                                                       02810000
* Routine to copy a sequential dataset (or concatenation)               02820000
*                                                                       02830000
*********************************************************************** 02840000
CPYPS    BEGSR ,                                                        02850000
*                                                                       02860000
* Allocate input DCB and DCBE in the workarea                           02870000
         MVPL  COPYDCBS,CPY_DCBS       * Copy input DCB                 02880000
         MVPL  COPYDCBE,CPY_DCBE       * Copy DCBE to be used           02890000
IN       USE   DCB,COPYDCBS            * Set DCB fields addressable     02900000
         USE   DCBE,COPYDCBE           * Set DCBE fields addressable    02910000
         SET   IN.DCBDCBE,COPYDCBE     * Point from DCB to DCBE         02920000
         SET   DCBEEODA,EODADRTN       * Point to EODAD routine         02930000
*                                                                       02940000
* Open the input dataset or concatenation                               02950000
         MVPL  COPYOPEN,CPY_OPEN       * Copy open parmlist             02960000
         OPEN  (COPYDCBS,INPUT),       * Open the input dataset(s)     *02970000
               MF=(E,COPYOPEN)         *                                02980000
         ABND  TSTRC,RCD=R_RCD         * Abend on failure               02990000
*                                                                       03000000
* Allocate and open the output DCB in the workarea                      03010000
         MVPL  COPYDCBO,CPY_DCBO       * Copy output DCB                03020000
OUT      USE   DCB,COPYDCBO            * Set DCB fields addressable     03030000
CPYPS_OPEN LABEL ,                     *                                03040000
         MVPL  COPYOPEN,CPY_OPEN       * Copy open parmlist             03050000
         OPEN  (COPYDCBO,OUTPUT),      * Open the output dataset       *03060000
               MF=(E,COPYOPEN)         *                                03070000
         ABND  TSTRC,RCD=R_RCD         * Abend on failure               03080000
*                                                                       03090000
* Allocate 1 buffer for the input BSAM dataset                          03100000
R_BUFS   EQUREG ,                      * Assign buffer ptr              03110000
         USE   R_BUFS                  * Set ptr in use                 03120000
         CPY   R_LEN,IN.DCBBLKSI       * Obtain input block size        03130000
         STORAGE OBTAIN,LOC=ANY,       * Get storage above the line    *03140000
               LENGTH=(R_LEN)          *   for a single block           03150000
         CPY   R_BUFS,R1               * Set ptr to buffer              03160000
         CPY   COPYBUFI,R_BUFS         * And save buffer address        03170000
*                                                                       03180000
* Allocate 1 buffer for an output record                                03190000
* R_BUFO EQUREG ,                      * Assigned in CPYMEM routine!    03200000
         USE   R_BUFO                  * Set ptr in use                 03210000
         CPY   R_LEN,OUT.DCBLRECL      * Obtain (max) output lrecl      03220000
         STORAGE OBTAIN,LOC=ANY,       * Get storage above the line    *03230000
               LENGTH=(R_LEN)          *   for a single block           03240000
         CPY   R_BUFO,R1               * Set ptr to buffer              03250000
         CPY   COPYBUFO,R_BUFO         * And save buffer address        03260000
*                                                                       03270000
* Loop to read all blocks in the dataset                                03280000
         DO    UNTIL,COPYEOF           * Until EOF detected             03290000
          MVPL COPYDECB,CPY_DECB       * Set up initial DECB            03300000
          USE  DECB,COPYDECB           * Set DECB fields addressable    03310000
          CPY  R_TMP,R_BUFS            * Set ptr to BSAM buffer         03320000
          READ COPYDECB,SF,            * Read forward                  *03330000
               COPYDCBS,(R_TMP),'S',   *  1 block from input dataset   *03340000
               MF=E                    *                                03350000
          CHECK COPYDECB               * Wait for READ to complete      03360000
          IF   NOT,COPYEOF             * Valid block was read?          03370000
* For Fixed records: use IOB to determine end-of-buffer                 03380000
* For Variable records: use BDW to determine end-of-buffer              03390000
           IF  IN.DCBRECF              * Fixed or FB input records?     03400000
            CPY R_LEN,IN.DCBBLKSI      * Load input block length        03410000
            USE IOBSTDRD,R_IOB         * Set IOB addressable            03420000
            CPY R_IOB,DECIOBPT         * And point to IOB               03430000
            CPY R_TMP,IOBRESCT         * Load residual count            03440000
            DROP R_IOB                 * IOB no longer needed           03450000
            SR R_LEN,R_TMP             * Nr of bytes in input buffer    03460000
            AR R_LEN,R_BUFS            * Point past end of data         03470000
            ST R_LEN,COPYBUFE          * Save end-of-block ptr          03480000
            ST R_BUFS,COPYREC          * Set ptr to current record      03490000
           ELSE  ,                     * Must be variable or VB records 03500000
            USE BDW,R_BDW              * Address block descriptor word  03510000
            CPY R_BDW,R_BUFS           * Point to filled buffer         03520000
            CPY R_LEN,BDWBLKLN         * Retrieve length of block       03530000
            AR  R_LEN,R_BUFS           * Point past end of data         03540000
            ST  R_LEN,COPYBUFE         * Set ptr to end of buffer       03550000
            LA  R_TMP,BDW_LEN(,R_BUFS) * Point to first RDW in buffer   03560000
            CPY COPYREC,R_TMP          * Set ptr to current record      03570000
            DROP R_BDW                 * Buffer ptr no longer needed    03580000
           ENDIF ,                     *                                03590000
           EXSR CPYBLK                 * Go copy a block to output      03600000
          ENDIF ,                      *                                03610000
         ENDDO ,                       *                                03620000
*                                                                       03630000
* Free the output record buffer                                         03640000
         CPY   R_LEN,OUT.DCBLRECL      * Obtain output record length    03650000
         STORAGE RELEASE,ADDR=(R_BUFO), * Free storage allocated       *03660000
               LENGTH=(R_LEN)          *   for a single record          03670000
         DROP  R_BUFO                  * Buffer ptr no longer valid     03680000
         CLEAR COPYBUFO                * And wipe ptr in storage too    03690000
*                                                                       03700000
* Free the BSAM input buffer                                            03710000
         CPY   R_LEN,IN.DCBBLKSI       * Obtain input block size        03720000
         STORAGE RELEASE,ADDR=(R_BUFS), * Free storage allocated       *03730000
               LENGTH=(R_LEN)          *   for a single block           03740000
         DROP  R_BUFS                  * Buffer ptr no longer valid     03750000
         CLEAR COPYBUFI                * And wipe ptr in storage too    03760000
*                                                                       03770000
* Close the input dataset (or concatenation)                            03780000
         MVPL  COPYCLOS,CPY_CLOS       * Copy close parmlist            03790000
         CLOSE (COPYDCBS),MF=(E,COPYCLOS) * Close the input dataset(s)  03800000
         ABND  TSTRC,RCD=R_RCD         * Abend on failure               03810000
*                                                                       03820000
* Close the output dataset                                              03830000
         MVPL  COPYCLOS,CPY_CLOS       * Copy close parmlist            03840000
         CLOSE (COPYDCBO),MF=(E,COPYCLOS) * Close the input dataset(s)  03850000
         ABND  TSTRC,RCD=R_RCD         * Abend on failure               03860000
*                                                                       03870000
* Release registers                                                     03880000
         DROP  R_RCD                   *                                03890000
         DROP  R_LEN                   *                                03900000
*                                                                       03910000
         ENDSR ,                                                        03920000
*********************************************************************** 03930000
*                                                                       03940000
* Routine to write an entire block                                      03950000
*                                                                       03960000
* At entry: COPYREC  points to first record in buffer                   03970000
*           COPYBUFE points to end-of-buffer                            03980000
*           COPYBUFO points to output record buffer                     03990000
*                                                                       04000000
*********************************************************************** 04010000
CPYBLK   BEGSR ,                                                        04020000
*                                                                       04030000
* Set up to loop thru the block                                         04040000
         CPY   R_BUFO,COPYBUFO         * Point to output record area    04050000
         USE   R_BUFO                  * and set register in use        04060000
*                                                                       04070000
R_REC    EQUREG ,                      * Assign record ptr              04080000
RDWIN    USE   RDW,R_REC               * Assume RECFM=V or VB           04090000
*                                                                       04100000
* No distinction is made between COPYDCBP (BPAM) and COPYDCBS (BSAM)    04110000
IN       USE   DCB,COPYDCBP            * Set DCB fields addressable     04120000
OUT      USE   DCB,COPYDCBO            * Set DCB fields addressable     04130000
*                                                                       04140000
* For each record in the buffer:                                        04150000
* - determine length, advance current record pointer                    04160000
* - copy record, truncate if too long, pad if too short                 04170000
* - write record to output dataset                                      04180000
*                                                                       04190000
         DO    WHILE,COPYREC,LT,COPYBUFE * For each record in buffer    04200000
*         Determine length, advance current record pointer              04210000
          CPY  R_REC,COPYREC           * Copy ptr to current record     04220000
          IF   IN.DCBRECF              * Fixed record length:           04230000
           CPY R_LEN,IN.DCBLRECL       * Retrieve rec length from DCB   04240000
           CPY R_TMP,R_REC             * Copy current record ptr        04250000
           INC R_TMP,(R_LEN)           * Point to next record           04260000
           CPY COPYREC,R_TMP           * Update current record ptr      04270000
          ELSE ,                       * Variable records:              04280000
           CPY R_LEN,RDWIN.RDWRECLN    * Retrieve length of record      04290000
           CPY R_TMP,R_REC             * Copy current record pointer    04300000
           INC R_TMP,(R_LEN)           * Point next record in buffer    04310000
           CPY COPYREC,R_TMP           * Update current record pointer  04320000
           INC R_REC,RDW_LEN           * Point to start of record data  04330000
           DEC R_LEN,RDW_LEN           * And adjust data length         04340000
          ENDIF ,                      *                                04350000
*         R_REC now points data, R_LEN holds data length                04360000
*         Copy record, truncate if too long, pad if too short           04370000
          IF   OUT.DCBRECF             * Fixed record length:           04380000
           IF  R_LEN,GT,OUT.DCBLRECL   * Record is too long?            04390000
            CPY R_LEN,OUT.DCBLRECL     * Yes: truncate                  04400000
           ENDIF ,                     *                                04410000
           IF  R_LEN,LE,256            * Length is legal?               04420000
            EXMVC 0(R_LEN,R_BUFO),0(R_REC) * Copy the data              04430000
           ELSE ,                      * Length too large               04440000
            ABND ,                     *                                04450000
           ENDIF ,                     *                                04460000
           IF  R_LEN,LT,OUT.DCBLRECL   * Wipe remainder of buffer?      04470000
            LA R_TMP,0(R_BUFO,R_LEN)   * Yes: point to remainder start  04480000
            SH R_LEN,OUT.DCBLRECL      *      and set remainder size    04490000
            IF R_LEN,LE,256            * Length is legal?               04500000
             EXXC 0(R_LEN,R_TMP),0(R_TMP) * Wipe remainder              04510000
            ELSE ,                     * Length too large               04520000
             ABND ,                    *                                04530000
            ENDIF ,                    *                                04540000
           ENDIF ,                     * End of wipe for short records  04550000
          ELSE  ,                      * Must be V or VB records        04560000
           DROP R_BUFO                 * Drop to swap using status      04570000
RDWOUT     USE RDW,R_BUFO              * Record starts with a RDW       04580000
           INC R_LEN,RDW_LEN           * Add size of RDW to lrecl       04590000
           IF  R_LEN,GT,OUT.DCBLRECL   * Record is too long?            04600000
            CPY R_LEN,OUT.DCBLRECL     * Yes: truncate                  04610000
           ENDIF ,                     *                                04620000
           CPY RDWOUT.RDWRECLN,R_LEN   * Set length in RDW              04630000
           CLEAR RDWOUT.RDWT00         * Wipe trailing zeroes           04640000
           DEC R_LEN,RDW_LEN           * Reduce to data length          04650000
           IF  R_LEN,LE,256            * Length is legal?               04660000
            EXMVC RDW_LEN(R_LEN,R_BUFO),0(R_REC) * Copy the data        04670000
           ELSE ,                      * Length too large               04680000
            ABND ,                     *                                04690000
           ENDIF ,                     *                                04700000
          ENDIF ,                      * Output buffer now ready        04710000
*         Output buffer now complete: write record to output            04720000
          PUT  COPYDCBO,(R_BUFO)       * Write record to output dataset 04730000
         ENDDO ,                       *                                04740000
*                                                                       04750000
         ENDSR ,                       *                                04760000
*********************************************************************** 04770000
*                                                                       04780000
* Retry routine after System 013 abend                                  04790000
*                                                                       04800000
*********************************************************************** 04810000
RETRY013 BEGSR TYPE=RETRY              *                                04820000
*                                                                       04830000
IN       USE   DCB,COPYDCBS            * Set DCB fields addressable     04840000
OUT      USE   DCB,COPYDCBO            * Set DCB fields addressable     04850000
*                                                                       04860000
* Setup fresh output DCB                                                04870000
         MVPL  COPYDCBO,CPY_DCBO       * Copy output DCB                04880000
*                                                                       04890000
* Copy LRECL, BLKSIZE, and record format from input DCB                 04900000
         CPY   OUT.DCBBLKSI,IN.DCBBLKSI * Copy block size               04910000
         CPY   OUT.DCBLRECL,IN.DCBLRECL * Copy record length            04920000
         CPY   OUT.DCBRECFM,IN.DCBRECFM * Copy record format            04930000
*                                                                       04940000
* Retry the open                                                        04950000
         GOTO  CPYMEM_OPEN,COPYMEM     * Retry for member copy          04960000
         GOTO  CPYPS_OPEN,COPYPS       * Retry for PS dataset copy      04970000
         ABND  ,                       * Error!                         04980000
*                                                                       04990000
         DROP  IN                      * DCB fields no longer           05000000
         DROP  OUT                     *     needed                     05010000
*                                                                       05020000
         ENDSR ,                       *                                05030000
*********************************************************************** 05040000
*                                                                       05050000
* Constants etc.                                                        05060000
*                                                                       05070000
*********************************************************************** 05080000
         LTORG ,                       *                                05090000
*********************************************************************** 05100000
*                                                                       05110000
* Out-of-line routinse                                                  05120000
*                                                                       05130000
*********************************************************************** 05140000
EODADRTN LABEL H                       * Ensure alignment               05150000
         SETON COPYEOF                 * Indicate EOF reached           05160000
         BR    R14                     * Return                         05170000
*********************************************************************** 05180000
*                                                                       05190000
* Recovery routine                                                      05200000
*                                                                       05210000
*********************************************************************** 05220000
RECOVER  BEGSR TYPE=ESTAE,             * Estae recovery routine        *05230000
               LVL=1                   * For normal code                05240000
*                                                                       05250000
* Do we have an SDWA?                                                   05260000
         GOTO  RECPERC,R0,EQ,12        * No SDWA: percolate             05270000
*                                                                       05280000
* SDWA found                                                            05290000
R_SDWA   EQUREG ,                      *                                05300000
         LR    R_SDWA,R1               * Copy SDWA pointer              05310000
         USE   SDWA,R_SDWA             * And set SDWA addressable       05320000
*                                                                       05330000
* If registers at time of error unavailable: do not retry               05340000
         GOTO  SETRP0,SDWARPIV         * Regs not available: percolate  05350000
*                                                                       05360000
* This is a recoverable abend?                                          05370000
         CASE  SDWACMPC,EQ,=X'013000'  * System 013 is recoverable      05380000
          GOTO SYS013                  * Retry if original SVC abended  05390000
         ELSE  ,                       * All other abends               05400000
          GOTO SETRP0                  * Percolate                      05410000
         ENDCASE ,                     *                                05420000
         GOTO  SETRP0                  * Always percolate               05430000
*                                                                       05440000
* We encountered a S013 abend, meaning that open could not complete     05450000
* successfully. If reasoncode is 34 some DCB parameters are missing     05460000
* and must be copied from the input DCB before retrying the open.       05470000
SYS013   LABEL ,                       *                                05480000
R_PTRS   EQUREG ,                      * Assign ptr to pointers block   05490000
         USE   SDWAPTRS,R_PTRS         * And set it addressable         05500000
         L     R_PTRS,SDWAXPAD         * Point to pointers block        05510000
R_RC1    EQUREG ,                      * Assign ptr service extension 1 05520000
         USE   SDWARC1,R_RC1           * And set it addressable         05530000
         L     R_RC1,SDWASRVP          * Point to service extension 1   05540000
         GOTO  SETRP0,NOT,SDWARCF      * Reasoncode must be available   05550000
         GOTO  SETRP0,SDWAHRC,NE,52    * Reasoncode must be 34 hex      05560000
*                                                                       05570000
* Open failed due to incomplete DCB                                     05580000
IN       USE   DCB,COPYDCBS            * Set DCB fields addressable     05590000
OUT      USE   DCB,COPYDCBO            * Set DCB fields addressable     05600000
*                                                                       05610000
* Make sure input DCB is open and output DCB is not                     05620000
         GOTO  SETRP0,NOT,IN.DCBOFOPN  * No retry: input not open       05630000
         GOTO  SETRP0,OUT.DCBOFOPN     * No retry: output is open       05640000
*                                                                       05650000
* Make sure we don't retry more than once                               05660000
         GOTO  SETRP0,COPYRTRY         * No retry: retried before       05670000
         SETON COPYRTRY                * Indicate retry performed       05680000
*                                                                       05690000
* Setup for retry                                                       05700000
         L     R0,=AL4(RETRY013)       * Retrieve address of retry-rout 05710000
         B     SETRP4                  * And go retry                   05720000
*                                                                       05730000
         DROP  R_RC1                   * SDWARC1 not needed anymore     05740000
         DROP  R_PTRS                  * SDWAPTRS no longer needed      05750000
         DROP  R_SDWA                  * SDWA no longer needed          05760000
*                                                                       05770000
* Percolate                                                             05780000
SETRP0   LABEL ,                       * SETRP RC=0: percolate          05790000
         SETRP RC=0,                   * Retcode 0 to percolate        *05800000
               WKAREA=(R_SDWA)         * Point to SDWA                  05810000
         B     RECEXIT                 *                                05820000
*                                                                       05830000
* Tell system to retry                                                  05840000
SETRP4   LABEL ,                       * SETRP RC=4: retry              05850000
         SETRP RC=4,                   * Retcode 0 to percolate        *05860000
               WKAREA=(R_SDWA),        * Points to SDWA                *05870000
               DUMP=NO,                * Suppress dump                 *05880000
               RETADDR=(R0),           * Retry address in R0           *05890000
               RETREGS=YES,            * Restore registers from SDWA   *05900000
               FRESDWA=YES,            * Free SDWA before retry        *05910000
               RECORD=NO               * Do not record in LOGREC        05920000
         B     RECEXIT                 *                                05930000
*                                                                       05940000
* Percolate: no SDWA                                                    05950000
RECPERC  LABEL ,                       *                                05960000
         CLEAR R15                     * RC=0 to percolate              05970000
*                                                                       05980000
RECEXIT  LABEL ,                       *                                05990000
         ENDSR RC=*,                   * When RC=4 (retry)             *06000000
               KEEPREG=R0              *   R0 contains retry address    06010000
*********************************************************************** 06020000
*                                                                       06030000
* Indirectly addressable Plists and constants                           06040000
*                                                                       06050000
*********************************************************************** 06060000
TRTAB1   TRTAB ,                       * Select no characters          *06070000
               CHARS=(C'=')            * Except equal sign              06080000
*                                                                       06090000
CPY_ESTAE ESTAE 0,                     * Establish ESTAE routine       *06100000
               MF=L                    *                                06110000
*                                                                       06120000
CPY_DCBP DCB   DDNAME=INPUT,           * Model input DCB for BPAM      *06130000
               DSORG=PO,               * Partitioned organization      *06140000
               DCBE=CPY_DCBE,          * For use in 31-bit environment *06150000
               MACRF=R                 * And read-only                  06160000
*                                                                       06170000
CPY_DCBS DCB   DDNAME=INPUT,           * Model input DCB for BSAM      *06180000
               DSORG=PS,               * Physical sequential           *06190000
               DCBE=CPY_DCBE,          * For use in 31-bit environment *06200000
               MACRF=R                 * And read-only                  06210000
*                                                                       06220000
CPY_DCBE DCBE  EODAD=EODADRTN          * DCB-extension prototype        06230000
*                                                                       06240000
         READ  CPY_DECB,SF,MF=L        * DECB prototype                 06250000
*                                                                       06260000
CPY_DCBO DCB   DDNAME=OUTPUT,          * Model output DCB              *06270000
               DSORG=PS,               * Sequential file               *06280000
               MACRF=PM                * Use Put-Move                   06290000
*                                                                       06300000
CPY_OPEN OPEN  (0,INPUT),MF=L          *                                06310000
CPY_CLOS CLOSE (0),MF=L                *                                06320000
*                                                                       06330000
         END                                                            06340000

 

This site is a member of WebRing.
You are invited to browse the list of mainframe-loving sites.
Running
    Tyrannosaurus Rex Dinos are not dead. They are alive and well and living in data centers all around you. They speak in tongues and work strange magics with computers. Beware the dino! And just in case you're waiting for the final demise of these dino's: remember that dinos ruled the world for 155-million years!
Dinos and other anachronisms
[ Join Now | Ring Hub | Random | << Prev | Next >> ]
 

Below you find the logo of our sponsor and logos of the web-standards that this page adheres to.