IDENTIFICATION DIVISION. PROGRAM-ID. 'SOFMRPUT'. AUTHOR. LIMES DATENTECHNIK GMBH. * ****************************************************************** * * * PROGRAM: SOFMRPUT * * PURPOSE: STORE A SEQUENTIAL DATASET AS A MEMBER IN A * * FLAM5 ARCHIVE FILE ON THE USS FILESYSTEM * * * * DESCRIPTION: * * Reads records from DD:INPUT via the FLUC record interface * * and writes them as a named member into a FLAM5 archive. * * The archive file path is passed as the JCL PARM field. * * If the archive does not yet exist, it is created using the * * FLAM default compression (to.new). If the archive exists, * * the member is added or overwritten (to.mod MBRMODE= * * OVERWRITE). The member name and state (ORGF, RECF, RECL) * * are taken from the state string returned by FCROPN and * * applied via FMRSMS. FCRGFN is used only for display. * * * * REQUIRED DD-NAMES: * * INPUT - Sequential input dataset (any record format). * * Opened by FLUC as 'DD:INPUT'. * * SYSOUT - Program messages and compression statistics. * * * * PARM: * * USS pathname of the archive file (up to 255 characters). * * PARM is mandatory; the program aborts with RC=12 if absent. * * * * IMPORTANT -- the JCL PARM needs a leading delimiter slash * * and the step needs a CEEOPTS DD with CBLOPTS(OFF): * * * * //SOFMRP EXEC PGM=SOFMRPUT, * * // PARM='//u/user/datasets.flam' * * //CEEOPTS DD * * * CBLOPTS(OFF) * * /* * * * * Why: for a COBOL main, Language Environment defaults to * * CBLOPTS(ON), which reads PARM as * * 'program-parameters/runtime-options' and splits it at the * * LAST slash. A USS path contains slashes, so LE hands the * * last path component to the runtime-option parser and gives * * the program only the directory part. Symptom: message * * CEE3611I naming the file name as an invalid run-time * * option, then FMROPA fails with rc 57 'Open of file failed' * * / EDC5123I 'Is a directory' and the step ends with RC=12. * * * * This is LE-level dependent: z/OS 2.2 strips the component, * * z/OS 3.1 reports CEE3611I but still passes the whole * * string, so the same JCL can work on one system and fail on * * another. CBLOPTS(OFF) selects the 'runtime-options/ * * program-parameters' convention used by C and PL/I, which * * splits at the FIRST slash; the leading '//' therefore means * * 'no runtime options' followed by the path '/u/user/...'. * * * * FLMRECLB API CALLS (void, CALL linkage, load modules): * * FMROPN Open global FLAM session (env, z/OS STDENV) * * Param 1: piRtc Return code (OUT) * * Param 2: pcErr Error trace buffer (32768 bytes) * * Param 3: ppGbl Receives session handle (OUT) * * Param 4: piSys 1=load z/OS system variables * * Param 5: piStd 1=load DD:STDENV * * Param 6: piEnvLen Length of env string (0=none) * * Param 7: pcEnv Extra env assignments (NULL=none)* * Param 8: piLogLen Length of log string (0=none) * * Param 9: pcLog Log config string (NULL=default) * * FMROPA Open FLAM5 archive for write (new or existing) * * Param 1: piRtc Return code (OUT) * * Param 2: pcErr Error trace buffer (32768 bytes) * * Param 3: ppGbl Global session handle (POINTER) * * Param 4: ppHdl Archive handle (POINTER, OUT) * * Param 5: piArcLen Length of the archive string * * Param 6: pcArc Archive string (see below) * * Param 7: piFmtLen Format string length (0 = none) * * Param 8: pcFmt Format string (NULL = default) * * Param 9: piNumber I/O batch size (0 = default) * * FMRSMS Set member state attributes * * Param 1: piRtc Return code (OUT) * * Param 2: pcErr Error trace buffer * * Param 3: ppHdl Archive handle * * Param 4: piLen Byte length of state string * * Param 5: pcState State string (see below) * * FMRPUT Write one record to the current archive member * * Param 1: piRtc Return code (OUT) * * Param 2: pcErr Error trace buffer * * Param 3: ppHdl Archive handle * * Param 4: piLen Actual record length in bytes * * Param 5: pcRec Record data buffer * * Param 6: ppCnv Element converter (NULL = none) * * FMRCLA Close FLAM5 archive * * Param 1: piRtc Return code (OUT) * * Param 2: pcErr Error trace buffer * * Param 3: ppHdl Archive handle (set to NULL) * * Param 4: piSucc 1=success/commit, 0=rollback * * Param 5: piStaFmt Statistics format (0 = none) * * Param 6: piStaLen Statistics buffer size (0 = none) * * Param 7: pcStaBuf Statistics buffer (NULL = none) * * RC 9 (VRS) and RC 19 (CHK) are non-fatal warnings. * * FMRMSG Map return code to a short English message * * Param 1: piRtc Return code of FMRMSG itself (OUT)* * Param 2: piCode FLAM return code to look up (IN) * * Param 3: piLen Buffer size / bytes written * * Param 4: pcBuf Output buffer for the message * * FMRCLS Close global FLAM session * * Param 1: piRtc Return code (OUT) * * Param 2: ppGbl Session handle (set to NULL) * * * * FLCRECLB API CALLS (ASM linkage, no RETURNING): * * FCROPN Open DD:INPUT for sequential record read * * Param 1: pvHdl File handle (set by FCROPN) * * Param 2: piRtc Return code * * Param 3: piFileLen Length of the file string * * Param 4: pcFile File string: * * read.file='DD:INPUT' * * Param 5: piFmtLen Length of format string (15) * * Param 6: pcFmt Format string: FORMAT.RECORD() * * Param 7: piStatLen Status buffer size * * Param 8: pcStat Status buffer (printed to SYSOUT) * * FCRGFN Retrieve actual dataset name of open DD * * Param 1: pvHdl File handle from FCROPN * * Param 2: piRtc Return code * * Param 3: piIndex File index (0=current, BY VALUE) * * Param 4: piLen Buffer size / bytes written * * Param 5: pcName Output buffer for the DSN * * FCRGET Read one record from the open file * * Param 1: pvHdl File handle from FCROPN * * Param 2: piRtc Return code * * 0 (FLMRTC_OK) -- record read * * 43 (FLMRTC_EOF) -- end of file * * Param 3: piLen Buffer size in / actual length out* * Param 4: pcRec Record data buffer * * FCRCLS Close open file and release all resources * * Param 1: pvHdl File handle from FCROPN * * Param 2: piRtc Return code * * Param 3: piDel 0 = keep dataset after close * * Param 4: piStaFmt 1 = human-readable statistics * * Param 5: piStaLen Statistics buffer size / written * * Param 6: pcStaBuf Statistics text buffer * * FCRMSG Retrieve an error message string from FLUC * * Param 1: piRtc Return code of FCRMSG itself * * Param 2: piCode Error code to look up * * Param 3: piLen Buffer size * * Param 4: pcBuf Output buffer for message text * * * * ARCHIVE STRINGS (FMROPA): * * to.mod(file='' flam(mbrmode=overwrite)) * * Modify existing archive; overwrite if name matches. * * RC 157 (FLMRTC_NFD) means the archive does not exist yet. * * to.new(file='') * * Create new archive; FLAM default compression is used. * * is the PARM value (USS pathname of the archive file).* * * * STATE STRING (FMRSMS): * * The state string is returned by FCROPN in F-STAT after the * * open call. FLUC fills it with the actual DCB attributes of * * DD:INPUT (ORGF=fully-qualified-DSN, RECF, RECL). F-STAT is * * passed directly to FMRSMS -- no manual construction needed. * * * * PROCESSING FLOW: * * 1. Validate PARM (archive path must be non-empty) * * 2. Build archive strings (to.mod / to.new) from PARM path * * 3. FMROPN - Open global session (env + z/OS STDENV) * * 4. FCROPN - Open DD:INPUT for sequential record read * * 5. FCRGFN - Get DSN of DD:INPUT for display (index=0) * * 6. FMROPA - Try to.mod; on RC=157 retry with to.new * * 7. FMRSMS - Set member state (F-STAT from FCROPN; contains * * ORGF, RECF, RECL determined at open time) * * 8. Loop: FCRGET one record, FMRPUT to archive member * * 9. FMRCLA - Close archive (piSuccess=1 on clean exit) * * 10. FCRCLS - Close DD:INPUT; print statistics to SYSOUT * * 11. FMRCLS - Close global session * * * * RETURN CODES: * * 0 - All records compressed into the archive member * * 8 - Error reading DD:INPUT (FLUC); see SYSOUT for details * * 12 - Error opening or closing the FLAM5 archive * * 16 - Error writing a record to the archive member * * * * COMPILER OPTIONS (z/OS Enterprise COBOL): * * PGMNAME(LONGMIXED) DLL RENT APOST * * PGMNAME(LONGMIXED) and DLL are required for FLMRECLB entry * * points FMROPA, FMRSMS, FMRPUT, FMRCLA, FMRMSG * * (names longer than 8 characters and DLL call mechanism). * * * * AUTHOR: LIMES DATENTECHNIK GMBH * * * ****************************************************************** * ENVIRONMENT DIVISION. * DATA DIVISION. * WORKING-STORAGE SECTION. * *---------------------------------------------------------------- * FLMRECLB INTERFACE PARAMETERS * * ERR-BUF: 32768-byte trace buffer (FLMERR_SIZ). * FMROPA / FMRSMS / FMRPUT / FMRCLA write a * detailed error trace here on failure. * Printed line-by-line to SYSOUT in FMR-ERROR. * * WS-GBL-HDL: Global FLAM session handle. * Set by FMROPN; passed to all FMROPA calls. * Closed by FMRCLS in END-PROGRAM cleanup. * * WS-ARC-HDL: Archive handle returned by FMROPA. * Passed unchanged to FMRSMS, FMRPUT, * FMRCLA. Set to NULL by FMRCLA on close. * * WS-RTC: Return code from the last FMROPA / FMRSMS / * FMRPUT / FMRCLA call. * Condition names: * 0 (WS-RTC-OK) Operation completed successfully * 9 (WS-RTC-VRS) Version mismatch warning (non-fatal) * 19 (WS-RTC-CHK) Checksum warning (non-fatal) * 50 (WS-RTC-NFF) File exists but is not a valid FLAMFILE * 157 (WS-RTC-NFD) No such file or directory (to.mod only); * retry FMROPA with to.new to create archive *---------------------------------------------------------------- * 01 WS-ERR-BUF PIC X(32768) VALUE SPACES. 01 WS-GBL-HDL USAGE IS POINTER VALUE NULL. 01 WS-ARC-HDL USAGE IS POINTER VALUE NULL. 01 WS-CNV-HDL USAGE IS POINTER VALUE NULL. 01 WS-RTC PIC S9(9) COMP. 88 WS-RTC-OK VALUE 0. 88 WS-RTC-VRS VALUE 9. 88 WS-RTC-CHK VALUE 19. 88 WS-RTC-NFF VALUE 50. 88 WS-RTC-NFD VALUE 157. 88 WS-RTC-WARN VALUE 9 19. 88 WS-RTC-NOT-OK VALUE 1 THRU 8 10 THRU 18 20 THRU 156 158 THRU 9999. * *---------------------------------------------------------------- * ARCHIVE STRINGS FOR FMROPA * * WS-ARC-OLD: Modify an existing archive for append or member * overwrite. Built from PARM path at run time: * to.mod(store.file(name='') * flam(mbrmode=overwrite)) * Length = WS-PATH-LEN + 51. * * WS-ARC-NEW: Create a new archive using the FLAM default * compression. Built from PARM path at run time: * to.new(store.file(name='')) * Length = WS-PATH-LEN + 27. * * WS-FMT-LEN: Format string length = 0; FORMAT.RECORD() is the * default and does not need to be specified. *---------------------------------------------------------------- * 01 WS-ARC-OLD PIC X(320) VALUE SPACES. 01 WS-ARC-OLD-L PIC S9(9) COMP VALUE 0. 01 WS-ARC-NEW PIC X(320) VALUE SPACES. 01 WS-ARC-NEW-L PIC S9(9) COMP VALUE 0. 01 WS-FMT-LEN PIC S9(9) COMP VALUE 0. * * WS-FMT-DUMMY: 1-byte placeholder passed instead of a NULL * pointer for unused CALL parameters (e.g. pcFmt, pcEnv, * pcLog). IBM Enterprise COBOL does not support passing BY * VALUE NULL in CALL USING, so a harmless dummy field is used. * 01 WS-FMT-DUMMY PIC X VALUE SPACE. * *---------------------------------------------------------------- * DSN FROM FCRGFN -- USED FOR PROTOCOL OUTPUT * * WS-MBR-NAME: Fully qualified dataset name of DD:INPUT, * retrieved via FCRGFN. Displayed in the protocol * (WRITING / INTO lines) to log what is archived. * WS-MBR-LEN: Actual byte length of the DSN string. * Set from GFN-FILENLEN after the FCRGFN call. *---------------------------------------------------------------- * 01 WS-MBR-NAME PIC X(256) VALUE SPACES. 01 WS-MBR-LEN PIC S9(9) COMP VALUE 0. * * *---------------------------------------------------------------- * FMRPUT -- RECORD BUFFER * * WS-REC-BUF: Receive buffer for FCRGET and source buffer for * FMRPUT. Sized for the largest possible record. * WS-REC-LEN: On FCRGET entry: buffer size (32760). * On FCRGET return: actual record length in bytes. * Passed unchanged to FMRPUT. *---------------------------------------------------------------- * 01 WS-REC-BUF PIC X(32760). 01 WS-REC-LEN PIC S9(9) COMP VALUE 32760. * *---------------------------------------------------------------- * FMRCLA -- CLOSE FLAGS * * WS-SUCCESS: 1 = all writes succeeded (normal close / commit). * 0 = an error occurred (rollback, discard member). * Set before calling FMRCLA. *---------------------------------------------------------------- * 01 WS-SUCCESS PIC S9(9) COMP VALUE 1. * *---------------------------------------------------------------- * FMRCLA -- STATISTICS BUFFER * * WS-STA-LEN: Buffer size on entry (4096); actual number of * bytes written by FMRCLA on return. * WS-STA-BUF: Receives a human-readable compression statistics * report (format: piStaFmt=1). Printed line-by-line * to SYSOUT after FMRCLA returns. *---------------------------------------------------------------- * 01 WS-STA-LEN PIC S9(9) COMP VALUE 4096. 01 WS-STA-BUF PIC X(4096) VALUE SPACES. * *---------------------------------------------------------------- * FMRMSG -- MESSAGE BUFFER * * WS-MSG-BUF: Receives a short human-readable English description * of WS-RTC, displayed together with the return code. * WS-MSG-LEN: Buffer size on entry; bytes written on return. *---------------------------------------------------------------- * 01 WS-MSG-BUF PIC X(80) VALUE SPACES. 01 WS-MSG-LEN PIC S9(9) COMP VALUE 80. * *---------------------------------------------------------------- * FLCRECLB INTERFACE PARAMETERS * * F-ID: Integer file handle set by FCROPN. * Passed to FCRGFN, FCRGET, FCRCLS unchanged. * F-RETCO: Return code from the last FLCRECLB call. * 0 (FLUC-OK) -- record read successfully * 43 (FLUC-EOF) -- end of file; loop exits normally *---------------------------------------------------------------- * 01 FLUC-PARAMETER. 02 F-ID PIC S9(8) COMP VALUE 0. 02 F-RETCO PIC S9(8) COMP. 88 FLUC-OK VALUE 0. 88 FLUC-EOF VALUE 43. * * FCROPN PARAMETERS: * F-FILELEN: Byte length of the file string in F-FILE (20). * F-FILE: Compact file string: read.file='DD:INPUT' * Opens the INPUT DD-name for sequential record read. * F-FORMLEN: Byte length of the format string in F-FORM (15). * F-FORM: FORMAT.RECORD() -- standard sequential record fmt. * F-STATLEN: Buffer size on entry (1024); actual state string * length written on return by FLUC. * F-STAT: State string returned by FCROPN; contains the * actual DCB attributes (ORGF, RECF, RECL) of * DD:INPUT. Passed directly to FMRSMS in SET-MEMBER. * 02 F-FILELEN PIC S9(8) COMP VALUE 20. 02 F-FILE PIC X(24) VALUE 'read.file=''DD:INPUT'''. 02 F-FORMLEN PIC S9(8) COMP VALUE 15. 02 F-FORM PIC X(16) VALUE 'FORMAT.RECORD()'. 02 F-STATLEN PIC S9(8) COMP VALUE 1024. 02 F-STAT PIC X(1024) VALUE SPACES. * * FCRGET PARAMETERS: * F-RECLEN: On entry: receive buffer capacity (32760). * On return: actual record length set by FCRGET. * Passed unchanged to FMRPUT as the write length. * 02 F-RECLEN PIC S9(8) COMP VALUE 32760. * * FCRGFN PARAMETERS: * GFN-INDEX: File index: 0 = currently open dataset. * Passed BY VALUE to FCRGFN. * GFN-FILENLEN: Buffer size on entry (256); actual DSN length * on return. Copied to WS-MBR-LEN after call. * GFN-FILENAME: Buffer that receives the fully qualified DSN. * Copied to WS-MBR-NAME after call. * 01 GFN-INDEX PIC 9(8) COMP VALUE 0. 01 GFN-FILENLEN PIC 9(8) COMP VALUE 256. 01 GFN-FILENAME PIC X(256) VALUE SPACES. * * FCRCLS PARAMETERS: * F-DELETE: 0 = keep DD:INPUT dataset after close (normal). * F-STATFMT: 1 = return human-readable multi-line statistics. * F-CSTATLEN: Statistics buffer size (4096 bytes). * F-CSTATBUF: Receives final compression statistics text from * FLUC; printed line-by-line to SYSOUT. * 01 F-DELETE PIC S9(8) COMP VALUE 0. 01 F-STATFMT PIC S9(8) COMP VALUE 1. 01 F-CSTATLEN PIC S9(8) COMP VALUE 4096. 01 F-CSTATBUF PIC X(4096) VALUE SPACES. * * FCRMSG PARAMETERS: * FCR-MSGRTC: Return code of the FCRMSG call itself (ignored). * FCR-MSGLEN: Size of FCR-MSGBUF (800 bytes). * FCR-MSGBUF: Receives a newline-delimited FLUC error message. * 01 FCR-MSGRTC PIC S9(8) COMP. 01 FCR-MSGLEN PIC S9(8) COMP VALUE 800. 01 FCR-MSGBUF PIC X(800) VALUE SPACES. * *---------------------------------------------------------------- * WORK FIELDS * * WS-ARC-PATH: Archive file path from JCL PARM. * WS-PATH-LEN: Byte length of the archive path. * WS-ARC-OPEN: 'Y' after FMROPA succeeds; used to ensure * FMRCLA is called exactly once in cleanup. * WS-INP-OPEN: 'Y' after FCROPN succeeds; ensures FCRCLS. * WS-FINAL-RC: Accumulated program return code (0/8/12/16). * WS-REC-CNT: Number of records written to the archive. * WS-DISP-NUM: Formatted display of WS-REC-CNT. *---------------------------------------------------------------- * 01 WS-ARC-PATH PIC X(255) VALUE SPACES. 01 WS-PATH-LEN PIC S9(9) COMP VALUE 0. 01 WS-ONE PIC S9(9) COMP VALUE 1. 01 WS-GBL-OPEN PIC X VALUE 'N'. 88 GBL-IS-OPEN VALUE 'Y'. 01 WS-ARC-OPEN PIC X VALUE 'N'. 88 ARC-IS-OPEN VALUE 'Y'. 01 WS-INP-OPEN PIC X VALUE 'N'. 88 INPUT-IS-OPEN VALUE 'Y'. 01 WS-FINAL-RC PIC S9(4) COMP VALUE 0. 01 WS-REC-CNT PIC 9(9) COMP VALUE 0. 01 WS-DISP-NUM PIC ZZZZZZZ9. * *---------------------------------------------------------------- * UNSTRING DISPLAY HELPERS * * Used to print multi-line text buffers (ERR-BUF, FCR-MSGBUF, * F-CSTATBUF) to SYSOUT line by line. Each buffer uses its own * set of AREA (line text), DLM (delimiter found), LEN (line * length), and PTR (scan position) fields. *---------------------------------------------------------------- * 77 WS-RTC-SAVE PIC S9(9) COMP VALUE 0. 77 ERRBUF-AREA PIC X(132). 77 ERRBUF-DLM PIC X. 77 ERRBUF-LEN PIC 9(8) COMP VALUE 0. 77 ERRBUF-PTR PIC 9(8) COMP VALUE 1. * 77 MSGBUF-AREA PIC X(132). 77 MSGBUF-DLM PIC X. 77 MSGBUF-LEN PIC 9(8) COMP VALUE 0. 77 MSGBUF-PTR PIC 9(8) COMP VALUE 1. * 77 STATBUF-AREA PIC X(132). 77 STATBUF-DLM PIC X. 77 STATBUF-LEN PIC 9(8) COMP VALUE 0. 77 STATBUF-PTR PIC 9(8) COMP VALUE 1. * 77 FSTAT-AREA PIC X(132). 77 FSTAT-DLM PIC X. 77 FSTAT-LEN PIC 9(8) COMP VALUE 0. 77 FSTAT-PTR PIC 9(8) COMP VALUE 1. / * *---------------------------------------------------------------- * LINKAGE SECTION -- JCL PARM * * PARM-LEN: Length of the PARM string in bytes (binary). * 0 means no PARM was provided. * PARM-TEXT: PARM value; the first PARM-LEN bytes hold the * archive file path supplied in the JCL EXEC stmt. * * LE strips the run-time option part of the PARM before the * program sees it, so PARM-LEN can be shorter than the string * coded in the JCL. Which part is stripped depends on the * CBLOPTS run-time option -- see the PARM notes in the program * header. The step must run with CBLOPTS(OFF) and a leading * delimiter slash in the PARM, otherwise the last path * component arrives here as a run-time option instead. *---------------------------------------------------------------- * LINKAGE SECTION. 01 PARM-AREA. 02 PARM-LEN PIC S9(4) COMP. 02 PARM-TEXT PIC X(255). / PROCEDURE DIVISION USING PARM-AREA. * *---------------------------------------------------------------- * MAIN *---------------------------------------------------------------- * MAIN SECTION. PRE-PROCESSING. * DISPLAY 'SOFMRPUT: START' * * Validate PARM: the archive file path is mandatory. * IF PARM-LEN = 0 DISPLAY 'SOFMRPUT: ERROR -- PARM MISSING.' DISPLAY 'SOFMRPUT: PROVIDE ARCHIVE PATH AS JCL PARM.' DISPLAY 'SOFMRPUT: EXAMPLE: PARM=''//u/user/arc.flam''' MOVE 12 TO WS-FINAL-RC GO TO END-PROGRAM-01 END-IF * * Copy PARM path and build archive open strings. * MOVE PARM-LEN TO WS-PATH-LEN MOVE PARM-TEXT(1:PARM-LEN) TO WS-ARC-PATH PERFORM BUILD-ARCHIVE-STRINGS DISPLAY 'SOFMRPUT: ARCHIVE PATH: ' WS-ARC-PATH(1:WS-PATH-LEN) * * Open global FLAM session. * piSys=WS-ONE(1) loads z/OS system variables. * piStd=WS-ONE(1) loads DD:STDENV for code page settings. * piEnvLen=WS-FMT-LEN(0) and pcEnv=WS-FMT-DUMMY: no env vars. * piLogLen=WS-FMT-LEN(0) and pcLog=WS-FMT-DUMMY: default log. * CALL 'FMROPN' USING WS-RTC, WS-ERR-BUF, WS-GBL-HDL, WS-ONE, WS-ONE, WS-FMT-LEN, WS-FMT-DUMMY, WS-FMT-LEN, WS-FMT-DUMMY IF WS-RTC-NOT-OK DISPLAY 'SOFMRPUT: FMROPN FAILED' PERFORM FMR-ERROR MOVE 12 TO WS-FINAL-RC GO TO END-PROGRAM-01 END-IF MOVE 'Y' TO WS-GBL-OPEN. * MAIN-PROCESSING. * PERFORM OPEN-INPUT IF NOT FLUC-OK MOVE 8 TO WS-FINAL-RC GO TO END-PROGRAM-01 END-IF * PERFORM GET-DSN * PERFORM OPEN-ARCHIVE IF WS-RTC-NOT-OK MOVE 12 TO WS-FINAL-RC GO TO END-PROGRAM-01 END-IF * PERFORM SET-MEMBER IF WS-RTC-NOT-OK MOVE 12 TO WS-FINAL-RC GO TO END-PROGRAM-01 END-IF * PERFORM PROCESS-RECORD UNTIL NOT FLUC-OK OR WS-RTC-NOT-OK. * END-PROCESSING. * GO TO END-PROGRAM-01. * MAIN-EX. EXIT. * *---------------------------------------------------------------- * ROUTINES *---------------------------------------------------------------- * * BUILD-ARCHIVE-STRINGS SECTION. BUILD-ARCHIVE-STRINGS-01. * * Build archive string for an existing archive (to.mod): * to.mod(store.file(name='') flam(mbrmode=overwrite)) * Length = path length + 24 (prefix) + 27 (suffix) = + 51. * STRING 'to.mod(store.file(name=''' DELIMITED SIZE WS-ARC-PATH(1:WS-PATH-LEN) DELIMITED SIZE ''') flam(mbrmode=overwrite))' DELIMITED SIZE INTO WS-ARC-OLD COMPUTE WS-ARC-OLD-L = WS-PATH-LEN + 51 * * Build archive string for a new archive (to.new): * to.new(store.file(name='')) * No compression suite specified; the FLAM default is used. * Length = path length + 24 (prefix) + 3 (suffix) = + 27. * STRING 'to.new(store.file(name=''' DELIMITED SIZE WS-ARC-PATH(1:WS-PATH-LEN) DELIMITED SIZE '''))' DELIMITED SIZE INTO WS-ARC-NEW COMPUTE WS-ARC-NEW-L = WS-PATH-LEN + 27. * BUILD-ARCHIVE-STRINGS-EX. EXIT. * * OPEN-INPUT SECTION. OPEN-INPUT-01. * * Open DD:INPUT via the FLUC record interface. * FCROPN(pvHdl, piRtc, piFileLen, pcFile, * piFmtLen, pcFmt, piStatLen, pcStat) * read.file='DD:INPUT': compact form to read DD:INPUT records. * FORMAT.RECORD(): standard sequential record format. * FLUC fills F-STAT with the actual DCB attributes of DD:INPUT * (ORGF, RECF, RECL) and sets F-STATLEN to the actual length. * F-STAT is passed directly to FMRSMS in SET-MEMBER. * CALL 'FCROPN' USING F-ID, F-RETCO, F-FILELEN, F-FILE, F-FORMLEN, F-FORM, F-STATLEN, F-STAT * COMPUTE FSTAT-PTR = 1 COMPUTE FSTAT-LEN = 0 * PERFORM W-DISPLAY-FSTAT PERFORM UNTIL FSTAT-DLM NOT = X'15' PERFORM W-DISPLAY-FSTAT END-PERFORM * IF FLUC-OK MOVE 'Y' TO WS-INP-OPEN ELSE DISPLAY 'SOFMRPUT: FCROPN FAILED' PERFORM FCR-ERROR END-IF. * OPEN-INPUT-EX. EXIT. * * GET-DSN SECTION. GET-DSN-01. * * Retrieve the fully qualified DSN of the open DD:INPUT. * FCRGFN(pvHdl, piRtc, index BY VALUE, piLen, pcName) * index=0 returns the name of the currently open dataset. * GFN-FILENLEN is set to the actual DSN length on return. * On failure a display fallback 'INPUT' is used so processing * can continue (the protocol shows 'INPUT' as the source DSN). * MOVE 256 TO GFN-FILENLEN MOVE SPACES TO GFN-FILENAME * CALL 'FCRGFN' USING F-ID, F-RETCO, BY VALUE GFN-INDEX, BY REFERENCE GFN-FILENLEN, BY REFERENCE GFN-FILENAME * IF FLUC-OK MOVE GFN-FILENLEN TO WS-MBR-LEN MOVE GFN-FILENAME TO WS-MBR-NAME DISPLAY 'SOFMRPUT: INPUT DSN: ' WS-MBR-NAME(1:WS-MBR-LEN) ELSE DISPLAY 'SOFMRPUT: FCRGFN FAILED, USING FALLBACK NAME' MOVE 'INPUT' TO WS-MBR-NAME MOVE 5 TO WS-MBR-LEN DISPLAY 'SOFMRPUT: INPUT DSN: INPUT (FALLBACK)' MOVE 0 TO F-RETCO END-IF. * GET-DSN-EX. EXIT. * * OPEN-ARCHIVE SECTION. OPEN-ARCHIVE-01. * * Try to open an existing FLAM5 archive (to.mod). * FMROPA(piRtc, pcErr, ppGbl, ppHdl, piArcLen, pcArc, * piFmtLen, pcFmt, piNumber) * ppGbl=WS-GBL-HDL: share the session opened by FMROPN. * piFmtLen=0 / pcFmt=WS-FMT-DUMMY: default FORMAT.RECORD(). * piNumber=0: default I/O batch size. * CALL 'FMROPA' USING WS-RTC, WS-ERR-BUF, WS-GBL-HDL, WS-ARC-HDL, WS-ARC-OLD-L, WS-ARC-OLD, WS-FMT-LEN, WS-FMT-DUMMY, BY VALUE 0 * EVALUATE TRUE * * RC 0: archive existed and was opened successfully. * WHEN WS-RTC-OK SET ARC-IS-OPEN TO TRUE DISPLAY 'SOFMRPUT: ARCHIVE OPENED (EXISTING)' * * RC 157 (FLMRTC_NFD): archive file not found -- create it. * WHEN WS-RTC-NFD DISPLAY 'SOFMRPUT: ARCHIVE NOT FOUND, CREATING NEW' CALL 'FMROPA' USING WS-RTC, WS-ERR-BUF, WS-GBL-HDL, WS-ARC-HDL, WS-ARC-NEW-L, WS-ARC-NEW, WS-FMT-LEN, WS-FMT-DUMMY, BY VALUE 0 IF WS-RTC-OK SET ARC-IS-OPEN TO TRUE DISPLAY 'SOFMRPUT: ARCHIVE CREATED' ELSE DISPLAY 'SOFMRPUT: FMROPA (to.new) FAILED' PERFORM FMR-ERROR END-IF * * Any other RC indicates a real error (permission, format, ...). * WHEN OTHER DISPLAY 'SOFMRPUT: FMROPA (to.mod) FAILED' PERFORM FMR-ERROR END-EVALUATE. * OPEN-ARCHIVE-EX. EXIT. * * SET-MEMBER SECTION. SET-MEMBER-01. * * Log what is being archived. * DISPLAY 'SOFMRPUT: WRITING : ' WS-MBR-NAME(1:WS-MBR-LEN) DISPLAY 'SOFMRPUT: INTO : ' WS-ARC-PATH(1:WS-PATH-LEN) DISPLAY 'SOFMRPUT: STATE : ' F-STAT(1:F-STATLEN) * * Set the member state attributes using the state string that * FCROPN filled into F-STAT at open time. FLUC stores the * actual DCB attributes (ORGF, RECF, RECL) of DD:INPUT there; * no FMRSMN call is needed -- ORGF in the state string serves * as the member identifier. * FMRSMS(pcErr, ppHdl, piStateLen, pcState) * CALL 'FMRSMS' USING WS-RTC, WS-ERR-BUF, WS-ARC-HDL, F-STATLEN, F-STAT * IF WS-RTC-NOT-OK DISPLAY 'SOFMRPUT: FMRSMS FAILED' PERFORM FMR-ERROR END-IF. * SET-MEMBER-EX. EXIT. * * PROCESS-RECORD SECTION. PROCESS-RECORD-01. * * Read one record from DD:INPUT. * FCRGET(pvHdl, piRtc, piLen, pcRec) * F-RECLEN carries the buffer capacity (32760) on entry * and the actual record length on return. * RC 43 (FLUC-EOF) signals end of file; the loop exits. * MOVE 32760 TO F-RECLEN CALL 'FCRGET' USING F-ID, F-RETCO, F-RECLEN, WS-REC-BUF * IF FLUC-EOF GO TO PROCESS-RECORD-EX END-IF * IF NOT FLUC-OK DISPLAY 'SOFMRPUT: FCRGET FAILED' PERFORM FCR-ERROR MOVE 8 TO WS-FINAL-RC GO TO PROCESS-RECORD-EX END-IF * * Write the record to the current archive member. * FMRPUT(pcErr, ppHdl, piLen, pcRec, ppCnv) * F-RECLEN (actual length from FCRGET) is the write length. * ppCnv=NULL: no element converter is used. * CALL 'FMRPUT' USING WS-RTC, WS-ERR-BUF, WS-ARC-HDL, F-RECLEN, WS-REC-BUF, WS-CNV-HDL * IF WS-RTC-NOT-OK DISPLAY 'SOFMRPUT: FMRPUT FAILED' PERFORM FMR-ERROR MOVE 16 TO WS-FINAL-RC ELSE ADD 1 TO WS-REC-CNT IF FUNCTION MOD(WS-REC-CNT, 10000) = 0 MOVE WS-REC-CNT TO WS-DISP-NUM DISPLAY 'SOFMRPUT: RECORDS WRITTEN: ' WS-DISP-NUM END-IF END-IF. * PROCESS-RECORD-EX. EXIT. * * CLOSE-ARCHIVE SECTION. CLOSE-ARCHIVE-01. * * Close the FLAM5 archive. * FMRCLA(piRtc, pcErr, ppHdl, piSuccess, piStaFmt, * piStaLen, pcStaBuf) * piSuccess=1 commits the member; piSuccess=0 triggers rollback. * piStaFmt=1: return human-readable statistics in WS-STA-BUF. * WS-STA-LEN: buffer size on entry; bytes written on return. * RC 9 (VRS) and RC 19 (CHK) are warnings; treat as success. * IF WS-FINAL-RC NOT = 0 MOVE 0 TO WS-SUCCESS END-IF * MOVE 4096 TO WS-STA-LEN MOVE SPACES TO WS-STA-BUF * CALL 'FMRCLA' USING WS-RTC, WS-ERR-BUF, WS-ARC-HDL, WS-SUCCESS, WS-ONE, WS-STA-LEN, WS-STA-BUF * MOVE 'N' TO WS-ARC-OPEN * IF WS-RTC-OK OR WS-RTC-WARN CONTINUE ELSE DISPLAY 'SOFMRPUT: FMRCLA FAILED' PERFORM FMR-ERROR IF WS-FINAL-RC = 0 MOVE 12 TO WS-FINAL-RC END-IF END-IF * * Print FMRCLA archive statistics (bytes, compression ratio). * WS-STA-BUF is copied into F-CSTATBUF so that the shared * W-DISPLAY-STATBUF routine can process it. F-CSTATBUF is * refilled by FCRCLS in CLOSE-INPUT, so there is no conflict. * DISPLAY 'SOFMRPUT: ARCHIVE STATISTICS:' * MOVE WS-STA-BUF TO F-CSTATBUF COMPUTE STATBUF-PTR = 1 COMPUTE STATBUF-LEN = 0 * PERFORM W-DISPLAY-STATBUF PERFORM UNTIL STATBUF-DLM NOT = X'15' PERFORM W-DISPLAY-STATBUF END-PERFORM * DISPLAY SPACE. * CLOSE-ARCHIVE-EX. EXIT. * * CLOSE-INPUT SECTION. CLOSE-INPUT-01. * * Close DD:INPUT and retrieve final statistics. * FCRCLS(pvHdl, piRtc, piDelete, piStaFmt, piStaLen, pcStaBuf) * piDelete=0 keeps the dataset; piStaFmt=1 returns statistics. * The statistics text is printed line-by-line to SYSOUT. * CALL 'FCRCLS' USING F-ID, F-RETCO, F-DELETE, F-STATFMT, F-CSTATLEN, F-CSTATBUF * MOVE 'N' TO WS-INP-OPEN * IF NOT FLUC-OK DISPLAY 'SOFMRPUT: FCRCLS FAILED' PERFORM FCR-ERROR END-IF * DISPLAY 'SOFMRPUT: INPUT STATISTICS:' * COMPUTE STATBUF-PTR = 1 COMPUTE STATBUF-LEN = 0 * PERFORM W-DISPLAY-STATBUF PERFORM UNTIL STATBUF-DLM NOT = X'15' PERFORM W-DISPLAY-STATBUF END-PERFORM * DISPLAY SPACE. * CLOSE-INPUT-EX. EXIT. * * END-PROGRAM SECTION. END-PROGRAM-01. * * Cleanup: close the archive and the input file if still open, * display the record count, and terminate the program. * IF ARC-IS-OPEN PERFORM CLOSE-ARCHIVE END-IF * IF INPUT-IS-OPEN PERFORM CLOSE-INPUT END-IF * MOVE WS-REC-CNT TO WS-DISP-NUM DISPLAY 'SOFMRPUT: RECORDS PROCESSED: ' WS-DISP-NUM DISPLAY 'SOFMRPUT: END, RETURN CODE: ' WS-FINAL-RC * * Close global FLAM session (releases environment resources). * IF GBL-IS-OPEN CALL 'FMRCLS' USING WS-RTC, WS-GBL-HDL MOVE 'N' TO WS-GBL-OPEN END-IF * MOVE WS-FINAL-RC TO RETURN-CODE STOP RUN. * END-PROGRAM-EX. EXIT. * * FMR-ERROR SECTION. FMR-ERROR-01. * * Display the short message for WS-RTC via FMRMSG, * then dump the ERR-BUF trace line by line. * FMRMSG(piRtc, piLen, pcBuf) * WS-MSG-LEN is reset to 80 before each call. * WS-RTC is restored from WS-RTC-SAVE after FMRMSG so that * callers can still test WS-RTC after error reporting. * MOVE WS-RTC TO WS-RTC-SAVE MOVE 80 TO WS-MSG-LEN CALL 'FMRMSG' USING WS-RTC, WS-RTC-SAVE, WS-MSG-LEN, WS-MSG-BUF * DISPLAY 'SOFMRPUT: FMR RETURNCODE= ' WS-RTC-SAVE ', MESSAGE: ' WS-MSG-BUF(1:WS-MSG-LEN) * DISPLAY 'SOFMRPUT: TRACE:' * COMPUTE ERRBUF-PTR = 1 COMPUTE ERRBUF-LEN = 0 * PERFORM W-DISPLAY-ERRBUF PERFORM UNTIL ERRBUF-DLM NOT = X'15' PERFORM W-DISPLAY-ERRBUF END-PERFORM * DISPLAY SPACE. MOVE WS-RTC-SAVE TO WS-RTC. * FMR-ERROR-EX. EXIT. * * FCR-ERROR SECTION. FCR-ERROR-01. * * Retrieve and display the FLUC error message for F-RETCO. * FCRMSG(piRtc, piCode, piLen, pcBuf) * FCR-MSGRTC is the return code of FCRMSG itself (ignored). * DISPLAY 'SOFMRPUT: FLUC RETURNCODE= ' F-RETCO * CALL 'FCRMSG' USING FCR-MSGRTC, F-RETCO, FCR-MSGLEN, FCR-MSGBUF * COMPUTE MSGBUF-PTR = 1 COMPUTE MSGBUF-LEN = 0 * PERFORM W-DISPLAY-MSGBUF PERFORM UNTIL MSGBUF-DLM NOT = X'15' PERFORM W-DISPLAY-MSGBUF END-PERFORM * DISPLAY SPACE. * FCR-ERROR-EX. EXIT. * * W-DISPLAY-ERRBUF SECTION. W-DISPLAY-ERRBUF-01. * UNSTRING WS-ERR-BUF DELIMITED BY X'15' OR X'00' INTO ERRBUF-AREA DELIMITER ERRBUF-DLM COUNT ERRBUF-LEN WITH POINTER ERRBUF-PTR DISPLAY ERRBUF-AREA. * W-DISPLAY-ERRBUF-EX. EXIT. * * W-DISPLAY-MSGBUF SECTION. W-DISPLAY-MSGBUF-01. * UNSTRING FCR-MSGBUF DELIMITED BY X'15' OR X'00' INTO MSGBUF-AREA DELIMITER MSGBUF-DLM COUNT MSGBUF-LEN WITH POINTER MSGBUF-PTR DISPLAY MSGBUF-AREA. * W-DISPLAY-MSGBUF-EX. EXIT. * * W-DISPLAY-STATBUF SECTION. W-DISPLAY-STATBUF-01. * UNSTRING F-CSTATBUF DELIMITED BY X'15' OR X'00' INTO STATBUF-AREA DELIMITER STATBUF-DLM COUNT STATBUF-LEN WITH POINTER STATBUF-PTR DISPLAY STATBUF-AREA. * W-DISPLAY-STATBUF-EX. EXIT. * * W-DISPLAY-FSTAT SECTION. W-DISPLAY-FSTAT-01. * UNSTRING F-STAT DELIMITED BY X'15' OR X'00' INTO FSTAT-AREA DELIMITER FSTAT-DLM COUNT FSTAT-LEN WITH POINTER FSTAT-PTR DISPLAY FSTAT-AREA. * W-DISPLAY-FSTAT-EX. EXIT. *