├── README.md ├── .gitignore ├── gnu-cobol.sh ├── LICENSE ├── DECSTR.COB ├── ENCSTR.COB ├── REESCAPE.COB ├── IRC-MSG.COB ├── PRINTCNF.COB ├── WOPO-CNF.COB ├── channel.c ├── BF-RUN.COB ├── DECASCII.COB ├── ENCASCII.COB └── WOPO.COB /README.md: -------------------------------------------------------------------------------- 1 | # WOPO 2 | IRC bot in COBOL-74 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Object files 2 | *.o 3 | *.ko 4 | *.obj 5 | *.elf 6 | 7 | # Precompiled Headers 8 | *.gch 9 | *.pch 10 | 11 | # Libraries 12 | *.lib 13 | *.a 14 | *.la 15 | *.lo 16 | 17 | # Shared objects (inc. Windows DLLs) 18 | *.dll 19 | *.so 20 | *.so.* 21 | *.dylib 22 | 23 | # Executables 24 | *.exe 25 | *.out 26 | *.app 27 | *.i*86 28 | *.x86_64 29 | *.hex 30 | 31 | # Debug files 32 | *.dSYM/ 33 | -------------------------------------------------------------------------------- /gnu-cobol.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | BUILD_COBOL=1 3 | BUILD_C=1 4 | 5 | if cc -v 2>&1 | grep 'clang' >/dev/null; then 6 | CLANG=1 7 | fi 8 | 9 | args=`getopt dCc $*` 10 | if [ $? -ne 0 ]; then 11 | echo 'Usage: sh gnu-cobol.sh [-d]' 12 | exit 2 13 | fi 14 | set -- $args 15 | while true; do 16 | case "$1" in 17 | -d) 18 | DEBUG=1 19 | shift 20 | ;; 21 | -C) 22 | unset BUILD_COBOL 23 | shift 24 | ;; 25 | -c) 26 | unset BUILD_C 27 | shift 28 | ;; 29 | --) 30 | shift 31 | break 32 | ;; 33 | esac 34 | done 35 | if [ $BUILD_C ]; then 36 | ${CC:-cc} ${DEBUG:+-DDEBUG} -std=gnu11 -o channel.o -c channel.c 37 | fi 38 | if [ $BUILD_COBOL ]; then 39 | ${COBC:-cobc} ${DEBUG:+-fdebugging-line} -std=mvs -x WOPO-CNF.COB PRINTCNF.COB 40 | ${COBC:-cobc} ${DEBUG:+-fdebugging-line} ${CLANG:+-A "-fbracket-depth=512"} -std=mvs -x WOPO.COB IRC-MSG.COB PRINTCNF.COB DECASCII.COB ENCASCII.COB DECSTR.COB ENCSTR.COB REESCAPE.COB BF-RUN.COB channel.o 41 | fi 42 | 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, heddwch 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 15 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | 25 | -------------------------------------------------------------------------------- /DECSTR.COB: -------------------------------------------------------------------------------- 1 | IDENTIFICATION DIVISION. 2 | PROGRAM-ID. "DECODE-STRING". 3 | 4 | DATA DIVISION. 5 | WORKING-STORAGE SECTION. 6 | 01 STATE. 7 | 03 LOOP-STATE PIC 99. 8 | 88 DONE VALUE 99. 9 | 03 STRING-POINTER PIC 999 USAGE COMPUTATIONAL. 10 | 03 TABLE-INDEX USAGE INDEX. 11 | 12 | 01 ASCII-CHARACTER. 13 | 03 CHAR-CODE PIC 999. 14 | 03 COBOL-STRING PIC X(6). 15 | 16 | LINKAGE SECTION. 17 | 01 ASCII-STRING. 18 | 03 MSG-BODY PIC X(999). 19 | 03 ASCII-TABLE. 20 | 05 ASCII-CELL PIC 999 OCCURS 999 TIMES. 21 | 22 | PROCEDURE DIVISION USING ASCII-STRING. 23 | MOVE 0 TO LOOP-STATE. 24 | MOVE 1 TO STRING-POINTER. 25 | MOVE SPACES TO MSG-BODY. 26 | PERFORM DECODE-CHARACTER VARYING TABLE-INDEX 27 | FROM 1, BY 1, 28 | UNTIL DONE. 29 | EXIT PROGRAM. 30 | 31 | DECODE-CHARACTER. 32 | MOVE ASCII-CELL(TABLE-INDEX) TO CHAR-CODE 33 | IF STRING-POINTER IS GREATER THAN OR EQUAL TO 999 THEN 34 | MOVE 99 TO LOOP-STATE 35 | ELSE IF NOT DONE THEN 36 | CALL "DECODE-ASCII" USING ASCII-CHARACTER. 37 | IF COBOL-STRING IS NOT EQUAL TO SPACES THEN 38 | STRING COBOL-STRING DELIMITED BY SPACES 39 | INTO MSG-BODY 40 | WITH POINTER STRING-POINTER 41 | ELSE 42 | ADD 1 TO STRING-POINTER. 43 | -------------------------------------------------------------------------------- /ENCSTR.COB: -------------------------------------------------------------------------------- 1 | IDENTIFICATION DIVISION. 2 | PROGRAM-ID. "ENCODE-STRING". 3 | 4 | DATA DIVISION. 5 | WORKING-STORAGE SECTION. 6 | 01 STATE. 7 | 03 LOOP-STATE PIC 99. 8 | 88 DONE VALUE 99. 9 | 03 STRING-POINTER PIC 999 USAGE COMPUTATIONAL. 10 | 03 TABLE-INDEX USAGE INDEX. 11 | 12 | 01 ASCII-CHARACTER. 13 | 03 CHAR-CODE PIC 999. 14 | 03 COBOL-STRING PIC X(6). 15 | 03 CURRENT-CHARACTER REDEFINES COBOL-STRING PIC X. 16 | 88 ESCAPE-CHAR VALUE "$". 17 | 18 | LINKAGE SECTION. 19 | 01 ASCII-STRING. 20 | 03 MSG-BODY PIC X(999). 21 | 03 ASCII-TABLE. 22 | 05 ASCII-CELL PIC 999 OCCURS 999 TIMES. 23 | 24 | PROCEDURE DIVISION USING ASCII-STRING. 25 | MOVE 0 TO LOOP-STATE. 26 | MOVE 1 TO STRING-POINTER. 27 | PERFORM ENCODE-CHARACTER 28 | VARYING TABLE-INDEX FROM 1, BY 1 29 | UNTIL DONE. 30 | EXIT PROGRAM. 31 | 32 | ENCODE-CHARACTER. 33 | MOVE SPACES TO COBOL-STRING. 34 | UNSTRING MSG-BODY 35 | INTO CURRENT-CHARACTER 36 | WITH POINTER STRING-POINTER. 37 | IF ESCAPE-CHAR THEN 38 | MOVE SPACES TO COBOL-STRING 39 | IF STRING-POINTER < 993 THEN 40 | UNSTRING MSG-BODY DELIMITED BY "$" 41 | INTO COBOL-STRING 42 | WITH POINTER STRING-POINTER 43 | IF COBOL-STRING IS EQUAL TO SPACES THEN 44 | MOVE "$" TO COBOL-STRING 45 | ELSE 46 | NEXT SENTENCE 47 | ELSE 48 | MOVE "NUL" TO COBOL-STRING. 49 | IF COBOL-STRING IS EQUAL TO "NUL" THEN 50 | MOVE 99 TO LOOP-STATE. 51 | IF TABLE-INDEX IS GREATER THAN 998 THEN 52 | MOVE 99 TO LOOP-STATE. 53 | CALL "ENCODE-ASCII" USING ASCII-CHARACTER. 54 | MOVE CHAR-CODE TO ASCII-CELL(TABLE-INDEX). 55 | -------------------------------------------------------------------------------- /REESCAPE.COB: -------------------------------------------------------------------------------- 1 | IDENTIFICATION DIVISION. 2 | PROGRAM-ID. "RE-ESCAPE". 3 | 4 | DATA DIVISION. 5 | WORKING-STORAGE SECTION. 6 | 01 PTRS. 7 | 03 IN-PTR PIC 999. 8 | 03 OUT-PTR PIC 999. 9 | 03 TEMP-PTR PIC 999. 10 | 01 CURRENT-CHAR PIC X. 11 | 88 ESCAPE-CHAR VALUE "$". 12 | 01 ESCAPE-TEMP PIC XXX. 13 | 88 STRING-TERMINATED VALUE "NUL". 14 | 01 LOOP-STATE PIC 99. 15 | 88 DONE VALUE 99. 16 | 17 | LINKAGE SECTION. 18 | 01 INPUT-BUFFER PIC X(999). 19 | 01 OUTPUT-BUFFER PIC X(999). 20 | 21 | PROCEDURE DIVISION USING INPUT-BUFFER, OUTPUT-BUFFER. 22 | MOVE 0 TO LOOP-STATE. 23 | MOVE 1 TO IN-PTR, OUT-PTR. 24 | PERFORM MAYBE-ESCAPE-CHAR UNTIL DONE. 25 | * IF THE STRING WAS UNTERMINATED, THE POINTER WILL HAVE WRAPPED 26 | IF OUT-PTR IS GREATER THAN 0 THEN 27 | MOVE 0 TO LOOP-STATE 28 | PERFORM BLANK-REST UNTIL DONE. 29 | EXIT PROGRAM. 30 | 31 | MAYBE-ESCAPE-CHAR. 32 | IF IN-PTR IS LESS THAN 999 AND 33 | OUT-PTR IS LESS THAN 999 THEN 34 | UNSTRING INPUT-BUFFER 35 | INTO CURRENT-CHAR 36 | WITH POINTER IN-PTR 37 | IF ESCAPE-CHAR THEN 38 | MOVE IN-PTR TO TEMP-PTR 39 | UNSTRING INPUT-BUFFER DELIMITED BY "$" 40 | INTO ESCAPE-TEMP 41 | WITH POINTER TEMP-PTR 42 | IF STRING-TERMINATED THEN 43 | MOVE 99 TO LOOP-STATE 44 | IF OUT-PTR IS LESS THAN 995 THEN 45 | STRING "$NUL$" 46 | INTO OUTPUT-BUFFER 47 | WITH POINTER OUT-PTR 48 | ELSE 49 | NEXT SENTENCE 50 | ELSE 51 | STRING "$$" 52 | INTO OUTPUT-BUFFER 53 | WITH POINTER OUT-PTR 54 | ELSE 55 | STRING CURRENT-CHAR 56 | INTO OUTPUT-BUFFER 57 | WITH POINTER OUT-PTR 58 | ELSE 59 | MOVE 99 TO LOOP-STATE 60 | UNSTRING INPUT-BUFFER 61 | INTO CURRENT-CHAR 62 | WITH POINTER IN-PTR 63 | IF ESCAPE-CHAR THEN 64 | STRING SPACE 65 | INTO OUTPUT-BUFFER 66 | WITH POINTER OUT-PTR 67 | ELSE 68 | STRING CURRENT-CHAR 69 | INTO OUTPUT-BUFFER 70 | WITH POINTER OUT-PTR. 71 | 72 | BLANK-REST. 73 | IF OUT-PTR IS EQUAL TO 999 THEN 74 | MOVE 99 TO LOOP-STATE. 75 | STRING SPACE 76 | INTO OUTPUT-BUFFER 77 | WITH POINTER OUT-PTR. 78 | -------------------------------------------------------------------------------- /IRC-MSG.COB: -------------------------------------------------------------------------------- 1 | IDENTIFICATION DIVISION. 2 | PROGRAM-ID. "PARSE-IRC-MSG". 3 | 4 | DATA DIVISION. 5 | WORKING-STORAGE SECTION. 6 | 01 WORK-PARAMETER. 7 | 03 WORK PIC X(999). 8 | 88 BLANK-PARAM VALUE SPACES. 9 | 03 WORK-1 REDEFINES WORK PIC X(6). 10 | 88 REST-PARAMETER VALUE "$COLN$". 11 | 03 WORK-DELIM PIC X(6). 12 | 88 IDENT-SPEC VALUE "$EXC$". 13 | 88 HOST-SPEC VALUE "$AT$". 14 | 88 PREFIX-END VALUE ALL SPACES. 15 | 01 MSG-POINTER PIC 999. 16 | 01 LOOP-STATE PIC 99. 17 | 88 DONE VALUE 99. 18 | 19 | LINKAGE SECTION. 20 | 01 BUFFER. 21 | 03 MSG-BODY PIC X(999). 22 | 03 MSG-BODY-1 REDEFINES MSG-BODY PIC X(6). 23 | 88 HAS-PREFIX VALUE "$COLN$". 24 | 01 IRC-PARAMS. 25 | 03 NUM-PARAMS PIC 99. 26 | 03 PREFIX. 27 | 05 MSG-SRC PIC 999. 28 | 05 IDENT PIC 999. 29 | 05 HOST PIC 999. 30 | 03 COMMAND PIC 999. 31 | 03 PARAM PIC 999 OCCURS 15 TIMES. 32 | 33 | PROCEDURE DIVISION USING BUFFER, IRC-PARAMS. 34 | MOVE 0 TO IRC-PARAMS. 35 | MOVE SPACES TO WORK. 36 | MOVE 1 TO MSG-POINTER. 37 | IF HAS-PREFIX THEN 38 | PERFORM WITH-PREFIX 39 | ELSE 40 | MOVE 0 TO MSG-SRC 41 | MOVE 1 TO MSG-POINTER. 42 | MOVE MSG-POINTER TO COMMAND. 43 | UNSTRING MSG-BODY DELIMITED BY SPACES 44 | INTO WORK 45 | WITH POINTER MSG-POINTER. 46 | MOVE 0 TO LOOP-STATE. 47 | PERFORM GET-PARAMETER 48 | VARYING NUM-PARAMS FROM 1, BY 1 49 | UNTIL DONE OR 50 | NUM-PARAMS IS NOT LESS THAN 15. 51 | SUBTRACT 1 FROM NUM-PARAMS. 52 | EXIT PROGRAM. 53 | 54 | GET-PARAMETER. 55 | MOVE MSG-POINTER TO PARAM(NUM-PARAMS). 56 | MOVE SPACES TO WORK. 57 | UNSTRING MSG-BODY DELIMITED BY SPACES 58 | INTO WORK 59 | WITH POINTER MSG-POINTER. 60 | IF BLANK-PARAM OR REST-PARAMETER THEN 61 | MOVE 99 TO LOOP-STATE. 62 | IF BLANK-PARAM THEN 63 | SUBTRACT 1 FROM NUM-PARAMS 64 | ELSE IF REST-PARAMETER THEN 65 | ADD 6 TO PARAM(NUM-PARAMS). 66 | 67 | WITH-PREFIX. 68 | MOVE 7 TO MSG-POINTER, MSG-SRC. 69 | MOVE 0 TO LOOP-STATE. 70 | PERFORM GET-PREFIX-PART UNTIL DONE. 71 | 72 | GET-PREFIX-PART. 73 | MOVE SPACES TO WORK-DELIM. 74 | UNSTRING MSG-BODY, 75 | DELIMITED BY "$EXC$", OR "$AT$", OR SPACES, 76 | INTO WORK, DELIMITER IN WORK-DELIM, 77 | WITH POINTER MSG-POINTER. 78 | IF IDENT-SPEC THEN MOVE MSG-POINTER TO IDENT. 79 | IF HOST-SPEC THEN MOVE MSG-POINTER TO HOST. 80 | IF PREFIX-END THEN MOVE 99 TO LOOP-STATE. 81 | -------------------------------------------------------------------------------- /PRINTCNF.COB: -------------------------------------------------------------------------------- 1 | IDENTIFICATION DIVISION. 2 | PROGRAM-ID. "PRINT-CONFIG". 3 | 4 | ENVIRONMENT DIVISION. 5 | INPUT-OUTPUT SECTION. 6 | FILE-CONTROL. 7 | SELECT CONFIG 8 | ASSIGN TO DISK 9 | ORGANIZATION IS INDEXED 10 | ACCESS MODE IS SEQUENTIAL 11 | RECORD KEY IS CONFIG-KEY. 12 | SELECT USERS 13 | ASSIGN TO DISK 14 | ORGANIZATION IS INDEXED 15 | ACCESS MODE IS SEQUENTIAL 16 | RECORD KEY IS USER-NAME. 17 | SELECT CHANNELS 18 | ASSIGN TO DISK 19 | ORGANIZATION IS SEQUENTIAL. 20 | SELECT PROGRAM-INDEX 21 | ASSIGN TO DISK 22 | ORGANIZATION IS INDEXED 23 | ACCESS MODE IS SEQUENTIAL 24 | RECORD KEY IS NAME OF INDEX-ENTRY. 25 | SELECT PROGRAM-CODE 26 | ASSIGN TO DISK 27 | ORGANIZATION IS RELATIVE 28 | ACCESS MODE IS DYNAMIC 29 | RELATIVE KEY IS PROGRAM-IP. 30 | 31 | DATA DIVISION. 32 | FILE SECTION. 33 | FD CONFIG. 34 | 01 CONFIG-RECORD. 35 | 03 CONFIG-KEY PIC X(16). 36 | 03 CONFIG-VALUE PIC X(64). 37 | FD USERS. 38 | 01 USER-RECORD. 39 | 03 USER-NAME PIC X(40). 40 | 03 USER-LEVEL PIC 9(2). 41 | FD CHANNELS. 42 | 01 CHANNEL-RECORD. 43 | 03 CHANNEL-NAME PIC X(50). 44 | FD PROGRAM-INDEX. 45 | 01 INDEX-ENTRY. 46 | 03 NAME PIC X(16). 47 | 03 ADDR PIC 999. 48 | FD PROGRAM-CODE. 49 | 01 PROGRAM-RECORD. 50 | 03 INSTRUCTION-RECORD PIC X(999). 51 | 03 PREV-IP PIC 999. 52 | 03 NEXT-IP PIC 999. 53 | 54 | WORKING-STORAGE SECTION. 55 | 01 STATE PIC 9(2) VALUE 0. 56 | 88 DONE VALUE 10. 57 | 01 PROGRAM-IP PIC 999. 58 | 59 | PROCEDURE DIVISION. 60 | DISPLAY "CONFIGURATION ENTRIES.". 61 | OPEN INPUT CONFIG. 62 | PERFORM PRINT-CONFIG-ENTRY UNTIL DONE. 63 | MOVE 0 TO STATE. 64 | CLOSE CONFIG. 65 | DISPLAY "USER ENTRIES.". 66 | OPEN INPUT USERS. 67 | PERFORM PRINT-USER-ENTRY UNTIL DONE. 68 | MOVE 0 TO STATE. 69 | CLOSE USERS. 70 | DISPLAY "CHANNEL ENTRIES.". 71 | OPEN INPUT CHANNELS. 72 | PERFORM PRINT-CHANNEL-ENTRY UNTIL DONE. 73 | MOVE 0 TO STATE. 74 | CLOSE CHANNELS. 75 | DISPLAY "PROGRAMS.". 76 | OPEN INPUT PROGRAM-INDEX, PROGRAM-CODE. 77 | PERFORM PRINT-PROGRAM UNTIL DONE. 78 | CLOSE PROGRAM-INDEX, PROGRAM-CODE. 79 | EXIT PROGRAM. 80 | 81 | PRINT-CONFIG-ENTRY. 82 | READ CONFIG NEXT RECORD 83 | AT END MOVE 10 TO STATE. 84 | IF NOT DONE THEN 85 | DISPLAY CONFIG-RECORD. 86 | 87 | PRINT-USER-ENTRY. 88 | READ USERS NEXT RECORD 89 | AT END MOVE 10 TO STATE. 90 | IF NOT DONE THEN 91 | DISPLAY USER-RECORD. 92 | 93 | PRINT-CHANNEL-ENTRY. 94 | READ CHANNELS NEXT RECORD 95 | AT END MOVE 10 TO STATE. 96 | IF NOT DONE THEN 97 | DISPLAY CHANNEL-RECORD. 98 | 99 | PRINT-PROGRAM. 100 | READ PROGRAM-INDEX NEXT RECORD 101 | AT END MOVE 10 TO STATE. 102 | IF NOT DONE THEN 103 | DISPLAY NAME OF INDEX-ENTRY 104 | MOVE ADDR OF INDEX-ENTRY TO PROGRAM-IP 105 | PERFORM PRINT-INSTRUCTION UNTIL DONE 106 | MOVE 0 TO STATE. 107 | 108 | PRINT-INSTRUCTION. 109 | READ PROGRAM-CODE RECORD 110 | AT END MOVE 10 TO STATE. 111 | IF NOT DONE THEN 112 | DISPLAY PROGRAM-IP, ".", INSTRUCTION-RECORD, ".", 113 | PREV-IP, ".", NEXT-IP 114 | IF NEXT-IP OF PROGRAM-RECORD IS EQUAL TO 999 THEN 115 | MOVE 10 TO STATE 116 | ELSE 117 | MOVE NEXT-IP OF PROGRAM-RECORD TO PROGRAM-IP. 118 | -------------------------------------------------------------------------------- /WOPO-CNF.COB: -------------------------------------------------------------------------------- 1 | IDENTIFICATION DIVISION. 2 | PROGRAM-ID. "WOPO-CNF". 3 | 4 | ENVIRONMENT DIVISION. 5 | INPUT-OUTPUT SECTION. 6 | FILE-CONTROL. 7 | SELECT CONFIG 8 | ASSIGN TO DISK 9 | ORGANIZATION IS INDEXED 10 | ACCESS MODE IS RANDOM 11 | RECORD KEY IS CONFIG-KEY. 12 | SELECT USERS 13 | ASSIGN TO DISK 14 | ORGANIZATION IS INDEXED 15 | ACCESS MODE IS RANDOM 16 | RECORD KEY IS USER-NAME. 17 | SELECT CHANNELS 18 | ASSIGN TO DISK 19 | ORGANIZATION IS SEQUENTIAL. 20 | SELECT PROGRAM-INDEX 21 | ASSIGN TO DISK 22 | ORGANIZATION IS INDEXED 23 | ACCESS MODE IS RANDOM 24 | RECORD KEY IS NAME OF INDEX-ENTRY. 25 | SELECT PROGRAM-CODE 26 | ASSIGN TO DISK 27 | ORGANIZATION IS RELATIVE 28 | ACCESS MODE IS SEQUENTIAL 29 | RELATIVE KEY IS PROGRAM-IP. 30 | 31 | DATA DIVISION. 32 | FILE SECTION. 33 | FD CONFIG. 34 | 01 CONFIG-RECORD. 35 | 03 CONFIG-KEY PIC X(16). 36 | 03 CONFIG-VALUE PIC X(64). 37 | FD USERS. 38 | 01 USER-RECORD. 39 | 03 USER-NAME PIC X(40). 40 | 03 USER-LEVEL PIC 9(2). 41 | FD CHANNELS. 42 | 01 CHANNEL-RECORD. 43 | 03 CHANNEL-NAME PIC X(50). 44 | FD PROGRAM-INDEX. 45 | 01 INDEX-ENTRY. 46 | 03 NAME PIC X(16). 47 | 03 ADDR PIC 999. 48 | FD PROGRAM-CODE. 49 | 01 PROGRAM-RECORD. 50 | 03 INSTRUCTION PIC X(999). 51 | 03 PREV-IP PIC 999. 52 | 03 NEXT-IP PIC 999. 53 | 54 | WORKING-STORAGE SECTION. 55 | 01 STATE PIC 9(2) VALUE 0. 56 | 88 WRITING-PROGRAM VALUE 10. 57 | 88 DONE VALUE 99. 58 | 01 CURRENT-INSTRUCTION. 59 | 03 INSTRUCTION PIC X(999). 60 | 03 PREV-IP PIC 999. 61 | 03 NEXT-IP PIC 999. 62 | 01 PROGRAM-IP PIC 999. 63 | 64 | PROCEDURE DIVISION. 65 | DISPLAY "WOPO CONFIGURATION PROGRAM". 66 | DISPLAY "BLANK ENTRY TO EXIT SECTION". 67 | DISPLAY "WRITING CONFIGURATION ENTRIES:". 68 | OPEN OUTPUT CONFIG. 69 | MOVE 0 TO STATE. 70 | PERFORM WRITE-CONFIG-ENTRY UNTIL DONE. 71 | CLOSE CONFIG. 72 | DISPLAY "WRITING USER ENTRIES:" 73 | OPEN OUTPUT USERS. 74 | MOVE 0 TO STATE. 75 | PERFORM WRITE-USER-ENTRY UNTIL DONE. 76 | CLOSE USERS. 77 | OPEN OUTPUT CHANNELS. 78 | DISPLAY "WRITING CHANNEL AUTOJOINS:" 79 | MOVE 0 TO STATE. 80 | PERFORM WRITE-CHANNEL-ENTRY UNTIL DONE. 81 | CLOSE CHANNELS. 82 | OPEN OUTPUT PROGRAM-INDEX, PROGRAM-CODE. 83 | DISPLAY "WRITING PROGRAMS." 84 | MOVE 0 TO STATE. 85 | PERFORM WRITE-PROGRAM UNTIL DONE. 86 | CLOSE PROGRAM-INDEX, PROGRAM-CODE. 87 | CALL "PRINT-CONFIG". 88 | STOP RUN. 89 | 90 | WRITE-CONFIG-ENTRY. 91 | ACCEPT CONFIG-RECORD. 92 | IF CONFIG-RECORD IS EQUAL TO SPACES 93 | THEN MOVE 99 TO STATE 94 | ELSE WRITE CONFIG-RECORD. 95 | 96 | WRITE-USER-ENTRY. 97 | ACCEPT USER-RECORD. 98 | IF USER-NAME IS EQUAL TO SPACES OR USER-LEVEL IS EQUAL TO 0 99 | THEN MOVE 99 TO STATE 100 | ELSE WRITE USER-RECORD. 101 | 102 | WRITE-CHANNEL-ENTRY. 103 | ACCEPT CHANNEL-NAME. 104 | IF CHANNEL-NAME IS EQUAL TO SPACES 105 | THEN MOVE 99 TO STATE 106 | ELSE WRITE CHANNEL-RECORD. 107 | 108 | WRITE-PROGRAM. 109 | ACCEPT NAME OF INDEX-ENTRY. 110 | IF NAME OF INDEX-ENTRY IS EQUAL TO SPACES THEN 111 | D DISPLAY "DONE WRITING PROGRAMS." 112 | MOVE 99 TO STATE 113 | ELSE 114 | D DISPLAY "WRITING PROGRAM ", NAME OF INDEX-ENTRY, "." 115 | COMPUTE ADDR OF INDEX-ENTRY = PROGRAM-IP + 1 116 | WRITE INDEX-ENTRY 117 | MOVE SPACES TO INSTRUCTION OF PROGRAM-RECORD, 118 | INSTRUCTION OF CURRENT-INSTRUCTION 119 | PERFORM WRITE-PROGRAM-RECORD UNTIL DONE 120 | MOVE 0 TO STATE. 121 | 122 | WRITE-PROGRAM-RECORD. 123 | ACCEPT INSTRUCTION OF CURRENT-INSTRUCTION. 124 | IF INSTRUCTION OF CURRENT-INSTRUCTION IS EQUAL TO SPACES THEN 125 | D DISPLAY "DONE WRITING PROGRAM ", 126 | D NAME OF INDEX-ENTRY, "." 127 | MOVE 999 TO NEXT-IP OF PROGRAM-RECORD 128 | MOVE 99 TO STATE 129 | ELSE 130 | D DISPLAY "ACCEPTED INSTRUCTION. ", 131 | D INSTRUCTION OF CURRENT-INSTRUCTION 132 | COMPUTE NEXT-IP IN PROGRAM-RECORD = PROGRAM-IP + 2 133 | IF WRITING-PROGRAM THEN 134 | COMPUTE PREV-IP OF CURRENT-INSTRUCTION = 135 | PROGRAM-IP + 1 136 | ELSE 137 | MOVE 0 TO PREV-IP OF CURRENT-INSTRUCTION. 138 | IF INSTRUCTION OF PROGRAM-RECORD IS NOT EQUAL TO SPACES THEN 139 | D DISPLAY "WRITING INSTRUCTION. ", PROGRAM-RECORD 140 | WRITE PROGRAM-RECORD 141 | IF NOT DONE THEN 142 | MOVE 10 TO STATE. 143 | MOVE CURRENT-INSTRUCTION TO PROGRAM-RECORD. 144 | -------------------------------------------------------------------------------- /channel.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | #define CELL_DIGITS 3 13 | #define BUFFER_SIZE 999 14 | /* 15 | * 01 COBOL-BUFFER PIC 9(CELL_DIGITS) OCCURS BUFFER_SIZE TIMES 16 | */ 17 | char msg_buf[BUFFER_SIZE]; 18 | 19 | #define STATE_DIGITS 2 20 | // 01 CHANNEL-STATUS PIC 9(STATE_DIGITS) 21 | #define EBADDEST 10 22 | #define EOPENFAIL 20 23 | #define EHUP 30 24 | #define ESERV 40 25 | 26 | #define DEFAULT_PORT "6667" 27 | int sockfd; 28 | 29 | #define RECV_BUF_SIZE 1024 30 | char recv_buf[RECV_BUF_SIZE]; 31 | size_t recv_buf_pos = 0; 32 | 33 | void channel_set_status(char *state, int value) 34 | { 35 | char buf[STATE_DIGITS + 1]; 36 | snprintf(buf, STATE_DIGITS + 1, "%.*hhu", STATE_DIGITS, (unsigned char)value); 37 | memcpy(state, buf, STATE_DIGITS); 38 | 39 | return; 40 | } 41 | 42 | void channel_from_cobol(char *cobol_buffer) 43 | { 44 | char buf[CELL_DIGITS + 1]; 45 | buf[CELL_DIGITS] = '\0'; 46 | memcpy(buf, cobol_buffer, CELL_DIGITS); 47 | 48 | int i; 49 | for(i = 0; i < BUFFER_SIZE; memcpy(buf, cobol_buffer + ++i * CELL_DIGITS, CELL_DIGITS)) { 50 | msg_buf[i] = (char)strtol(buf, NULL, 10); 51 | if(!msg_buf[i]) { 52 | break; 53 | } 54 | } 55 | if (i == BUFFER_SIZE) { 56 | int message_length = 0; 57 | for(i = 0; i < BUFFER_SIZE; i++) { 58 | if(msg_buf[i] != ' ') { 59 | message_length = i + 1; 60 | } 61 | } 62 | if(message_length == BUFFER_SIZE) { 63 | message_length--; 64 | } 65 | msg_buf[message_length] = '\0'; 66 | } else { 67 | msg_buf[i] = '\0'; 68 | } 69 | return; 70 | } 71 | 72 | void channel_to_cobol(char *cobol_buffer) 73 | { 74 | char buf[CELL_DIGITS + 1]; 75 | int i; 76 | for(i = 0; i < BUFFER_SIZE - 1 77 | && msg_buf[i] 78 | && msg_buf[i] != '\n' 79 | && msg_buf[i] != '\r' 80 | && msg_buf[i]; i++) { 81 | snprintf(buf, CELL_DIGITS + 1, "%.*hhu", CELL_DIGITS, msg_buf[i]); 82 | memcpy(cobol_buffer + i * CELL_DIGITS, buf, CELL_DIGITS); 83 | } 84 | memset(cobol_buffer + i * CELL_DIGITS, (int)'0', CELL_DIGITS); 85 | 86 | return; 87 | } 88 | 89 | void channel_string_to_cobol(char *cobol_buffer, const char *s) 90 | { 91 | strncpy(msg_buf, s, BUFFER_SIZE); 92 | msg_buf[BUFFER_SIZE - 1] = '\0'; 93 | channel_to_cobol(cobol_buffer); 94 | return; 95 | } 96 | 97 | /* 98 | * ASCII "HOST[:PORT]$NUL$" IN COBOL-BUFFER 99 | * CALL "CHANNEL-OPEN" USING COBOL-BUFFER, STATE. 100 | */ 101 | void CHANNEL__OPEN(char *cobol_buffer, char *state) 102 | { 103 | channel_from_cobol(cobol_buffer); 104 | #ifdef DEBUG 105 | printf("CHANNEL__OPEN: %s\n", msg_buf); 106 | #endif 107 | if(!strlen(msg_buf)) { 108 | channel_string_to_cobol(cobol_buffer, "No host specified"); 109 | channel_set_status(state, EBADDEST); 110 | return; 111 | } 112 | char *port = strchr(msg_buf, ':'); 113 | if(port) { 114 | *port = '\0'; 115 | port++; 116 | if(!strlen(port)) { 117 | channel_string_to_cobol(cobol_buffer, "Port separator specified, but not port"); 118 | channel_set_status(state, EBADDEST); 119 | return; 120 | } 121 | } else { 122 | port = DEFAULT_PORT; 123 | } 124 | 125 | struct addrinfo hints, *res; 126 | int status; 127 | memset(&hints, 0, sizeof(hints)); 128 | hints.ai_family = AF_UNSPEC; 129 | hints.ai_socktype = SOCK_STREAM; 130 | hints.ai_flags = AI_ADDRCONFIG; 131 | if((status = getaddrinfo(msg_buf, port, &hints, &res))) { 132 | channel_string_to_cobol(cobol_buffer, gai_strerror(status)); 133 | channel_set_status(state, EBADDEST); 134 | return; 135 | } 136 | 137 | struct addrinfo *curr_addr; 138 | for(curr_addr = res; curr_addr; curr_addr = curr_addr->ai_next) { 139 | sockfd = socket(curr_addr->ai_family, curr_addr->ai_socktype, curr_addr->ai_protocol); 140 | if(sockfd == -1) { 141 | perror("socket"); 142 | continue; 143 | } 144 | if(connect(sockfd, curr_addr->ai_addr, curr_addr->ai_addrlen) == -1) { 145 | perror("connect"); 146 | close(sockfd); 147 | continue; 148 | } 149 | 150 | break; 151 | } 152 | 153 | if(!curr_addr) { 154 | channel_string_to_cobol(cobol_buffer, "Unable to connect to host"); 155 | channel_set_status(state, EOPENFAIL); 156 | return; 157 | } 158 | 159 | channel_set_status(state, 0); 160 | return; 161 | } 162 | 163 | // CALL "CHANNEL-SEND" USING COBOL-BUFFER, STATE. 164 | void CHANNEL__SEND(char *cobol_buffer, char *state) 165 | { 166 | char *msg; 167 | int sent, total; 168 | channel_from_cobol(cobol_buffer); 169 | #ifdef DEBUG 170 | printf("Got from COBOL: %s\n", msg_buf); 171 | #endif 172 | sent = 0; 173 | total = strlen(msg_buf); 174 | if(msg_buf[total - 1] != '\n') { 175 | if(total < BUFFER_SIZE) { 176 | total++; 177 | } 178 | msg_buf[total - 1] = '\n'; 179 | msg_buf[total] = '\0'; 180 | } 181 | #ifdef DEBUG 182 | printf("Sending: %s\n", msg_buf); 183 | #endif 184 | /* Let's quit getting WOPO kicked off Freenode */ 185 | usleep(200000); 186 | while(sent < total) { 187 | int status = send(sockfd, msg_buf + sent, total - sent, 0); 188 | if(status == -1) { 189 | perror("send"); 190 | close(sockfd); 191 | channel_string_to_cobol(cobol_buffer, "Hung up"); 192 | channel_set_status(state, EHUP); 193 | return; 194 | } 195 | sent += status; 196 | } 197 | 198 | channel_set_status(state, 0); 199 | return; 200 | } 201 | 202 | // CALL "CHANNEL-RECV" USING COBOL-BUFFER, STATE. 203 | void CHANNEL__RECV(char *cobol_buffer, char *state) 204 | { 205 | char *message_end; 206 | get_buffered: 207 | message_end = memchr(recv_buf, '\n', recv_buf_pos); 208 | if(message_end) { 209 | size_t message_size = message_end - recv_buf; 210 | if (message_size > BUFFER_SIZE) { 211 | channel_string_to_cobol(cobol_buffer, "Server sent too-long message"); 212 | channel_set_status(state, ESERV); 213 | return; 214 | } 215 | memcpy(msg_buf, recv_buf, message_size); 216 | msg_buf[message_size] = '\0'; 217 | recv_buf_pos -= message_size + 1; 218 | message_end++; 219 | for(size_t i = 0; i < recv_buf_pos; i++) { 220 | recv_buf[i] = message_end[i]; 221 | } 222 | #ifdef DEBUG 223 | printf("Received: %s\n", msg_buf); 224 | #endif 225 | channel_to_cobol(cobol_buffer); 226 | channel_set_status(state, 0); 227 | #ifdef DEBUG 228 | printf("Line converted to COBOL ASCII string.\n"); 229 | #endif 230 | return; 231 | } 232 | if(recv_buf_pos < RECV_BUF_SIZE - 1) { 233 | ssize_t received = recv(sockfd, recv_buf + recv_buf_pos, RECV_BUF_SIZE - recv_buf_pos, 0); 234 | if(received != -1) { 235 | recv_buf_pos += received; 236 | goto get_buffered; 237 | } 238 | perror("recv"); 239 | channel_string_to_cobol(cobol_buffer, "Hung up"); 240 | channel_set_status(state, EHUP); 241 | return; 242 | } 243 | 244 | channel_string_to_cobol(cobol_buffer, "Server failed to send newline"); 245 | channel_set_status(state, ESERV); 246 | return; 247 | } 248 | 249 | void CHANNEL__CLOSE(void) 250 | { 251 | close(sockfd); 252 | 253 | return; 254 | } 255 | 256 | -------------------------------------------------------------------------------- /BF-RUN.COB: -------------------------------------------------------------------------------- 1 | IDENTIFICATION DIVISION. 2 | PROGRAM-ID. "BF-RUN". 3 | 4 | DATA DIVISION. 5 | WORKING-STORAGE SECTION. 6 | 01 STATE USAGE COMPUTATIONAL. 7 | 03 IN-PTR PIC 9(3) VALUE 1. 8 | 03 IP PIC 9(3) VALUE 1. 9 | 03 CYCLES PIC 9(8) VALUE 0. 10 | 03 OUT-PTR PIC 9(3) VALUE 1. 11 | 03 LOOP-DEPTH PIC 99 VALUE 0. 12 | 03 LOOP-WORK PIC 99 VALUE 0. 13 | 03 LOOP-STATE PIC 99 VALUE 0. 14 | 88 DONE VALUE 99. 15 | 01 BF-MEMORY. 16 | 03 BF-CELL PIC 999 17 | USAGE COMPUTATIONAL 18 | OCCURS 9999 TIMES 19 | INDEXED BY CURRENT-CELL. 20 | 01 CURRENT-INSTRUCTION PIC X. 21 | 88 BF-LEFT VALUE "<". 22 | 88 BF-RIGHT VALUE ">". 23 | 88 BF-DEC VALUE "-". 24 | 88 BF-INC VALUE "+". 25 | 88 BF-OUT VALUE ".". 26 | 88 BF-IN VALUE ",". 27 | 88 BF-BEGIN VALUE "(". 28 | 88 BF-END VALUE ")". 29 | 88 BF-ESCAPE VALUE "$". 30 | 88 BF-DIE VALUE "$". 31 | 01 I-O-CHARACTER PIC X. 32 | 88 ESCAPE-CHAR VALUE "$". 33 | 01 ASCII-CHARACTER. 34 | 03 CHAR-CODE PIC 999. 35 | 03 COBOL-STRING PIC X(6). 36 | 88 LSQB VALUE "LSQB". 37 | 88 RSQB VALUE "RSQB". 38 | D01 DEBUG-DISPLAY. 39 | D 03 FILLER PIC XXX VALUE "IP.". 40 | D 03 DEBUG-IP PIC 9(3). 41 | D 03 FILLER PIC X VALUE ";". 42 | D 03 DEBUG-INSTRUCTION PIC X. 43 | D 03 FILLER PIC X(5) VALUE "CELL.". 44 | D 03 DEBUG-CURRENT-CELL PIC 999. 45 | D 03 FILLER PIC X(4) VALUE "VAL.". 46 | D 03 DEBUG-CELL PIC 999. 47 | D 03 FILLER PIC X VALUE "L". 48 | D 03 DEBUG-LOOP-DEPTH PIC 99. 49 | D 03 FILLER PIC X VALUE "C". 50 | D 03 DEBUG-CYCLES PIC 9(5). 51 | 52 | LINKAGE SECTION. 53 | 01 BF-INPUT PIC X(999). 54 | 01 BF-CODE PIC X(999). 55 | 01 BF-OUTPUT PIC X(999). 56 | 01 CYCLE-LIMIT PIC 9(8). 57 | 58 | PROCEDURE DIVISION USING BF-INPUT, BF-CODE, 59 | BF-OUTPUT, CYCLE-LIMIT. 60 | MOVE 1 TO IN-PTR. 61 | MOVE 1 TO IP. 62 | MOVE 0 TO CYCLES. 63 | MOVE 1 TO OUT-PTR. 64 | MOVE 0 TO LOOP-DEPTH. 65 | MOVE 0 TO LOOP-WORK. 66 | MOVE 0 TO LOOP-STATE. 67 | MOVE SPACES TO BF-OUTPUT. 68 | SET CURRENT-CELL TO 1. 69 | PERFORM ZERO-CELL VARYING CURRENT-CELL 70 | FROM 1 BY 1 71 | UNTIL CURRENT-CELL IS GREATER THAN 9999. 72 | SET CURRENT-CELL TO 1. 73 | D MOVE 1 TO DEBUG-CURRENT-CELL. 74 | PERFORM EXECUTE-INSTRUCTION 75 | UNTIL CYCLES IS GREATER THAN OR EQUAL TO CYCLE-LIMIT. 76 | EXIT PROGRAM. 77 | 78 | HELL. 79 | EXIT PROGRAM. 80 | 81 | ZERO-CELL. 82 | MOVE 0 TO BF-CELL(CURRENT-CELL). 83 | 84 | READ-INSTRUCTION. 85 | IF IP IS LESS THAN 999 THEN 86 | UNSTRING BF-CODE INTO CURRENT-INSTRUCTION WITH POINTER IP 87 | IF BF-ESCAPE THEN 88 | UNSTRING BF-CODE DELIMITED BY "$" 89 | INTO COBOL-STRING 90 | WITH POINTER IP 91 | IF COBOL-STRING IS EQUAL TO SPACES OR 92 | COBOL-STRING IS EQUAL TO "NUL" THEN 93 | MOVE "$" TO CURRENT-INSTRUCTION 94 | ELSE IF LSQB THEN 95 | MOVE "(" TO CURRENT-INSTRUCTION 96 | ELSE IF RSQB THEN 97 | MOVE ")" TO CURRENT-INSTRUCTION 98 | ELSE 99 | MOVE SPACE TO CURRENT-INSTRUCTION 100 | ELSE 101 | NEXT SENTENCE 102 | ELSE 103 | MOVE 99 TO LOOP-STATE. 104 | 105 | EXECUTE-INSTRUCTION. 106 | MOVE 0 TO LOOP-STATE. 107 | PERFORM READ-INSTRUCTION. 108 | D MOVE IP TO DEBUG-IP. 109 | D MOVE CURRENT-INSTRUCTION TO DEBUG-INSTRUCTION. 110 | D MOVE BF-CELL(CURRENT-CELL) TO DEBUG-CELL. 111 | D MOVE LOOP-DEPTH TO DEBUG-LOOP-DEPTH. 112 | D MOVE CYCLES TO DEBUG-CYCLES. 113 | D DISPLAY DEBUG-DISPLAY. 114 | IF DONE THEN 115 | D DISPLAY "GOING TO HELL" 116 | GO TO HELL. 117 | IF BF-LEFT THEN 118 | PERFORM DO-LEFT 119 | MOVE 99 TO LOOP-STATE 120 | ELSE IF BF-RIGHT AND NOT DONE THEN 121 | PERFORM DO-RIGHT 122 | MOVE 99 TO LOOP-STATE 123 | ELSE IF BF-DEC AND NOT DONE THEN 124 | PERFORM DO-DEC 125 | MOVE 99 TO LOOP-STATE 126 | ELSE IF BF-INC AND NOT DONE THEN 127 | PERFORM DO-INC 128 | MOVE 99 TO LOOP-STATE 129 | ELSE IF BF-OUT AND NOT DONE THEN 130 | PERFORM DO-OUT 131 | MOVE 99 TO LOOP-STATE 132 | ELSE IF BF-IN AND NOT DONE THEN 133 | PERFORM DO-IN 134 | MOVE 99 TO LOOP-STATE 135 | ELSE IF BF-BEGIN AND NOT DONE THEN 136 | PERFORM DO-BEGIN 137 | MOVE 99 TO LOOP-STATE 138 | ELSE IF BF-END AND NOT DONE THEN 139 | PERFORM DO-END 140 | MOVE 99 TO LOOP-STATE 141 | ELSE IF BF-DIE THEN 142 | GO TO HELL. 143 | ADD 1 TO CYCLES. 144 | 145 | DO-LEFT. 146 | IF CURRENT-CELL IS GREATER THAN 1 THEN 147 | SET CURRENT-CELL DOWN BY 1 148 | D SUBTRACT 1 FROM DEBUG-CURRENT-CELL 149 | ELSE 150 | D MOVE 9999 TO DEBUG-CURRENT-CELL 151 | SET CURRENT-CELL TO 9999. 152 | MOVE 99 TO LOOP-STATE. 153 | 154 | DO-RIGHT. 155 | IF CURRENT-CELL IS LESS THAN 9999 THEN 156 | SET CURRENT-CELL UP BY 1 157 | D ADD 1 TO DEBUG-CURRENT-CELL 158 | ELSE 159 | D MOVE 1 TO DEBUG-CURRENT-CELL 160 | SET CURRENT-CELL TO 1. 161 | MOVE 99 TO LOOP-STATE. 162 | 163 | DO-DEC. 164 | IF BF-CELL(CURRENT-CELL) > 0 THEN 165 | SUBTRACT 1 FROM BF-CELL(CURRENT-CELL) 166 | ELSE 167 | MOVE 255 TO BF-CELL(CURRENT-CELL). 168 | MOVE 99 TO LOOP-STATE. 169 | 170 | DO-INC. 171 | IF BF-CELL(CURRENT-CELL) < 255 THEN 172 | ADD 1 TO BF-CELL(CURRENT-CELL) 173 | ELSE 174 | MOVE 0 TO BF-CELL(CURRENT-CELL). 175 | MOVE 99 TO LOOP-STATE. 176 | 177 | DO-OUT. 178 | IF OUT-PTR < 999 THEN 179 | MOVE BF-CELL(CURRENT-CELL) TO CHAR-CODE 180 | CALL "DECODE-ASCII" USING ASCII-CHARACTER 181 | IF COBOL-STRING IS EQUAL TO SPACES THEN 182 | ADD 1 TO OUT-PTR 183 | ELSE 184 | STRING COBOL-STRING, 185 | DELIMITED BY SPACES, 186 | INTO BF-OUTPUT, 187 | WITH POINTER OUT-PTR 188 | D DISPLAY "OUT", I-O-CHARACTER, BF-CELL(CURRENT-CELL) 189 | ELSE 190 | GO TO HELL. 191 | MOVE 99 TO LOOP-STATE. 192 | 193 | DO-IN. 194 | UNSTRING BF-INPUT, 195 | INTO I-O-CHARACTER, 196 | WITH POINTER IN-PTR. 197 | IF NOT ESCAPE-CHAR THEN 198 | MOVE I-O-CHARACTER TO COBOL-STRING 199 | ELSE IF IN-PTR < 999 THEN 200 | UNSTRING BF-INPUT, 201 | INTO I-O-CHARACTER, 202 | WITH POINTER IN-PTR 203 | IF ESCAPE-CHAR THEN 204 | MOVE I-O-CHARACTER TO COBOL-STRING 205 | ELSE IF IN-PTR < 996 THEN 206 | SUBTRACT 1 FROM IN-PTR 207 | UNSTRING BF-INPUT, 208 | DELIMITED BY "$", 209 | INTO COBOL-STRING, 210 | WITH POINTER IN-PTR 211 | ELSE GO TO HELL 212 | ELSE GO TO HELL. 213 | CALL "ENCODE-ASCII" USING ASCII-CHARACTER. 214 | MOVE CHAR-CODE TO BF-CELL(CURRENT-CELL). 215 | D DISPLAY "IN", I-O-CHARACTER, BF-CELL(CURRENT-CELL). 216 | MOVE 99 TO LOOP-STATE. 217 | 218 | DO-BEGIN. 219 | IF BF-CELL(CURRENT-CELL) IS EQUAL TO 0 THEN 220 | MOVE LOOP-DEPTH TO LOOP-WORK 221 | ADD 1 TO LOOP-WORK 222 | PERFORM FIND-END UNTIL DONE 223 | ELSE 224 | ADD 1 TO LOOP-DEPTH. 225 | MOVE 99 TO LOOP-STATE. 226 | 227 | FIND-END. 228 | D DISPLAY "ENTERED FIND-END." 229 | PERFORM READ-INSTRUCTION. 230 | IF NOT DONE THEN 231 | IF BF-BEGIN THEN 232 | ADD 1 TO LOOP-WORK 233 | ELSE IF BF-END THEN 234 | D DISPLAY "FOUND END." 235 | SUBTRACT 1 FROM LOOP-WORK 236 | IF LOOP-WORK IS EQUAL TO LOOP-DEPTH THEN 237 | MOVE 99 TO LOOP-STATE. 238 | D DISPLAY "FIND-END.", IP, ";", CURRENT-INSTRUCTION, 239 | D "LD", LOOP-DEPTH, "LW", LOOP-WORK. 240 | 241 | DO-END. 242 | SUBTRACT 1 FROM LOOP-DEPTH. 243 | IF BF-CELL(CURRENT-CELL) IS NOT EQUAL TO 0 THEN 244 | MOVE LOOP-DEPTH TO LOOP-WORK 245 | SUBTRACT 1 FROM IP 246 | PERFORM FIND-BEGIN UNTIL DONE. 247 | MOVE 99 TO LOOP-STATE. 248 | 249 | FIND-BEGIN. 250 | D DISPLAY "ENTERED FIND-BEGIN." 251 | PERFORM UNREAD-INSTRUCTION. 252 | IF NOT DONE THEN 253 | IF BF-END THEN 254 | ADD 1 TO LOOP-WORK 255 | ELSE IF BF-BEGIN THEN 256 | D DISPLAY "FOUND BEGIN." 257 | SUBTRACT 1 FROM LOOP-WORK 258 | IF LOOP-WORK IS EQUAL TO LOOP-DEPTH THEN 259 | ADD 1 TO IP 260 | MOVE 99 TO LOOP-STATE. 261 | D DISPLAY "FIND-BEGIN.", IP, ";", CURRENT-INSTRUCTION, 262 | D "LD", LOOP-DEPTH, "LW", LOOP-WORK. 263 | 264 | 265 | UNREAD-INSTRUCTION. 266 | UNSTRING BF-CODE INTO CURRENT-INSTRUCTION WITH POINTER IP. 267 | IF BF-ESCAPE THEN 268 | D DISPLAY "PROCESSING ESCAPE" 269 | SUBTRACT 2 FROM IP 270 | PERFORM FIND-ESCAPE-BEGIN UNTIL DONE 271 | MOVE 0 TO LOOP-STATE 272 | ADD 2 TO IP 273 | UNSTRING BF-CODE DELIMITED BY "$" 274 | INTO COBOL-STRING 275 | WITH POINTER IP 276 | D DISPLAY "ESCAPED CHARACTER. $", COBOL-STRING, "$" 277 | SUBTRACT 2 FROM IP 278 | PERFORM FIND-ESCAPE-BEGIN UNTIL DONE 279 | MOVE 0 TO LOOP-STATE 280 | IF COBOL-STRING IS EQUAL TO SPACES THEN 281 | MOVE "$" TO CURRENT-INSTRUCTION 282 | ELSE IF LSQB THEN 283 | MOVE "(" TO CURRENT-INSTRUCTION 284 | ELSE IF RSQB THEN 285 | MOVE ")" TO CURRENT-INSTRUCTION 286 | ELSE 287 | MOVE SPACE TO CURRENT-INSTRUCTION 288 | ELSE 289 | D DISPLAY "NOT AN ESCAPE" 290 | IF IP IS GREATER THAN 2 THEN 291 | SUBTRACT 2 FROM IP 292 | ELSE 293 | MOVE 1 TO IP 294 | MOVE 99 TO LOOP-STATE. 295 | 296 | FIND-ESCAPE-BEGIN. 297 | UNSTRING BF-CODE INTO CURRENT-INSTRUCTION WITH POINTER IP. 298 | D DISPLAY "PROCESSING CHARACTER. ", CURRENT-INSTRUCTION. 299 | IF BF-ESCAPE THEN 300 | MOVE 99 TO LOOP-STATE. 301 | IF IP IS GREATER THAN 2 THEN 302 | SUBTRACT 2 FROM IP 303 | ELSE 304 | MOVE 1 TO IP 305 | MOVE 99 TO LOOP-STATE. 306 | -------------------------------------------------------------------------------- /DECASCII.COB: -------------------------------------------------------------------------------- 1 | IDENTIFICATION DIVISION. 2 | PROGRAM-ID. "DECODE-ASCII". 3 | 4 | DATA DIVISION. 5 | LINKAGE SECTION. 6 | 01 ASCII-CHARACTER. 7 | 03 CHAR-CODE PIC 999. 8 | * CONTROL CHARACTERS. 9 | 88 ASCII-NUL VALUE 0. 10 | 88 ASCII-SOH VALUE 1. 11 | 88 ASCII-STX VALUE 2. 12 | 88 ASCII-ETX VALUE 3. 13 | 88 ASCII-EOT VALUE 4. 14 | 88 ASCII-ENQ VALUE 5. 15 | 88 ASCII-ACK VALUE 6. 16 | 88 ASCII-BEL VALUE 7. 17 | 88 ASCII-BS VALUE 8. 18 | 88 ASCII-TAB VALUE 9. 19 | 88 ASCII-LF VALUE 10. 20 | 88 ASCII-VT VALUE 11. 21 | 88 ASCII-FF VALUE 12. 22 | 88 ASCII-CR VALUE 13. 23 | 88 ASCII-SO VALUE 14. 24 | 88 ASCII-SI VALUE 15. 25 | 88 ASCII-DLE VALUE 16. 26 | 88 ASCII-DC1 VALUE 17. 27 | 88 ASCII-DC2 VALUE 18. 28 | 88 ASCII-DC3 VALUE 19. 29 | 88 ASCII-DC4 VALUE 20. 30 | 88 ASCII-NAK VALUE 21. 31 | 88 ASCII-SYN VALUE 22. 32 | 88 ASCII-ETB VALUE 23. 33 | 88 ASCII-CAN VALUE 24. 34 | 88 ASCII-EM VALUE 25. 35 | 88 ASCII-SUB VALUE 26. 36 | 88 ASCII-ESC VALUE 27. 37 | 88 ASCII-FS VALUE 28. 38 | 88 ASCII-GS VALUE 29. 39 | 88 ASCII-RS VALUE 30. 40 | 88 ASCII-US VALUE 31. 41 | * PRINTABLE CHARACTERS. 42 | 88 ASCII-SPC VALUE 32. 43 | 88 ASCII-EXC VALUE 33. 44 | 88 ASCII-DBQT VALUE 34. 45 | 88 ASCII-PND VALUE 35. 46 | 88 ASCII-DLR VALUE 36. 47 | 88 ASCII-PCNT VALUE 37. 48 | 88 ASCII-AMP VALUE 38. 49 | 88 ASCII-SGQT VALUE 39. 50 | 88 ASCII-LPRN VALUE 40. 51 | 88 ASCII-RPRN VALUE 41. 52 | 88 ASCII-STAR VALUE 42. 53 | 88 ASCII-PLUS VALUE 43. 54 | 88 ASCII-COMA VALUE 44. 55 | 88 ASCII-DASH VALUE 45. 56 | 88 ASCII-DOT VALUE 46. 57 | 88 ASCII-SLSH VALUE 47. 58 | 88 ASCII-NUM0 VALUE 48. 59 | 88 ASCII-NUM1 VALUE 49. 60 | 88 ASCII-NUM2 VALUE 50. 61 | 88 ASCII-NUM3 VALUE 51. 62 | 88 ASCII-NUM4 VALUE 52. 63 | 88 ASCII-NUM5 VALUE 53. 64 | 88 ASCII-NUM6 VALUE 54. 65 | 88 ASCII-NUM7 VALUE 55. 66 | 88 ASCII-NUM8 VALUE 56. 67 | 88 ASCII-NUM9 VALUE 57. 68 | 88 ASCII-COLN VALUE 58. 69 | 88 ASCII-SCLN VALUE 59. 70 | 88 ASCII-LESS VALUE 60. 71 | 88 ASCII-EQL VALUE 61. 72 | 88 ASCII-GRTR VALUE 62. 73 | 88 ASCII-QUES VALUE 63. 74 | 88 ASCII-AT VALUE 64. 75 | 88 ASCII-LETA VALUES 65, 97. 76 | 88 ASCII-LETB VALUES 66, 98. 77 | 88 ASCII-LETC VALUES 67, 99. 78 | 88 ASCII-LETD VALUES 68, 100. 79 | 88 ASCII-LETE VALUES 69, 101. 80 | 88 ASCII-LETF VALUES 70, 102. 81 | 88 ASCII-LETG VALUES 71, 103. 82 | 88 ASCII-LETH VALUES 72, 104. 83 | 88 ASCII-LETI VALUES 73, 105. 84 | 88 ASCII-LETJ VALUES 74, 106. 85 | 88 ASCII-LETK VALUES 75, 107. 86 | 88 ASCII-LETL VALUES 76, 108. 87 | 88 ASCII-LETM VALUES 77, 109. 88 | 88 ASCII-LETN VALUES 78, 110. 89 | 88 ASCII-LETO VALUES 79, 111. 90 | 88 ASCII-LETP VALUES 80, 112. 91 | 88 ASCII-LETQ VALUES 81, 113. 92 | 88 ASCII-LETR VALUES 82, 114. 93 | 88 ASCII-LETS VALUES 83, 115. 94 | 88 ASCII-LETT VALUES 84, 116. 95 | 88 ASCII-LETU VALUES 85, 117. 96 | 88 ASCII-LETV VALUES 86, 118. 97 | 88 ASCII-LETW VALUES 87, 119. 98 | 88 ASCII-LETX VALUES 88, 120. 99 | 88 ASCII-LETY VALUES 89, 121. 100 | 88 ASCII-LETZ VALUES 90, 122. 101 | 88 ASCII-LSQB VALUE 91. 102 | 88 ASCII-BKSL VALUE 92. 103 | 88 ASCII-RSQB VALUE 93. 104 | 88 ASCII-CRT VALUE 94. 105 | 88 ASCII-UNDS VALUE 95. 106 | 88 ASCII-BKTK VALUE 96. 107 | 88 ASCII-LCRB VALUE 123. 108 | 88 ASCII-PIPE VALUE 124. 109 | 88 ASCII-RCRB VALUE 125. 110 | 88 ASCII-TLDE VALUE 126. 111 | * LONELY CONTROL CHAR 112 | 88 ASCII-DEL VALUE 127. 113 | 03 COBOL-STRING PIC X(6). 114 | 03 FIRST-CHAR REDEFINES COBOL-STRING PIC X. 115 | 116 | PROCEDURE DIVISION USING ASCII-CHARACTER. 117 | MOVE SPACES TO COBOL-STRING. 118 | IF ASCII-NUL THEN 119 | MOVE "$NUL$" TO COBOL-STRING 120 | ELSE IF ASCII-SOH THEN 121 | MOVE "$SOH$" TO COBOL-STRING 122 | ELSE IF ASCII-STX THEN 123 | MOVE "$STX$" TO COBOL-STRING 124 | ELSE IF ASCII-ETX THEN 125 | MOVE "$ETX$" TO COBOL-STRING 126 | ELSE IF ASCII-EOT THEN 127 | MOVE "$EOT$" TO COBOL-STRING 128 | ELSE IF ASCII-ENQ THEN 129 | MOVE "$ENQ$" TO COBOL-STRING 130 | ELSE IF ASCII-ACK THEN 131 | MOVE "$ACK$" TO COBOL-STRING 132 | ELSE IF ASCII-BEL THEN 133 | MOVE "$BEL$" TO COBOL-STRING 134 | ELSE IF ASCII-BS THEN 135 | MOVE "$BS$" TO COBOL-STRING 136 | ELSE IF ASCII-TAB THEN 137 | MOVE "$TAB$" TO COBOL-STRING 138 | ELSE IF ASCII-LF THEN 139 | MOVE "$LF$" TO COBOL-STRING 140 | ELSE IF ASCII-VT THEN 141 | MOVE "$VT$" TO COBOL-STRING 142 | ELSE IF ASCII-FF THEN 143 | MOVE "$FF$" TO COBOL-STRING 144 | ELSE IF ASCII-CR THEN 145 | MOVE "$CR$" TO COBOL-STRING 146 | ELSE IF ASCII-SO THEN 147 | MOVE "$SO$" TO COBOL-STRING 148 | ELSE IF ASCII-SI THEN 149 | MOVE "$SI$" TO COBOL-STRING 150 | ELSE IF ASCII-DLE THEN 151 | MOVE "$DLE$" TO COBOL-STRING 152 | ELSE IF ASCII-DC1 THEN 153 | MOVE "$DC1$" TO COBOL-STRING 154 | ELSE IF ASCII-DC2 THEN 155 | MOVE "$DC2$" TO COBOL-STRING 156 | ELSE IF ASCII-DC3 THEN 157 | MOVE "$DC3$" TO COBOL-STRING 158 | ELSE IF ASCII-DC4 THEN 159 | MOVE "$DC4$" TO COBOL-STRING 160 | ELSE IF ASCII-NAK THEN 161 | MOVE "$NAK$" TO COBOL-STRING 162 | ELSE IF ASCII-SYN THEN 163 | MOVE "$SYN$" TO COBOL-STRING 164 | ELSE IF ASCII-ETB THEN 165 | MOVE "$ETB$" TO COBOL-STRING 166 | ELSE IF ASCII-CAN THEN 167 | MOVE "$CAN$" TO COBOL-STRING 168 | ELSE IF ASCII-EM THEN 169 | MOVE "$EM$" TO COBOL-STRING 170 | ELSE IF ASCII-SUB THEN 171 | MOVE "$SUB$" TO COBOL-STRING 172 | ELSE IF ASCII-ESC THEN 173 | MOVE "$ESC$" TO COBOL-STRING 174 | ELSE IF ASCII-FS THEN 175 | MOVE "$FS$" TO COBOL-STRING 176 | ELSE IF ASCII-GS THEN 177 | MOVE "$GS$" TO COBOL-STRING 178 | ELSE IF ASCII-RS THEN 179 | MOVE "$RS$" TO COBOL-STRING 180 | ELSE IF ASCII-US THEN 181 | MOVE "$US$" TO COBOL-STRING 182 | ELSE IF ASCII-SPC THEN 183 | MOVE SPACE TO COBOL-STRING 184 | ELSE IF ASCII-EXC THEN 185 | MOVE "$EXC$" TO COBOL-STRING 186 | ELSE IF ASCII-DBQT THEN 187 | MOVE SPACES TO COBOL-STRING 188 | MOVE QUOTE TO FIRST-CHAR 189 | ELSE IF ASCII-PND THEN 190 | MOVE "$PND$" TO COBOL-STRING 191 | ELSE IF ASCII-DLR THEN 192 | MOVE "$$" TO COBOL-STRING 193 | ELSE IF ASCII-PCNT THEN 194 | MOVE "$PCNT$" TO COBOL-STRING 195 | ELSE IF ASCII-AMP THEN 196 | MOVE "$AMP$" TO COBOL-STRING 197 | ELSE IF ASCII-SGQT THEN 198 | MOVE "$SGQT$" TO COBOL-STRING 199 | ELSE IF ASCII-LPRN THEN 200 | MOVE "(" TO COBOL-STRING 201 | ELSE IF ASCII-RPRN THEN 202 | MOVE ")" TO COBOL-STRING 203 | ELSE IF ASCII-STAR THEN 204 | MOVE "*" TO COBOL-STRING 205 | ELSE IF ASCII-PLUS THEN 206 | MOVE "+" TO COBOL-STRING 207 | ELSE IF ASCII-COMA THEN 208 | MOVE "," TO COBOL-STRING 209 | ELSE IF ASCII-DASH THEN 210 | MOVE "-" TO COBOL-STRING 211 | ELSE IF ASCII-DOT THEN 212 | MOVE "." TO COBOL-STRING 213 | ELSE IF ASCII-SLSH THEN 214 | MOVE "/" TO COBOL-STRING 215 | ELSE IF ASCII-NUM0 THEN 216 | MOVE "0" TO COBOL-STRING 217 | ELSE IF ASCII-NUM1 THEN 218 | MOVE "1" TO COBOL-STRING 219 | ELSE IF ASCII-NUM2 THEN 220 | MOVE "2" TO COBOL-STRING 221 | ELSE IF ASCII-NUM3 THEN 222 | MOVE "3" TO COBOL-STRING 223 | ELSE IF ASCII-NUM4 THEN 224 | MOVE "4" TO COBOL-STRING 225 | ELSE IF ASCII-NUM5 THEN 226 | MOVE "5" TO COBOL-STRING 227 | ELSE IF ASCII-NUM6 THEN 228 | MOVE "6" TO COBOL-STRING 229 | ELSE IF ASCII-NUM7 THEN 230 | MOVE "7" TO COBOL-STRING 231 | ELSE IF ASCII-NUM8 THEN 232 | MOVE "8" TO COBOL-STRING 233 | ELSE IF ASCII-NUM9 THEN 234 | MOVE "9" TO COBOL-STRING 235 | ELSE IF ASCII-COLN THEN 236 | MOVE "$COLN$" TO COBOL-STRING 237 | ELSE IF ASCII-SCLN THEN 238 | MOVE ";" TO COBOL-STRING 239 | ELSE IF ASCII-LESS THEN 240 | MOVE "<" TO COBOL-STRING 241 | ELSE IF ASCII-EQL THEN 242 | MOVE "=" TO COBOL-STRING 243 | ELSE IF ASCII-GRTR THEN 244 | MOVE ">" TO COBOL-STRING 245 | ELSE IF ASCII-QUES THEN 246 | MOVE "$QUES$" TO COBOL-STRING 247 | ELSE IF ASCII-AT THEN 248 | MOVE "$AT$" TO COBOL-STRING 249 | ELSE IF ASCII-LETA THEN 250 | MOVE "A" TO COBOL-STRING 251 | ELSE IF ASCII-LETB THEN 252 | MOVE "B" TO COBOL-STRING 253 | ELSE IF ASCII-LETC THEN 254 | MOVE "C" TO COBOL-STRING 255 | ELSE IF ASCII-LETD THEN 256 | MOVE "D" TO COBOL-STRING 257 | ELSE IF ASCII-LETE THEN 258 | MOVE "E" TO COBOL-STRING 259 | ELSE IF ASCII-LETF THEN 260 | MOVE "F" TO COBOL-STRING 261 | ELSE IF ASCII-LETG THEN 262 | MOVE "G" TO COBOL-STRING 263 | ELSE IF ASCII-LETH THEN 264 | MOVE "H" TO COBOL-STRING 265 | ELSE IF ASCII-LETI THEN 266 | MOVE "I" TO COBOL-STRING 267 | ELSE IF ASCII-LETJ THEN 268 | MOVE "J" TO COBOL-STRING 269 | ELSE IF ASCII-LETK THEN 270 | MOVE "K" TO COBOL-STRING 271 | ELSE IF ASCII-LETL THEN 272 | MOVE "L" TO COBOL-STRING 273 | ELSE IF ASCII-LETM THEN 274 | MOVE "M" TO COBOL-STRING 275 | ELSE IF ASCII-LETN THEN 276 | MOVE "N" TO COBOL-STRING 277 | ELSE IF ASCII-LETO THEN 278 | MOVE "O" TO COBOL-STRING 279 | ELSE IF ASCII-LETP THEN 280 | MOVE "P" TO COBOL-STRING 281 | ELSE IF ASCII-LETQ THEN 282 | MOVE "Q" TO COBOL-STRING 283 | ELSE IF ASCII-LETR THEN 284 | MOVE "R" TO COBOL-STRING 285 | ELSE IF ASCII-LETS THEN 286 | MOVE "S" TO COBOL-STRING 287 | ELSE IF ASCII-LETT THEN 288 | MOVE "T" TO COBOL-STRING 289 | ELSE IF ASCII-LETU THEN 290 | MOVE "U" TO COBOL-STRING 291 | ELSE IF ASCII-LETV THEN 292 | MOVE "V" TO COBOL-STRING 293 | ELSE IF ASCII-LETW THEN 294 | MOVE "W" TO COBOL-STRING 295 | ELSE IF ASCII-LETX THEN 296 | MOVE "X" TO COBOL-STRING 297 | ELSE IF ASCII-LETY THEN 298 | MOVE "Y" TO COBOL-STRING 299 | ELSE IF ASCII-LETZ THEN 300 | MOVE "Z" TO COBOL-STRING 301 | ELSE IF ASCII-LSQB THEN 302 | MOVE "$LSQB$" TO COBOL-STRING 303 | ELSE IF ASCII-BKSL THEN 304 | MOVE "$BKSL$" TO COBOL-STRING 305 | ELSE IF ASCII-RSQB THEN 306 | MOVE "$RSQB$" TO COBOL-STRING 307 | ELSE IF ASCII-CRT THEN 308 | MOVE "$CRT$" TO COBOL-STRING 309 | ELSE IF ASCII-UNDS THEN 310 | MOVE "$UNDS$" TO COBOL-STRING 311 | ELSE IF ASCII-BKTK THEN 312 | MOVE "$BKTK$" TO COBOL-STRING 313 | ELSE IF ASCII-LCRB THEN 314 | MOVE "$LCRB$" TO COBOL-STRING 315 | ELSE IF ASCII-PIPE THEN 316 | MOVE "$PIPE$" TO COBOL-STRING 317 | ELSE IF ASCII-RCRB THEN 318 | MOVE "$RCRB$" TO COBOL-STRING 319 | ELSE IF ASCII-TLDE THEN 320 | MOVE "$TLDE$" TO COBOL-STRING 321 | ELSE IF ASCII-DEL THEN 322 | MOVE "$DEL$" TO COBOL-STRING 323 | ELSE STRING "$", CHAR-CODE, "$" INTO COBOL-STRING. 324 | EXIT PROGRAM. 325 | -------------------------------------------------------------------------------- /ENCASCII.COB: -------------------------------------------------------------------------------- 1 | IDENTIFICATION DIVISION. 2 | PROGRAM-ID. "ENCODE-ASCII". 3 | 4 | DATA DIVISION. 5 | WORKING-STORAGE SECTION. 6 | 01 STRING-POINTER PIC 9. 7 | 8 | LINKAGE SECTION. 9 | 01 ASCII-CHARACTER. 10 | 03 CHAR-CODE PIC 999. 11 | 03 COBOL-STRING PIC X(6). 12 | * CONTROL CHARACTERS. 13 | 88 ASCII-NUL VALUE "NUL". 14 | 88 ASCII-SOH VALUE "SOH". 15 | 88 ASCII-STX VALUE "STX". 16 | 88 ASCII-ETX VALUE "ETX". 17 | 88 ASCII-EOT VALUE "EOT". 18 | 88 ASCII-ENQ VALUE "ENQ". 19 | 88 ASCII-ACK VALUE "ACK". 20 | 88 ASCII-BEL VALUE "BEL". 21 | 88 ASCII-BS VALUE "BS". 22 | 88 ASCII-TAB VALUE "TAB". 23 | 88 ASCII-LF VALUE "LF". 24 | 88 ASCII-VT VALUE "VT". 25 | 88 ASCII-FF VALUE "FF". 26 | 88 ASCII-CR VALUE "CR". 27 | 88 ASCII-SO VALUE "SO". 28 | 88 ASCII-SI VALUE "SI". 29 | 88 ASCII-DLE VALUE "DLE". 30 | 88 ASCII-DC1 VALUE "DC1". 31 | 88 ASCII-DC2 VALUE "DC2". 32 | 88 ASCII-DC3 VALUE "DC3". 33 | 88 ASCII-DC4 VALUE "DC4". 34 | 88 ASCII-NAK VALUE "NAK". 35 | 88 ASCII-SYN VALUE "SYN". 36 | 88 ASCII-ETB VALUE "ETB". 37 | 88 ASCII-CAN VALUE "CAN". 38 | 88 ASCII-EM VALUE "EM". 39 | 88 ASCII-SUB VALUE "SUB". 40 | 88 ASCII-ESC VALUE "ESC". 41 | 88 ASCII-FS VALUE "FS". 42 | 88 ASCII-GS VALUE "GS". 43 | 88 ASCII-RS VALUE "RS". 44 | 88 ASCII-US VALUE "US". 45 | * PRINTABLE CHARACTERS. 46 | 88 ASCII-SPC VALUE SPACE. 47 | 88 ASCII-EXC VALUE "EXC". 48 | * ASCII-DBQT DEFINED BELOW UNDER FIRST-CHAR. 49 | 88 ASCII-PND VALUE "PND". 50 | 88 ASCII-DLR VALUE "$". 51 | 88 ASCII-PCNT VALUE "PCNT". 52 | 88 ASCII-AMP VALUE "AMP". 53 | 88 ASCII-SGQT VALUE "SGQT". 54 | 88 ASCII-LPRN VALUE "(". 55 | 88 ASCII-RPRN VALUE ")". 56 | 88 ASCII-STAR VALUE "*". 57 | 88 ASCII-PLUS VALUE "+". 58 | 88 ASCII-COMA VALUE ",". 59 | 88 ASCII-DASH VALUE "-". 60 | 88 ASCII-DOT VALUE ".". 61 | 88 ASCII-SLSH VALUE "/". 62 | 88 ASCII-NUM0 VALUE 0. 63 | 88 ASCII-NUM1 VALUE 1. 64 | 88 ASCII-NUM2 VALUE 2. 65 | 88 ASCII-NUM3 VALUE 3. 66 | 88 ASCII-NUM4 VALUE 4. 67 | 88 ASCII-NUM5 VALUE 5. 68 | 88 ASCII-NUM6 VALUE 6. 69 | 88 ASCII-NUM7 VALUE 7. 70 | 88 ASCII-NUM8 VALUE 8. 71 | 88 ASCII-NUM9 VALUE 9. 72 | 88 ASCII-COLN VALUE "COLN". 73 | 88 ASCII-SCLN VALUE ";". 74 | 88 ASCII-LESS VALUE "<". 75 | 88 ASCII-EQL VALUE "=". 76 | 88 ASCII-GRTR VALUE ">". 77 | 88 ASCII-QUES VALUE "QUES". 78 | 88 ASCII-AT VALUE "AT". 79 | 88 ASCII-LETA VALUES "A". 80 | 88 ASCII-LETB VALUES "B". 81 | 88 ASCII-LETC VALUES "C". 82 | 88 ASCII-LETD VALUES "D". 83 | 88 ASCII-LETE VALUES "E". 84 | 88 ASCII-LETF VALUES "F". 85 | 88 ASCII-LETG VALUES "G". 86 | 88 ASCII-LETH VALUES "H". 87 | 88 ASCII-LETI VALUES "I". 88 | 88 ASCII-LETJ VALUES "J". 89 | 88 ASCII-LETK VALUES "K". 90 | 88 ASCII-LETL VALUES "L". 91 | 88 ASCII-LETM VALUES "M". 92 | 88 ASCII-LETN VALUES "N". 93 | 88 ASCII-LETO VALUES "O". 94 | 88 ASCII-LETP VALUES "P". 95 | 88 ASCII-LETQ VALUES "Q". 96 | 88 ASCII-LETR VALUES "R". 97 | 88 ASCII-LETS VALUES "S". 98 | 88 ASCII-LETT VALUES "T". 99 | 88 ASCII-LETU VALUES "U". 100 | 88 ASCII-LETV VALUES "V". 101 | 88 ASCII-LETW VALUES "W". 102 | 88 ASCII-LETX VALUES "X". 103 | 88 ASCII-LETY VALUES "Y". 104 | 88 ASCII-LETZ VALUES "Z". 105 | 88 ASCII-LOWA VALUES "LOWA". 106 | 88 ASCII-LOWB VALUES "LOWB". 107 | 88 ASCII-LOWC VALUES "LOWC". 108 | 88 ASCII-LOWD VALUES "LOWD". 109 | 88 ASCII-LOWE VALUES "LOWE". 110 | 88 ASCII-LOWF VALUES "LOWF". 111 | 88 ASCII-LOWG VALUES "LOWG". 112 | 88 ASCII-LOWH VALUES "LOWH". 113 | 88 ASCII-LOWI VALUES "LOWI". 114 | 88 ASCII-LOWJ VALUES "LOWJ". 115 | 88 ASCII-LOWK VALUES "LOWK". 116 | 88 ASCII-LOWL VALUES "LOWL". 117 | 88 ASCII-LOWM VALUES "LOWM". 118 | 88 ASCII-LOWN VALUES "LOWN". 119 | 88 ASCII-LOWO VALUES "LOWO". 120 | 88 ASCII-LOWP VALUES "LOWP". 121 | 88 ASCII-LOWQ VALUES "LOWQ". 122 | 88 ASCII-LOWR VALUES "LOWR". 123 | 88 ASCII-LOWS VALUES "LOWS". 124 | 88 ASCII-LOWT VALUES "LOWT". 125 | 88 ASCII-LOWU VALUES "LOWU". 126 | 88 ASCII-LOWV VALUES "LOWV". 127 | 88 ASCII-LOWW VALUES "LOWW". 128 | 88 ASCII-LOWX VALUES "LOWX". 129 | 88 ASCII-LOWY VALUES "LOWY". 130 | 88 ASCII-LOWZ VALUES "LOWZ". 131 | 88 ASCII-LSQB VALUE "LSQB". 132 | 88 ASCII-BKSL VALUE "BKSL". 133 | 88 ASCII-RSQB VALUE "RSQB". 134 | 88 ASCII-CRT VALUE "CRT". 135 | 88 ASCII-UNDS VALUE "UNDS". 136 | 88 ASCII-BKTK VALUE "BKTK". 137 | 88 ASCII-LCRB VALUE "LCRB". 138 | 88 ASCII-PIPE VALUE "PIPE". 139 | 88 ASCII-RCRB VALUE "RCRB". 140 | 88 ASCII-TLDE VALUE "TLDE". 141 | * LONELY CONTROL CHAR 142 | 88 ASCII-DEL VALUE "DEL". 143 | 03 FIRST-CHAR REDEFINES COBOL-STRING PIC X. 144 | 88 ASCII-DBQT VALUE QUOTE. 145 | 146 | PROCEDURE DIVISION USING ASCII-CHARACTER. 147 | IF ASCII-NUL THEN 148 | MOVE 0 TO CHAR-CODE 149 | ELSE IF ASCII-SOH THEN 150 | MOVE 1 TO CHAR-CODE 151 | ELSE IF ASCII-STX THEN 152 | MOVE 2 TO CHAR-CODE 153 | ELSE IF ASCII-ETX THEN 154 | MOVE 3 TO CHAR-CODE 155 | ELSE IF ASCII-EOT THEN 156 | MOVE 4 TO CHAR-CODE 157 | ELSE IF ASCII-ENQ THEN 158 | MOVE 5 TO CHAR-CODE 159 | ELSE IF ASCII-ACK THEN 160 | MOVE 6 TO CHAR-CODE 161 | ELSE IF ASCII-BEL THEN 162 | MOVE 7 TO CHAR-CODE 163 | ELSE IF ASCII-BS THEN 164 | MOVE 8 TO CHAR-CODE 165 | ELSE IF ASCII-TAB THEN 166 | MOVE 9 TO CHAR-CODE 167 | ELSE IF ASCII-LF THEN 168 | MOVE 10 TO CHAR-CODE 169 | ELSE IF ASCII-VT THEN 170 | MOVE 11 TO CHAR-CODE 171 | ELSE IF ASCII-FF THEN 172 | MOVE 12 TO CHAR-CODE 173 | ELSE IF ASCII-CR THEN 174 | MOVE 13 TO CHAR-CODE 175 | ELSE IF ASCII-SO THEN 176 | MOVE 14 TO CHAR-CODE 177 | ELSE IF ASCII-SI THEN 178 | MOVE 15 TO CHAR-CODE 179 | ELSE IF ASCII-DLE THEN 180 | MOVE 16 TO CHAR-CODE 181 | ELSE IF ASCII-DC1 THEN 182 | MOVE 17 TO CHAR-CODE 183 | ELSE IF ASCII-DC2 THEN 184 | MOVE 18 TO CHAR-CODE 185 | ELSE IF ASCII-DC3 THEN 186 | MOVE 19 TO CHAR-CODE 187 | ELSE IF ASCII-DC4 THEN 188 | MOVE 20 TO CHAR-CODE 189 | ELSE IF ASCII-NAK THEN 190 | MOVE 21 TO CHAR-CODE 191 | ELSE IF ASCII-SYN THEN 192 | MOVE 22 TO CHAR-CODE 193 | ELSE IF ASCII-ETB THEN 194 | MOVE 23 TO CHAR-CODE 195 | ELSE IF ASCII-CAN THEN 196 | MOVE 24 TO CHAR-CODE 197 | ELSE IF ASCII-EM THEN 198 | MOVE 25 TO CHAR-CODE 199 | ELSE IF ASCII-SUB THEN 200 | MOVE 26 TO CHAR-CODE 201 | ELSE IF ASCII-ESC THEN 202 | MOVE 27 TO CHAR-CODE 203 | ELSE IF ASCII-FS THEN 204 | MOVE 28 TO CHAR-CODE 205 | ELSE IF ASCII-GS THEN 206 | MOVE 29 TO CHAR-CODE 207 | ELSE IF ASCII-RS THEN 208 | MOVE 30 TO CHAR-CODE 209 | ELSE IF ASCII-US THEN 210 | MOVE 31 TO CHAR-CODE 211 | ELSE IF ASCII-SPC THEN 212 | MOVE 32 TO CHAR-CODE 213 | ELSE IF ASCII-EXC THEN 214 | MOVE 33 TO CHAR-CODE 215 | ELSE IF ASCII-DBQT THEN 216 | MOVE 34 TO CHAR-CODE 217 | ELSE IF ASCII-PND THEN 218 | MOVE 35 TO CHAR-CODE 219 | ELSE IF ASCII-DLR THEN 220 | MOVE 36 TO CHAR-CODE 221 | ELSE IF ASCII-PCNT THEN 222 | MOVE 37 TO CHAR-CODE 223 | ELSE IF ASCII-AMP THEN 224 | MOVE 38 TO CHAR-CODE 225 | ELSE IF ASCII-SGQT THEN 226 | MOVE 39 TO CHAR-CODE 227 | ELSE IF ASCII-LPRN THEN 228 | MOVE 40 TO CHAR-CODE 229 | ELSE IF ASCII-RPRN THEN 230 | MOVE 41 TO CHAR-CODE 231 | ELSE IF ASCII-STAR THEN 232 | MOVE 42 TO CHAR-CODE 233 | ELSE IF ASCII-PLUS THEN 234 | MOVE 43 TO CHAR-CODE 235 | ELSE IF ASCII-COMA THEN 236 | MOVE 44 TO CHAR-CODE 237 | ELSE IF ASCII-DASH THEN 238 | MOVE 45 TO CHAR-CODE 239 | ELSE IF ASCII-DOT THEN 240 | MOVE 46 TO CHAR-CODE 241 | ELSE IF ASCII-SLSH THEN 242 | MOVE 47 TO CHAR-CODE 243 | ELSE IF ASCII-NUM0 THEN 244 | MOVE 48 TO CHAR-CODE 245 | ELSE IF ASCII-NUM1 THEN 246 | MOVE 49 TO CHAR-CODE 247 | ELSE IF ASCII-NUM2 THEN 248 | MOVE 50 TO CHAR-CODE 249 | ELSE IF ASCII-NUM3 THEN 250 | MOVE 51 TO CHAR-CODE 251 | ELSE IF ASCII-NUM4 THEN 252 | MOVE 52 TO CHAR-CODE 253 | ELSE IF ASCII-NUM5 THEN 254 | MOVE 53 TO CHAR-CODE 255 | ELSE IF ASCII-NUM6 THEN 256 | MOVE 54 TO CHAR-CODE 257 | ELSE IF ASCII-NUM7 THEN 258 | MOVE 55 TO CHAR-CODE 259 | ELSE IF ASCII-NUM8 THEN 260 | MOVE 56 TO CHAR-CODE 261 | ELSE IF ASCII-NUM9 THEN 262 | MOVE 57 TO CHAR-CODE 263 | ELSE IF ASCII-COLN THEN 264 | MOVE 58 TO CHAR-CODE 265 | ELSE IF ASCII-SCLN THEN 266 | MOVE 59 TO CHAR-CODE 267 | ELSE IF ASCII-LESS THEN 268 | MOVE 60 TO CHAR-CODE 269 | ELSE IF ASCII-EQL THEN 270 | MOVE 61 TO CHAR-CODE 271 | ELSE IF ASCII-GRTR THEN 272 | MOVE 62 TO CHAR-CODE 273 | ELSE IF ASCII-QUES THEN 274 | MOVE 63 TO CHAR-CODE 275 | ELSE IF ASCII-AT THEN 276 | MOVE 64 TO CHAR-CODE 277 | ELSE IF ASCII-LETA THEN 278 | MOVE 65 TO CHAR-CODE 279 | ELSE IF ASCII-LETB THEN 280 | MOVE 66 TO CHAR-CODE 281 | ELSE IF ASCII-LETC THEN 282 | MOVE 67 TO CHAR-CODE 283 | ELSE IF ASCII-LETD THEN 284 | MOVE 68 TO CHAR-CODE 285 | ELSE IF ASCII-LETE THEN 286 | MOVE 69 TO CHAR-CODE 287 | ELSE IF ASCII-LETF THEN 288 | MOVE 70 TO CHAR-CODE 289 | ELSE IF ASCII-LETG THEN 290 | MOVE 71 TO CHAR-CODE 291 | ELSE IF ASCII-LETH THEN 292 | MOVE 72 TO CHAR-CODE 293 | ELSE IF ASCII-LETI THEN 294 | MOVE 73 TO CHAR-CODE 295 | ELSE IF ASCII-LETJ THEN 296 | MOVE 74 TO CHAR-CODE 297 | ELSE IF ASCII-LETK THEN 298 | MOVE 75 TO CHAR-CODE 299 | ELSE IF ASCII-LETL THEN 300 | MOVE 76 TO CHAR-CODE 301 | ELSE IF ASCII-LETM THEN 302 | MOVE 77 TO CHAR-CODE 303 | ELSE IF ASCII-LETN THEN 304 | MOVE 78 TO CHAR-CODE 305 | ELSE IF ASCII-LETO THEN 306 | MOVE 79 TO CHAR-CODE 307 | ELSE IF ASCII-LETP THEN 308 | MOVE 80 TO CHAR-CODE 309 | ELSE IF ASCII-LETQ THEN 310 | MOVE 81 TO CHAR-CODE 311 | ELSE IF ASCII-LETR THEN 312 | MOVE 82 TO CHAR-CODE 313 | ELSE IF ASCII-LETS THEN 314 | MOVE 83 TO CHAR-CODE 315 | ELSE IF ASCII-LETT THEN 316 | MOVE 84 TO CHAR-CODE 317 | ELSE IF ASCII-LETU THEN 318 | MOVE 85 TO CHAR-CODE 319 | ELSE IF ASCII-LETV THEN 320 | MOVE 86 TO CHAR-CODE 321 | ELSE IF ASCII-LETW THEN 322 | MOVE 87 TO CHAR-CODE 323 | ELSE IF ASCII-LETX THEN 324 | MOVE 88 TO CHAR-CODE 325 | ELSE IF ASCII-LETY THEN 326 | MOVE 89 TO CHAR-CODE 327 | ELSE IF ASCII-LETZ THEN 328 | MOVE 90 TO CHAR-CODE 329 | ELSE IF ASCII-LSQB THEN 330 | MOVE 91 TO CHAR-CODE 331 | ELSE IF ASCII-BKSL THEN 332 | MOVE 92 TO CHAR-CODE 333 | ELSE IF ASCII-RSQB THEN 334 | MOVE 93 TO CHAR-CODE 335 | ELSE IF ASCII-CRT THEN 336 | MOVE 94 TO CHAR-CODE 337 | ELSE IF ASCII-UNDS THEN 338 | MOVE 95 TO CHAR-CODE 339 | ELSE IF ASCII-BKTK THEN 340 | MOVE 96 TO CHAR-CODE 341 | ELSE IF ASCII-LOWA THEN 342 | MOVE 97 TO CHAR-CODE 343 | ELSE IF ASCII-LOWB THEN 344 | MOVE 98 TO CHAR-CODE 345 | ELSE IF ASCII-LOWC THEN 346 | MOVE 99 TO CHAR-CODE 347 | ELSE IF ASCII-LOWD THEN 348 | MOVE 100 TO CHAR-CODE 349 | ELSE IF ASCII-LOWE THEN 350 | MOVE 101 TO CHAR-CODE 351 | ELSE IF ASCII-LOWF THEN 352 | MOVE 102 TO CHAR-CODE 353 | ELSE IF ASCII-LOWG THEN 354 | MOVE 103 TO CHAR-CODE 355 | ELSE IF ASCII-LOWH THEN 356 | MOVE 104 TO CHAR-CODE 357 | ELSE IF ASCII-LOWI THEN 358 | MOVE 105 TO CHAR-CODE 359 | ELSE IF ASCII-LOWJ THEN 360 | MOVE 106 TO CHAR-CODE 361 | ELSE IF ASCII-LOWK THEN 362 | MOVE 107 TO CHAR-CODE 363 | ELSE IF ASCII-LOWL THEN 364 | MOVE 108 TO CHAR-CODE 365 | ELSE IF ASCII-LOWM THEN 366 | MOVE 109 TO CHAR-CODE 367 | ELSE IF ASCII-LOWN THEN 368 | MOVE 110 TO CHAR-CODE 369 | ELSE IF ASCII-LOWO THEN 370 | MOVE 111 TO CHAR-CODE 371 | ELSE IF ASCII-LOWP THEN 372 | MOVE 112 TO CHAR-CODE 373 | ELSE IF ASCII-LOWQ THEN 374 | MOVE 113 TO CHAR-CODE 375 | ELSE IF ASCII-LOWR THEN 376 | MOVE 114 TO CHAR-CODE 377 | ELSE IF ASCII-LOWS THEN 378 | MOVE 115 TO CHAR-CODE 379 | ELSE IF ASCII-LOWT THEN 380 | MOVE 116 TO CHAR-CODE 381 | ELSE IF ASCII-LOWU THEN 382 | MOVE 117 TO CHAR-CODE 383 | ELSE IF ASCII-LOWV THEN 384 | MOVE 118 TO CHAR-CODE 385 | ELSE IF ASCII-LOWW THEN 386 | MOVE 119 TO CHAR-CODE 387 | ELSE IF ASCII-LOWX THEN 388 | MOVE 120 TO CHAR-CODE 389 | ELSE IF ASCII-LOWY THEN 390 | MOVE 121 TO CHAR-CODE 391 | ELSE IF ASCII-LOWZ THEN 392 | MOVE 122 TO CHAR-CODE 393 | ELSE IF ASCII-LCRB THEN 394 | MOVE 123 TO CHAR-CODE 395 | ELSE IF ASCII-PIPE THEN 396 | MOVE 124 TO CHAR-CODE 397 | ELSE IF ASCII-RCRB THEN 398 | MOVE 125 TO CHAR-CODE 399 | ELSE IF ASCII-TLDE THEN 400 | MOVE 126 TO CHAR-CODE 401 | ELSE IF ASCII-DEL THEN 402 | MOVE 127 TO CHAR-CODE 403 | ELSE MOVE COBOL-STRING TO CHAR-CODE. 404 | EXIT PROGRAM. 405 | -------------------------------------------------------------------------------- /WOPO.COB: -------------------------------------------------------------------------------- 1 | IDENTIFICATION DIVISION. 2 | PROGRAM-ID. "WOPO". 3 | 4 | ENVIRONMENT DIVISION. 5 | INPUT-OUTPUT SECTION. 6 | FILE-CONTROL. 7 | SELECT CONFIG 8 | ASSIGN TO DISK 9 | ORGANIZATION IS INDEXED 10 | ACCESS MODE IS RANDOM 11 | RECORD KEY IS CONFIG-KEY. 12 | SELECT USERS 13 | ASSIGN TO DISK 14 | ORGANIZATION IS INDEXED 15 | ACCESS MODE IS DYNAMIC 16 | RECORD KEY IS USER-NAME. 17 | SELECT CHANNELS 18 | ASSIGN TO DISK 19 | ORGANIZATION IS SEQUENTIAL. 20 | SELECT PROGRAM-INDEX 21 | ASSIGN TO DISK 22 | ORGANIZATION IS INDEXED 23 | ACCESS MODE IS DYNAMIC 24 | RECORD KEY IS NAME OF INDEX-ENTRY. 25 | SELECT PROGRAM-CODE 26 | ASSIGN TO DISK 27 | ORGANIZATION IS RELATIVE 28 | ACCESS MODE IS RANDOM 29 | RELATIVE KEY IS PROGRAM-IP. 30 | 31 | DATA DIVISION. 32 | FILE SECTION. 33 | FD CONFIG. 34 | 01 CONFIG-RECORD. 35 | 03 CONFIG-KEY PIC X(16). 36 | 03 CONFIG-VALUE PIC X(64). 37 | FD USERS. 38 | 01 USER-RECORD. 39 | 03 USER-NAME PIC X(40). 40 | 03 USER-LEVEL PIC 9(2). 41 | FD CHANNELS. 42 | 01 CHANNEL-NAME PIC X(50). 43 | FD PROGRAM-INDEX. 44 | 01 INDEX-ENTRY. 45 | 03 NAME PIC X(16). 46 | 03 ADDR PIC 999. 47 | FD PROGRAM-CODE. 48 | 01 PROGRAM-RECORD. 49 | 03 INSTRUCTION. 50 | 05 IN-REG PIC 9. 51 | 88 INPUT-FROM-RECORD VALUE 9. 52 | 05 OUT-REG PIC 9. 53 | 05 INTERPRETER PIC X(5). 54 | 05 INSTRUCTION-CODE PIC X(992). 55 | 05 VM-INSTRUCTION REDEFINES INSTRUCTION-CODE. 56 | 07 CYCLE-LIMIT PIC 9(8). 57 | 07 VM-CODE PIC X(984). 58 | 03 RAW-INSTRUCTION REDEFINES INSTRUCTION PIC X(999). 59 | 03 PREV-IP PIC 999. 60 | 03 NEXT-IP PIC 999. 61 | 62 | WORKING-STORAGE SECTION. 63 | *CONFIGURATION "CONSTANTS" 64 | 01 PLATFORM PIC X(16) VALUE "UNIX". 65 | 01 STATE PIC 9(2). 66 | 88 SUCCESS VALUE 0. 67 | 88 DONE VALUE 99. 68 | 69 | 01 I-O-REGS. 70 | 03 INPUT-BUFFER. 71 | 05 MSG-BODY PIC X(999). 72 | 05 ASCII-TABLE. 73 | 07 ASCII-CELL PIC 999 OCCURS 999 TIMES. 74 | 03 INPUT-SOURCE PIC 9. 75 | 88 STANDARD-INPUT VALUE 0. 76 | 03 OUTPUT-BUFFER. 77 | 05 MSG-BODY PIC X(999). 78 | 05 ASCII-TABLE. 79 | 07 ASCII-CELL PIC 999 OCCURS 999 TIMES. 80 | 03 OUTPUT-DEST PIC 9. 81 | 88 STANDARD-OUTPUT VALUE 0. 82 | 03 OUTPUT-SPEC. 83 | 05 COMMAND PIC X(16). 84 | 05 NICK PIC X(40). 85 | 05 TARGET PIC X(50). 86 | 87 | 01 WOPO. 88 | 03 NICK PIC X(40). 89 | 03 REGISTER-FILE. 90 | 05 REGISTER OCCURS 8 TIMES. 91 | 07 R PIC X(999). 92 | 07 R-COMMAND REDEFINES R. 93 | 09 PREFIX PIC XX. 94 | 88 IS-COMMAND VALUE "$$". 95 | 09 COMMAND-BODY PIC X(997). 96 | 07 R-CTCP REDEFINES R. 97 | 09 CTCP-PREFIX PIC X(5). 98 | 88 IS-CTCP VALUE "$SOH$". 99 | 09 CTCP-BODY PIC X(994). 100 | 07 R-SWITCH REDEFINES R. 101 | 09 SWITCH PIC X. 102 | 09 SWITCH-PARAM PIC X. 103 | 07 R-INDEX REDEFINES R PIC X. 104 | 07 PTR PIC 999. 105 | 05 SRC PIC 9. 106 | 05 DEST PIC 9. 107 | 03 DELIM PIC X. 108 | 03 PARAM PIC 999 OCCURS 9 TIMES. 109 | 03 NUM-PARAMS PIC 9. 110 | 03 WOPO-COUNTER PIC 9. 111 | D 03 DEBUG-PTR PIC 9. 112 | 03 SHOW-ESCAPES PIC 9. 113 | 88 SHOULD-SHOW-ESCAPES VALUE 1. 114 | 115 | 01 USERS-HEADER. 116 | 03 FILLER PIC X(40) VALUE "USER NAME.". 117 | 03 FILLER PIC X(6) VALUE "LEVEL.". 118 | 119 | 01 IRC-PARAMS. 120 | 03 NUM-PARAMS PIC 99. 121 | 03 PREFIX. 122 | 05 MSG-SRC PIC 999. 123 | 88 GOT-PREFIX VALUES 1 THROUGH 999. 124 | 05 IDENT PIC 999. 125 | 05 HOST PIC 999. 126 | 03 COMMAND PIC 999. 127 | 03 PARAM PIC 999 OCCURS 15 TIMES. 128 | 129 | 01 IRC-STATE. 130 | 03 NICK PIC X(40). 131 | 03 COMMAND PIC X(16). 132 | 88 KICK VALUE "KICK". 133 | 88 PING VALUE "PING". 134 | 88 PRIVMSG VALUE "PRIVMSG". 135 | 88 NOTICE VALUE "NOTICE". 136 | 03 TARGET PIC X(50). 137 | 03 WAITING-COMMAND PIC X(16). 138 | 139 | 01 BF-I-O. 140 | 03 BF-INPUT PIC X(999) 141 | VALUE "$NUL$". 142 | 03 BF-CODE PIC X(999) 143 | VALUE "++++++++++(>++++++(>++++<-)<-)>>.<<+++++(>++++(>-- 144 | - "--<-)<-)>>-.<+++(>---<-)>.-.$NUL$". 145 | 03 BF-OUTPUT PIC X(999) 146 | VALUE SPACES. 147 | 03 CYCLE-LIMIT PIC 9(8) 148 | VALUE 0. 149 | 150 | 01 BF-STATE. 151 | 03 MAYBE-CYCLE-LIMIT PIC 9(8) 152 | VALUE 0. 153 | 154 | 01 INTERPRETER-STATE. 155 | 03 PROGRAM-IP PIC 999. 156 | 03 IP-TEMP PIC 999. 157 | 158 | 01 PROGRAM-LISTING-HEADER. 159 | 03 FILLER PIC X(4) VALUE " IP.". 160 | 03 FILLER PIC X(2) VALUE "IO". 161 | 03 FILLER PIC X(5) VALUE " LANG". 162 | 03 FILLER PIC X(5) VALUE " CODE". 163 | 164 | 01 FORMATTED-TIME. 165 | 03 FILLER PIC X VALUE "H". 166 | 03 HOURS-DIGITS PIC 99. 167 | 03 FILLER PIC X VALUE "M". 168 | 03 MINUTES-DIGITS PIC 99. 169 | 03 FILLER PIC X VALUE "S". 170 | 03 SECONDS-DIGITS PIC 99. 171 | 03 FILLER PIC X VALUE ".". 172 | 03 TENTH-SECONDS PIC 99. 173 | 174 | PROCEDURE DIVISION. 175 | DISPLAY "CONFIGURATION FOLLOWS.". 176 | CALL "PRINT-CONFIG". 177 | OPEN INPUT CONFIG. 178 | MOVE "SERVER" TO CONFIG-KEY. 179 | PERFORM READ-CONFIG-ENTRY. 180 | STRING 181 | CONFIG-VALUE, DELIMITED BY SPACE, 182 | "$NUL$" 183 | INTO MSG-BODY OF OUTPUT-BUFFER, 184 | CALL "ENCODE-STRING" USING OUTPUT-BUFFER. 185 | CALL "CHANNEL-OPEN" USING ASCII-TABLE OF OUTPUT-BUFFER, 186 | STATE. 187 | IF NOT SUCCESS THEN DISPLAY MSG-BODY OF OUTPUT-BUFFER 188 | GO TO DIE. 189 | MOVE "PASS" TO CONFIG-KEY. 190 | READ CONFIG RECORD 191 | INVALID KEY MOVE SPACES TO CONFIG-VALUE. 192 | IF CONFIG-VALUE IS NOT EQUAL TO SPACES THEN 193 | STRING "PASS " DELIMITED BY SIZE, 194 | CONFIG-VALUE DELIMITED BY SPACE, 195 | "$NUL$" 196 | INTO MSG-BODY OF OUTPUT-BUFFER 197 | PERFORM SEND-LINE. 198 | MOVE "NICK" TO CONFIG-KEY. 199 | PERFORM READ-CONFIG-ENTRY. 200 | MOVE CONFIG-VALUE TO NICK OF WOPO. 201 | MOVE SPACES TO MSG-BODY OF OUTPUT-BUFFER. 202 | STRING "NICK " DELIMITED BY SIZE, 203 | NICK OF WOPO DELIMITED BY SPACES, 204 | "$NUL$" 205 | INTO MSG-BODY OF OUTPUT-BUFFER. 206 | PERFORM SEND-LINE. 207 | MOVE SPACES TO MSG-BODY OF OUTPUT-BUFFER. 208 | MOVE 1 TO PTR(1). 209 | STRING "USER " DELIMITED BY SIZE 210 | INTO MSG-BODY OF OUTPUT-BUFFER 211 | WITH POINTER PTR(1). 212 | MOVE "IDENT" TO CONFIG-KEY. 213 | PERFORM READ-CONFIG-ENTRY. 214 | STRING CONFIG-VALUE DELIMITED BY SPACE, 215 | INTO MSG-BODY OF OUTPUT-BUFFER 216 | WITH POINTER PTR(1). 217 | ADD 1 TO PTR(1). 218 | MOVE "REAL-NAME" TO CONFIG-KEY. 219 | PERFORM READ-CONFIG-ENTRY. 220 | STRING "BOGUS HOST $COLN$" DELIMITED BY SIZE, 221 | CONFIG-VALUE DELIMITED BY " ", 222 | INTO MSG-BODY OF OUTPUT-BUFFER 223 | WITH POINTER PTR(1). 224 | PERFORM SEND-LINE. 225 | OPEN INPUT CHANNELS. 226 | PERFORM AUTOJOIN-CHANNELS UNTIL DONE. 227 | CLOSE CHANNELS. 228 | OPEN I-O USERS. 229 | PERFORM MAIN FOREVER. 230 | 231 | DIE. 232 | DISPLAY STATE. 233 | STOP RUN. 234 | 235 | AUTOJOIN-CHANNELS. 236 | READ CHANNELS RECORD 237 | AT END MOVE 99 TO STATE. 238 | IF NOT DONE THEN 239 | STRING "JOIN " DELIMITED BY SIZE, 240 | CHANNEL-NAME DELIMITED BY SPACES, 241 | "$NUL$" 242 | INTO MSG-BODY OF OUTPUT-BUFFER 243 | PERFORM SEND-LINE. 244 | 245 | READ-CONFIG-ENTRY. 246 | READ CONFIG RECORD 247 | INVALID KEY DISPLAY "REQUIRED KEY UNSPECIFIED." 248 | DISPLAY CONFIG-KEY 249 | GO TO DIE. 250 | 251 | SEND-LINE. 252 | CALL "ENCODE-STRING" USING OUTPUT-BUFFER. 253 | CALL "CHANNEL-SEND" USING ASCII-TABLE OF OUTPUT-BUFFER, 254 | STATE. 255 | IF NOT SUCCESS THEN CALL "DECODE-STRING" USING OUTPUT-BUFFER 256 | DISPLAY MSG-BODY OF OUTPUT-BUFFER 257 | GO TO DIE. 258 | 259 | RECEIVE-LINE. 260 | CALL "CHANNEL-RECV" USING ASCII-TABLE OF INPUT-BUFFER, 261 | STATE. 262 | MOVE SPACES TO MSG-BODY OF INPUT-BUFFER. 263 | CALL "DECODE-STRING" USING INPUT-BUFFER. 264 | D DISPLAY "RECEIVED LINE FROM CHANNEL", 265 | D MSG-BODY OF INPUT-BUFFER. 266 | IF NOT SUCCESS THEN DISPLAY MSG-BODY OF INPUT-BUFFER 267 | GO TO DIE. 268 | PERFORM GET-IRC-STATE. 269 | 270 | GET-IRC-STATE. 271 | CALL "PARSE-IRC-MSG" USING MSG-BODY OF INPUT-BUFFER, 272 | IRC-PARAMS. 273 | MOVE SPACES TO NICK OF IRC-STATE. 274 | IF GOT-PREFIX THEN 275 | MOVE MSG-SRC TO PTR(1) 276 | UNSTRING MSG-BODY OF INPUT-BUFFER 277 | DELIMITED BY "$EXC$" OR "$AT$" OR SPACES 278 | INTO NICK OF IRC-STATE 279 | WITH POINTER PTR(1). 280 | MOVE COMMAND OF IRC-PARAMS TO PTR(1). 281 | UNSTRING MSG-BODY OF INPUT-BUFFER 282 | DELIMITED BY SPACES 283 | INTO COMMAND OF IRC-STATE 284 | WITH POINTER PTR(1). 285 | IF NUM-PARAMS OF IRC-PARAMS IS NOT LESS THAN 1 THEN 286 | MOVE PARAM OF IRC-PARAMS(1) TO PTR(1) 287 | UNSTRING MSG-BODY OF INPUT-BUFFER 288 | DELIMITED BY SPACES 289 | INTO TARGET OF IRC-STATE 290 | WITH POINTER PTR(1) 291 | ELSE 292 | MOVE SPACES TO TARGET OF IRC-STATE. 293 | 294 | GET-MSG-CONTENTS. 295 | MOVE PARAM OF IRC-PARAMS(NUM-PARAMS OF IRC-PARAMS) 296 | TO PTR(DEST). 297 | UNSTRING MSG-BODY OF INPUT-BUFFER DELIMITED BY "$NUL$", 298 | INTO R(DEST) 299 | WITH POINTER PTR(DEST). 300 | SUBTRACT PARAM OF IRC-PARAMS(NUM-PARAMS OF IRC-PARAMS), 4 301 | FROM PTR(DEST). 302 | STRING "$NUL$" 303 | INTO R(DEST) 304 | WITH POINTER PTR(DEST). 305 | 306 | INDEX-PARAMS. 307 | MOVE 0 TO NUM-PARAMS OF WOPO, STATE. 308 | MOVE 1 TO PTR(DEST) 309 | PERFORM INDEX-PARAM UNTIL DONE. 310 | D DISPLAY "NUM-PARAMS. ", NUM-PARAMS OF WOPO. 311 | 312 | INDEX-PARAM. 313 | ADD 1 TO NUM-PARAMS OF WOPO. 314 | MOVE PTR(DEST) TO PARAM OF WOPO(NUM-PARAMS OF WOPO). 315 | MOVE SPACES TO R(DEST). 316 | UNSTRING R(SRC) DELIMITED BY "$$" OR "$NUL$" 317 | INTO R(DEST) 318 | WITH POINTER PTR(DEST). 319 | IF R(DEST) IS EQUAL TO SPACES THEN 320 | SUBTRACT 1 FROM NUM-PARAMS OF WOPO 321 | MOVE 99 TO STATE. 322 | IF NUM-PARAMS OF WOPO IS NOT LESS THAN 9 THEN 323 | MOVE 99 TO STATE. 324 | 325 | GET-PARAM. 326 | MOVE PARAM OF WOPO(PTR(SRC)) TO PTR(DEST). 327 | UNSTRING R(SRC) DELIMITED BY "$$" OR "$NUL$" 328 | INTO R(DEST) 329 | WITH POINTER PTR(DEST). 330 | 331 | GET-REST. 332 | MOVE PARAM OF WOPO(PTR(SRC)) TO PTR(DEST). 333 | UNSTRING R(SRC) 334 | INTO R(DEST) 335 | WITH POINTER PTR(DEST). 336 | 337 | WAIT-FOR-COMMAND. 338 | MOVE SPACES TO COMMAND OF IRC-STATE. 339 | PERFORM RECEIVE-LINE UNTIL 340 | COMMAND OF IRC-STATE IS EQUAL TO WAITING-COMMAND. 341 | 342 | INDEX-NICKSERV-PARAMS. 343 | MOVE 0 TO NUM-PARAMS OF WOPO, STATE. 344 | MOVE 1 TO PTR(DEST) 345 | PERFORM INDEX-NICKSERV-PARAM UNTIL DONE. 346 | D DISPLAY "NUM-PARAMS. ", NUM-PARAMS OF WOPO. 347 | 348 | INDEX-NICKSERV-PARAM. 349 | ADD 1 TO NUM-PARAMS OF WOPO. 350 | MOVE PTR(DEST) TO PARAM OF WOPO(NUM-PARAMS OF WOPO). 351 | MOVE SPACES TO R(DEST). 352 | UNSTRING R(SRC) DELIMITED BY SPACES OR "$NUL$" 353 | INTO R(DEST) 354 | WITH POINTER PTR(DEST). 355 | IF R(DEST) IS EQUAL TO SPACES THEN 356 | SUBTRACT 1 FROM NUM-PARAMS OF WOPO 357 | MOVE 99 TO STATE. 358 | IF NUM-PARAMS OF WOPO IS NOT LESS THAN 9 THEN 359 | MOVE 99 TO STATE. 360 | 361 | GET-NICKSERV-PARAM. 362 | MOVE PARAM OF WOPO(PTR(SRC)) TO PTR(DEST). 363 | UNSTRING R(SRC) DELIMITED BY SPACES OR "$NUL$" 364 | INTO R(DEST) 365 | WITH POINTER PTR(DEST). 366 | 367 | VALIDATE-USER. 368 | D DISPLAY "ENTERED VALIDATE-USER". 369 | MOVE NICK OF IRC-STATE TO USER-NAME. 370 | MOVE SPACES TO MSG-BODY OF OUTPUT-BUFFER. 371 | STRING "PRIVMSG NICKSERV $COLN$ACC " DELIMITED BY SIZE 372 | NICK OF IRC-STATE DELIMITED BY SPACE 373 | " *$NUL$" 374 | INTO MSG-BODY OF OUTPUT-BUFFER. 375 | PERFORM SEND-LINE. 376 | MOVE "NOTICE" TO WAITING-COMMAND. 377 | MOVE 0 TO STATE. 378 | D DISPLAY "WAITING FOR ACC." 379 | PERFORM WAIT-FOR-ACC UNTIL DONE. 380 | 381 | WAIT-FOR-ACC. 382 | PERFORM WAIT-FOR-COMMAND. 383 | MOVE 2 TO DEST. 384 | PERFORM GET-MSG-CONTENTS. 385 | MOVE 2 TO SRC. 386 | MOVE 1 TO DEST. 387 | PERFORM INDEX-NICKSERV-PARAMS. 388 | MOVE 1 TO PTR(2). 389 | PERFORM GET-NICKSERV-PARAM. 390 | IF R(1) IS EQUAL TO USER-NAME THEN 391 | MOVE 4 TO PTR(2) 392 | PERFORM GET-NICKSERV-PARAM 393 | IF R(1) IS EQUAL TO "ACC" THEN 394 | MOVE 99 TO STATE 395 | MOVE 5 TO PTR(2) 396 | PERFORM GET-NICKSERV-PARAM 397 | IF R(1) IS NOT EQUAL TO "3" THEN 398 | MOVE 0 TO USER-LEVEL 399 | ELSE 400 | MOVE 3 TO PTR(2) 401 | PERFORM GET-NICKSERV-PARAM 402 | MOVE R(1) TO USER-NAME 403 | READ USERS RECORD 404 | INVALID KEY MOVE 0 TO USER-LEVEL. 405 | 406 | MAIN. 407 | PERFORM RECEIVE-LINE. 408 | D DISPLAY "NICK. ", NICK OF IRC-STATE, 409 | D "COMMAND. ", COMMAND OF IRC-STATE, 410 | D "TARGET. ", TARGET OF IRC-STATE. 411 | IF PING THEN 412 | PERFORM PONG 413 | ELSE IF PRIVMSG OR NOTICE THEN 414 | PERFORM HANDLE-MESSAGE 415 | ELSE IF KICK THEN 416 | D DISPLAY "PROCESSING KICK" 417 | PERFORM HANDLE-KICK. 418 | 419 | INIT-REPLY. 420 | MOVE COMMAND OF IRC-STATE TO COMMAND OF OUTPUT-SPEC. 421 | MOVE NICK OF IRC-STATE TO NICK OF OUTPUT-SPEC. 422 | IF TARGET OF IRC-STATE IS EQUAL TO NICK OF WOPO THEN 423 | MOVE NICK OF IRC-STATE TO TARGET OF OUTPUT-SPEC 424 | ELSE 425 | MOVE TARGET OF IRC-STATE TO TARGET OF OUTPUT-SPEC. 426 | 427 | BEGIN-REPLY. 428 | MOVE SPACES TO MSG-BODY OF OUTPUT-BUFFER. 429 | MOVE 1 TO PTR(SRC). 430 | STRING COMMAND OF OUTPUT-SPEC DELIMITED BY SPACES, 431 | " " DELIMITED BY SIZE, 432 | TARGET OF OUTPUT-SPEC DELIMITED BY SPACES, 433 | " $COLN$" DELIMITED BY SIZE 434 | INTO MSG-BODY OF OUTPUT-BUFFER 435 | WITH POINTER PTR(SRC). 436 | 437 | BEGIN-STANDARD-REPLY. 438 | PERFORM BEGIN-REPLY. 439 | IF TARGET OF OUTPUT-SPEC IS NOT EQUAL TO NICK OF WOPO THEN 440 | STRING "$226$$128$$139$" DELIMITED BY SIZE, 441 | NICK OF OUTPUT-SPEC DELIMITED BY SPACES, 442 | ". " DELIMITED BY SIZE 443 | INTO MSG-BODY OF OUTPUT-BUFFER 444 | WITH POINTER PTR(SRC). 445 | 446 | USAGE-REPLY. 447 | PERFORM BEGIN-STANDARD-REPLY. 448 | STRING "USAGE. " DELIMITED BY SIZE, 449 | R(SRC) DELIMITED BY "$NUL$", 450 | "$NUL$" DELIMITED BY SIZE 451 | INTO MSG-BODY OF OUTPUT-BUFFER 452 | WITH POINTER PTR(SRC). 453 | PERFORM SEND-LINE. 454 | 455 | REPLY-ACK. 456 | PERFORM BEGIN-STANDARD-REPLY. 457 | STRING "OK.$NUL$" 458 | INTO MSG-BODY OF OUTPUT-BUFFER 459 | WITH POINTER PTR(SRC). 460 | PERFORM SEND-LINE. 461 | 462 | REPLY-NAK. 463 | PERFORM BEGIN-STANDARD-REPLY. 464 | STRING "ACCESS DENIED.$NUL$" 465 | INTO MSG-BODY OF OUTPUT-BUFFER 466 | WITH POINTER PTR(SRC). 467 | PERFORM SEND-LINE. 468 | 469 | MAYBE-SHOW-ESCAPES. 470 | IF SHOULD-SHOW-ESCAPES THEN 471 | IF SRC IS EQUAL TO 1 THEN 472 | CALL "RE-ESCAPE" USING R(SRC), R(2) 473 | MOVE PTR(SRC) TO PTR(2) 474 | MOVE 2 TO SRC 475 | ELSE 476 | CALL "RE-ESCAPE" USING R(SRC), R(1) 477 | MOVE PTR(SRC) TO PTR(1) 478 | MOVE 1 TO SRC. 479 | 480 | DO-OUTPUT. 481 | IF STANDARD-OUTPUT THEN 482 | PERFORM MAYBE-SHOW-ESCAPES 483 | STRING R(SRC) DELIMITED BY "$NUL$", 484 | "$NUL$" 485 | INTO MSG-BODY OF OUTPUT-BUFFER 486 | WITH POINTER PTR(SRC) 487 | PERFORM SEND-LINE 488 | ELSE 489 | MOVE R(SRC) TO R(OUTPUT-DEST). 490 | 491 | PONG. 492 | STRING "PONG$NUL$" 493 | INTO MSG-BODY OF OUTPUT-BUFFER. 494 | PERFORM SEND-LINE. 495 | 496 | HANDLE-KICK. 497 | D DISPLAY "DETECTED KICK.". 498 | MOVE SPACES TO R(1). 499 | MOVE PARAM OF IRC-PARAMS(2) TO PTR(1). 500 | UNSTRING MSG-BODY OF INPUT-BUFFER DELIMITED BY SPACE 501 | INTO R(1) 502 | WITH POINTER PTR(1). 503 | IF R(1) IS EQUAL TO NICK OF WOPO THEN 504 | D DISPLAY "KICK WAS ME." 505 | MOVE SPACES TO MSG-BODY OF OUTPUT-BUFFER 506 | STRING "JOIN " DELIMITED BY SIZE, 507 | TARGET OF IRC-STATE DELIMITED BY SPACES 508 | "$NUL$" 509 | INTO MSG-BODY OF OUTPUT-BUFFER 510 | PERFORM SEND-LINE 511 | MOVE PARAM OF IRC-PARAMS(NUM-PARAMS OF IRC-PARAMS) 512 | TO PTR(1) 513 | UNSTRING MSG-BODY OF INPUT-BUFFER 514 | INTO R(1) 515 | WITH POINTER PTR(1) 516 | D DISPLAY "KICK MESSAGE. ", R(1) 517 | IF R(1) IS NOT EQUAL TO NICK OF WOPO THEN 518 | MOVE SPACES TO MSG-BODY OF OUTPUT-BUFFER 519 | STRING "PRIVMSG " DELIMITED BY SIZE, 520 | TARGET OF IRC-STATE DELIMITED BY SPACES, 521 | " $COLN$" DELIMITED BY SIZE, 522 | NICK OF IRC-STATE DELIMITED BY SPACES, 523 | ". " DELIMITED BY SIZE, 524 | R(1) DELIMITED BY "$NUL$", 525 | "$NUL$" 526 | INTO MSG-BODY OF OUTPUT-BUFFER 527 | PERFORM SEND-LINE. 528 | 529 | HANDLE-MESSAGE. 530 | D DISPLAY "HANDLING MESSAGE." 531 | MOVE 2 TO DEST. 532 | PERFORM GET-MSG-CONTENTS. 533 | D DISPLAY "MESSAGE CONTENTS. ", R(2). 534 | IF IS-CTCP(2) THEN 535 | PERFORM HANDLE-CTCP 536 | ELSE 537 | MOVE 0 TO INPUT-SOURCE, OUTPUT-DEST. 538 | PERFORM INIT-REPLY 539 | IF IS-COMMAND(2) THEN 540 | D DISPLAY "PREFIXED COMMAND DETECTED." 541 | MOVE COMMAND-BODY(2) TO R(1) 542 | D DISPLAY "COMMAND BODY ", R(1) 543 | PERFORM HANDLE-INTERACTIVE-COMMAND 544 | ELSE IF TARGET OF IRC-STATE IS EQUAL TO NICK OF WOPO THEN 545 | D DISPLAY "DIRECT MESSAGE DETECTED." 546 | MOVE R(2) TO R(1) 547 | PERFORM HANDLE-INTERACTIVE-COMMAND 548 | ELSE 549 | D DISPLAY "ADDRESSED MESSAGE DETECTED." 550 | MOVE 1 TO PTR(2) 551 | UNSTRING R(2) DELIMITED BY "$COLN$ " OR "$$" 552 | INTO R(1) 553 | WITH POINTER PTR(2) 554 | D DISPLAY "NICK ADDRESSED. ", R(1) 555 | IF R(1) IS EQUAL TO NICK OF WOPO THEN 556 | D DISPLAY "NICK MATCHED MINE." 557 | UNSTRING R(2) 558 | INTO R(1) 559 | WITH POINTER PTR(2) 560 | PERFORM HANDLE-INTERACTIVE-COMMAND 561 | D ELSE 562 | D DISPLAY "NOT TALKING TO ME. I AM ", NICK OF WOPO 563 | . 564 | 565 | HANDLE-SWITCHES. 566 | UNSTRING R(2) DELIMITED BY "/" 567 | INTO R(3), DELIMITER IN DELIM 568 | WITH POINTER PTR(1). 569 | IF SWITCH-PARAM(3) IS NUMERIC THEN 570 | IF SWITCH(3) IS EQUAL TO "I" THEN 571 | MOVE SWITCH-PARAM(3) TO INPUT-SOURCE 572 | ELSE IF SWITCH(3) IS EQUAL TO "O" THEN 573 | MOVE SWITCH-PARAM(3) TO OUTPUT-DEST. 574 | IF DELIM IS NOT EQUAL TO "/" THEN 575 | MOVE 99 TO STATE. 576 | 577 | HANDLE-INTERACTIVE-COMMAND. 578 | MOVE SPACES TO R(8). 579 | MOVE 8 TO INPUT-SOURCE. 580 | PERFORM HANDLE-COMMAND. 581 | 582 | HANDLE-COMMAND. 583 | MOVE 1 TO SRC. 584 | MOVE 2 TO DEST. 585 | PERFORM INDEX-PARAMS. 586 | MOVE 1 TO PTR(1). 587 | PERFORM GET-PARAM. 588 | UNSTRING R(2) DELIMITED BY "/" 589 | INTO R(3) 590 | WITH POINTER PTR(3). 591 | IF R(3) IS NOT EQUAL TO R(2) THEN 592 | MOVE 0 TO STATE 593 | PERFORM HANDLE-SWITCHES UNTIL DONE. 594 | IF NUM-PARAMS OF WOPO IS GREATER THAN 1 THEN 595 | MOVE 2 TO PTR(1) 596 | MOVE 8 TO DEST 597 | PERFORM GET-REST. 598 | UNSTRING R(2) DELIMITED BY "/" OR SPACES INTO R(1). 599 | D DISPLAY "INPUT-SOURCE. ", INPUT-SOURCE, 600 | D " OUTPUT-DEST. ", OUTPUT-DEST. 601 | IF STANDARD-INPUT THEN 602 | MOVE 8 TO INPUT-SOURCE. 603 | MOVE INPUT-SOURCE TO SRC. 604 | IF R(1) IS EQUAL TO "BF-CODE" THEN 605 | PERFORM HANDLE-BF-CODE 606 | ELSE IF R(1) IS EQUAL TO "BF-INPUT" THEN 607 | PERFORM HANDLE-BF-INPUT 608 | ELSE IF R(1) IS EQUAL TO "BF-OUTPUT" THEN 609 | PERFORM HANDLE-BF-OUTPUT 610 | ELSE IF R(1) IS EQUAL TO "BF-RUN" THEN 611 | D DISPLAY "BF-RUN" 612 | PERFORM HANDLE-BF-RUN 613 | ELSE IF R(1) IS EQUAL TO "DEOP" THEN 614 | PERFORM HANDLE-DEOP 615 | ELSE IF R(1) IS EQUAL TO "DEVOICE" THEN 616 | PERFORM HANDLE-DEVOICE 617 | ELSE IF R(1) IS EQUAL TO "COMMANDS" THEN 618 | PERFORM HANDLE-COMMANDS 619 | ELSE IF R(1) IS EQUAL TO "JOIN" THEN 620 | PERFORM HANDLE-JOIN 621 | ELSE IF R(1) IS EQUAL TO "LEVEL" THEN 622 | PERFORM HANDLE-LEVEL 623 | ELSE IF R(1) IS EQUAL TO "LICK" THEN 624 | PERFORM HANDLE-LICK 625 | ELSE IF R(1) IS EQUAL TO "LIST-USERS" THEN 626 | PERFORM HANDLE-LIST-USERS 627 | ELSE IF R(1) IS EQUAL TO "OP" THEN 628 | PERFORM HANDLE-OP 629 | ELSE IF R(1) IS EQUAL TO "PART" THEN 630 | PERFORM HANDLE-PART 631 | ELSE IF R(1) IS EQUAL TO "QUIT" THEN 632 | PERFORM HANDLE-QUIT 633 | ELSE IF R(1) IS EQUAL TO "RELEVEL" THEN 634 | PERFORM HANDLE-RELEVEL 635 | ELSE IF R(1) IS EQUAL TO "SHITFED" THEN 636 | PERFORM HANDLE-SHITFED 637 | ELSE IF R(1) IS EQUAL TO "SHOW-ESCAPES" THEN 638 | PERFORM HANDLE-SHOW-ESCAPES 639 | ELSE IF R(1) IS EQUAL TO "SOURCE" THEN 640 | PERFORM HANDLE-SOURCE 641 | ELSE IF R(1) IS EQUAL TO "STRESS" THEN 642 | PERFORM HANDLE-STRESS 643 | ELSE IF R(1) IS EQUAL TO "VOICE" THEN 644 | PERFORM HANDLE-VOICE 645 | ELSE IF R(1) IS EQUAL TO "ECHO" THEN 646 | PERFORM HANDLE-ECHO 647 | ELSE IF R(1) IS EQUAL TO "CAT" THEN 648 | PERFORM HANDLE-CAT 649 | ELSE IF R(1) IS EQUAL TO "DUMP-REGS" THEN 650 | PERFORM HANDLE-DUMP-REGS 651 | ELSE IF R(1) IS EQUAL TO "PROGRAMS" THEN 652 | PERFORM HANDLE-PROGRAMS 653 | ELSE IF R(1) IS EQUAL TO "LIST-PROGRAM" THEN 654 | PERFORM HANDLE-LIST-PROGRAM 655 | ELSE IF R(1) IS EQUAL TO "RUN" THEN 656 | PERFORM HANDLE-RUN 657 | ELSE IF R(1) IS EQUAL TO "HELP" THEN 658 | PERFORM HANDLE-HELP 659 | ELSE 660 | PERFORM INTERPRET-PROGRAM. 661 | D PERFORM DEBUG-REGISTERS 662 | D VARYING WOPO-COUNTER 663 | D FROM 1, BY 1 664 | D UNTIL WOPO-COUNTER IS GREATER THAN 8. 665 | 666 | DDEBUG-REGISTERS. 667 | D DISPLAY "REGISTER ", WOPO-COUNTER, ". ", R(WOPO-COUNTER). 668 | 669 | HANDLE-COMMANDS. 670 | STRING "COMMANDS. " 671 | "$$BF-CODE $$BF-INPUT $$BF-OUTPUT $$BF-RUN ", 672 | "$$DEOP $$DEVOICE $$COMMANDS $$JOIN $$LEVEL $$LICK ", 673 | "$$LIST-USERS $$OP $$PART $$QUIT $$RELEVEL ", 674 | "$$SHITFED $$SHOW-ESCAPES $$SOURCE $$STRESS ", 675 | "$$VOICE $$ECHO $$CAT $$DUMP-REGS $$PROGRAMS ", 676 | "$$LIST-PROGRAMS $$RUN $$HELP" 677 | "$NUL$" 678 | INTO R(1). 679 | MOVE 1 TO SRC. 680 | PERFORM BEGIN-STANDARD-REPLY. 681 | PERFORM DO-OUTPUT. 682 | 683 | HANDLE-SHITFED. 684 | STRING "$002$LEAVE MY CASE ALONE, ", 685 | "$226$$156$$168$ASSHOL$LOWE$$226$$156$$168$.$NUL$" 686 | INTO R(1). 687 | MOVE 1 TO SRC. 688 | PERFORM BEGIN-STANDARD-REPLY. 689 | PERFORM DO-OUTPUT. 690 | 691 | HANDLE-SOURCE. 692 | MOVE "HTTPS$COLN$//GITHUB.COM/HEDDWCH/WOPO$NUL$" 693 | TO R(1). 694 | MOVE 1 TO SRC. 695 | PERFORM BEGIN-STANDARD-REPLY. 696 | PERFORM DO-OUTPUT. 697 | 698 | HANDLE-STRESS. 699 | STRING "$SOH$ACTION PUNCHES A " 700 | "$226$$156$$168$BABY$226$$156$$168$.$SOH$$NUL$" 701 | INTO R(1). 702 | MOVE 1 TO SRC. 703 | PERFORM BEGIN-REPLY. 704 | PERFORM DO-OUTPUT. 705 | 706 | HANDLE-LICK. 707 | MOVE 1 TO DEST. 708 | PERFORM INDEX-PARAMS. 709 | IF NUM-PARAMS OF WOPO IS EQUAL TO 0 THEN 710 | MOVE NICK OF OUTPUT-SPEC TO R(1) 711 | ELSE 712 | MOVE 1 TO PTR(SRC) 713 | PERFORM GET-PARAM. 714 | STRING "$SOH$ACTION VIGOROUSLY LICKS " DELIMITED BY SIZE, 715 | R(1) DELIMITED BY SPACES, 716 | ".$SOH$$NUL$" DELIMITED BY SIZE 717 | INTO R(2). 718 | MOVE 2 TO SRC. 719 | PERFORM BEGIN-REPLY. 720 | PERFORM DO-OUTPUT. 721 | 722 | HANDLE-LEVEL. 723 | MOVE 1 TO DEST. 724 | PERFORM INDEX-PARAMS. 725 | IF NUM-PARAMS OF WOPO IS GREATER THAN 0 THEN 726 | MOVE 1 TO PTR(SRC) 727 | PERFORM GET-PARAM 728 | MOVE R(1) TO USER-NAME 729 | ELSE 730 | PERFORM VALIDATE-USER. 731 | READ USERS RECORD 732 | INVALID KEY MOVE 0 TO USER-LEVEL. 733 | STRING USER-RECORD, "$NUL$" INTO R(1). 734 | MOVE 1 TO SRC. 735 | PERFORM BEGIN-STANDARD-REPLY. 736 | PERFORM DO-OUTPUT. 737 | 738 | HANDLE-LIST-USERS. 739 | CLOSE USERS. 740 | STRING USERS-HEADER, "$NUL$" INTO R(1). 741 | MOVE 1 TO SRC. 742 | PERFORM BEGIN-STANDARD-REPLY. 743 | PERFORM DO-OUTPUT. 744 | OPEN I-O USERS. 745 | MOVE 0 TO STATE. 746 | PERFORM LIST-USER-RECORD UNTIL DONE. 747 | 748 | LIST-USER-RECORD. 749 | READ USERS NEXT RECORD, AT END MOVE 99 TO STATE. 750 | IF NOT DONE THEN 751 | STRING USER-RECORD, "$NUL$" INTO R(1) 752 | MOVE 1 TO SRC 753 | PERFORM BEGIN-STANDARD-REPLY 754 | PERFORM DO-OUTPUT. 755 | 756 | HANDLE-JOIN. 757 | MOVE 1 TO SRC. 758 | PERFORM REPLY-ACK. 759 | PERFORM VALIDATE-USER. 760 | MOVE INPUT-SOURCE TO SRC. 761 | MOVE 1 TO DEST. 762 | PERFORM INDEX-PARAMS. 763 | IF USER-LEVEL IS NOT LESS THAN 80 AND 764 | NUM-PARAMS OF WOPO IS GREATER THAN 0 THEN 765 | MOVE 1 TO DEST 766 | MOVE 1 TO PTR(SRC) 767 | PERFORM GET-PARAM 768 | IF R(1) IS NOT EQUAL TO "0" THEN 769 | MOVE SPACES TO MSG-BODY OF OUTPUT-BUFFER 770 | STRING "JOIN ", DELIMITED BY SIZE, 771 | R(1), DELIMITED BY SPACES, 772 | "$NUL$" 773 | INTO MSG-BODY OF OUTPUT-BUFFER 774 | PERFORM SEND-LINE 775 | ELSE 776 | NEXT SENTENCE 777 | ELSE 778 | PERFORM REPLY-NAK. 779 | 780 | HANDLE-PART. 781 | MOVE 1 TO SRC. 782 | PERFORM REPLY-ACK. 783 | PERFORM VALIDATE-USER. 784 | MOVE INPUT-SOURCE TO SRC. 785 | MOVE 1 TO DEST. 786 | PERFORM INDEX-PARAMS. 787 | IF NUM-PARAMS OF WOPO IS GREATER THAN 0 THEN 788 | MOVE 1 TO DEST 789 | MOVE 1 TO PTR(SRC) 790 | PERFORM GET-PARAM 791 | ELSE 792 | MOVE TARGET OF OUTPUT-SPEC TO R(1). 793 | IF USER-LEVEL IS NOT LESS THAN 80 THEN 794 | IF R(1) IS NOT EQUAL TO "0" THEN 795 | MOVE SPACES TO MSG-BODY OF OUTPUT-BUFFER 796 | STRING "PART ", DELIMITED BY SIZE, 797 | R(1), DELIMITED BY SPACES, 798 | "$NUL$" 799 | INTO MSG-BODY OF OUTPUT-BUFFER 800 | PERFORM SEND-LINE 801 | ELSE 802 | NEXT SENTENCE 803 | ELSE 804 | PERFORM REPLY-NAK. 805 | 806 | STRING-LOWVS. 807 | STRING "$LOWV$" INTO MSG-BODY OF OUTPUT-BUFFER 808 | WITH POINTER PTR(2). 809 | 810 | STRING-MODE-PARAMS. 811 | PERFORM GET-PARAM. 812 | ADD 1 TO PTR(2). 813 | STRING R(1) DELIMITED BY SPACES 814 | INTO MSG-BODY OF OUTPUT-BUFFER 815 | WITH POINTER PTR(2). 816 | 817 | HANDLE-VOICE. 818 | MOVE 1 TO SRC. 819 | PERFORM REPLY-ACK. 820 | PERFORM VALIDATE-USER. 821 | MOVE INPUT-SOURCE TO SRC. 822 | MOVE 1 TO DEST. 823 | PERFORM INDEX-PARAMS. 824 | IF NUM-PARAMS OF WOPO IS LESS THAN 1 THEN 825 | MOVE NICK OF OUTPUT-SPEC TO R(3) 826 | MOVE 3 TO SRC, INPUT-SOURCE 827 | PERFORM INDEX-PARAMS. 828 | IF USER-LEVEL IS NOT LESS THAN 60 THEN 829 | MOVE SPACES TO MSG-BODY OF OUTPUT-BUFFER 830 | MOVE 1 TO PTR(2) 831 | STRING "MODE " DELIMITED BY SIZE, 832 | TARGET OF OUTPUT-SPEC DELIMITED BY SPACES, 833 | " +" DELIMITED BY SIZE 834 | INTO MSG-BODY OF OUTPUT-BUFFER 835 | WITH POINTER PTR(2) 836 | PERFORM STRING-LOWVS 837 | VARYING PTR(SRC) 838 | FROM 1, BY 1 839 | UNTIL PTR(SRC) IS GREATER THAN 840 | NUM-PARAMS OF WOPO 841 | PERFORM STRING-MODE-PARAMS 842 | VARYING PTR(SRC) 843 | FROM 1, BY 1 844 | UNTIL PTR(SRC) IS GREATER THAN 845 | NUM-PARAMS OF WOPO 846 | STRING "$NUL$" 847 | INTO MSG-BODY OF OUTPUT-BUFFER 848 | WITH POINTER PTR(2) 849 | PERFORM SEND-LINE 850 | ELSE 851 | PERFORM REPLY-NAK. 852 | 853 | HANDLE-DEVOICE. 854 | MOVE 1 TO SRC. 855 | PERFORM REPLY-ACK. 856 | PERFORM VALIDATE-USER. 857 | MOVE INPUT-SOURCE TO SRC. 858 | MOVE 1 TO DEST. 859 | PERFORM INDEX-PARAMS. 860 | IF NUM-PARAMS OF WOPO IS LESS THAN 1 THEN 861 | MOVE NICK OF OUTPUT-SPEC TO R(3) 862 | MOVE 3 TO SRC, INPUT-SOURCE 863 | PERFORM INDEX-PARAMS. 864 | IF USER-LEVEL IS NOT LESS THAN 60 THEN 865 | MOVE SPACES TO MSG-BODY OF OUTPUT-BUFFER 866 | MOVE 1 TO PTR(2) 867 | STRING "MODE " DELIMITED BY SIZE, 868 | TARGET OF OUTPUT-SPEC DELIMITED BY SPACES, 869 | " -" DELIMITED BY SIZE 870 | INTO MSG-BODY OF OUTPUT-BUFFER 871 | WITH POINTER PTR(2) 872 | PERFORM STRING-LOWVS 873 | VARYING PTR(SRC) 874 | FROM 1, BY 1 875 | UNTIL PTR(SRC) IS GREATER THAN 876 | NUM-PARAMS OF WOPO 877 | PERFORM STRING-MODE-PARAMS 878 | VARYING PTR(SRC) 879 | FROM 1, BY 1 880 | UNTIL PTR(SRC) IS GREATER THAN 881 | NUM-PARAMS OF WOPO 882 | STRING "$NUL$" 883 | INTO MSG-BODY OF OUTPUT-BUFFER 884 | WITH POINTER PTR(2) 885 | PERFORM SEND-LINE 886 | ELSE 887 | PERFORM REPLY-NAK. 888 | 889 | STRING-LOWOS. 890 | STRING "$LOWO$" INTO MSG-BODY OF OUTPUT-BUFFER 891 | WITH POINTER PTR(2). 892 | 893 | HANDLE-OP. 894 | MOVE 1 TO SRC. 895 | PERFORM REPLY-ACK. 896 | PERFORM VALIDATE-USER. 897 | MOVE INPUT-SOURCE TO SRC. 898 | MOVE 1 TO DEST. 899 | PERFORM INDEX-PARAMS. 900 | IF NUM-PARAMS OF WOPO IS LESS THAN 1 THEN 901 | MOVE NICK OF OUTPUT-SPEC TO R(3) 902 | MOVE 3 TO SRC, INPUT-SOURCE 903 | PERFORM INDEX-PARAMS. 904 | IF USER-LEVEL IS NOT LESS THAN 70 THEN 905 | MOVE SPACES TO MSG-BODY OF OUTPUT-BUFFER 906 | MOVE 1 TO PTR(2) 907 | STRING "MODE " DELIMITED BY SIZE, 908 | TARGET OF OUTPUT-SPEC DELIMITED BY SPACES, 909 | " +" DELIMITED BY SIZE 910 | INTO MSG-BODY OF OUTPUT-BUFFER 911 | WITH POINTER PTR(2) 912 | PERFORM STRING-LOWOS 913 | VARYING PTR(SRC) 914 | FROM 1, BY 1 915 | UNTIL PTR(SRC) IS GREATER THAN 916 | NUM-PARAMS OF WOPO 917 | PERFORM STRING-MODE-PARAMS 918 | VARYING PTR(SRC) 919 | FROM 1, BY 1 920 | UNTIL PTR(SRC) IS GREATER THAN 921 | NUM-PARAMS OF WOPO 922 | STRING "$NUL$" 923 | INTO MSG-BODY OF OUTPUT-BUFFER 924 | WITH POINTER PTR(2) 925 | PERFORM SEND-LINE 926 | ELSE 927 | PERFORM REPLY-NAK. 928 | 929 | HANDLE-DEOP. 930 | MOVE 1 TO SRC. 931 | PERFORM REPLY-ACK. 932 | PERFORM VALIDATE-USER. 933 | MOVE INPUT-SOURCE TO SRC. 934 | MOVE 1 TO DEST. 935 | PERFORM INDEX-PARAMS. 936 | IF NUM-PARAMS OF WOPO IS LESS THAN 1 THEN 937 | MOVE NICK OF OUTPUT-SPEC TO R(3) 938 | MOVE 3 TO SRC, INPUT-SOURCE 939 | PERFORM INDEX-PARAMS. 940 | IF USER-LEVEL IS NOT LESS THAN 70 THEN 941 | MOVE SPACES TO MSG-BODY OF OUTPUT-BUFFER 942 | MOVE 1 TO PTR(2) 943 | STRING "MODE " DELIMITED BY SIZE, 944 | TARGET OF OUTPUT-SPEC DELIMITED BY SPACES, 945 | " -" DELIMITED BY SIZE 946 | INTO MSG-BODY OF OUTPUT-BUFFER 947 | WITH POINTER PTR(2) 948 | PERFORM STRING-LOWOS 949 | VARYING PTR(SRC) 950 | FROM 1, BY 1 951 | UNTIL PTR(SRC) IS GREATER THAN 952 | NUM-PARAMS OF WOPO 953 | PERFORM STRING-MODE-PARAMS 954 | VARYING PTR(SRC) 955 | FROM 1, BY 1 956 | UNTIL PTR(SRC) IS GREATER THAN 957 | NUM-PARAMS OF WOPO 958 | STRING "$NUL$" 959 | INTO MSG-BODY OF OUTPUT-BUFFER 960 | WITH POINTER PTR(2) 961 | PERFORM SEND-LINE 962 | ELSE 963 | PERFORM REPLY-NAK. 964 | 965 | HANDLE-QUIT. 966 | MOVE 1 TO SRC. 967 | PERFORM REPLY-ACK. 968 | MOVE "QUIT-MESSAGE" TO CONFIG-KEY. 969 | READ CONFIG RECORD 970 | INVALID KEY MOVE SPACES TO CONFIG-VALUE. 971 | PERFORM VALIDATE-USER. 972 | IF USER-LEVEL IS NOT LESS THAN 90 THEN 973 | MOVE SPACES TO MSG-BODY OF OUTPUT-BUFFER 974 | STRING "QUIT $COLN$" DELIMITED BY SIZE, 975 | CONFIG-VALUE, 976 | INTO MSG-BODY OF OUTPUT-BUFFER 977 | PERFORM SEND-LINE 978 | GO TO QUIT 979 | ELSE 980 | PERFORM REPLY-NAK. 981 | 982 | HANDLE-SHOW-ESCAPES. 983 | MOVE 1 TO SRC. 984 | PERFORM REPLY-ACK. 985 | PERFORM VALIDATE-USER. 986 | IF USER-LEVEL IS NOT LESS THAN 90 THEN 987 | MOVE INPUT-SOURCE TO SRC 988 | MOVE 1 TO DEST 989 | PERFORM INDEX-PARAMS 990 | IF NUM-PARAMS OF WOPO IS GREATER THAN 0 THEN 991 | MOVE 1 TO PTR(SRC) 992 | PERFORM GET-PARAM 993 | IF R(1) IS EQUAL TO "ON" THEN 994 | MOVE 1 TO SHOW-ESCAPES 995 | ELSE IF R(1) IS EQUAL TO "OFF" THEN 996 | MOVE 0 TO SHOW-ESCAPES 997 | ELSE NEXT SENTENCE 998 | ELSE IF SHOULD-SHOW-ESCAPES THEN 999 | MOVE 0 TO SHOW-ESCAPES 1000 | ELSE MOVE 1 TO SHOW-ESCAPES 1001 | ELSE 1002 | PERFORM REPLY-NAK. 1003 | IF SHOULD-SHOW-ESCAPES THEN 1004 | MOVE "SHOW-ESCAPES ON.$NUL$" TO R(1) 1005 | ELSE 1006 | MOVE "SHOW-ESCAPES OFF.$NUL$" TO R(1). 1007 | MOVE 1 TO SRC. 1008 | PERFORM BEGIN-STANDARD-REPLY. 1009 | PERFORM DO-OUTPUT. 1010 | 1011 | HANDLE-RELEVEL. 1012 | MOVE 1 TO SRC. 1013 | PERFORM REPLY-ACK. 1014 | PERFORM VALIDATE-USER. 1015 | IF USER-LEVEL IS NOT LESS THAN 99 THEN 1016 | MOVE INPUT-SOURCE TO SRC 1017 | MOVE 1 TO DEST 1018 | PERFORM INDEX-PARAMS 1019 | IF NUM-PARAMS OF WOPO IS EQUAL TO 2 THEN 1020 | MOVE 1 TO PTR(SRC) 1021 | PERFORM GET-PARAM 1022 | MOVE R(1) TO USER-NAME 1023 | MOVE 2 TO PTR(SRC) 1024 | PERFORM GET-PARAM 1025 | MOVE R(1) TO USER-LEVEL 1026 | IF USER-LEVEL IS NOT GREATER THAN ZERO THEN 1027 | DELETE USERS RECORD 1028 | INVALID KEY NEXT SENTENCE 1029 | ELSE 1030 | REWRITE USER-RECORD 1031 | INVALID KEY WRITE USER-RECORD 1032 | ELSE 1033 | MOVE "$$$NUL$" TO R(1) 1034 | MOVE 1 TO SRC 1035 | PERFORM USAGE-REPLY 1036 | ELSE 1037 | PERFORM REPLY-NAK. 1038 | READ USERS RECORD 1039 | INVALID KEY MOVE 0 TO USER-LEVEL. 1040 | MOVE 1 TO SRC. 1041 | STRING USER-RECORD, "$NUL$" INTO R(1). 1042 | PERFORM BEGIN-STANDARD-REPLY. 1043 | PERFORM DO-OUTPUT. 1044 | 1045 | HANDLE-BF-CODE. 1046 | MOVE 1 TO DEST. 1047 | PERFORM INDEX-PARAMS. 1048 | IF NUM-PARAMS OF WOPO IS LESS THAN 1 THEN 1049 | MOVE BF-CODE TO R(1) 1050 | D DISPLAY "BF-CODE. ", BF-CODE 1051 | MOVE 1 TO SRC 1052 | PERFORM BEGIN-STANDARD-REPLY 1053 | PERFORM DO-OUTPUT 1054 | ELSE 1055 | MOVE 1 TO SRC 1056 | PERFORM REPLY-ACK 1057 | PERFORM VALIDATE-USER 1058 | IF USER-LEVEL IS NOT LESS THAN 60 THEN 1059 | MOVE INPUT-SOURCE TO SRC 1060 | MOVE 1 TO DEST 1061 | PERFORM INDEX-PARAMS 1062 | MOVE 1 TO PTR(SRC) 1063 | PERFORM GET-REST 1064 | MOVE R(1) TO BF-CODE 1065 | ELSE 1066 | PERFORM REPLY-NAK. 1067 | 1068 | HANDLE-BF-INPUT. 1069 | MOVE 1 TO DEST. 1070 | PERFORM INDEX-PARAMS. 1071 | IF NUM-PARAMS OF WOPO IS LESS THAN 1 THEN 1072 | MOVE BF-INPUT TO R(1) 1073 | D DISPLAY "BF-INPUT. ", BF-INPUT 1074 | MOVE 1 TO SRC 1075 | PERFORM BEGIN-STANDARD-REPLY 1076 | PERFORM DO-OUTPUT 1077 | ELSE 1078 | MOVE 1 TO SRC 1079 | PERFORM REPLY-ACK 1080 | PERFORM VALIDATE-USER 1081 | IF USER-LEVEL IS NOT LESS THAN 50 THEN 1082 | MOVE INPUT-SOURCE TO SRC 1083 | MOVE 1 TO DEST 1084 | PERFORM INDEX-PARAMS 1085 | MOVE 1 TO PTR(SRC) 1086 | PERFORM GET-REST 1087 | MOVE R(1) TO BF-INPUT 1088 | ELSE 1089 | PERFORM REPLY-NAK. 1090 | 1091 | HANDLE-BF-OUTPUT. 1092 | D DISPLAY "BF OUTPUT. ", BF-OUTPUT. 1093 | MOVE BF-OUTPUT TO R(1). 1094 | MOVE 1 TO SRC. 1095 | PERFORM BEGIN-STANDARD-REPLY. 1096 | PERFORM DO-OUTPUT. 1097 | 1098 | HANDLE-BF-RUN. 1099 | D DISPLAY "HANDLING BF-RUN". 1100 | MOVE 1 TO SRC. 1101 | PERFORM REPLY-ACK. 1102 | PERFORM VALIDATE-USER. 1103 | IF USER-LEVEL IS NOT LESS THAN 50 THEN 1104 | MOVE INPUT-SOURCE TO SRC 1105 | MOVE 1 TO DEST 1106 | PERFORM INDEX-PARAMS 1107 | IF NUM-PARAMS OF WOPO IS LESS THAN 2 THEN 1108 | PERFORM BF-LIMIT-CYCLES 1109 | D DISPLAY "CYCLE LIMIT. ", CYCLE-LIMIT OF BF-I-O 1110 | CALL "BF-RUN" USING BF-INPUT, BF-CODE, 1111 | BF-OUTPUT, CYCLE-LIMIT OF BF-I-O 1112 | D DISPLAY "BF RAN" 1113 | PERFORM HANDLE-BF-OUTPUT 1114 | ELSE 1115 | MOVE "" TO R(1) 1116 | MOVE 1 TO SRC 1117 | PERFORM USAGE-REPLY 1118 | ELSE 1119 | PERFORM REPLY-NAK. 1120 | 1121 | BF-LIMIT-CYCLES. 1122 | IF NUM-PARAMS OF WOPO IS EQUAL TO 0 THEN 1123 | MOVE 999 TO CYCLE-LIMIT OF BF-I-O 1124 | ELSE 1125 | MOVE 1 TO PTR(SRC) 1126 | PERFORM GET-PARAM 1127 | MOVE R(1) TO CYCLE-LIMIT OF BF-I-O. 1128 | IF CYCLE-LIMIT OF BF-I-O > 250000 THEN 1129 | IF USER-LEVEL < 90 THEN 1130 | IF USER-LEVEL < 70 THEN 1131 | MOVE 250000 TO CYCLE-LIMIT OF BF-I-O 1132 | PERFORM BF-CYCLES-LIMITED 1133 | ELSE IF CYCLE-LIMIT OF BF-I-O > 1900000 THEN 1134 | MOVE 1900000 TO CYCLE-LIMIT OF BF-I-O 1135 | PERFORM BF-CYCLES-LIMITED. 1136 | 1137 | BF-CYCLES-LIMITED. 1138 | STRING "INSUFFICIENT LEVEL FOR REQUESTED CYCLE LIMIT. ", 1139 | "ACTUAL LIMIT WILL BE ", 1140 | CYCLE-LIMIT OF BF-I-O, 1141 | "." 1142 | INTO R(1). 1143 | MOVE 1 TO SRC. 1144 | PERFORM BEGIN-STANDARD-REPLY. 1145 | PERFORM DO-OUTPUT. 1146 | 1147 | HANDLE-ECHO. 1148 | MOVE 1 TO DEST. 1149 | PERFORM INDEX-PARAMS. 1150 | IF NUM-PARAMS OF WOPO IS LESS THAN 1 THEN 1151 | MOVE "" TO R(1) 1152 | MOVE 1 TO SRC 1153 | PERFORM USAGE-REPLY 1154 | ELSE 1155 | PERFORM BEGIN-STANDARD-REPLY 1156 | PERFORM DO-OUTPUT. 1157 | 1158 | * GET EACH SUCCESSIVE PARAM INTO R(1), STRINGING EACH CORRESPONDING 1159 | * REGISTER'S CONTENTS INTO R(2) 1160 | STRING-CAT-PARAMS. 1161 | MOVE INPUT-SOURCE TO SRC. 1162 | PERFORM GET-PARAM. 1163 | IF R-INDEX(DEST) IS NUMERIC THEN 1164 | MOVE R-INDEX(DEST) TO SRC 1165 | IF SRC IS LESS THAN 1 OR 1166 | SRC IS GREATER THAN 8 THEN 1167 | MOVE 99 TO STATE 1168 | ELSE 1169 | STRING R(SRC) DELIMITED BY "$NUL$" 1170 | INTO R(2) 1171 | WITH POINTER PTR(2) 1172 | ELSE 1173 | MOVE 99 TO STATE. 1174 | 1175 | HANDLE-CAT. 1176 | MOVE 1 TO DEST, PTR(2). 1177 | PERFORM INDEX-PARAMS. 1178 | MOVE 0 TO STATE. 1179 | PERFORM STRING-CAT-PARAMS 1180 | VARYING PTR(INPUT-SOURCE) 1181 | FROM 1, BY 1, 1182 | UNTIL PTR(INPUT-SOURCE) IS GREATER THAN 1183 | NUM-PARAMS OF WOPO 1184 | OR DONE. 1185 | STRING "$NUL$" INTO R(2) 1186 | WITH POINTER PTR(2). 1187 | MOVE 2 TO SRC. 1188 | PERFORM BEGIN-STANDARD-REPLY. 1189 | PERFORM DO-OUTPUT. 1190 | 1191 | DUMP-REG. 1192 | STRING "R(", WOPO-COUNTER, "). ", 1193 | R(WOPO-COUNTER) 1194 | INTO R(1). 1195 | MOVE 1 TO SRC. 1196 | PERFORM BEGIN-STANDARD-REPLY. 1197 | PERFORM DO-OUTPUT. 1198 | 1199 | HANDLE-DUMP-REGS. 1200 | MOVE 1 TO SRC, WOPO-COUNTER. 1201 | PERFORM DUMP-REG VARYING WOPO-COUNTER 1202 | FROM 1, BY 1, 1203 | UNTIL WOPO-COUNTER IS GREATER THAN 8. 1204 | 1205 | STRING-PROGRAM-NAME. 1206 | READ PROGRAM-INDEX NEXT RECORD 1207 | AT END MOVE 99 TO STATE. 1208 | IF NOT DONE THEN 1209 | STRING NAME OF INDEX-ENTRY DELIMITED BY SPACE, 1210 | " " DELIMITED BY SIZE 1211 | INTO R(1) 1212 | WITH POINTER PTR(1). 1213 | 1214 | HANDLE-PROGRAMS. 1215 | OPEN INPUT PROGRAM-INDEX. 1216 | MOVE 1 TO SRC, PTR(1). 1217 | MOVE 0 TO STATE. 1218 | PERFORM STRING-PROGRAM-NAME UNTIL DONE. 1219 | CLOSE PROGRAM-INDEX. 1220 | STRING "$NUL$" 1221 | INTO R(1) 1222 | WITH POINTER PTR(1). 1223 | PERFORM BEGIN-STANDARD-REPLY. 1224 | PERFORM DO-OUTPUT. 1225 | 1226 | LIST-INSTRUCTION. 1227 | READ PROGRAM-CODE RECORD. 1228 | MOVE 1 TO SRC, PTR(1). 1229 | STRING PROGRAM-IP, ".", 1230 | RAW-INSTRUCTION OF PROGRAM-RECORD 1231 | INTO R(1), 1232 | WITH POINTER PTR(1). 1233 | PERFORM BEGIN-STANDARD-REPLY. 1234 | PERFORM DO-OUTPUT. 1235 | D DISPLAY "NEXT-IP. ", NEXT-IP 1236 | IF NEXT-IP OF PROGRAM-RECORD IS LESS THAN 999 THEN 1237 | MOVE NEXT-IP OF PROGRAM-RECORD TO PROGRAM-IP 1238 | ELSE 1239 | MOVE 99 TO STATE. 1240 | 1241 | LIST-PROGRAM. 1242 | MOVE INPUT-SOURCE TO SRC. 1243 | PERFORM GET-PARAM. 1244 | MOVE 1 TO SRC. 1245 | MOVE R(1) TO NAME OF INDEX-ENTRY. 1246 | MOVE 0 TO STATE. 1247 | READ PROGRAM-INDEX RECORD 1248 | INVALID KEY 1249 | MOVE 1 TO PTR(1) 1250 | STRING "NO SUCH PROGRAM " DELIMITED BY SIZE, 1251 | NAME OF INDEX-ENTRY DELIMITED BY SPACE, 1252 | ".$NUL$" DELIMITED BY SIZE 1253 | INTO R(1) 1254 | WITH POINTER PTR(1) 1255 | PERFORM BEGIN-STANDARD-REPLY 1256 | PERFORM DO-OUTPUT 1257 | MOVE 99 TO STATE. 1258 | IF NOT DONE THEN 1259 | PERFORM BEGIN-STANDARD-REPLY 1260 | PERFORM DO-OUTPUT 1261 | MOVE PROGRAM-LISTING-HEADER TO R(1) 1262 | PERFORM BEGIN-STANDARD-REPLY 1263 | PERFORM DO-OUTPUT 1264 | MOVE ADDR OF INDEX-ENTRY TO PROGRAM-IP 1265 | PERFORM LIST-INSTRUCTION UNTIL DONE. 1266 | 1267 | HANDLE-LIST-PROGRAM. 1268 | MOVE 1 TO DEST. 1269 | PERFORM INDEX-PARAMS. 1270 | IF NUM-PARAMS OF WOPO IS LESS THAN 1 THEN 1271 | MOVE "$$..." TO R(1) 1272 | MOVE 1 TO SRC 1273 | PERFORM USAGE-REPLY 1274 | ELSE 1275 | OPEN INPUT PROGRAM-INDEX, PROGRAM-CODE 1276 | PERFORM LIST-PROGRAM 1277 | VARYING PTR(SRC) 1278 | FROM 1, BY 1, 1279 | UNTIL PTR(SRC) IS GREATER THAN NUM-PARAMS OF WOPO 1280 | CLOSE PROGRAM-INDEX, PROGRAM-CODE. 1281 | 1282 | DO-NEXT-INSTRUCTION. 1283 | READ PROGRAM-CODE RECORD. 1284 | IF NOT INPUT-FROM-RECORD THEN 1285 | MOVE IN-REG TO INPUT-SOURCE 1286 | ELSE 1287 | IF NEXT-IP OF PROGRAM-RECORD IS NOT LESS THAN 999 THEN 1288 | STRING "MISSING INPUT RECORD FOR INSTRUCTION ", 1289 | PROGRAM-IP, 1290 | " IN PROGRAM " DELIMITED BY SIZE, 1291 | NAME OF INDEX-ENTRY DELIMITED BY SPACE, 1292 | ".$NUL$" 1293 | INTO R(1) 1294 | MOVE 1 TO SRC 1295 | PERFORM BEGIN-STANDARD-REPLY 1296 | PERFORM DO-OUTPUT 1297 | MOVE 99 TO STATE 1298 | ELSE 1299 | MOVE PROGRAM-IP TO IP-TEMP 1300 | MOVE NEXT-IP OF PROGRAM-RECORD TO PROGRAM-IP 1301 | READ PROGRAM-CODE RECORD 1302 | MOVE RAW-INSTRUCTION TO R(8) 1303 | MOVE 8 TO INPUT-SOURCE 1304 | MOVE IP-TEMP TO PROGRAM-IP 1305 | READ PROGRAM-CODE RECORD. 1306 | IF NOT DONE THEN 1307 | MOVE OUT-REG TO OUTPUT-DEST 1308 | MOVE INSTRUCTION-CODE TO R(1) 1309 | IF INTERPRETER OF PROGRAM-RECORD IS EQUAL TO "WOPO" THEN 1310 | PERFORM HANDLE-COMMAND 1311 | MOVE 0 TO STATE 1312 | ELSE 1313 | STRING "INVALID INTERPRETER " DELIMITED BY SIZE, 1314 | INTERPRETER DELIMITED BY SPACE, 1315 | " IN INSTRUCTION ", 1316 | PROGRAM-IP, 1317 | " IN PROGRAM " DELIMITED BY SIZE, 1318 | NAME OF INDEX-ENTRY DELIMITED BY SPACE, 1319 | ".$NUL$" 1320 | INTO R(1) 1321 | MOVE 1 TO SRC 1322 | PERFORM BEGIN-STANDARD-REPLY 1323 | PERFORM DO-OUTPUT 1324 | MOVE 99 TO STATE. 1325 | IF NEXT-IP OF PROGRAM-RECORD IS NOT LESS THAN 999 THEN 1326 | MOVE 99 TO STATE 1327 | ELSE 1328 | MOVE NEXT-IP OF PROGRAM-RECORD TO PROGRAM-IP. 1329 | 1330 | INTERPRET-PROGRAM. 1331 | OPEN INPUT PROGRAM-INDEX. 1332 | MOVE R(1) TO NAME OF INDEX-ENTRY. 1333 | MOVE 0 TO STATE. 1334 | READ PROGRAM-INDEX RECORD 1335 | INVALID KEY MOVE 99 TO STATE. 1336 | IF DONE THEN 1337 | STRING "NO SUCH PROGRAM " DELIMITED BY SIZE 1338 | NAME OF INDEX-ENTRY DELIMITED BY SPACE, 1339 | ".$NUL$" 1340 | INTO R(1) 1341 | MOVE 1 TO SRC 1342 | PERFORM BEGIN-STANDARD-REPLY 1343 | PERFORM DO-OUTPUT 1344 | ELSE 1345 | OPEN INPUT PROGRAM-CODE 1346 | MOVE ADDR OF INDEX-ENTRY TO PROGRAM-IP 1347 | PERFORM DO-NEXT-INSTRUCTION UNTIL DONE 1348 | CLOSE PROGRAM-CODE. 1349 | CLOSE PROGRAM-INDEX. 1350 | 1351 | HANDLE-RUN. 1352 | MOVE 1 TO DEST. 1353 | PERFORM INDEX-PARAMS. 1354 | IF NUM-PARAMS OF WOPO IS LESS THAN 1 THEN 1355 | MOVE "" TO R(1) 1356 | MOVE 1 TO SRC 1357 | PERFORM USAGE-REPLY 1358 | ELSE 1359 | MOVE 1 TO PTR(SRC) 1360 | PERFORM GET-PARAM 1361 | IF NUM-PARAMS OF WOPO IS GREATER THAN 1 THEN 1362 | MOVE 2 TO PTR(SRC), DEST 1363 | PERFORM GET-REST 1364 | MOVE R(2) TO R(8). 1365 | PERFORM INTERPRET-PROGRAM. 1366 | 1367 | HANDLE-HELP. 1368 | MOVE 1 TO DEST. 1369 | PERFORM INDEX-PARAMS. 1370 | IF NUM-PARAMS OF WOPO IS GREATER THAN 0 THEN 1371 | MOVE 1 TO PTR(SRC) 1372 | PERFORM GET-PARAM 1373 | ELSE 1374 | MOVE SPACES TO R(1). 1375 | IF R(1) IS EQUAL TO "ME" THEN 1376 | STRING "$240$$159$$142$$135$ ", 1377 | "GOD HELPS THOSE WHO HELP THEMSELVES, COMMIE. ", 1378 | "$240$$159$$142$$134$$NUL$" 1379 | INTO R(1) 1380 | ELSE 1381 | STRING "COMMANDS BEGIN WITH $$. PARAMETERS ARE ", 1382 | "SEPARATED WITH $$ ALSO. EXAMPLES$COLN$ ", 1383 | """$$HELP"", ""$$HELP$$ME"". ", 1384 | "A SPECIFIC INSTANCE OF THE BOT CAN BE ADDRESSED ", 1385 | "IN THE DE FACTO STANDARD WAY ", 1386 | "(""WOPO$COLN$ HELP"") OR BY EXTENSION OF ", 1387 | "WOPO$SGQT$S SYNTAX (""WOPO$$HELP""). ", 1388 | "FOR A LIST OF BUILT-IN COMMANDS, SEE $$COMMANDS", 1389 | "$NUL$" 1390 | INTO R(1). 1391 | MOVE 1 TO SRC. 1392 | PERFORM BEGIN-STANDARD-REPLY. 1393 | PERFORM DO-OUTPUT. 1394 | 1395 | HANDLE-CTCP. 1396 | D DISPLAY "HANDLING CTCP.". 1397 | IF NOTICE AND 1398 | TARGET OF IRC-STATE IS NOT EQUAL TO NICK OF WOPO THEN 1399 | NEXT SENTENCE 1400 | ELSE 1401 | MOVE CTCP-BODY(2) TO R(1) 1402 | MOVE 1 TO SRC 1403 | PERFORM INDEX-PARAMS 1404 | MOVE 1 TO PTR(1) 1405 | PERFORM GET-PARAM 1406 | D DISPLAY "CTCP PARAM. ", R(2) 1407 | IF R(2) IS EQUAL TO "PING" THEN 1408 | PERFORM HANDLE-PING 1409 | ELSE IF R(2) IS EQUAL TO "VERSION" THEN 1410 | PERFORM HANDLE-VERSION 1411 | * ELSE IF R(2) IS EQUAL TO "TIME" THEN 1412 | * PERFORM HANDLE-TIME 1413 | ELSE NEXT SENTENCE. 1414 | 1415 | HANDLE-PING. 1416 | STRING "NOTICE " DELIMITED BY SIZE, 1417 | NICK OF IRC-STATE DELIMITED BY SPACES, 1418 | " $COLN$$SOH$" DELIMITED BY SIZE, 1419 | R(1) DELIMITED BY "$SOH$", 1420 | "$SOH$$NUL$" DELIMITED BY SIZE 1421 | INTO MSG-BODY OF OUTPUT-BUFFER. 1422 | D DISPLAY MSG-BODY OF OUTPUT-BUFFER. 1423 | PERFORM SEND-LINE. 1424 | 1425 | HANDLE-VERSION. 1426 | D DISPLAY "HANDLING VERSION." 1427 | STRING "NOTICE " DELIMITED BY SIZE, 1428 | NICK OF IRC-STATE DELIMITED BY SPACES, 1429 | " $COLN$$SOH$VERSION WOPO THE COBOL-74 BOT. " 1430 | "VERSION WHATEVER. RUNNING ON " DELIMITED BY SIZE 1431 | PLATFORM DELIMITED BY SPACES 1432 | ".$SOH$$NUL$" DELIMITED BY SIZE 1433 | INTO MSG-BODY OF OUTPUT-BUFFER. 1434 | PERFORM SEND-LINE. 1435 | 1436 | *HANDLE-TIME. 1437 | * MOVE TIME TO FORMATTED-TIME. 1438 | * STRING "NOTICE " DELIMITED BY SIZE, 1439 | * NICK DELIMITED BY SPACES, 1440 | * " $COLN$$SOH$TIME" DELIMITED BY SIZE, 1441 | * FORMATTED-TIME DELIMITED BY SIZE, 1442 | * "$SOH$" 1443 | * INTO MSG-BODY OF OUTPUT-BUFFER. 1444 | * PERFORM SEND-LINE. 1445 | 1446 | QUIT. 1447 | CALL "CHANNEL-CLOSE". 1448 | CLOSE CONFIG. 1449 | CLOSE USERS. 1450 | STOP RUN. 1451 | --------------------------------------------------------------------------------