001000$CONTROL USLINIT 001100 IDENTIFICATION DIVISION. 001200 PROGRAM-ID. COBCMC. 001300 AUTHOR. TOM KIRBY, 3k Associates, Inc. 001400 ENVIRONMENT DIVISION. 001500 CONFIGURATION SECTION. 001600 SOURCE-COMPUTER. HP-3000. 001700 OBJECT-COMPUTER. HP-3000. 001800 DATA DIVISION. 001900 WORKING-STORAGE SECTION. 002000 002100* FIELDS USED BY CMC CALLS 002200 002300* CMC return code 002400 01 RC PIC 9(9) COMP VALUE 0. 002500 002600* CMC session id 002700 01 SID PIC 9(9) COMP VALUE 0. 002800 01 TEMP-ID PIC 9(9) COMP VALUE 0. 002900 003000* CMC flags parameter 003100 01 FLGS PIC 9(9) COMP VALUE 0. 003200 003300* CMC user interface ID (not used by us) 003400 01 UI-ID PIC 9(9) COMP VALUE 0. 003500 003600* NETMAIL user 003700 01 USER PIC X(17) VALUE SPACES. 003800 003900* NETMAIL user password 004000 01 PASS PIC X(9) VALUE SPACES. 004100 004200* CMC version (must match RL) 004300 01 VERS PIC 9(4) COMP VALUE 0. 004400 004500* CMC recipient structure 004600 01 RECADDR PIC 9(9) COMP VALUE 0. 004700 01 RECPT. 004800 02 RNAME PIC S9(9) BINARY. 004900 02 NAME-TYPE PIC S9(9) COMP. 005000 02 RADDRESS PIC S9(9) BINARY. 005100 02 ROLE PIC S9(9) COMP. 005200 02 RECIP-FLAGS PIC 9(9) COMP. 005300 02 RECIP-EXTENSIONS PIC S9(9) BINARY. 005400 005500* Another recipient structure for the second message in the 005600* message structure... 005700 01 RECPT-2. 005800 02 R2NAME PIC S9(9) BINARY. 005900 02 R2NAME-TYPE PIC S9(9) COMP. 006000 02 R2ADDRESS PIC S9(9) BINARY. 006100 02 R2ROLE PIC S9(9) COMP. 006200 02 R2RECIP-FLAGS PIC 9(9) COMP. 006300 02 R2RECIP-EXTENSIONS PIC S9(9) BINARY. 006400 006500* CMC extensions structure (not used) 006600 01 EXTENSIONS PIC S9(9) BINARY VALUE 0. 006700 006800* CMC object identifier (character set), also not used 006900 01 CHARSET PIC S9(9) BINARY VALUE 0. 007000 007100* CMC service (not used) 007200 01 SERVICE PIC S9(9) BINARY VALUE 0. 007300 007400* VARIABLES TO TAKE THE PLACE OF CMC DEFINES 007500 007600 01 CMC-RECIP-LAST-ELEMENT PIC 9(9) COMP. 007700 01 CMC-TYPE-INDIVIDUAL PIC 9(9) COMP VALUE 1. 007800 01 CMC-TYPE-GROUP PIC 9(9) COMP VALUE 2. 007900 01 CMC-LU-R-PREFIX-SEARCH PIC 9(9) COMP VALUE 1. 008000 01 CMC-LU-R-IDENTITY PIC 9(9) COMP VALUE 2. 008100 01 CMC-ATT-OID-BINARY. 008200 02 FILLER PIC X(18) VALUE "1 2 840 113658 1 1". 008300 02 FILLER PIC X VALUE %0. 008400 01 CMC-ATT-OID-TEXT. 008500 02 FILLER PIC X(20) VALUE "1 2 840 113658 1 1 0". 008600 02 FILLER PIC X VALUE %0. 008700 01 CMC-FALSE PIC 9(4) COMP VALUE 0. 008800 01 CMC-TRUE PIC 9(4) COMP VALUE 1. 008900 009000* WORK AREAS 009100 009200 01 II PIC S9(4) COMP VALUE 0. 009300 01 NULL-TERMINATOR PIC X VALUE LOW-VALUE. 009400 01 CARR-RET PIC X VALUE %15. 009500 01 NEWLINE PIC X VALUE %12. 009600 01 PTR1 PIC S9(9) BINARY VALUE 0. 009700 01 PTR2 PIC S9(9) BINARY VALUE 0. 009800 01 M-SUB PIC X(80) VALUE SPACES. 009900 01 A-FILE PIC X(80) VALUE SPACES. 010000 01 B-FILE PIC X(80) VALUE SPACES. 010100 01 NAME-WORK PIC X(30) VALUE SPACES. 010200 01 NAME-AND-ADDRESS. 010300 02 U-NAME OCCURS 3 TIMES PIC X(30). 010400 02 U-ADDR OCCURS 3 TIMES PIC X(80). 010500 01 U2-NAME PIC X(30). 010600 01 U2-ADDR PIC X(80). 010700 01 N-TEXT PIC X(256) VALUE SPACES. 010800 01 BIG-NUM PIC 9(16) COMP VALUE 0. 010900 01 LIL-NUMS REDEFINES BIG-NUM. 011000 02 FILLER PIC 9(9) COMP. 011100 02 LIL-NUM PIC 9(9) COMP. 011200 01 CELL-CONTENTS PIC X(80) VALUE SPACES. 011300 01 REC-COUNT PIC 9(9) COMP VALUE 0. 011400 011500 PROCEDURE DIVISION. 011600 XXXX-MAIN. 011700 MOVE LOW-VALUES TO RECPT, RECPT-2. 011800 MOVE 2147483648 TO BIG-NUM. 011900 MOVE LIL-NUM TO CMC-RECIP-LAST-ELEMENT. 012000 012100 PERFORM 0000-CMCLOGON THRU 0999-EXIT. 012200 DISPLAY "NAME?" WITH NO ADVANCING. 012300 MOVE SPACES TO NAME-WORK. 012400 012500* WARNING: COMPARISONS ARE CASE-SENSITIVE 012600 012700 ACCEPT NAME-WORK. 012710 012720* The last byte is now guaranteed to be a blank. This is needed 012730* because I am stringing it DELIMITED BY SPACE with a NULL. 012800 MOVE SPACES TO NAME-WORK (30:1). 012900 PERFORM 1000-CMCLOOKUP THRU 1999-EXIT. 013000 PERFORM 3000-CMCLOGOFF THRU 3999-EXIT. 013100 013200 STOP RUN. 013300 013400 0000-CMCLOGON. 013500* CMCLOGON 013600 013700* UI-ID is not used anyway, set to 0 * 013800 MOVE 0 to UI-ID. 013900 014000* USER must be 16 or less characters, terminated with a \0 * 014100 STRING "MY_USER" NULL-TERMINATOR DELIMITED BY SIZE 014200 INTO USER. 014300* NOTE: If you wish to pass a NULL, you must move 0 to PTR1, 014400* because a string of spaces doth not a true NULL make. 014500* Otherwise, you can skip the PTR1 step and just pass 014600* the variable USER to the CMC routine. 014700* 014800* If you use PTR1, be sure to pass it as \PTR1\, because 014900* its value of 0 is what you really want to pass... 015000* MOVE 0 TO PTR1. 015100 015200* PASS must be 8 characters, terminated with a \0 * 015300 STRING "PaSsWoRd" NULL-TERMINATOR DELIMITED BY SIZE 015400 INTO PASS. 015500* NOTE: If you wish to pass a NULL, you must move 0 to PTR2, 015600* because a string of spaces doth not a true NULL make. 015700* Otherwise, you can skip the PTR2 step and just pass 015800* the variable PASS to the CMC routine. 015900* 016000* If you use PTR2, be sure to pass it as \PTR2\, because 016100* its value of 0 is what you really want to pass... 016200* MOVE 0 TO PTR2. 016300 016400* SERVICE, CHARACTER SET, AND EXTENSIONS ARE NOT USED, PASS NULLS. * 016500 016600* Programmed to specification 1.00 * 016700 MOVE 100 TO VERS. 016800 016900* Pass a 0 in FLGS because we don't support LOGON_UI, ERROR_UI, * 017000* or COUNTED_STRING_TYPE. * 017100 MOVE 0 TO FLGS. 017200 017300* SID is the session ID that must be used in all the other calls. * 017400 CALL "CMC_LOGON" USING \SERVICE\, USER, PASS, 017500 \CHARSET\, \UI-ID\, \VERS\, 017600 \FLGS\, SID, \EXTENSIONS\ 017700 GIVING RC. 017800 017900* I am just printing the return, you will probably want to stop * 018000* if you don't get a 0 return... * 018100 DISPLAY "LOGON = " RC. 018200 018300 0999-EXIT. 018400 EXIT. 018500 018600 1000-CMCLOOKUP. 018700 MOVE 0 TO FLGS. 018800 MOVE 0 TO PTR1. 018810 018820* First, use CMC_LOOK_UP to find out who *I* am... 018821* Rather than find out how to use long symbol names in COBOL, 018822* I just shortened the variable names. In reality, CMC-LU-R- 018823* equates to CMC_LOOKUP_RESOLVE_. 018830 018900 ADD CMC-LU-R-IDENTITY TO FLGS. 019000 MOVE 0 TO REC-COUNT. 019001 019010* Passing \PTR1\ in order to pass a NULL pointer. 019100 CALL "CMC_LOOK_UP" USING \SID\, \PTR1\, \FLGS\, \UI-ID\, 019200 REC-COUNT, RECADDR, \EXTENSIONS\ 019300 GIVING RC. 019400 DISPLAY "LOOKUP = " RC. 019500 019600 DISPLAY "I AM:". 019601 019602* Read the first 24 bytes pointed to by RECADDR into RECPT. 019610 CALL "CMC_COBOL_CELL_READ" USING \RECADDR\, RECPT, 24, 1. 019620 019630* RNAME, part of the RECPT record, is a pointer to a name. 019700 CALL "CMC_COBOL_CELL_READ" USING \RNAME\, CELL-CONTENTS, 019800 80, 0. 019900 DISPLAY CELL-CONTENTS. 019910* RADDRESS is also a pointer, to an address. 020000 CALL "CMC_COBOL_CELL_READ" USING \RADDRESS\, 020100 CELL-CONTENTS, 80, 0. 020200 DISPLAY CELL-CONTENTS. 020300 020400 MOVE 0 TO FLGS. 020500 ADD CMC-LU-R-PREFIX-SEARCH TO FLGS. 020600 STRING NAME-WORK NULL-TERMINATOR DELIMITED BY SPACE INTO 020700 CELL-CONTENTS. 020710 020720* RECPT-2 must contain pointers, so I must load the pointer to 020730* CELL-CONTENTS into R2NAME. 020800 MOVE 0 TO R2ADDRESS. 020810 020820* REC-COUNT = 0 means "return as many as you find, no limit..." 020900 MOVE 0 TO REC-COUNT. 021000 CALL INTRINSIC ".LOC." USING CELL-CONTENTS 021100 GIVING R2NAME. 021200 CALL "CMC_LOOK_UP" USING \SID\, RECPT-2, \FLGS\, \UI-ID\, 021300 REC-COUNT, RECADDR, \EXTENSIONS\ 021400 GIVING RC. 021500 DISPLAY "LOOKUP = " RC. 021600 021700 PERFORM 2000-READ-EM THRU 2999-EXIT 021800 VARYING II FROM 1 BY 1 UNTIL II > REC-COUNT. 021900 022000 1999-EXIT. 022100 EXIT. 022200 022300 2000-READ-EM. 022400 DISPLAY "---". 022410 022420* RECADDR points to a CMC_RECIPIENT entry, go get it. 022500 CALL "CMC_COBOL_CELL_READ" USING \RECADDR\, RECPT, 24, 1. 022600 022700 CALL "CMC_COBOL_CELL_READ" USING \RNAME\, CELL-CONTENTS, 022800 80, 0. 022900 DISPLAY CELL-CONTENTS. 023000 CALL "CMC_COBOL_CELL_READ" USING \RADDRESS\, 023100 CELL-CONTENTS, 80, 0. 023200 DISPLAY CELL-CONTENTS. 023300 IF NAME-TYPE = CMC-TYPE-INDIVIDUAL 023400 DISPLAY "INDIVIDUAL" 023500 ELSE 023510 IF NAME-TYPE = CMC-TYPE-GROUP 023520 DISPLAY "MAILING LIST" 023530 ELSE 023540 DISPLAY "???". 023600 023610* Bump the RECADDR pointer to the next entry... 023700 MOVE RECADDR TO LIL-NUM. 023800 ADD 24 TO BIG-NUM. 023900 MOVE LIL-NUM TO RECADDR. 024000 024100 2999-EXIT. 024200 EXIT. 024300 024400 3000-CMCLOGOFF. 024500* CMCLOGOFF * 024600* Set FLGS to 0 because we don't support any UIs... * 024700 MOVE 0 TO FLGS. 024800 024900 CALL "CMC_LOGOFF" USING \SID\, \UI-ID\, \FLGS\, 025000 \EXTENSIONS\ 025100 GIVING RC. 025200 025300* I am just printing the return, you will probably want to stop * 025400* if you don't get a 0 return... * 025500 DISPLAY "LOGOFF = " RC. 025600 025700 3999-EXIT. 025800 EXIT.