* Note version ID is displayed at start of procedure division. * IDENTIFICATION DIVISION. PROGRAM-ID. TEST_CALLS. ***************************************************************************** * Simple program to test all DECforms calls ***************************************************************************** * * COPYRIGHT (c) 1988 1989 BY * DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS. * * THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED * ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE * INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER * COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY * OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY * TRANSFERRED. * * THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE * AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT * CORPORATION. * * DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS * SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL. * AUTHOR. Digital Equipment Corporation. INSTALLATION. DATE-WRITTEN. 7-Apr-1988 DATE-COMPILED. *++ * * PROGRAM ABSTRACT: * *-- / ENVIRONMENT DIVISION. CONFIGURATION SECTION. SPECIAL-NAMES. CLASS ASCII-CHARACTER IS 1 THROUGH 128. DATA DIVISION. WORKING-STORAGE SECTION. *+ * The DECforms definitions *- COPY "sys$library:forms$cob_definitions.lib". *+ * Information that is transferred between this program and DECforms *- 01 session_id PIC X(16) GLOBAL. 01 form_file PIC X(16) VALUE "FORMS$DEMO_CALLS". 01 form_name PIC X(10) VALUE "DEMO_CALLS". 01 device_name PIC X(9) VALUE "SYS$INPUT". 01 single_record PIC S9(5) COMP VALUE 1 GLOBAL. 01 no_form_name PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_send_ctl_txt_string PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_send_ctl_txt_count PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_receive_ctl_txt_string PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_receive_ctl_txt_count PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_timeout PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_parent_request_id PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_request_options PIC S9(9) COMP VALUE 0 GLOBAL. 01 no_shadow_record PIC S9(9) COMP VALUE 0 GLOBAL. 01 forms_status PIC S9(9) COMP GLOBAL. *+ * Input control text is an array of up to five five-character control text * items returned by the FORMS$... calls. The call also returns a count. *- 01 input_ctl_txt_ct PIC S9(9) COMP GLOBAL. 01 input_ctl GLOBAL. 05 input_ctl_txt OCCURS 5 INDEXED BY input_ctl_txt_index. 10 input_ctl_txt_severity PIC X. 10 input_ctl_txt_source PIC X. 10 input_ctl_txt_value PIC XXX. 01 input_ctl_txt_string REDEFINES input_ctl GLOBAL. 05 FILLER PIC X(25). *+ * Output control text is an array of up to five five-character control text * items sent to the FORMS$... calls. The call also requires a count. * This program doesn't treat it as an array, but as a string since it only * uses the first position in the array. *- 01 output_ctl_txt_ct PIC S9(9) COMP GLOBAL. 01 output_ctl_txt PIC X(25) GLOBAL. *+ * Records passed to DECforms and/or the data file. * 01 simple_record_structure. 03 receive_rec_name PIC X(14) VALUE "RECEIVE_RECORD". 03 simple_record_receive. 05 call_type PIC X(1). 05 simple_count PIC 9(4) COMP. 05 simple_text. 07 receive_char PIC X OCCURS 26. * * note that the length of the text field is held in the text_length data * item declared below. * 03 send_rec_name PIC X(11) VALUE "SEND_RECORD". 03 simple_record_send. 05 call_type PIC X(1). 05 simple_count PIC 9(4) COMP. 05 simple_text. 07 send_char PIC X OCCURS 26. 01 initial_record. 03 call_type PIC X(1) value "S". 03 simple_count PIC 9(4) comp value 1. 03 simple_text PIC X(26) value "ABCDEFGHIJKLMNOPQRSTUVWXYZ". * * Other items * * 01 parent_request_id PIC X(24). 01 misc_items. 03 receive_char_count PIC 99 comp value 0. 03 send_char_count PIC 99 comp value 0. 03 text_length PIC 99 comp value 26. / PROCEDURE DIVISION. 0. DISPLAY "COBOL Calls Program starting. Version V1.0-18.02". display "Initial call is " call_type of initial_record. *+ * Initialize the DECforms form & check for errors * * (We don't include form_name, since the form isn't linked in) *- CALL "forms$enable" USING OMITTED BY DESCRIPTOR device_name BY DESCRIPTOR session_id BY DESCRIPTOR form_file GIVING forms_status. CALL "check_forms_status" USING forms_status. *+ * First call is a transceive *_ move initial_record to simple_record_send. IF call_type of simple_record_send = "T" THEN perform transceive_call ELSE perform send_call perform receive_call. loop. IF input_ctl_txt_value(1) = "XIT" THEN GO TO clean_up. move call_type of simple_record_receive to call_type of simple_record_send. add 1 to simple_count of simple_record_receive. move simple_count of simple_record_receive to simple_count of simple_record_send. perform text_switch thru text_switch_exit. IF call_type of simple_record_receive = "T" THEN perform transceive_call ELSE perform send_call perform receive_call. go to loop. clean_up. *+ * Clean up, Print ending message on console, leave. *- CALL "forms$disable" USING BY DESCRIPTOR session_id GIVING forms_status. CALL "check_forms_status" USING forms_status. DISPLAY "...COBOL CALLS Program ending.". STOP RUN. text_switch. move text_length to send_char_count. perform char_switch varying receive_char_count from 1 by 1 UNTIL receive_char_count > text_length. go to text_switch_exit. char_switch. if receive_char (receive_char_count) is ascii-character move receive_char (receive_char_count) to send_char (send_char_count) else if receive_char_count is less than text_length move receive_char (receive_char_count) to send_char (send_char_count - 1) move receive_char (receive_char_count + 1) to send_char (send_char_count) subtract 1 from send_char_count else move space to send_char (1) end-if add 1 to receive_char_count end-if subtract 1 from send_char_count. text_switch_exit. EXIT. transceive_call. CALL "forms$transceive" USING BY DESCRIPTOR session_id BY DESCRIPTOR send_rec_name BY REFERENCE single_record BY DESCRIPTOR receive_rec_name BY REFERENCE single_record BY DESCRIPTOR input_ctl_txt_string BY REFERENCE input_ctl_txt_ct BY DESCRIPTOR output_ctl_txt BY REFERENCE output_ctl_txt_ct BY VALUE no_timeout no_parent_request_id no_request_options BY DESCRIPTOR simple_record_send BY VALUE no_shadow_record BY DESCRIPTOR simple_record_receive BY VALUE no_shadow_record GIVING forms_status. CALL "check_forms_status" USING forms_status. send_call. CALL "forms$send" USING BY DESCRIPTOR session_id BY DESCRIPTOR send_rec_name BY REFERENCE single_record BY DESCRIPTOR input_ctl_txt_string BY REFERENCE input_ctl_txt_ct BY DESCRIPTOR output_ctl_txt BY REFERENCE output_ctl_txt_ct BY VALUE no_timeout no_parent_request_id no_request_options BY DESCRIPTOR simple_record_send BY VALUE no_shadow_record GIVING forms_status. CALL "check_forms_status" USING forms_status. receive_call. CALL "forms$receive" USING BY DESCRIPTOR session_id BY DESCRIPTOR receive_rec_name BY REFERENCE single_record BY DESCRIPTOR input_ctl_txt_string BY REFERENCE input_ctl_txt_ct BY DESCRIPTOR output_ctl_txt BY REFERENCE output_ctl_txt_ct BY VALUE no_timeout no_parent_request_id no_request_options BY DESCRIPTOR simple_record_receive BY VALUE no_shadow_record GIVING forms_status. CALL "check_forms_status" USING forms_status. / IDENTIFICATION DIVISION. * ****************** PROGRAM-ID. check_forms_status COMMON. * ****************** *+ * If parameter is success, return; else print error message and stop. *- DATA DIVISION. WORKING-STORAGE SECTION. LINKAGE SECTION. 01 forms_status PIC S9(9) COMP. PROCEDURE DIVISION USING forms_status. 0. IF forms_status IS FAILURE THEN CALL "LIB$SIGNAL" USING BY VALUE forms_status STOP RUN END-IF. END PROGRAM check_forms_status. END PROGRAM TEST_CALLS.