00001 IDENTIFICATION DIVISION. 00002 PROGRAM-ID. SNAPSHOT. 00003 AUTHOR. ZAC. 00004 **************************************************************** 00005 * * 00006 * COPYRIGHT (C) 2002, ZAC. * 00007 * POBox 121, Teaneck, NJ 07666 * 00008 * This program is distributed under the LGPL license agreement * 00009 * (see the full text of this license agreement in the URL: * 00010 * http://www.gnu.org/licenses/lgpl.html; LGPL stands for: * 00011 * GNU Lesser General Public License or in older interpretation* 00012 * GNU Library General Public License.) * 00013 * * 00014 **************************************************************** 00015 * * 00016 * Purpose: * 00017 * To provide a simple way to dump memory blocks in hex from * 00018 * COBOL programs. One may use it in conjunction with COBOL's * 00019 * DISPLAY command as means of debugging or displaying output * 00020 * in formatted hex. * 00021 * * 00022 * Usag: * 00023 * CALL SNAPSHOT USING SNAP-ID SNAP-AREA SNAP-LEN where * 00024 * SNAP-ID - PIC X(64). text identifying the snapshot. * 00025 * SNAP-AREA - the memory to snap out up to 9K bytes (9216) * 00026 * SNAP-LEN - PIC 9(4) COMP. length of memory to snap. * 00027 * - Zero value means that only the SNAP-ID is to be printed.* 00028 * * 000100* Example: * 000110* WORKING-STORAGE SECTION. * 000120* - - - - - - - * 000200* 01 WS-SNAPID PIC X(64). * 000300* 01 WS-LEN PIC 9(4) COMP. * 000400* - - - - - - - * 000410* POCEDURE DIVISION. * 000420* - - - - - - - * 000500* MOVE 'id information' TO WS-SNAPID * 000600* MOVE nnn TO WS-LEN * 000700* CALL 'SNAPSHOT' USING WS-SNAPID DUMP-AREA WS-LEN * 000200* * 000300* where nnn is a number between 0 to 9216. * 000400* * 00029 * This little CALLable routine is coded with the KISS * 00030 * philosophy in mind. There are no frills! Only digits and * 00031 * the characters A-Z and a-z are considered to be printable. * 00032 * As this program is distributed under the LGPL lcence, you may* 00033 * modify the behavior of this program to suit your needs. For * 00034 * example adding printable characters is as simple as adding * 00035 * them to the list of printable charcters in the WS-PRINTABLE * 00036 * 88 level. * 00037 * * 00038 **************************************************************** 00039 ENVIRONMENT DIVISION. 00040 DATA DIVISION. 00041 WORKING-STORAGE SECTION. 00042 01 WS-REMAINDER PIC 9(4) COMP VALUE ZERO. 00043 01 WS-CURRENT PIC 9(4) COMP VALUE ZERO. 00044 01 WS-POINT PIC 9(4) COMP VALUE ZERO. 00045 01 WS-HALF PIC 9(4) COMP. 00046 01 FILLER REDEFINES WS-HALF. 00047 05 WS-XZ PIC X. 00048 05 WS-HEX PIC X. 00049 01 WS-HEX-VALUES PIC X(16) VALUE '0123456789ABCDEF'. 00050 01 FILLER REDEFINES WS-HEX-VALUES. 00051 05 WS-HEX-CHR OCCURS 16 PIC X. 00052 01 WS-PRINT. 00053 05 WS-CHAR-STRING. 00054 10 WS-CHAR OCCURS 100 INDEXED BY IX-CHAR 00055 PIC X. 00056 05 WS-LEFT-STRING. 00057 10 WS-LEFT OCCURS 100 INDEXED BY IX-LEFT 00058 PIC X. 00059 05 WS-RIGHT-STRING. 00060 10 WS-RIGHT OCCURS 100 INDEXED BY IX-RIGHT 00061 PIC X. 00062 01 WS-RULLER PIC X(100) VALUE '----+---10----+---20----+---3 00063 - '0----+---40----+---50----+---60----+---70----+ 00064 - '---80----+---90----+---00'. 00065 01 WS-SPACELINE. 00066 05 WS-FROM PIC ZZZ9. 00067 05 FILLER PIC X(4) VALUE SPACE. 00068 05 WS-ID PIC X(64). 00069 05 FILLER PIC X(28) VALUE SPACE. 00070 01 WS-STRING. 00071 05 WS-BYTE OCCURS 100 INDEXED BY IX-BYTE 00072 PIC X. 00073 88 WS-PRINTABLE VALUE 'a' THRU 'z' 00074 'A' THRU 'Z' 00075 '0' THRU '9' SPACE. 00076 LINKAGE SECTION. 00077 01 LS-ID PIC X(64). 00078 01 LS-AREA PIC X(9216). 00079 01 LS-LEN PIC 9(4) COMP. 00080 PROCEDURE DIVISION USING 00081 LS-ID 00082 LS-AREA 00083 LS-LEN. 00084 00085 MAIN SECTION. 00086 00087 IF LS-LEN > 9216 00088 MOVE 9216 TO WS-REMAINDER 00089 ELSE 00090 IF LS-LEN < ZERO 00091 DISPLAY LS-ID ' ERROR: NEGATIVE LENGTH' 00092 ELSE 00093 MOVE LS-LEN TO WS-REMAINDER 00094 END-IF 00095 END-IF. 00096 00097 MOVE 1 TO WS-POINT. 00098 00099 PERFORM UNTIL WS-REMAINDER = ZERO 00100 00101 IF WS-REMAINDER > 100 00102 MOVE 100 TO WS-CURRENT 00103 SUBTRACT 100 FROM WS-REMAINDER 00104 ELSE 00105 MOVE WS-REMAINDER TO WS-CURRENT 00106 MOVE ZERO TO WS-REMAINDER 00107 END-IF 00108 00109 INITIALIZE WS-PRINT 00110 MOVE LS-AREA (WS-POINT:WS-CURRENT) TO WS-STRING 00111 00112 PERFORM VARYING IX-BYTE FROM 1 BY 1 00113 UNTIL IX-BYTE > WS-CURRENT 00114 00115 SET IX-CHAR TO IX-BYTE 00116 SET IX-LEFT TO IX-BYTE 00117 SET IX-RIGHT TO IX-BYTE 00118 00119 IF WS-PRINTABLE (IX-BYTE) 00120 MOVE WS-BYTE (IX-BYTE) TO WS-CHAR (IX-CHAR) 00121 ELSE 00122 MOVE '.' TO WS-CHAR (IX-CHAR) 00123 END-IF 00124 00125 MOVE ZERO TO WS-HALF 00126 MOVE WS-BYTE (IX-BYTE) TO WS-HEX 00127 MULTIPLY WS-HALF BY 16 GIVING WS-HALF 00128 MOVE X'00' TO WS-XZ 00129 DIVIDE WS-HALF BY 16 GIVING WS-HALF 00130 ADD 1 TO WS-HALF GIVING WS-HALF 00131 MOVE WS-HEX-CHR (WS-HALF) TO WS-RIGHT (IX-RIGHT) 00132 00133 MOVE ZERO TO WS-HALF 00134 MOVE WS-BYTE (IX-BYTE) TO WS-HEX 00135 DIVIDE WS-HALF BY 16 GIVING WS-HALF 00136 ADD 1 TO WS-HALF GIVING WS-HALF 00137 MOVE WS-HEX-CHR (WS-HALF) TO WS-LEFT (IX-LEFT) 00138 00139 END-PERFORM 00140 00141 MOVE WS-POINT TO WS-FROM 00142 MOVE LS-ID TO WS-ID 00143 DISPLAY WS-SPACELINE 00144 DISPLAY WS-CHAR-STRING 00145 DISPLAY WS-RULLER 00146 DISPLAY WS-LEFT-STRING 00147 DISPLAY WS-RIGHT-STRING 00148 ADD 100 TO WS-POINT 00149 00150 END-PERFORM. 00151 MOVE SPACE TO WS-SPACELINE 00152 DISPLAY WS-SPACELINE 00153 GOBACK.