Category : OS/2 Files
Archive   : OS2CMAPI.ZIP
Filename : HSMPLCBL.CBL

 
Output of file : HSMPLCBL.CBL contained in archive : OS2CMAPI.ZIP
****************************************************************
* *
* *
* FILE NAME: HSMPLCBL.CBL *
* *
* MODULE NAME= HSMPLCBL.CBL *
* *
* DESCRIPTIVE NAME= COBOL SAMPLE PROGRAM FOR EHLLAPI *
* *
* Displays EHLLAPI and session information. *
* Writes string to host. *
* Searches for written string on host. *
* Displays host session screen. *
* *
* *
* COPYRIGHT: XXXXXXXXX (C) COPYRIGHT IBM CORP. 1987,1988 *
* LICENSED MATERIAL - PROGRAM PROPERTY OF IBM *
* ALL RIGHTS RESERVED *
* *
* NOTES= *
* *
**********************-END OF SPECIFICATIONS-*******************
IDENTIFICATION DIVISION.
PROGRAM-ID. EHLLAPI-SAMPLE-PROGRAM.
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.

****************************************************************
************************ CONSTANTS *****************************
****************************************************************

78 MAX-DATA-SIZE VALUE 3840.
* 000 The maximum data
* size for this
* application.

78 EABS VALUE 128.
* 000 Extended attribute
* bit.

78 PSS VALUE 64.
* 000 Programmed Symbol
* Set bit.

77 ZRO PIC 9(4) COMP-5 VALUE 0.

77 MDS PIC 9(4) COMP-5 VALUE 3840.


77 DUMMY PIC X(1).

77 PRESS-ENT-MSG PIC X(26) VALUE
"Press ENTER to continue...".

77 DFT-SESS PIC X VALUE SPACE.

77 HOST-TEXT PIC X(12) VALUE
"3270 EHLLAPI".

77 HOME-KEY PIC X(2) VALUE
"@0".

77 SETPARM-TEXT PIC X(17) VALUE
"NOATTRB EAB XLATE".

77 DISP-NUM PIC ZZZZ9.

77 LOOP-COUNT PIC 99 COMP-0.

77 NUM-SESS PIC 99 COMP-0.

77 BIN-NUM PIC 99 COMP-0.

77 BIN-NUM2 PIC 99 COMP-0.

77 TEST-NUM PIC 99999.

01 HEX-TABLE.
05 FILLER PIC X(16) VALUE "0123456789ABCDEF".



01 HEX-DIGITS REDEFINES HEX-TABLE.
05 HEX-DIG PIC X OCCURS 16 TIMES INDEXED BY INDX.

77 HEX-OUTPUT PIC X(2).

01 HEX-OUTR REDEFINES HEX-OUTPUT.
05 HEX-OUT PIC X OCCURS 2 TIMES INDEXED BY IND.

77 BLANK-LINE PIC X VALUE SPACE.


****** EHLLAPI variables. ********
77 HFUNC-NUM PIC 99 COMP-0.
* 000 EHLLAPI function
* number.
01 HDATA-STRING.
05 HDATA-STR PIC X(1) OCCURS 3840 TIMES.
* 000 EHLLAPI datation
* string.
77 HDS-LEN PIC 99 COMP-0.
* 000 EHLLAPI data on
* string length.
77 HRC PIC 99 COMP-0 VALUE ZERO.
* 000 EHLLAPI return n
* code.



****************************************************************
***************** BEGIN INCLUDE FILES **************************
****************************************************************

COPY "HAPI_CBL.INC".



SCREEN SECTION.
01 BLANK-SCR.
05 BLANK SCREEN.



PROCEDURE DIVISION.
*********************************************************************
* MAIN - Main code calls routines to do real work. *
* *
* INPUT *
* *
* OUTPUT *
* *
* *
*********************************************************************
MAIN.

DISPLAY BLANK-SCR.

PERFORM DISP-EHLLAPI-INFO.

IF HRC = ZERO THEN

DISPLAY PRESS-ENT-MSG WITH NO ADVANCING
ACCEPT DUMMY
PERFORM DISP-SESSION-INFO.


IF HRC = ZERO THEN
PERFORM M-NEXT.

STOP RUN.

M-NEXT.

IF DFT-SESS NOT = SPACE THEN


DISPLAY BLANK-LINE
DISPLAY BLANK-LINE
DISPLAY 'Press ENTER to send string "' HOST-TEXT
WITH NO ADVANCING
DISPLAY '" to session short name ' DFT-SESS
WITH NO ADVANCING
DISPLAY '...'
WITH NO ADVANCING
ACCEPT DUMMY
PERFORM WRITE-STR-2-HOST


ELSE

DISPLAY 'NO DFT SESSION SESSION STARTED.'
MOVE 1 TO HRC.


IF HRC = ZERO THEN

DISPLAY BLANK-LINE
DISPLAY BLANK-LINE
DISPLAY 'Press ENTER to search for string "' HOST-TEXT
WITH NO ADVANCING
DISPLAY '" on Host Presentation Space...'
WITH NO ADVANCING
ACCEPT DUMMY
PERFORM SEARCH-STR-ON-HOST.


IF HRC = ZERO THEN

DISPLAY BLANK-LINE
DISPLAY BLANK-LINE
DISPLAY 'Press ENTER to display first 1920 '
WITH NO ADVANCING
DISPLAY 'bytes of Host presentation space...'
WITH NO ADVANCING
ACCEPT DUMMY
PERFORM DISP-HOST-SCR.

IF HRC = ZERO THEN

DISPLAY 'SAMPLE PROGRAM DONE. To Exit Program '
WITH NO ADVANCING
DISPLAY 'Press ENTER...'
WITH NO ADVANCING
ACCEPT DUMMY.


*********************************************************************
* DISP-EHLLAPI-INFO - CALLs EHLLAPI QUERY-SYSTEM and then displays *
* the requested info. *
* *
* INPUT *
* *
* OUTPUT *
* *
*********************************************************************
DISP-EHLLAPI-INFO.


MOVE HA-QUERY-SYSTEM TO HFUNC-NUM.

CALL 'COBLIM' USING HFUNC-NUM, QSYS-STRUCT, HDS-LEN, HRC.

IF HRC = HARC-SUCCESS
PERFORM DEI-DISP
ELSE
PERFORM ERROR-HAND.


DEI-DISP.
DISPLAY ' EHLLAPI INFORMATION'.

DISPLAY BLANK-LINE.

DISPLAY ' EHLLAPI version : '
QSYS-HLLAPI-VER.

DISPLAY ' EHLLAPI level : '
QSYS-HLLAPI-LVL.

DISPLAY ' EHLLAPI release date : '
QSYS-HLLAPI-DATE.

DISPLAY ' EHLLAPI LIM version : '
QSYS-LIM-VER.

DISPLAY ' EHLLAPI LIM level : '
QSYS-LIM-LVL.

DISPLAY ' EHLLAPI hardware base : '
QSYS-HARDWARE-BASE ' = '
WITH NO ADVANCING.
IF QSYS-HARDWARE-BASE = 'A'
DISPLAY 'AT' WITH NO ADVANCING.
IF QSYS-HARDWARE-BASE = 'X'
DISPLAY 'XT' WITH NO ADVANCING.
IF QSYS-HARDWARE-BASE = 'S'
DISPLAY 'S/2' WITH NO ADVANCING.
IF QSYS-HARDWARE-BASE = 'Z'
DISPLAY '(See System model/submodel below)'
WITH NO ADVANCING.
DISPLAY BLANK-LINE.

DISPLAY ' EHLLAPI CTRL program type : '
QSYS-CTRL-PROG-TYPE ' = '
WITH NO ADVANCING.
IF QSYS-CTRL-PROG-TYPE = 'X'
DISPLAY 'OS/2' WITH NO ADVANCING.
IF QSYS-CTRL-PROG-TYPE = 'C'
DISPLAY '3270 PC' WITH NO ADVANCING.
IF QSYS-CTRL-PROG-TYPE = 'W'
DISPLAY 'WSP' WITH NO ADVANCING.
DISPLAY BLANK-LINE.

DISPLAY ' EHLLAPI sequence number : '
QSYS-SEQ-NUM.

DISPLAY ' EHLLAPI CTRL program version : '
QSYS-CTRL-PROG-VER.

DISPLAY ' EHLLAPI PC session name : '
QSYS-PC-SNAME.

DISPLAY ' EHLLAPI extended error 1 : '
QSYS-ERR1.

DISPLAY ' EHLLAPI extended error 2 : '
QSYS-ERR2.

DISPLAY ' EHLLAPI system model/submodel: '
WITH NO ADVANCING.
MOVE QSYS-SYS-MODEL TO BIN-NUM.
PERFORM ITOH.
DISPLAY HEX-OUT(1) WITH NO ADVANCING.
DISPLAY HEX-OUT(2) WITH NO ADVANCING.
MOVE QSYS-SYS-SUBMODEL TO BIN-NUM.
PERFORM ITOH.
DISPLAY HEX-OUT(1) WITH NO ADVANCING.
DISPLAY HEX-OUT(2) WITH NO ADVANCING.
DISPLAY ' HEX = ' WITH NO ADVANCING.
IF QSYS-SYS-MODEL = H'FC' AND QSYS-SYS-SUBMODEL = H'00'
DISPLAY 'Model PC AT' WITH NO ADVANCING.
IF QSYS-SYS-MODEL = H'FC' AND QSYS-SYS-SUBMODEL = H'01'
DISPLAY 'Model PC AT ENHANCED' WITH NO ADVANCING.
IF QSYS-SYS-MODEL = H'FC' AND QSYS-SYS-SUBMODEL = H'02'
DISPLAY 'Model PC XT Model 286' WITH NO ADVANCING.
IF QSYS-SYS-MODEL = H'FA' AND QSYS-SYS-SUBMODEL = H'01'
DISPLAY 'Model 25' WITH NO ADVANCING.
IF QSYS-SYS-MODEL = H'FA' AND QSYS-SYS-SUBMODEL = H'00'
DISPLAY 'Model 30' WITH NO ADVANCING.
IF QSYS-SYS-MODEL = H'FC' AND QSYS-SYS-SUBMODEL = H'04'
DISPLAY 'Model 50' WITH NO ADVANCING.
IF QSYS-SYS-MODEL = H'FC' AND QSYS-SYS-SUBMODEL = H'05'
DISPLAY 'Model 60' WITH NO ADVANCING.
IF QSYS-SYS-MODEL = H'F8' AND QSYS-SYS-SUBMODEL = H'00'
DISPLAY 'Model 80' WITH NO ADVANCING.
DISPLAY BLANK-LINE.


MOVE QSYS-PC-NLS TO DISP-NUM.
DISPLAY ' EHLLAPI National Language : '
DISP-NUM.


DISPLAY ' EHLLAPI monitor type : '
QSYS-MONITOR-TYPE ' = '
WITH NO ADVANCING.
IF QSYS-MONITOR-TYPE = 'M'
DISPLAY 'PC MONOCHROME' WITH NO ADVANCING.
IF QSYS-MONITOR-TYPE = 'C'
DISPLAY 'PC CGA' WITH NO ADVANCING.
IF QSYS-MONITOR-TYPE = 'E'
DISPLAY 'PC EGA' WITH NO ADVANCING.
IF QSYS-MONITOR-TYPE = 'A'
DISPLAY 'PS MONOCHROME' WITH NO ADVANCING.
IF QSYS-MONITOR-TYPE = 'V'
DISPLAY 'PS 8512' WITH NO ADVANCING.
IF QSYS-MONITOR-TYPE = 'H'
DISPLAY 'PS 8514' WITH NO ADVANCING.
IF QSYS-MONITOR-TYPE = 'U'
DISPLAY 'UNKNOWN monitor type' WITH NO ADVANCING.
DISPLAY BLANK-LINE.





*********************************************************************
* DISP-SESSION-INFO - CALLs EHLLAPI QUERY funtions and then displays*
* the requested session info. *
* *
* INPUT *
* *
* OUTPUT *
* *
*********************************************************************
DISP-SESSION-INFO.


DISPLAY BLANK-LINE.
DISPLAY BLANK-LINE.
DISPLAY BLANK-LINE.
DISPLAY BLANK-LINE.
DISPLAY BLANK-LINE.
DISPLAY BLANK-LINE.
DISPLAY BLANK-LINE.
DISPLAY BLANK-LINE.
DISPLAY BLANK-LINE.
DISPLAY BLANK-LINE.
DISPLAY BLANK-LINE.
DISPLAY BLANK-LINE.
DISPLAY ' SESSION INFO'.
DISPLAY BLANK-LINE.

MOVE HA-QUERY-SESSIONS TO HFUNC-NUM.

COMPUTE HDS-LEN = 12 * HAMMAX-SESSIONS.

CALL 'COBLIM' USING HFUNC-NUM, QSES-STRUCT(1), HDS-LEN,HRC.

IF HRC = HARC-SUCCESS
PERFORM DSI-SUCCESS
ELSE
PERFORM ERROR-HAND.

DSI-SUCCESS.

MOVE HDS-LEN TO NUM-SESS.

MOVE NUM-SESS TO DISP-NUM.
DISPLAY 'Number of started sessions = ' DISP-NUM.
DISPLAY BLANK-LINE.
DISPLAY BLANK-LINE.

SET HAIX TO 1.
MOVE 1 TO LOOP-COUNT.

PERFORM DSI-LOOP UNTIL HRC NOT = 0 OR HAIX > NUM-SESS.

DSI-LOOP.


MOVE LOOP-COUNT TO DISP-NUM.
DISPLAY 'Session number : ' DISP-NUM.

DISPLAY 'Session Long name : ' QSES-LONGNAME(HAIX).

DISPLAY 'Session Short name : '
QSES-SHORTNAME(HAIX).

DISPLAY 'Session Type : '
QSES-SESTYPE(HAIX) ' = ' WITH NO ADVANCING.
IF QSES-SESTYPE(HAIX) = 'H'
PERFORM DSI-SET-HOST
DISPLAY 'Host' WITH NO ADVANCING.
IF QSES-SESTYPE(HAIX) = 'P'
DISPLAY 'PC' WITH NO ADVANCING.
DISPLAY BLANK-LINE.

MOVE QSES-PSSIZE(HAIX) TO DISP-NUM.
DISPLAY 'Session PS size : ' DISP-NUM.


MOVE HA-QUERY-SESSION-STATUS TO HFUNC-NUM.

MOVE 18 TO HDS-LEN.

MOVE QSES-SHORTNAME(HAIX) TO QSST-SHORTNAME.

CALL 'COBLIM' USING HFUNC-NUM, QSST-STRUCT, HDS-LEN, HRC.

IF HRC = HARC-SUCCESS
PERFORM DSI-SUCCESS2
ELSE
PERFORM ERROR-HAND.

DSI-SUCCESS2.

MOVE QSST-PS-ROWS TO DISP-NUM.
DISPLAY 'Session PS rows : ' DISP-NUM.

MOVE QSST-PS-COLS TO DISP-NUM.
DISPLAY 'Session PS columns : ' DISP-NUM.

DISPLAY 'Session type 2 : ' QSST-SESTYPE ' = '
WITH NO ADVANCING.
IF QSST-SESTYPE = 'D'
DISPLAY 'DFT Host' WITH NO ADVANCING.
IF QSST-SESTYPE = 'P'

DISPLAY 'PC' WITH NO ADVANCING.
DISPLAY BLANK-LINE.

DISPLAY 'Session supports Extended attributes (EABs)? : '
WITH NO ADVANCING.

IF QSST-CHAR >= X'80'
DISPLAY 'YES' WITH NO ADVANCING
ELSE
DISPLAY 'NO' WITH NO ADVANCING.
DISPLAY BLANK-LINE.

DISPLAY 'Session supports Program Symbols (PSS)? : '
WITH NO ADVANCING.
IF QSST-CHAR >= X'C0'
OR (QSST-CHAR < X'80' AND QSST-CHAR >= X'40')
DISPLAY 'YES' WITH NO ADVANCING
ELSE
DISPLAY 'NO' WITH NO ADVANCING.
DISPLAY BLANK-LINE.

DISPLAY PRESS-ENT-MSG WITH NO ADVANCING.
ACCEPT DUMMY.



SET HAIX UP BY 1.
ADD 1 TO LOOP-COUNT.


DSI-SET-HOST.

IF DFT-SESS = SPACE
MOVE QSES-SHORTNAME(HAIX) TO DFT-SESS.



*********************************************************************
* WRITE-STR-2-HOST - Connects to first session and writes home-key *
* and string to host. *
* *
* INPUT *
* *
* OUTPUT *
* *
*********************************************************************
WRITE-STR-2-HOST.


MOVE HA-CONNECT-PS TO HFUNC-NUM.

MOVE DFT-SESS TO HDATA-STR(1).

CALL 'COBLIM' USING HFUNC-NUM, HDATA-STRING, HDS-LEN, HRC.

IF HRC = HARC-SUCCESS
PERFORM WS2H-SUCCESS
ELSE
PERFORM ERROR-HAND.

WS2H-SUCCESS.

MOVE HA-SENDKEY TO HFUNC-NUM.

MOVE 2 TO HDS-LEN.

CALL 'COBLIM' USING HFUNC-NUM, HOME-KEY, HDS-LEN, HRC.

IF HRC = HARC-SUCCESS
PERFORM WS2H-SUCCESS2
ELSE
PERFORM ERROR-HAND.

WS2H-SUCCESS2.


MOVE 12 TO HDS-LEN.

CALL 'COBLIM' USING HFUNC-NUM, HOST-TEXT, HDS-LEN, HRC.

IF HRC = HARC-SUCCESS
DISPLAY 'Sent String to Host.'
DISPLAY BLANK-LINE
DISPLAY BLANK-LINE

ELSE
PERFORM ERROR-HAND.



*********************************************************************
* SEARCH-STR-ON-HOST- Searches for string on host. *
* *
* INPUT *
* *
* OUTPUT *
* *
*********************************************************************
SEARCH-STR-ON-HOST.


MOVE HA-SEARCH-PS TO HFUNC-NUM.

MOVE 12 TO HDS-LEN.

CALL 'COBLIM' USING HFUNC-NUM, HOST-TEXT, HDS-LEN, HRC.

IF HRC = HARC-SUCCESS
DISPLAY 'Found string "' HOST-TEXT
WITH NO ADVANCING
MOVE HDS-LEN TO DISP-NUM
DISPLAY '" at PS position ' DISP-NUM '.'
DISPLAY BLANK-LINE
DISPLAY BLANK-LINE

ELSE
PERFORM ERROR-HAND.


*********************************************************************
* DISP-HOST-SCR - Displays first 1920 bytes of host screen. *
* *
* INPUT *
* *
* OUTPUT *
* *
*********************************************************************
DISP-HOST-SCR.

MOVE HA-SET-SESSION-PARMS TO HFUNC-NUM.

MOVE 17 TO HDS-LEN.

CALL 'COBLIM' USING HFUNC-NUM, SETPARM-TEXT, HDS-LEN, HRC.

IF HRC = HARC-SUCCESS
PERFORM DHS-SUCCESS
ELSE
PERFORM ERROR-HAND.

DHS-SUCCESS.

MOVE HA-COPY-PS-TO-STR TO HFUNC-NUM.

MOVE MAX-DATA-SIZE TO HDS-LEN.

MOVE 1 TO HRC.

CALL 'COBLIM' USING HFUNC-NUM, HDATA-STRING, HDS-LEN, HRC.

IF HRC = HARC-SUCCESS

CALL '__VIOWRTCELLSTR' USING BY VALUE ZRO
BY VALUE ZRO
BY VALUE ZRO
BY VALUE MDS
BY REFERENCE HDATA-STRING

ELSE

PERFORM ERROR-HAND.



*********************************************************************
* ERROR_HAND - Error handler. *
* *
* INPUT *
* *
* OUTPUT *
*********************************************************************
ERROR-HAND.

DISPLAY BLANK-LINE.
MOVE HRC TO DISP-NUM.
DISPLAY 'UNEXPECTED RETURN CODE ' DISP-NUM ' from '
WITH NO ADVANCING.
MOVE HFUNC-NUM TO DISP-NUM.
DISPLAY 'FUNCTION #' DISP-NUM '.'
WITH NO ADVANCING.


******************************************************************
* ITOH - Convert binary to hex digits. *
* *
* INPUT *
* *
* OUTPUT *
* *
* *
******************************************************************
ITOH.


IF BIN-NUM < 0
COMPUTE BIN-NUM = 256 + BIN-NUM.

COMPUTE BIN-NUM2 = BIN-NUM / 16.

ADD 1 TO BIN-NUM2.

SET INDX TO BIN-NUM2.

MOVE HEX-DIG(INDX) TO HEX-OUT(1).

COMPUTE BIN-NUM2 = BIN-NUM - ((BIN-NUM2 - 1) * 16).

ADD 1 TO BIN-NUM2.

SET INDX TO BIN-NUM2.

MOVE HEX-DIG(INDX) TO HEX-OUT(2).



  3 Responses to “Category : OS/2 Files
Archive   : OS2CMAPI.ZIP
Filename : HSMPLCBL.CBL

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/